Parse JSON file for L-system input

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 import Graphics.Gloss
@@ -6,30 +7,17 @@ import Data.Semigroup ((<>))
 import Data.List
 import Safe
 
-import Lib
-import Examples
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as B
 
-data Options = Options
-  { optionLSystem :: LSystem Char
-  , optionIterations :: Integer
+import Lib
+
+data CmdLnOptions = CmdLnOptions
+  { optionIterations :: Integer
   , optionColor :: Color
   , optionWhiteBg :: Bool
   }
 
-selectLSystem :: [LSystem a] -> String -> Either String (LSystem a)
-selectLSystem ls s = case find (\x -> name x == s) ls of
-  Just x -> Right x
-  Nothing -> Left $ "Cannot find L-system \"" ++ s ++ "\". Use -l to find all available L-systems."
-
-lsystemParser :: Parser (LSystem Char)
-lsystemParser = argument (eitherReader (selectLSystem lsystems))
-  (metavar "LSYSTEM"
-   <> help "L-system to generate"
-   <> showDefaultWith name
-   <> value penroseP3
-   <> completeWith (map name lsystems)
-   <> completer (listCompleter (map name lsystems)))
-
 iterationsParser :: Parser Integer
 iterationsParser = option auto
   (long "iterations"
@@ -39,13 +27,6 @@ iterationsParser = option auto
    <> value 5
    <> metavar "N")
 
-listLSystemsParser :: Parser (a -> a)
-listLSystemsParser = infoOption (printList lsystems)
-  (long "list-lsystems"
-   <> short 'l'
-   <> help "List all available L-systems")
-  where printList xs = "Available L-systems:\n" ++ unlines (map name xs)
-
 splitOn :: Char -> String -> [String]
 splitOn c s = case dropWhile (== c) s of
                 "" -> []
@@ -75,22 +56,24 @@ whiteBackgroundParser = switch
    <> short 'w'
    <> help "Use a white background")
 
-optionsParser :: Parser Options
-optionsParser = Options <$>
-  lsystemParser <*> iterationsParser <*> colorParser <*> whiteBackgroundParser
+optionsParser :: Parser CmdLnOptions
+optionsParser = CmdLnOptions <$>
+  iterationsParser <*> colorParser <*> whiteBackgroundParser
 
-opts :: ParserInfo Options
-opts = info (optionsParser <**> listLSystemsParser <**> helper)
+opts :: ParserInfo CmdLnOptions
+opts = info (optionsParser <**> helper)
   ( fullDesc
   <> progDesc "Generate and draw an L-system"
   <> header "lsystems -- Generate L-systems")
 
 createDisplay :: (Eq a, Integral p) => Color -> Bool -> p -> LSystem a -> IO ()
-createDisplay fgColor wbg n ls = display (InWindow "L-System" (200, 200) (10, 10)) bgColor (color fgColor pic)
+createDisplay fgColor wbg n ls = display (InWindow (name ls) (200, 200) (10, 10)) bgColor (color fgColor pic)
   where pic = drawLSystem $ iterateLSystem n ls
         bgColor = if wbg then white else black
 
 main :: IO ()
 main = do
-  Options ls n fgColor wbg <- execParser opts
+  lsStr <- B.getContents
+  let Just ls = decode lsStr :: Maybe (LSystem Char)
+  CmdLnOptions n fgColor wbg <- execParser opts
   createDisplay fgColor wbg n ls

package.yaml

@@ -23,6 +23,9 @@ dependencies:
 - gloss
 - optparse-applicative
 - safe
+- aeson
+- text
+- bytestring
 
 library:
   source-dirs: src

src/Lib.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Lib
     ( -- * L-system data types
       LSystem(..)
@@ -11,6 +13,11 @@ module Lib
 
 import Data.Maybe
 import Graphics.Gloss
+import GHC.Generics
+import Data.Aeson
+import qualified Data.Text.Lazy as T
+import qualified Data.Text as TS
+import qualified Data.ByteString.Lazy as B
 
 -- | L-system data type
 data LSystem a = LSystem
@@ -26,7 +33,12 @@ data LSystem a = LSystem
                                          -- defining how each variable
                                          -- and constant should be
                                          -- represented
-  } deriving (Eq, Show)
+  } deriving (Eq, Show, Generic)
+
+instance (FromJSON a) => FromJSON (LSystem a)
+
+instance (ToJSON a) => ToJSON (LSystem a) where
+    toEncoding = genericToEncoding defaultOptions
 
 -- | Instructions for displaying the L-system
 data Instruction =
@@ -36,8 +48,25 @@ data Instruction =
   | Push -- ^ push a position on the stack
   | Pop -- ^ pop a position from the stack
   | Stay -- ^ do nothing
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 
+instance FromJSON Instruction where
+  parseJSON = withText "Instruction" $ \s ->
+    if s `elem` ["Forward", "forward", "F", "f"] then
+      pure Forward
+    else if s `elem` ["TurnRight", "Turnright", "turnright", "Right", "right", "R", "r"] then
+      pure TurnRight
+    else if s `elem` ["TurnLeft", "Turnleft", "turnleft", "Left", "left", "L", "l"] then
+      pure TurnLeft
+    else if s `elem` ["Push", "push"] then
+      pure Push
+    else if s `elem` ["Pop", "pop"] then
+      pure Pop
+    else
+      pure Stay
+
+instance ToJSON Instruction where
+  toEncoding = genericToEncoding defaultOptions
 
 -- | Iterate the L-system by n steps
 iterateLSystem :: (Eq a, Integral t) => t -> LSystem a -> LSystem a