app/CoreDriver.hs

@@ -0,0 +1,14 @@
+module CoreDriver
+    ( driver
+    )
+    where
+--------------------------------------------------------------------------------
+
+driver :: RLPCIO ()
+driver = undefined
+
+parseProg :: RLPCOptions
+          -> Text
+          -> (Maybe Program', [MsgEnvelope RlpcError])
+parseProg o = lexCoreR >=> parseCoreProgR
+

app/Main.hs

@@ -10,12 +10,16 @@ import Data.HashSet             qualified as S
 import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Text.IO             qualified as TIO
+import Data.List
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
 import Lens.Micro.Mtl
+
+import CoreDriver               qualified
+import RlpDriver                qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -37,9 +41,15 @@ options = RLPCOptions
     {- -d -}
     <*> fmap S.fromList # many # option debugFlagReader
         (  short 'd'
-        <> help "dump evaluation logs"
+        <> help "pass debug flags"
         <> metavar "DEBUG FLAG"
         )
+    {- -f -}
+    <*> fmap S.fromList # many # option compilerFlagReader
+        (  short 'f'
+        <> help "pass compilation flags"
+        <> metavar "COMPILATION FLAG"
+        )
     {- --evaluator, -e -}
     <*> option evaluatorReader
         (  long "evaluator"
@@ -57,6 +67,7 @@ options = RLPCOptions
         )
     <*> option languageReader
         (  long "language"
+        <> short 'x'
         )
     <*> some (argument str $ metavar "FILES...")
     where
@@ -67,9 +78,13 @@ languageReader :: ReadM Language
 languageReader = maybeReader $ \case
     "rlp"   -> Just LanguageRlp
     "core"  -> Just LanguageCore
+    _       -> Nothing
 
 debugFlagReader :: ReadM DebugFlag
-debugFlagReader = maybeReader $ Just
+debugFlagReader = str
+
+compilerFlagReader :: ReadM CompilerFlag
+compilerFlagReader = str
 
 evaluatorReader :: ReadM Evaluator
 evaluatorReader = maybeReader $ \case
@@ -88,54 +103,9 @@ main = do
     void $ evalRLPCIO opts driver
 
 driver :: RLPCIO ()
-driver = sequence_
+driver = view rlpcLanguage >>= \case
-    [ dshowFlags
+    LanguageCore -> CoreDriver.driver
-    , ddumpAST
+    LanguageRlp  -> RlpDriver.driver
-    , ddumpEval
-    ]
-
-dshowFlags :: RLPCIO ()
-dshowFlags = whenDFlag "dump-flags" do
-    ask >>= liftIO . print
-
-ddumpAST :: RLPCIO ()
-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 ()
-ddumpEval = whenDFlag "dump-eval" do
-    fs <- view rlpcInputFiles
-    forM_ fs $ \f -> liftIO (TIO.readFile f) >>= doProg
-
-    where
-        doProg :: Text -> RLPCIO ()
-        doProg = undefined
-        -- doProg s = ask >>= \o -> case parseProg o s of
-        --     -- TODO: error handling
-        --     Left e -> addFatal . CompilerError $ show e
-        --     Right (a,_) -> do
-        --         log <- view rlpcLogFile
-        --         dumpEval <- chooseEval
-        --         case log of
-        --             Just f  -> liftIO $ withFile f WriteMode $ dumpEval a
-        --             Nothing -> liftIO $ dumpEval a stderr
-
-        -- choose the appropriate model based on the compiler opts
-        -- chooseEval = do
-        --     ev <- view rlpcEvaluator
-        --     pure $ case ev of
-        --         EvaluatorGM  -> v GM.hdbgProg
-        --         EvaluatorTI -> v TI.hdbgProg
-        --     where v f p h = f p h *> pure ()
-
-parseProg :: RLPCOptions
-          -> Text
-          -> (Maybe Program', [MsgEnvelope RlpcError])
-parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 
 forFiles_ :: (Monad m)
           => (RLPCOptions -> FilePath -> RLPCT m a)

src/Compiler/RLPC.hs

@@ -11,7 +11,7 @@ errors and the family of RLPC monads.
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments, ViewPatterns #-}
 module Compiler.RLPC
     (
     -- * Rlpc Monad transformer
@@ -31,6 +31,7 @@ module Compiler.RLPC
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
+    , addDebugMsg
     , whenDFlag, whenFFlag
     -- * Convenient re-exports
     , addFatal, addWound, def
@@ -60,13 +61,15 @@ import Data.Text                qualified as T
 import Text.ANSI                qualified as Ansi
 import Text.PrettyPrint         hiding ((<>))
 import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
 import System.Exit
 ----------------------------------------------------------------------------------
 
 newtype RLPCT m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
+    deriving ( Functor, Applicative, Monad
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
 
 rlpc :: (IsRlpcError e, Monad m)
      => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
@@ -103,10 +106,18 @@ evalRLPCIO opt r = do
         Nothing -> die "Failed, no code compiled."
 
 putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ (putStrLn . ('\n':) . render . prettyRlpcErr)
+putRlpcErrs = traverse_ (putStrLn . ('\n':) . prettyRlpcMsg)
 
-prettyRlpcErr :: MsgEnvelope RlpcError -> Doc
+prettyRlpcMsg :: MsgEnvelope RlpcError -> String
-prettyRlpcErr msg = header
+prettyRlpcMsg m@(view msgSeverity -> SevDebug) = prettyRlpcDebugMsg m
+prettyRlpcMsg m                                = render $ docRlpcErr m
+
+prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
+prettyRlpcDebugMsg (view msgDiagnostic -> Text ts) =
+    T.unpack . foldMap (`T.snoc` '\n') $ ts
+
+docRlpcErr :: MsgEnvelope RlpcError -> Doc
+docRlpcErr msg = header
                  $$ nest 2 bullets
                  $$ source
     where
@@ -177,6 +188,9 @@ type CompilerFlag = String
 makeLenses ''RLPCOptions
 pure []
 
+addDebugMsg :: (Monad m, IsText e) => e -> RLPCT m ()
+addDebugMsg e = addWound . debugMsg $ Text [e ^. unpacked . packed]
+
 -- TODO: rewrite this with prisms once microlens-pro drops :3
 whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
 whenDFlag f m = do

src/Compiler/RlpcError.hs

@@ -10,6 +10,7 @@ module Compiler.RlpcError
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    , debugMsg
     -- * Located Comonad
     , Located(..)
     , SrcSpan(..)
@@ -46,6 +47,7 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
+              | SevDebug
               deriving Show
 
 makeLenses ''MsgEnvelope
@@ -65,3 +67,11 @@ errorMsg s e = MsgEnvelope
     , _msgSeverity = SevError
     }
 
+debugMsg :: e -> MsgEnvelope e
+debugMsg e = MsgEnvelope
+    -- TODO: not pretty, but it is a debug message after all
+    { _msgSpan = SrcSpan 0 0 0 0
+    , _msgDiagnostic = e
+    , _msgSeverity = SevDebug
+    }
+

src/Control/Monad/Errorful.hs

@@ -13,6 +13,7 @@ module Control.Monad.Errorful
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.State.Strict
+import Control.Monad.Reader
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
@@ -76,7 +77,7 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $
 --------------------------------------------------------------------------------
 -- daily dose of n^2 instances
 
-instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
-    addWound = undefined
+    addWound = lift . addWound
-    addFatal = undefined
+    addFatal = lift . addFatal
 

src/Core/Parse.y

@@ -21,6 +21,7 @@ import Data.Functor.Identity
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Control.Monad
 import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
@@ -225,12 +226,17 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: forall m. (Applicative m) => [Located CoreToken] -> RLPCT m Program'
+parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
-parseCoreProgR = hoistRlpcT generalise . parseCoreProg
+parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
     where
         generalise :: forall a. Identity a -> m a
         generalise (Identity a) = pure a
 
+        ddumpast :: Program' -> RLPCT m Program'
+        ddumpast p = do
+            whenDFlag "dump-ast" $ (addDebugMsg . show $ p)
+            pure p
+
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k