From a6e267fc29a1137ccacc108e371cc6c6646f7e27 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 27 Feb 2024 06:14:02 -0700 Subject: [PATCH] terse pretty-printing --- examples/Core/factorial.cr | 2 + rlp.cabal | 3 + src/Compiler/JustRun.hs | 13 ++++- src/Core/Parse.y | 8 ++- src/Core/Syntax.hs | 116 +++++++++++++++++++++++++++++-------- src/Core/SystemF.hs | 15 ++++- src/Data/Pretty.hs | 12 ++++ 7 files changed, 139 insertions(+), 30 deletions(-) diff --git a/examples/Core/factorial.cr b/examples/Core/factorial.cr index 305e9d8..f6f5557 100644 --- a/examples/Core/factorial.cr +++ b/examples/Core/factorial.cr @@ -1,7 +1,9 @@ +fac : Int# -> Int# fac n = case (==#) n 0 of { <1> -> 1 ; <0> -> *# n (fac (-# n 1)) }; +main : IO () main = fac 3; diff --git a/rlp.cabal b/rlp.cabal index 4288b30..beb39bb 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -49,6 +49,9 @@ library , Core2Core , Rlp2Core , Control.Monad.Utils + , Misc + , Misc.Lift1 + , Core.SystemF build-tool-depends: happy:happy, alex:alex diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs index 7191885..9888bcc 100644 --- a/src/Compiler/JustRun.hs +++ b/src/Compiler/JustRun.hs @@ -12,13 +12,14 @@ module Compiler.JustRun , justParseCore , justTypeCheckCore , justHdbg + , makeItPretty, makeItPretty' ) where ---------------------------------------------------------------------------------- import Core.Lex import Core.Parse import Core.HindleyMilner -import Core.Syntax (Program') +import Core.Syntax import Compiler.RLPC import Control.Arrow ((>>>)) import Control.Monad ((>=>), void) @@ -30,6 +31,7 @@ import System.IO import GM import Rlp.Parse import Rlp2Core +import Data.Pretty ---------------------------------------------------------------------------------- justHdbg :: String -> IO GmState @@ -42,9 +44,8 @@ justLexCore s = lexCoreR (T.pack s) & mapped . each %~ extract & rlpcToEither -justParseCore :: String -> Either [MsgEnvelope RlpcError] Program' +justParseCore :: String -> Either [MsgEnvelope RlpcError] (Program Var) justParseCore s = parse (T.pack s) - & undefined & rlpcToEither where parse = lexCoreR @Identity >=> parseCoreProgR @@ -53,6 +54,12 @@ justTypeCheckCore s = typechk (T.pack s) & rlpcToEither where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR +makeItPretty :: (Pretty a) => Either e a -> Either e Doc +makeItPretty = fmap pretty + +makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc +makeItPretty' = fmap (pretty . WithTerseBinds) + rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a rlpcToEither r = case evalRLPC def r of (Just a, _) -> Right a diff --git a/src/Core/Parse.y b/src/Core/Parse.y index c89cb62..d6aecf8 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -69,6 +69,8 @@ import Core.Parse.Types ':' { Located _ TokenHasType } eof { Located _ TokenEOF } +%right '->' + %% Eof :: { () } @@ -114,7 +116,11 @@ TypedScDef :: { (Var, ScDef Var) } -- ($4 & binders %~ Right) } Type :: { Type } - : Type1 '->' Type { $1 :-> $3 } + : TypeApp '->' TypeApp { $1 :-> $3 } + | TypeApp { $1 } + +TypeApp :: { Type } + : TypeApp Type1 { TyApp $1 $2 } | Type1 { $1 } -- do we want to allow symbolic names for tyvars and tycons? diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index cece62e..8411e49 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -29,8 +29,8 @@ module Core.Syntax , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let , pattern Case, pattern Type, pattern Lit - -- * Misc - , Pretty(pretty) + -- * Pretty-printing + , Pretty(pretty), WithTerseBinds(..) -- * Optics , programScDefs, programTypeSigs, programDataTags @@ -59,6 +59,7 @@ import Data.These import GHC.Generics (Generic, Generically(..)) import Text.Show.Deriving import Data.Eq.Deriving +import Data.Kind qualified import Data.Fix hiding (cata, ana) import Data.Bifunctor (Bifunctor(..)) @@ -293,6 +294,44 @@ formalising = iso sa bt where -------------------------------------------------------------------------------- +newtype WithTerseBinds a = WithTerseBinds a + +class MakeTerse a where + type AsTerse a :: Data.Kind.Type + asTerse :: a -> AsTerse a + +instance MakeTerse Var where + type AsTerse Var = Name + asTerse (MkVar n _) = n + +instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b) + => Pretty (WithTerseBinds (Program b)) where + pretty (WithTerseBinds p) + = (datatags <> "\n") + $+$ defs + where + datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p + defs = vlinesOf (programJoinedDefs . to prettyGroup) p + + programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b)) + programJoinedDefs = folding $ \p -> + foldMapOf programTypeSigs thisTs p + `u` foldMapOf programScDefs thatSc p + where u = H.unionWith unionThese + + thisTs = ifoldMap @b @(HashMap b) + (\n t -> H.singleton n (This (n,t))) + thatSc = foldMap $ \sc -> + H.singleton (sc ^. _lhs . _1) (That sc) + + prettyGroup :: These (b, Type) (ScDef b) -> Doc + prettyGroup = bifoldr vs vs mempty + . bimap (uncurry prettyTySig') + (pretty . WithTerseBinds) + where vs = vsepTerm ";" + + cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc + instance (Hashable b, Pretty b) => Pretty (Program b) where pretty p = (datatags <> "\n") $+$ defs @@ -312,30 +351,48 @@ instance (Hashable b, Pretty b) => Pretty (Program b) where H.singleton (sc ^. _lhs . _1) (That sc) prettyGroup :: These (b, Type) (ScDef b) -> Doc - prettyGroup = bifoldr vcatWithSemi vcatWithSemi mempty - . bimap prettyTySig pretty - - vcatWithSemi a b = (a <+> ";") $$ b - - prettyTySig (n,t) = hsep [ttext n, "::", pretty t] - - unionThese (This a) (That b) = These a b - unionThese (That b) (This a) = These a b - unionThese (These a b) _ = These a b + prettyGroup = bifoldr vs vs mempty + . bimap (uncurry prettyTySig) pretty + where vs = vsepTerm ";" cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc - prettyDataTag n t a = - hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"] +unionThese :: These a b -> These a b -> These a b +unionThese (This a) (That b) = These a b +unionThese (That b) (This a) = These a b +unionThese (These a b) _ = These a b + +prettyDataTag :: (Pretty n, Pretty t, Pretty a) + => n -> t -> a -> Doc +prettyDataTag n t a = + hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"] + +prettyTySig :: (Pretty n, Pretty t) => n -> t -> Doc +prettyTySig n t = hsep [ttext n, ":", pretty t] + +prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc +prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t] + +-- Pretty Type +-- TyApp | appPrec | left +-- (:->) | appPrec-1 | right instance Pretty Type where - prettyPrec _ (TyVar n) = ttext n - prettyPrec _ TyFun = "(->)" - prettyPrec _ (TyCon n) = ttext n - prettyPrec p (a :-> b) = maybeParens (p>0) $ - hsep [prettyPrec 1 a, "->", prettyPrec 0 b] - prettyPrec p (TyApp f x) = maybeParens (p>1) $ - prettyPrec 1 f <+> prettyPrec 2 x + prettyPrec _ (TyVar n) = ttext n + prettyPrec _ TyFun = "(->)" + prettyPrec _ (TyCon n) = ttext n + prettyPrec p (a :-> b) = maybeParens (p>appPrec-1) $ + hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b] + prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $ + prettyPrec appPrec f <+> prettyPrec appPrec1 x + +instance (Pretty b, Pretty (AsTerse b), MakeTerse b) + => Pretty (WithTerseBinds (ScDef b)) where + pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e] + where + name = ttext $ sc ^. _lhs . _1 . to asTerse + as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext) + e = pretty $ sc ^. _rhs instance (Pretty b) => Pretty (ScDef b) where pretty sc = hsep [name, as, "=", hang empty 1 e] @@ -344,9 +401,18 @@ instance (Pretty b) => Pretty (ScDef b) where 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) <> "}" +instance (Pretty (f (Fix f))) => Pretty (Fix f) where + prettyPrec d (Fix f) = prettyPrec d f + +-- Pretty Expr +-- LamF | appPrec1 | right +-- AppF | appPrec | left + +instance (Pretty b, Pretty a) => Pretty (ExprF b a) where + prettyPrec _ (VarF n) = ttext n + prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}" + prettyPrec p (LamF bs e) = maybeParens (p bs), "->", pretty e] -- prettyPrec _ (Lam bs e) = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e] -- prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs] -- $+$ hsep ["in", pretty e] @@ -372,7 +438,7 @@ instance Pretty Lit where pretty (IntL n) = ttext n instance (Pretty b, Pretty a) => Pretty (BindingF b a) where - -- pretty (k := v) = hsep [pretty k, "=", pretty v] + pretty (BindingF k v) = hsep [pretty k, "=", pretty v] explicitLayout :: (Pretty a) => [a] -> Doc explicitLayout as = vcat inner <+> "}" where diff --git a/src/Core/SystemF.hs b/src/Core/SystemF.hs index a7c7414..b375fc7 100644 --- a/src/Core/SystemF.hs +++ b/src/Core/SystemF.hs @@ -1,2 +1,15 @@ -module Core.SystemF where +module Core.SystemF + ( lintCoreProgR + ) + where +-------------------------------------------------------------------------------- +import Compiler.RLPC +import Core +-------------------------------------------------------------------------------- + +lintCoreProgR :: (Monad m) => Program Var -> RLPCT m (Program Name) +lintCoreProgR = undefined + +lint :: Program Var -> Program Name +lint = undefined diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index 56086b0..972ed9f 100644 --- a/src/Data/Pretty.hs +++ b/src/Data/Pretty.hs @@ -6,8 +6,11 @@ module Data.Pretty , hsepOf, vsepOf , vcatOf , vlinesOf + , vsepTerm , module Text.PrettyPrint , maybeParens + , appPrec + , appPrec1 ) where ---------------------------------------------------------------------------------- @@ -63,3 +66,12 @@ vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty -- hack(?) to separate chunks with a blankline +vsepTerm :: Doc -> Doc -> Doc -> Doc +vsepTerm term a b = (a <> term) $+$ b + +-------------------------------------------------------------------------------- + +appPrec, appPrec1 :: Int +appPrec = 10 +appPrec1 = 11 +