tidy things up

2023-11-27 17:29:00 -07:00
parent c0ebd227fc
commit 7f6813beb5
6 changed files with 100 additions and 48 deletions
--- a/app/Main.hs
+++ b/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 
-        (  long "dump-evals"
-        <> short 'd'
+    <*> fmap S.fromList # many # option debugFlagReader
+        (  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 ()
-whenView l m = view l >>= \a -> when a m
+dshowFlags :: RLPCIO () ()
+dshowFlags = whenFlag flagDDumpOpts do
+    ask >>= liftIO . print
+    liftIO $ exitSuccess

-dumpEval :: RLPCIO () ()
-dumpEval = whenView rlpcDumpEval do
+ddumpEval :: RLPCIO () ()
+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)

--- a/rlp.cabal
+++ b/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
--- a/src/Compiler/RLPC.hs
+++ b/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
+
--- a/src/Core.hs
+++ b/src/Core.hs
@@ -4,7 +4,7 @@ module Core
    , parseCoreProg
    , parseCoreExpr
    , lexCore
-    , ParseError
+    , SrcError(..)
    )
    where
 ----------------------------------------------------------------------------------
--- a/src/Core/Lex.x
+++ b/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

--- a/src/Core/Parse.y
+++ b/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