tidy things up

app/Main.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments, LambdaCase #-}
 module Main where
 ----------------------------------------------------------------------------------
 import Compiler.RLPC
 import Options.Applicative      hiding (ParseError)
 import Control.Monad
 import Control.Monad.Reader
+import Data.HashSet             qualified as S
 import System.IO
+import System.Exit              (exitSuccess)
 import Core
 import TIM
 import Lens.Micro
@@ -28,16 +30,24 @@ options = RLPCOptions
         <> help "output dumps to FILE. stderr is used by default"
         )
     -- temp. i want gcc/ghc style options
-    <*> switch 
+    <*> fmap S.fromList # many # option debugFlagReader
-        (  long "dump-evals"
+        (  short 'd'
-        <> short 'd'
         <> help "dump evaluation logs"
+        <> metavar "DEBUG FLAG"
         )
     <*> some (argument str (metavar "FILES..."))
     where
         infixr 9 #
         f # x = f x
 
+mmany :: (Alternative f, Monoid m) => f m -> f m
+mmany v = liftA2 (<>) v (mmany v)
+
+debugFlagReader :: ReadM DebugFlag
+debugFlagReader = maybeReader $ Just . \case
+    "dump-eval"  -> DDumpEval
+    "dump-opts"  -> DDumpOpts
+
 main :: IO ()
 main = do
     opts <- execParser optParser
@@ -46,14 +56,17 @@ main = do
 
 driver :: RLPCIO () ()
 driver = sequence_
-    [ dumpEval
+    [ dshowFlags
+    , ddumpEval
     ]
 
-whenView :: (MonadReader s m) => Getting Bool s Bool -> m () -> m ()
+dshowFlags :: RLPCIO () ()
-whenView l m = view l >>= \a -> when a m
+dshowFlags = whenFlag flagDDumpOpts do
+    ask >>= liftIO . print
+    liftIO $ exitSuccess
 
-dumpEval :: RLPCIO () ()
+ddumpEval :: RLPCIO () ()
-dumpEval = whenView rlpcDumpEval do
+ddumpEval = whenFlag flagDDumpEval do
     fs <- view rlpcInputFiles
     forM_ fs $ \f -> liftIO (readFile f) >>= doProg
 
@@ -70,6 +83,6 @@ dumpEval = whenView rlpcDumpEval do
 
         parseProg :: RLPCOptions
                   -> String
-                  -> Either (SrcError ParseError) (Program, [SrcError ParseError])
+                  -> Either SrcError (Program, [SrcError])
         parseProg o = evalRLPC o . (lexCore >=> parseCoreProg)
 

rlp.cabal

@@ -43,6 +43,8 @@ library
                     -- required for happy
                     , array
                     , data-default-class
+                    , unordered-containers
+                    , hashable
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -58,6 +60,7 @@ executable rlpc
                  , microlens
                  , microlens-mtl
                  , mtl
+                 , unordered-containers
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/RLPC.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving, StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
 module Compiler.RLPC
     ( RLPC(..)
     , RLPCIO
@@ -7,13 +8,16 @@ module Compiler.RLPC
     , addFatal
     , addWound
     , Severity(..)
-    , SrcError(..)
     , evalRLPCT
     , evalRLPCIO
     , evalRLPC
     , rlpcLogFile
-    , rlpcDumpEval  
+    , rlpcDebugOpts
     , rlpcInputFiles
+    , DebugFlag(..)
+    , whenFlag
+    , flagDDumpEval
+    , flagDDumpOpts
     )
 
     where
@@ -23,6 +27,10 @@ import Control.Monad.Reader
 import Control.Monad.Errorful
 import Data.Functor.Identity
 import Data.Default.Class
+import GHC.Generics             (Generic)
+import Data.Hashable            (Hashable)
+import Data.HashSet             (HashSet)
+import Data.HashSet             qualified as S
 import Data.Coerce
 import Lens.Micro
 import Lens.Micro.TH
@@ -30,7 +38,7 @@ import Lens.Micro.TH
 
 -- TODO: fancy errors
 newtype RLPCT e m a = RLPC {
-        runRLPCT :: ReaderT RLPCOptions (ErrorfulT (SrcError e) m) a
+        runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
     }
     deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
 
@@ -42,17 +50,17 @@ type RLPCIO e = RLPCT e IO
 
 evalRLPCT :: RLPCOptions
           -> RLPCT e m a
-          -> m (Either (SrcError e) (a, [SrcError e]))
+          -> m (Either e (a, [e]))
 evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
 
 evalRLPC :: RLPCOptions
          -> RLPC e a
-         -> Either (SrcError e) (a, [SrcError e])
+         -> Either e (a, [e])
 evalRLPC o m = coerce $ evalRLPCT o m
 
 evalRLPCIO :: RLPCOptions
            -> RLPCIO e a
-           -> IO (a, [SrcError e])
+           -> IO (a, [e])
 evalRLPCIO o m = do
     m' <- evalRLPCT o m
     case m' of
@@ -62,26 +70,11 @@ evalRLPCIO o m = do
 
 data RLPCOptions = RLPCOptions
     { _rlpcLogFile    :: Maybe FilePath
-    , _rlpcDumpEval   :: Bool
+    , _rlpcDebugOpts  :: DebugOpts
     , _rlpcInputFiles :: [FilePath]
     }
     deriving Show
 
-instance Default RLPCOptions where
-    def = RLPCOptions
-        { _rlpcLogFile = Nothing
-        , _rlpcDumpEval = False
-        , _rlpcInputFiles = []
-        }
-
-data SrcError e = SrcError
-    { _errSpan       :: (Int, Int, Int)
-    , _errSeverity   :: Severity
-    , _errDiagnostic :: e
-    }
-
-deriving instance (Show e) => Show (SrcError e)
-
 data Severity = Error
               | Warning
               | Debug
@@ -93,12 +86,44 @@ type ErrorDoc = String
 class Diagnostic e where
     errorDoc :: e -> ErrorDoc
 
-makeLenses ''RLPCOptions
+instance MonadErrorful e (RLPC e) where
-makeLenses ''SrcError
-
-pure []
-
-instance MonadErrorful (SrcError e) (RLPC e) where
     addWound = RLPC . lift . addWound
     addFatal = RLPC . lift . addFatal
 
+----------------------------------------------------------------------------------
+
+instance Default RLPCOptions where
+    def = RLPCOptions
+        { _rlpcLogFile = Nothing
+        , _rlpcDebugOpts = mempty
+        , _rlpcInputFiles = []
+        }
+
+type DebugOpts = HashSet DebugFlag
+
+data DebugFlag = DDumpEval
+               | DDumpOpts
+               deriving (Show, Eq, Generic)
+
+    -- deriving (Hashable)
+    -- via Generically DebugFlag
+
+instance Hashable DebugFlag
+
+makeLenses ''RLPCOptions
+pure []
+
+whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
+whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
+
+-- there's probably a better way to write this. my current knowledge of lenses
+-- is too weak.
+flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool
+flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d
+
+flagDDumpEval :: SimpleGetter RLPCOptions Bool
+flagDDumpEval = flagGetter DDumpEval
+
+flagDDumpOpts :: SimpleGetter RLPCOptions Bool
+flagDDumpOpts = flagGetter DDumpOpts
+

src/Core.hs

@@ -4,7 +4,7 @@ module Core
     , parseCoreProg
     , parseCoreExpr
     , lexCore
-    , ParseError
+    , SrcError(..)
     )
     where
 ----------------------------------------------------------------------------------

src/Core/Lex.x

@@ -3,7 +3,8 @@ module Core.Lex
     ( lexCore
     , lexCore'
     , CoreToken(..)
-    , ParseError(..)
+    , SrcError(..)
+    , SrcErrorType(..)
     , Located(..)
     , AlexPosn(..)
     )
@@ -119,19 +120,30 @@ data CoreToken = TokenLet
                | TokenEOF
                deriving Show
 
+data SrcError = SrcError
+    { _errSpan       :: (Int, Int, Int)
+    , _errSeverity   :: Severity
+    , _errDiagnostic :: SrcErrorType
+    }
+    deriving Show
+
+data SrcErrorType = SrcErrLexical String
+                  | SrcErrParse
+                  deriving Show
+
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
 
 lexWith :: (String -> CoreToken) -> Lexer
 lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
 
 -- | The main lexer driver.
-lexCore :: String -> RLPC ParseError [Located CoreToken]
+lexCore :: String -> RLPC SrcError [Located CoreToken]
 lexCore s = case m of
     Left e   -> addFatal err
         where err = SrcError
                 { _errSpan       = (0,0,0) -- TODO: location
                 , _errSeverity   = Error
-                , _errDiagnostic = ParErrLexical e
+                , _errDiagnostic = SrcErrLexical e
                 }
     Right ts -> pure ts
     where
@@ -139,7 +151,7 @@ lexCore s = case m of
 
 -- | @lexCore@, but the tokens are stripped of location info. Useful for
 -- debugging
-lexCore' :: String -> RLPC ParseError [CoreToken]
+lexCore' :: String -> RLPC SrcError [CoreToken]
 lexCore' s = fmap f <$> lexCore s
     where f (Located _ _ _ t) = t
 

src/Core/Parse.y

@@ -6,7 +6,6 @@ module Core.Parse
     , module Core.Lex -- temp convenience
     , parseTmp
     , SrcError
-    , ParseError
     , Module
     )
     where
@@ -24,7 +23,7 @@ import Data.Default.Class   (def)
 %name parseCoreProg StandaloneProgram
 %tokentype { Located CoreToken }
 %error { parseError }
-%monad { RLPC ParseError }
+%monad { RLPC SrcError }
 
 %token
       let             { Located _ _ _ TokenLet }
@@ -126,12 +125,12 @@ Con             : '(' consym ')'                    { $2 }
                 | conname                           { $1 }
 
 {
-parseError :: [Located CoreToken] -> RLPC ParseError a
+parseError :: [Located CoreToken] -> RLPC SrcError a
 parseError (Located y x l _ : _) = addFatal err
     where err = SrcError
             { _errSpan       = (y,x,l)
             , _errSeverity   = Error
-            , _errDiagnostic = ParErrParse
+            , _errDiagnostic = SrcErrParse
             }
 
 parseTmp :: IO Module