minfp.icl

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