From 6c943af4a1e9628e8c66961f466c56df32d10e98 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 8 Feb 2024 09:26:53 -0700 Subject: [PATCH] ppr debug flags ddump-parsed --- README.md | 33 ++++++++++++++----- app/CoreDriver.hs | 7 ++++ app/Main.hs | 41 +++++++++++++++++++---- app/RlpDriver.hs | 10 +++++- rlp.cabal | 6 ++-- src/Compiler/RLPC.hs | 23 ++++++++++--- src/Compiler/RlpcError.hs | 4 +-- src/Control/Monad/Errorful.hs | 6 ++-- src/Core/Parse.y | 2 +- src/Core/Syntax.hs | 61 ++++++++++++++++++++++++++++++++++- src/Core2Core.hs | 14 ++++++-- src/Data/Pretty.hs | 48 +++++++++++++++++++++++---- src/Rlp/Parse.y | 8 +++-- src/Rlp2Core.hs | 22 ++++++++++++- 14 files changed, 244 insertions(+), 41 deletions(-) diff --git a/README.md b/README.md index 6087d89..ee49f51 100644 --- a/README.md +++ b/README.md @@ -22,21 +22,38 @@ $ cabal test --test-show-details=direct ``` ### Use + +#### TLDR + ```sh -# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr -$ rlpc -ddump-eval examples/factorial.hs -# Compile and evaluate t.hs, with evaluation info dumped to t.log -$ rlpc -ddump-eval -l t.log t.hs -# Print the raw structure describing the compiler options -# (option parsing still must succeed in order to print) -$ rlpc -ddump-opts t.hs +# Compile and evaluate examples/factorial.cr, with evaluation info dumped to stderr +$ rlpc -ddump-eval examples/factorial.cr +# Compile and evaluate t.cr, with evaluation info dumped to t.log +$ rlpc -ddump-eval -l t.log t.cr +# Compile and evaluate t.rl, dumping the desugared Core +$ rlpc -ddump-desugared t.rl ``` +#### Options + +```sh +Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG] + [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core] + FILES... +``` + +Available debug flags include: +* `-ddump-desugared`: dump Core generated from rl' +* `-ddump-parsed-core`: dump raw Core AST +* `-ddump-parsed`: dump raw rl' AST +* `-ddump-eval`: dump evaluation logs +* `-dALL`: disable debug message filtering. enables **all** debug messages + ### Potential Features Listed in order of importance. - [x] ADTs - [x] First-class functions -- [ ] Higher-kinded types +- [x] Higher-kinded types - [ ] Typeclasses - [x] Parametric polymorphism - [x] Hindley-Milner type inference diff --git a/app/CoreDriver.hs b/app/CoreDriver.hs index 56ec299..2ded66e 100644 --- a/app/CoreDriver.hs +++ b/app/CoreDriver.hs @@ -5,6 +5,8 @@ module CoreDriver -------------------------------------------------------------------------------- import Compiler.RLPC import Control.Monad +import Data.Text qualified as T +import Lens.Micro.Platform import Core.Lex import Core.Parse @@ -15,3 +17,8 @@ driver :: RLPCIO () driver = forFiles_ $ \f -> withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR) +driverSource :: T.Text -> RLPCIO () +driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes + where + printRes = liftIO . print . view _1 + diff --git a/app/Main.hs b/app/Main.hs index 524b590..5571352 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,9 @@ {-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main where ---------------------------------------------------------------------------------- import Compiler.RLPC +import Compiler.RlpcError import Control.Exception import Options.Applicative hiding (ParseError) import Control.Monad @@ -11,12 +13,13 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.List +import Data.Maybe (listToMaybe) import System.IO import System.Exit (exitSuccess) import Core import TI import GM -import Lens.Micro.Mtl +import Lens.Micro.Platform import CoreDriver qualified import RlpDriver qualified @@ -65,7 +68,7 @@ options = RLPCOptions \triggering the garbage collector" <> value 50 ) - <*> option languageReader + <*> optional # option languageReader ( long "language" <> short 'x' <> metavar "rlp|core" @@ -80,6 +83,8 @@ languageReader :: ReadM Language languageReader = maybeReader $ \case "rlp" -> Just LanguageRlp "core" -> Just LanguageCore + "rl" -> Just LanguageRlp + "cr" -> Just LanguageCore _ -> Nothing debugFlagReader :: ReadM DebugFlag @@ -102,10 +107,34 @@ mmany v = liftA2 (<>) v (mmany v) main :: IO () main = do opts <- execParser optParser - void $ evalRLPCIO opts driver + void $ evalRLPCIO opts dispatch + +dispatch :: RLPCIO () +dispatch = getLang >>= \case + Just LanguageCore -> CoreDriver.driver + Just LanguageRlp -> RlpDriver.driver + Nothing -> addFatal err + where + -- TODO: why didn't i make the srcspan optional LOL + err = errorMsg (SrcSpan 0 0 0 0) $ Text + [ "Could not determine source language from filetype." + , "Possible Solutions:\n\ + \ Suffix the file with `.cr' for Core, or `.rl' for rl'\n\ + \ Specify a language with `rlpc -x core' or `rlpc -x rlp'" + ] + where + getLang = liftA2 (<|>) + (view rlpcLanguage) + -- TODO: we only check the first file lol + ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles) + driver :: RLPCIO () -driver = view rlpcLanguage >>= \case - LanguageCore -> CoreDriver.driver - LanguageRlp -> RlpDriver.driver +driver = undefined + +inferLanguage :: FilePath -> Maybe Language +inferLanguage fp + | ".rl" `isSuffixOf` fp = Just LanguageRlp + | ".cr" `isSuffixOf` fp = Just LanguageCore + | otherwise = Nothing diff --git a/app/RlpDriver.hs b/app/RlpDriver.hs index 3df1b24..89ad8d7 100644 --- a/app/RlpDriver.hs +++ b/app/RlpDriver.hs @@ -1,11 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} module RlpDriver ( driver ) where -------------------------------------------------------------------------------- import Compiler.RLPC +import Control.Monad + +import Rlp.Lex +import Rlp.Parse +import Rlp2Core +import GM -------------------------------------------------------------------------------- driver :: RLPCIO () -driver = undefined +driver = forFiles_ $ \f -> + withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR) diff --git a/rlp.cabal b/rlp.cabal index c082198..1f18e4d 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -88,6 +88,9 @@ library LambdaCase ViewPatterns DataKinds + DerivingVia + StandaloneDeriving + DerivingStrategies executable rlpc import: warnings @@ -98,8 +101,7 @@ executable rlpc build-depends: base >=4.17.0.0 && <4.20.0.0 , rlp , optparse-applicative >= 0.18.1 && < 0.19 - , microlens >= 0.4.13 && < 0.5 - , microlens-mtl >= 0.2.0 && < 0.3 + , microlens-platform , mtl >= 2.3.1 && < 2.4 , unordered-containers >= 0.2.20 && < 0.3 , text >= 2.0.2 && < 2.1 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index c75ac95..ec4b8bf 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -10,7 +10,6 @@ errors and the family of RLPC monads. {-# LANGUAGE TemplateHaskell #-} -- only used for mtl instances {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-} {-# LANGUAGE BlockArguments, ViewPatterns #-} module Compiler.RLPC ( @@ -18,6 +17,7 @@ module Compiler.RLPC RLPCT(RLPCT), -- ** Special cases RLPC, RLPCIO + , liftIO -- ** Running , runRLPCT , evalRLPCT, evalRLPCIO, evalRLPC @@ -61,6 +61,7 @@ import Data.Coerce import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T +import System.IO import Text.ANSI qualified as Ansi import Text.PrettyPrint hiding ((<>)) import Lens.Micro.Platform @@ -84,7 +85,11 @@ type RLPC = RLPCT Identity type RLPCIO = RLPCT IO +instance MonadTrans RLPCT where + lift = RLPCT . lift . lift + instance (MonadIO m) => MonadIO (RLPCT m) where + liftIO = lift . liftIO evalRLPC :: RLPCOptions -> RLPC a @@ -114,7 +119,7 @@ data RLPCOptions = RLPCOptions , _rlpcFFlags :: HashSet CompilerFlag , _rlpcEvaluator :: Evaluator , _rlpcHeapTrigger :: Int - , _rlpcLanguage :: Language + , _rlpcLanguage :: Maybe Language , _rlpcInputFiles :: [FilePath] } deriving Show @@ -135,7 +140,7 @@ instance Default RLPCOptions where , _rlpcEvaluator = EvaluatorGM , _rlpcHeapTrigger = 200 , _rlpcInputFiles = [] - , _rlpcLanguage = LanguageRlp + , _rlpcLanguage = Nothing } -- debug flags are passed with -dFLAG @@ -175,10 +180,18 @@ evalRLPCIO opt r = do Nothing -> die "Failed, no code compiled." putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO () -putRlpcErrs opts = filter byTag - >>> traverse_ (putStrLn . ('\n':) . prettyRlpcMsg) +putRlpcErrs opt es = case opt ^. rlpcLogFile of + Just lf -> withFile lf WriteMode putter + Nothing -> putter stderr + where + putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es + +renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String] +renderRlpcErrs opts = (if don'tBother then id else filter byTag) + >>> fmap prettyRlpcMsg where dflags = opts ^. rlpcDFlags + don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags) byTag :: MsgEnvelope RlpcError -> Bool byTag (view msgSeverity -> SevDebug t) = diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index a590a85..a8ef710 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -34,7 +34,7 @@ data MsgEnvelope e = MsgEnvelope deriving (Functor, Show) newtype RlpcError = Text [Text] - deriving Show + deriving Show instance IsString RlpcError where fromString = Text . pure . T.pack @@ -47,7 +47,7 @@ instance IsRlpcError RlpcError where data Severity = SevWarning | SevError - | SevDebug Text + | SevDebug Text -- ^ Tag deriving Show makeLenses ''MsgEnvelope diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 0d70585..f788aaf 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -50,7 +50,7 @@ instance (MonadIO m) => MonadIO (ErrorfulT e m) where liftIO = lift . liftIO instance (Functor m) => Functor (ErrorfulT e m) where - fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f) + fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f) instance (Applicative m) => Applicative (ErrorfulT e m) where pure a = ErrorfulT . pure $ (Just a, []) @@ -63,12 +63,12 @@ instance (Monad m) => Monad (ErrorfulT e m) where ErrorfulT m >>= k = ErrorfulT $ do (a,es) <- m case a of - Just x -> runErrorfulT (k x) + Just x -> runErrorfulT (k x) <&> _2 %~ (es<>) Nothing -> pure (Nothing, es) mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a mapErrorful f (ErrorfulT m) = ErrorfulT $ - m & mapped . _2 . mapped %~ f + m <&> _2 . mapped %~ f -- when microlens-pro drops we can write this as -- mapErrorful f = coerced . mapped . _2 . mapped %~ f diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 20ee3eb..467216d 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -234,7 +234,7 @@ parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg) ddumpast :: Program' -> RLPCT m Program' ddumpast p = do - addDebugMsg "dump-ast" . show $ p + addDebugMsg "dump-parsed-core" . show $ p pure p happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 7b71f91..f95163e 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -41,6 +41,7 @@ module Core.Syntax , Binding' , HasRHS(_rhs) , HasLHS(_lhs) + , Pretty(pretty) ) where ---------------------------------------------------------------------------------- @@ -56,7 +57,7 @@ import Data.HashMap.Strict qualified as H import Data.Hashable import Data.Text qualified as T import Data.Char -import GHC.Generics +import GHC.Generics (Generic, Generically(..)) -- Lift instances for the Core quasiquoters import Language.Haskell.TH.Syntax (Lift) -- import Lens.Micro.TH (makeLenses) @@ -215,3 +216,61 @@ instance HasLHS (Binding b) (Binding b) b b where (\ (k := _) -> k) (\ (_ := e) k' -> k' := e) +-------------------------------------------------------------------------------- + +-- TODO: print type sigs with corresponding scdefs +-- TODO: emit pragmas for datatags +instance (Pretty b) => Pretty (Program b) where + pretty = vsepOf (programScDefs . each . to pretty) + +instance (Pretty b) => Pretty (ScDef b) where + pretty sc = hsep [name, as, "=", hang empty 1 e] + where + name = ttext $ sc ^. _lhs . _1 + as = sc & hsepOf (_lhs . _2 . each . to ttext) + e = pretty $ sc ^. _rhs + +instance (Pretty b) => Pretty (Expr b) where + prettyPrec _ (Var n) = ttext n + prettyPrec _ (Con t a) = "Pack{" <> (ttext t <+> ttext a) <> "}" + prettyPrec _ (Lam bs e) = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e] + prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs] + $$ hsep ["in", pretty e] + where word = if r == Rec then "letrec" else "let" + prettyPrec p (App f x) = maybeParens (p>0) $ + prettyPrec 0 f <+> prettyPrec 1 x + prettyPrec _ (Lit l) = pretty l + prettyPrec p (Case e as) = maybeParens (p>0) $ + "case" <+> pretty e <+> "of" + $$ nest 2 (explicitLayout as) + +{- + +x = pretty $ desugarRlpProg [rlpProg| + main = 3 + data B = T | F +|] + +-} + +instance (Pretty b) => Pretty (Alter b) where + pretty (Alter c as e) = + hsep [pretty c, hsep (pretty <$> as), "->", pretty e] + +instance Pretty AltCon where + pretty (AltData n) = ttext n + pretty (AltLit l) = pretty l + pretty (AltTag t) = ttext t + pretty AltDefault = "_" + +instance Pretty Lit where + pretty (IntL n) = ttext n + +instance (Pretty b) => Pretty (Binding b) where + pretty (k := v) = hsep [pretty k, "=", pretty v] + +explicitLayout :: (Pretty a) => [a] -> Doc +explicitLayout as = vcat inner <+> "}" where + inner = zipWith (<+>) delims (pretty <$> as) + delims = "{" : repeat ";" + diff --git a/src/Core2Core.hs b/src/Core2Core.hs index 7717aa7..a187a63 100644 --- a/src/Core2Core.hs +++ b/src/Core2Core.hs @@ -21,16 +21,27 @@ import Control.Arrow ((>>>)) import Data.Text qualified as T import Data.HashMap.Strict (HashMap) import Numeric (showHex) + +import Data.Pretty +import Compiler.RLPC -- import Lens.Micro.Platform import Control.Lens import Core.Syntax import Core.Utils ---------------------------------------------------------------------------------- +-- | General optimisations + core2core :: Program' -> Program' core2core p = undefined --- | G-machine preprocessing. +gmPrepR :: (Monad m) => Program' -> RLPCT m Program' +gmPrepR p = do + let p' = gmPrep p + addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p' + pure p' + +-- | G-machine-specific preprocessing. gmPrep :: Program' -> Program' gmPrep p = p & appFloater (floatNonStrictCases globals) @@ -46,7 +57,6 @@ gmPrep p = p & appFloater (floatNonStrictCases globals) defineData :: Program' -> Program' defineData p = p & programScDefs <>~ defs where - -- defs = ifoldMap' _ (p ^. programDataTags) defs = p ^. programDataTags . to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)])) diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index b00bfb1..f5b1b4d 100644 --- a/src/Data/Pretty.hs +++ b/src/Data/Pretty.hs @@ -1,17 +1,51 @@ -{-# LANGUAGE OverloadedStrings #-} module Data.Pretty ( Pretty(..) + , ttext + -- * Pretty-printing lens combinators + , hsepOf, vsepOf + , module Text.PrettyPrint + , maybeParens ) where ---------------------------------------------------------------------------------- -import Data.String (IsString(..)) +import Text.PrettyPrint hiding ((<>)) +import Text.PrettyPrint.HughesPJ hiding ((<>)) +import Data.String (IsString(..)) +import Data.Text.Lens +import Data.Monoid +import Data.Text qualified as T +import Control.Lens ---------------------------------------------------------------------------------- class Pretty a where - -- pretty :: a -> ISeq - -- prettyPrec :: a -> Int -> ISeq + pretty :: a -> Doc + prettyPrec :: Int -> a -> Doc - -- {-# MINIMAL pretty | prettyPrec #-} - -- pretty a = prettyPrec a 0 - -- prettyPrec a _ = iBracket (pretty a) + {-# MINIMAL pretty | prettyPrec #-} + pretty = prettyPrec 0 + prettyPrec a _ = pretty a + +instance Pretty String where + pretty = Text.PrettyPrint.text + +instance Pretty T.Text where + pretty = Text.PrettyPrint.text . view unpacked + +newtype Showing a = Showing a + +instance (Show a) => Pretty (Showing a) where + prettyPrec p (Showing a) = fromString $ showsPrec p a "" + +deriving via Showing Int instance Pretty Int + +-------------------------------------------------------------------------------- + +ttext :: Pretty t => t -> Doc +ttext = pretty + +hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc +hsepOf l = foldrOf l (<+>) mempty + +vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc +vsepOf l = foldrOf l ($+$) mempty diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 26363e5..6f8aeb2 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -228,6 +228,7 @@ Expr1 :: { RlpExpr' RlpcPs } : '(' Expr ')' { $1 .> $2 <. $3 } | Lit { fmap LitE $1 } | Var { fmap VarE $1 } + | Con { fmap VarE $1 } InfixOp :: { Located PsName } : consym { mkPsName $1 } @@ -251,8 +252,11 @@ parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st st = programInitState s parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs) -parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st - where +parseRlpProgR s = do + a <- liftErrorful $ pToErrorful parseRlpProg st + addDebugMsg @_ @String "dump-parsed" $ show a + pure a + where st = programInitState s mkPsName :: Located RlpToken -> Located PsName diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 017c2d6..887f40c 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveTraversable #-} module Rlp2Core - ( desugarRlpProg + ( desugarRlpProgR + , desugarRlpProg , desugarRlpExpr ) where @@ -15,6 +16,7 @@ import Control.Comonad -- import Lens.Micro -- import Lens.Micro.Internal import Control.Lens +import Compiler.RLPC import Data.List (mapAccumL) import Data.Text (Text) import Data.Text qualified as T @@ -26,6 +28,7 @@ import Data.Maybe (fromJust, fromMaybe) import Data.Functor.Bind import Data.Function (on) import Debug.Trace + import Effectful.State.Static.Local import Effectful.Labeled import Effectful @@ -33,6 +36,7 @@ import Text.Show.Deriving import Core.Syntax as Core import Compiler.Types +import Data.Pretty (render, pretty) import Rlp.Syntax as Rlp import Rlp.Parse.Types (RlpcPs, PsName) -------------------------------------------------------------------------------- @@ -55,6 +59,12 @@ deriveShow1 ''Branch -------------------------------------------------------------------------------- +desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program' +desugarRlpProgR p = do + let p' = desugarRlpProg p + addDebugMsg "dump-desugared" $ render (pretty p') + pure p' + desugarRlpProg :: RlpProgram RlpcPs -> Program' desugarRlpProg = rlpProgToCore @@ -107,10 +117,19 @@ exprToCore (VarE n) = pure $ Var (dsNameToName n) exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b +exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b + where + mkApp s t = (Var f `App` s) `App` t + exprToCore (CaseE (unXRec -> e) as) = do e' <- exprToCore e Case e' <$> caseAltToCore `traverse` as +exprToCore (LitE l) = litToCore l + +litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr' +litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n + -- TODO: where-binds caseAltToCore :: (NameSupply :> es) => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter' @@ -127,6 +146,7 @@ conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as Right <$> liftA2 (,) uniqueName br where br = unwrapFix <$> conToRose (unXRec p) +conToRose _ = error "conToRose: not a ConP!" branchToCore :: Expr' -> Branch Alter' -> Alter' branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'