driver progress

app/Main.hs

@@ -55,11 +55,22 @@ options = RLPCOptions
                 \triggering the garbage collector"
         <> value 50
         )
+    <*> option languageReader
+        (  long "language"
+        )
     <*> some (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
 
+languageReader :: ReadM Language
+languageReader = maybeReader $ \case
+    "rlp"   -> Just LanguageRlp
+    "core"  -> Just LanguageCore
+
+debugFlagReader :: ReadM DebugFlag
+debugFlagReader = maybeReader $ Just
+
 evaluatorReader :: ReadM Evaluator
 evaluatorReader = maybeReader $ \case
     "gm"  -> Just EvaluatorGM
@@ -69,80 +80,66 @@ evaluatorReader = maybeReader $ \case
 mmany :: (Alternative f, Monoid m) => f m -> f m
 mmany v = liftA2 (<>) v (mmany v)
 
-debugFlagReader :: ReadM DebugFlag
-debugFlagReader = maybeReader $ \case
-    "dump-eval"  -> Just DDumpEval
-    "dump-opts"  -> Just DDumpOpts
-    "dump-ast"   -> Just DDumpAST
-    _            -> Nothing
-
 ----------------------------------------------------------------------------------
 
--- temp
-data CompilerError = CompilerError String
-    deriving Show
-
-instance Exception CompilerError
-
 main :: IO ()
 main = do
     opts <- execParser optParser
-    (_, es) <- evalRLPCIO opts driver
+    void $ evalRLPCIO opts driver
-    forM_ es $ \ (CompilerError e) -> print $ "warning: " <> e
-    pure ()
 
-driver :: RLPCIO CompilerError ()
+driver :: RLPCIO ()
 driver = sequence_
     [ dshowFlags
     , ddumpAST
     , ddumpEval
     ]
 
-dshowFlags :: RLPCIO CompilerError ()
+dshowFlags :: RLPCIO ()
-dshowFlags = whenFlag flagDDumpOpts do
+dshowFlags = whenDFlag "dump-flags" do
     ask >>= liftIO . print
 
-ddumpAST :: RLPCIO CompilerError ()
+ddumpAST :: RLPCIO ()
-ddumpAST = whenFlag flagDDumpAST $ forFiles_ \o f -> do
+ddumpAST = whenDFlag "dump-ast" $ forFiles_ \o f -> do
     liftIO $ withFile f ReadMode $ \h -> do
         s <- TIO.hGetContents h
         case parseProg o s of
             Right (a,_) -> hPutStrLn stderr $ show a
             Left e -> error "todo errors lol"
 
-ddumpEval :: RLPCIO CompilerError ()
+ddumpEval :: RLPCIO ()
-ddumpEval = whenFlag flagDDumpEval do
+ddumpEval = whenDFlag "dump-eval" do
     fs <- view rlpcInputFiles
     forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
 
     where
-        doProg :: Text -> RLPCIO CompilerError ()
+        doProg :: Text -> RLPCIO ()
-        doProg s = ask >>= \o -> case parseProg o s of
+        doProg = undefined
-            -- TODO: error handling
+        -- doProg s = ask >>= \o -> case parseProg o s of
-            Left e -> addFatal . CompilerError $ show e
+        --     -- TODO: error handling
-            Right (a,_) -> do
+        --     Left e -> addFatal . CompilerError $ show e
-                log <- view rlpcLogFile
+        --     Right (a,_) -> do
-                dumpEval <- chooseEval
+        --         log <- view rlpcLogFile
-                case log of
+        --         dumpEval <- chooseEval
-                    Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
+        --         case log of
-                    Nothing -> liftIO $ dumpEval a stderr
+        --             Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
+        --             Nothing -> liftIO $ dumpEval a stderr
 
         -- choose the appropriate model based on the compiler opts
-        chooseEval = do
+        -- chooseEval = do
-            ev <- view rlpcEvaluator
+        --     ev <- view rlpcEvaluator
-            pure $ case ev of
+        --     pure $ case ev of
-                EvaluatorGM  -> v GM.hdbgProg
+        --         EvaluatorGM  -> v GM.hdbgProg
-                EvaluatorTI -> v TI.hdbgProg
+        --         EvaluatorTI -> v TI.hdbgProg
-            where v f p h = f p h *> pure ()
+        --     where v f p h = f p h *> pure ()
 
 parseProg :: RLPCOptions
           -> Text
-          -> Either SrcError (Program', [SrcError])
+          -> (Maybe Program', [MsgEnvelope RlpcError])
 parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 
 forFiles_ :: (Monad m)
-          => (RLPCOptions -> FilePath -> RLPCT e m a)
+          => (RLPCOptions -> FilePath -> RLPCT m a)
-          -> RLPCT e m ()
+          -> RLPCT m ()
 forFiles_ k = do
     fs <- view rlpcInputFiles
     o <- ask

src/Compiler/RLPC.hs

@@ -23,6 +23,7 @@ module Compiler.RLPC
     , addWound
     , MonadErrorful
     , Severity(..)
+    , Language(..)
     , Evaluator(..)
     , evalRLPCT
     , evalRLPCIO
@@ -45,6 +46,7 @@ import Control.Monad
 import Control.Monad.Reader
 import Control.Monad.State      (MonadState(state))
 import Control.Monad.Errorful
+import Control.Monad.IO.Class
 import Compiler.RlpcError
 import Compiler.Types
 import Data.Functor.Identity
@@ -73,6 +75,8 @@ type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
 
+instance (MonadIO m) => MonadIO (RLPCT m) where
+
 evalRLPC :: RLPCOptions
          -> RLPC a
          -> (Maybe a, [MsgEnvelope RlpcError])
@@ -134,6 +138,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
+    , _rlpcLanguage    :: Language
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -141,6 +146,9 @@ data RLPCOptions = RLPCOptions
 data Evaluator = EvaluatorGM | EvaluatorTI
     deriving Show
 
+data Language = LanguageRlp | LanguageCore
+    deriving Show
+
 ----------------------------------------------------------------------------------
 
 instance Default RLPCOptions where
@@ -151,6 +159,7 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcLanguage = LanguageRlp
         }
 
 -- debug flags are passed with -dFLAG