msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

ppr debug flags

Browse Source 
ddump-parsed
This commit is contained in:
crumbtoo
2024-02-08 09:26:53 -07:00
parent 1079fc7c9b
commit 6c943af4a1
14 changed files with 244 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/Compiler/RLPC.hs
View File

@@ -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) =

4
src/Compiler/RlpcError.hs
View File

@@ -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

6
src/Control/Monad/Errorful.hs
View File

@@ -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

2
src/Core/Parse.y
View File

@@ -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

61
src/Core/Syntax.hs
View File

@@ -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 ";"

14
src/Core2Core.hs
View File

@@ -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)]))

48
src/Data/Pretty.hs
View File

@@ -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

8
src/Rlp/Parse.y
View File

@@ -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

22
src/Rlp2Core.hs
View File

@@ -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'