tidy things up

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  
+    , rlpcLogFile
+    , 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
-makeLenses ''SrcError
-
-pure []
-
-instance MonadErrorful (SrcError e) (RLPC e) where
+instance MonadErrorful 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