terse pretty-printing

2024-02-27 06:14:02 -07:00
parent 1315ea7ea8
commit b67fe4eb2d
7 changed files with 139 additions and 30 deletions
--- 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;

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

--- 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
--- 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?
--- 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<appPrec1) $
+        hsep ["λ", hsep (prettyPrec appPrec1 <$> 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
--- 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

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