More printing

Author: dougalm

dex.cabal

@@ -114,7 +114,7 @@ library
                      , megaparsec
                      , parser-combinators
                        -- Text output
-                     , prettyprinter
+                     -- , prettyprinter
                      , text
                        -- Portable system utilities
                      , directory
@@ -232,7 +232,7 @@ executable dex
                      , haskeline
                      , mtl
                      , optparse-applicative
-                     , prettyprinter
+                     -- , prettyprinter
                      , store
                      , text
                      , unix

src/lib/PPrint.hs

@@ -4,9 +4,11 @@
 -- license that can be found in the LICENSE file or at
 -- https://developers.google.com/open-source/licenses/bsd
 
-module PPrint (Pretty (..), Doc (..), indent, hcat, vcat, pprint, app) where
+module PPrint (Pretty (..), Doc (..), indent, hcat, hlist, vcat, pprint, app) where
 
 import Data.Int
+import Data.Word
+import Data.List (intersperse)
 import Data.String
 import Control.Monad.Reader
 import Control.Monad.State.Strict
@@ -59,7 +61,8 @@ vcat :: [Doc] -> Doc
 vcat = DocItems
 
 hlist :: String -> [Doc] -> Doc
-hlist [l,sep,r] xs = undefined
+hlist [l,sep,r] xs = hcat [pr l, hcat (intersperse (pr sep) xs), pr r]
+
 hlist _ _ = error "expected left bracket, separator, right bracket"
 
 hcat :: [Doc] -> Doc
@@ -78,7 +81,7 @@ indent = DocIndent
 app :: Doc -> [Doc] -> Doc
 app f xs = hcat [f, hlist "(,)" xs]
 
--- === instances
+-- === instances ===
 
 instance IsString Doc where
   fromString = DocLine
@@ -93,7 +96,14 @@ instance Pretty a => Pretty [a] where
 instance (Pretty a, Pretty b) => Pretty (a, b) where
   pr (x, y) = hcat ["(", pr x, ", ", pr y, ")"]
 
-instance Pretty Int   where pr x = pr $ show x
-instance Pretty Int32 where pr x = pr $ show x
-instance Pretty Int64 where pr x = pr $ show x
-instance Pretty Float where pr x = pr $ show x
+instance Pretty a => Pretty (Maybe a) where
+  pr = \case
+    Nothing -> ""
+    Just x -> pr x
+
+instance Pretty Int    where pr x = pr $ show x
+instance Pretty Int32  where pr x = pr $ show x
+instance Pretty Int64  where pr x = pr $ show x
+instance Pretty Float  where pr x = pr $ show x
+instance Pretty Double where pr x = pr $ show x
+instance Pretty Word64 where pr x = pr $ show x

src/lib/Types/Complicated.hs

@@ -176,7 +176,18 @@ data DataConDef n =
 
 instance GenericE CExpr where
   type RepE CExpr = UnitE
-instance Pretty (CExpr n)
+
+instance Pretty (CExpr n) where
+  pr = \case
+    CBlock  _ b -> pr b
+    CVar v _ -> pr v
+    CLit l -> pr l
+    CPrimOp _ op -> pr op
+    CTyCon _ -> undefined
+    Lam _ -> undefined
+    NewtypeCon _ _ -> undefined
+    Dict _ -> undefined
+
 instance SinkableE      CExpr
 instance HoistableE     CExpr
 instance RenameE        CExpr

src/lib/Types/Primitives.hs

@@ -381,6 +381,9 @@ instance Pretty ScalarBaseType where
     Word32Type  -> "Word32"
     Word64Type  -> "Word64"
 
+instance Pretty BinOp where pr x = pr $ show x
+instance Pretty UnOp  where pr x = pr $ show x
+
 instance Pretty a => Pretty (PrimOp a) where
   pr = \case
     MemOp    op -> pr op
