From dda0e173580330f61ae3b9a42a3f6ecd2c11ea0f Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 1 Feb 2024 11:37:52 -0700 Subject: [PATCH] -ddump-ast --- app/CoreDriver.hs | 14 +++++++ app/Main.hs | 70 ++++++++++------------------------- app/RlpDriver.hs | 0 src/Compiler/RLPC.hs | 24 +++++++++--- src/Compiler/RlpcError.hs | 10 +++++ src/Control/Monad/Errorful.hs | 7 ++-- src/Core/Parse.y | 10 ++++- 7 files changed, 75 insertions(+), 60 deletions(-) create mode 100644 app/CoreDriver.hs create mode 100644 app/RlpDriver.hs diff --git a/app/CoreDriver.hs b/app/CoreDriver.hs new file mode 100644 index 0000000..ba546c9 --- /dev/null +++ b/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 + diff --git a/app/Main.hs b/app/Main.hs index 0424aa2..440789c 100644 --- a/app/Main.hs +++ b/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_ - [ dshowFlags - , ddumpAST - , 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) +driver = view rlpcLanguage >>= \case + LanguageCore -> CoreDriver.driver + LanguageRlp -> RlpDriver.driver forFiles_ :: (Monad m) => (RLPCOptions -> FilePath -> RLPCT m a) diff --git a/app/RlpDriver.hs b/app/RlpDriver.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index f928f5d..90ee262 100644 --- a/src/Compiler/RLPC.hs +++ b/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 -prettyRlpcErr msg = header +prettyRlpcMsg :: MsgEnvelope RlpcError -> String +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 diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 9530b2e..f44b1ca 100644 --- a/src/Compiler/RlpcError.hs +++ b/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 + } + diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index f24042b..0d70585 100644 --- a/src/Control/Monad/Errorful.hs +++ b/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 - addWound = undefined - addFatal = undefined +instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where + addWound = lift . addWound + addFatal = lift . addFatal diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 5f4dc38..d89f60f 100644 --- a/src/Core/Parse.y +++ b/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 = hoistRlpcT generalise . parseCoreProg +parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program' +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