main.icl

   1 module main
   2
   3 import StdEnv
   4 import Data.Either
   5 import Data.Functor
   6 import Data.List
   7 import Control.Monad
   8 import System.GetOpt
   9 import System.CommandLine
  10
  11 import parse
  12 import ast
  13 import check
  14 import int
  15 import gen
  16
  17 chars :: *File -> ([Char], *File)
  18 chars f
  19         # (ok,c,f) = freadc f
  20         | not ok = ([], f)
  21         # (cs,f) = chars f
  22         = ([c:cs], f)
  23
  24 :: Mode = MHelp | MLex | MParse | MType | MInterpret | MGen
  25
  26 opts :: [OptDescr (Mode -> Mode)]
  27 opts =
  28         [ Option ['?'] ["help"]      (NoArg (const MHelp))      "Display this message"
  29         , Option ['l'] ["lex"]       (NoArg (const MLex))       "Up to and including lexing"
  30         , Option ['p'] ["parse"]     (NoArg (const MParse))     "Up to and including parse"
  31         , Option ['t'] ["type"]      (NoArg (const MType))      "Up to and including typing"
  32         , Option ['i'] ["interpret"] (NoArg (const MInterpret)) "Up to and including interpretation"
  33         , Option ['g'] ["gen"]       (NoArg (const MGen))       "Up to and including generation"
  34         ]
  35
  36 exit :: Int [String] *File *World -> *World
  37 exit i e f w = snd (fclose (foldr fwrites f e) (setReturnCode i w))
  38
  39 Start :: *World -> *World
  40 Start w
  41         # (io, w) = stdio w
  42         # ([argv0:args], w) = getCommandLine w
  43         # (mode, positionals, errs) = getOpt Permute opts args
  44         # mode = foldl (o) id mode MInterpret
  45         | not (errs =: []) = exit 1 [e +++ "\n"\\e<-errs] io w
  46         | not (positionals =: []) = exit 1 ["Positional arguments not allowed"] io w
  47         # (cs, io) = chars io
  48         # mstr = case mode of
  49                 MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [opts]\n") opts]
  50                 MLex = map (nl o toString) <$> lex cs
  51                 MParse = map (nl o toString) <$> (lex cs >>= parse)
  52                 MType = map (\(t, s)->nl (toString t +++ " :: " +++ toString s)) o snd <$> (lex cs >>= parse >>= check)
  53                 MInterpret = pure o toString <$> (lex cs >>= parse >>= check >>= int o fst)
  54                 MGen = lex cs >>= parse >>= check >>= gen o fst
  55         = exit (either (\_->1) (\_->0) mstr) (either id id mstr) io w
  56
  57 nl x = x +++ "\n"
  58
  59