@@ -390,8 +393,8 @@ instance Pretty a => Pretty (PrimOp a) where
       MPut x      -> app "(:=)" [pr ref, pr x]
       IndexRef i  -> app "(!)"  [pr ref, pr i]
       ProjRef i   -> app "proj_ref" [pr ref, pr i]
-    UnOp  op x   -> undefined
-    BinOp op x y -> undefined
+    UnOp  op x   -> app (pr op) [pr x]
+    BinOp op x y -> app (pr op) [pr x, pr y]
     MiscOp op -> undefined
 
 instance Pretty Projection where

src/lib/Types/Source.hs

@@ -905,9 +905,18 @@ instance Pretty CSBlock where
   pr (ExprBlock g) = pr g
 
 instance Pretty Group where
-  pr = undefined
-  -- prettyPrec (CIdentifier n) = atPrec ArgPrec $ fromString n
-  -- prettyPrec (CPrim prim args) = prettyOpDefault prim args
+  pr = \case
+    CLeaf leaf -> pr leaf
+    CPrim prim args -> app (pr prim) (map pr args)
+
+
+-- prettyOpDefault :: PrettyPrec a => PrimName -> [a] -> DocPrec ann
+-- prettyOpDefault name args =
+--   case length args of
+--     0 -> atPrec ArgPrec primName
+--     _ -> atPrec AppPrec $ pAppArg primName args
+--   where primName = pretty name
+    
   -- prettyPrec (CParens blk)  =
   --   atPrec ArgPrec $ "(" <> p blk <> ")"
   -- prettyPrec (CBrackets g) = atPrec ArgPrec $ pretty g
@@ -919,6 +928,16 @@ instance Pretty Group where
   --   atPrec LowestPrec $ "case " <> p scrut <> " of " <> prettyLines alts
   -- prettyPrec g = atPrec ArgPrec $ fromString $ show g
 
+instance Pretty CLeaf where
+  pr = \case
+    CIdentifier s -> pr s
+    CNat n -> pr n
+    CInt n -> pr n
+    CString s -> pr $ show s
+    CChar c -> pr $ show c
+    CFloat f -> pr f
+    CHole -> "_"
+
 instance Pretty Bin where
   pr = \case
     EvalBinOp name -> pr name
@@ -945,8 +964,7 @@ instance Pretty CTopDecl where
   pr d = fromString $ show d
 
 instance Pretty CSDecl where
-  pr = undefined
-  -- pr (CLet pat blk) = pArg pat <+> "=" <+> p blk
+  pr (CLet pat blk) = hcat [pr pat, "=", pr blk]
   -- pr (CDefDecl (CDef name args maybeAnn blk)) =
   --   "def " <> fromString name <> " " <> prParamGroups args <+> annDoc
   --     <> nest 2 (hardline <> p blk)
@@ -990,8 +1008,9 @@ instance Pretty (UAlt n) where
   pr (UAlt pat body) = undefined -- pr pat <+> "->" <+> pr body
 
 instance Pretty UTopDecl where
-  pr = undefined
-  -- pretty = \case
+  pr = \case
+    UTopLet b _ expr -> hcat [pr b, " = ", pr expr]
+     -- (Maybe (UType VoidS)) (UExpr VoidS)
   --   UDataDefDecl (UDataDef nm bs dataCons) bTyCon bDataCons ->
   --     "enum" <+> p bTyCon <+> p nm <+> spaced (unsafeFromNest bs) <+> "where" <> nest 2
   --        (prettyLines (zip (toList $ unsafeFromNest bDataCons) dataCons))
