cs3161a1/Main.hs at master · OldJeffSpectator/cs3161a1 · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
import MinHS.Parse
import MinHS.Syntax
import MinHS.TypeChecker
import MinHS.Pretty
import MinHS.Evaluator
import Control.Monad
import Data.Either

import Options.Applicative
import Text.PrettyPrint.ANSI.Leijen (Pretty (..),Doc, putDoc, plain)

type Action a b = a -> Either (IO ()) b

main = execParser argsInfo >>= main'
  where main' (pipeline, filter, file) = (pipeline filter <$> readFile file) >>= either id id

        argsInfo = info (helper <*> args)
                    (fullDesc <> progDesc "A interpreter for a small functional language"
                              <> header "MinHS - COMP3161 Concepts of Programming Languages")

        args =  (,,) <$> nullOption ( long "dump"
                                  <> metavar "STAGE"
                                  <> reader readAction
                                  <> value (evaluatorAction)
                                  <> help "stage after which to dump the current state. \n                           [parser,parser-raw,typechecker,evaluator]")
                     <*> flag id plain (long "no-colour"
                                     <> help "do not use colour when pretty printing")
                     <*> argument str (metavar "FILE")

        readAction :: String -> ReadM ((Doc -> Doc) -> Action String (IO ()))
        readAction str = case str of
            "parser"      -> return $ \f -> parser >=> printer f
            "parser-raw"  -> return $ \f -> parser >=> rawPrinter
            "typechecker" -> return $ \f -> parser >=> typechecker f >=> printer f
            "evaluator"   -> return $ evaluatorAction
            _             -> readerAbort (ShowHelpText)
        evaluatorAction :: (Doc -> Doc) -> Action String (IO ())
        evaluatorAction f = parser >=> typechecker f >=> evaluator >=> printer f

        parser :: Action String Program
        parser = either (Left . putStrLn . show) Right . parseProgram ""

        typechecker :: (Doc -> Doc) -> Action Program Program
        typechecker f p | Just v <- typecheck p = Left . (>> putStrLn "") . putDoc . f . pretty $ v
                        | otherwise             = Right $ p

        evaluator p = Right $ evaluate p

        rawPrinter :: (Show a) => Action a (IO ())
        rawPrinter = Right . putStrLn . show

        printer :: (Pretty a) => (Doc -> Doc) -> Action a (IO ())
        printer filter = Right . (>> putStrLn "") . putDoc . filter . pretty

        fromRight = either (error "fromRight on Left") id