From 7f6813beb5284a4095328d5d6f2bef7d7e97efa9 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 27 Nov 2023 17:29:00 -0700 Subject: [PATCH] tidy things up --- app/Main.hs | 33 ++++++++++++------ rlp.cabal | 3 ++ src/Compiler/RLPC.hs | 83 ++++++++++++++++++++++++++++---------------- src/Core.hs | 2 +- src/Core/Lex.x | 20 ++++++++--- src/Core/Parse.y | 7 ++-- 6 files changed, 100 insertions(+), 48 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 78b53fd..ba55eb4 100644 --- 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) diff --git a/rlp.cabal b/rlp.cabal index 58e71de..3d6efbf 100644 --- 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 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 5f0e622..1163542 100644 --- 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 + diff --git a/src/Core.hs b/src/Core.hs index aaab099..04ef41c 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -4,7 +4,7 @@ module Core , parseCoreProg , parseCoreExpr , lexCore - , ParseError + , SrcError(..) ) where ---------------------------------------------------------------------------------- diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 08d5c0d..6317c49 100644 --- 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 diff --git a/src/Core/Parse.y b/src/Core/Parse.y index e0e8527..ecfb77b 100644 --- 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