diff --git a/dex.cabal b/dex.cabal index a6a98f14b..eba4ea139 100644 --- a/dex.cabal +++ b/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 diff --git a/src/lib/PPrint.hs b/src/lib/PPrint.hs index 8570fdce3..a48964508 100644 --- a/src/lib/PPrint.hs +++ b/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 diff --git a/src/lib/Types/Complicated.hs b/src/lib/Types/Complicated.hs index 1af10ac4b..7d35c69f3 100644 --- a/src/lib/Types/Complicated.hs +++ b/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 diff --git a/src/lib/Types/Primitives.hs b/src/lib/Types/Primitives.hs index 404fd20e6..3aec4574c 100644 --- a/src/lib/Types/Primitives.hs +++ b/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 diff --git a/src/lib/Types/Source.hs b/src/lib/Types/Source.hs index eb8ad3620..35e1e04a9 100644 --- a/src/lib/Types/Source.hs +++ b/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 _ -> "" 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 diff --git a/src/lib/Types/Top2.hs b/src/lib/Types/Top2.hs index 868130d69..cfbfc52ed 100644 --- a/src/lib/Types/Top2.hs +++ b/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 diff --git a/src/lib/Util.hs b/src/lib/Util.hs index 0eed90bdd..2bb1504e7 100644 --- a/src/lib/Util.hs +++ b/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