@@ -1056,11 +1075,9 @@ instance Pretty (UBlock' n) where
   --   prettyLines (unsafeFromNest decls) <> hardline <> pLowest result
 
 instance Pretty (UExpr' n) where
-  pr = undefined
--- instance PrettyPrec (UExpr' n) where
---   prettyPrec expr = case expr of
---     ULit l -> prettyPrec l
---     UVar v -> atPrec ArgPrec $ p v
+  pr = \case
+    ULit l -> pr l
+    UVar v -> pr v
 --     ULam lam -> prettyPrec lam
 --     UApp    f xs named -> atPrec AppPrec $ pAppArg (pApp f) xs <+> p named
 --     UTabApp f x -> atPrec AppPrec $ pArg f <> "." <> pArg x
@@ -1078,20 +1095,20 @@ instance Pretty (UExpr' n) where
 --     UTypeAnn v ty -> atPrec LowestPrec $
 --       group $ pApp v <> line <> ":" <+> pApp ty
 --     UTabCon xs -> atPrec ArgPrec $ p xs
---     UPrim prim xs -> atPrec AppPrec $ p (show prim) <+> p xs
+    UPrim prim xs -> app (pr prim) (map pr xs)
 --     UCase e alts -> atPrec LowestPrec $ "case" <+> p e <>
 --       nest 2 (prettyLines alts)
 --     UFieldAccess x (WithSrc _ f) -> atPrec AppPrec $ p x <> "~" <> p f
---     UNatLit   v -> atPrec ArgPrec $ p v
---     UIntLit   v -> atPrec ArgPrec $ p v
---     UFloatLit v -> atPrec ArgPrec $ p v
+    UNatLit   v -> pr v
+    UIntLit   v -> pr v
+    UFloatLit v -> pr v
 --     UDo block -> atPrec LowestPrec $ p block
 --     where
 --       p :: Pretty a => a -> Doc ann
 --       p = pretty
 
 instance Pretty SourceBlock where
-  pr block = undefined
+  pr block = pr $ sbContents block
     -- pr $ ensureNewline (sbText block) where
     -- -- Force the SourceBlock to end in a newline for echoing, even if
     -- -- it was terminated with EOF in the original program.
@@ -1105,7 +1122,7 @@ instance Pretty Output where
     TextOut s -> pr s
     HtmlOut _ -> "<html output>"
     SourceInfo _ -> ""
-    PassResult _ s -> undefined -- pr s
+    PassResult _ s -> pr s
     MiscLog s -> pr s
     Error e -> pr e
 
@@ -1122,10 +1139,3 @@ instance Pretty FieldName' where
   pr = \case
     FieldName s -> pr s
     FieldNum n  -> pr n
-
--- prettyOpDefault :: PrettyPrec a => PrimName -> [a] -> DocPrec ann
--- prettyOpDefault name args =
---   case length args of
---     0 -> atPrec ArgPrec primName
---     _ -> atPrec AppPrec $ pAppArg primName args
---   where primName = pretty name

src/lib/Types/Top2.hs

@@ -13,7 +13,6 @@ module Types.Top2 where
 
 import Data.Functor ((<&>))
 import Data.Hashable
-import Data.Text.Prettyprint.Doc
 import qualified Data.Map.Strict       as M
 import qualified Data.Set              as S
 

src/lib/Util.hs

@@ -28,11 +28,11 @@ import qualified Data.Text.Encoding as T
 import qualified Data.List.NonEmpty as NE
 import qualified Data.ByteString    as BS
 import Data.Foldable
-import Data.Text.Prettyprint.Doc (Pretty (..), pretty)
 import Data.List.NonEmpty (NonEmpty (..))
 import GHC.Generics (Generic)
 
 import Err
+import PPrint
 
 class IsBool a where
   toBool :: a -> Bool
@@ -365,9 +365,9 @@ zipTrees (Branch xs) (Branch ys) | length xs == length ys = Branch $ zipWith zip
 zipTrees _ _ = error "zip error"
 
 instance Pretty a => Pretty (Tree a) where
-  pretty = \case
-    Leaf x -> pretty x
-    Branch xs -> pretty xs
+  pr = \case
+    Leaf x -> pr x
+    Branch xs -> pr xs
 
 readFileText :: MonadIO m => FilePath -> m T.Text
 readFileText fname = liftIO $ T.decodeUtf8 <$> BS.readFile fname