pretty -> prettyprinter
This commit is contained in:
crumbtoo
@@ -65,11 +65,11 @@ 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 :: (Out a) => Either e a -> Either e (Doc ann)
|
||||
makeItPretty = fmap out
|
||||
|
||||
makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc
|
||||
makeItPretty' = fmap (pretty . WithTerseBinds)
|
||||
makeItPretty' :: (Out (WithTerseBinds a)) => Either e a -> Either e (Doc ann)
|
||||
makeItPretty' = fmap (out . WithTerseBinds)
|
||||
|
||||
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
|
||||
rlpcToEither r = case evalRLPC def r of
|
||||
|
||||
@@ -54,6 +54,7 @@ import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Maybe
|
||||
import Data.Pretty
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as S
|
||||
@@ -63,7 +64,6 @@ 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 Control.Lens
|
||||
import Data.Text.Lens (packed, unpacked, IsText)
|
||||
import System.Exit
|
||||
@@ -203,7 +203,7 @@ renderRlpcErrs opts = (if don'tBother then id else filter byTag)
|
||||
|
||||
prettyRlpcMsg :: MsgEnvelope RlpcError -> String
|
||||
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
|
||||
prettyRlpcMsg m = render $ docRlpcErr m
|
||||
prettyRlpcMsg m = show $ docRlpcErr m
|
||||
|
||||
prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
|
||||
prettyRlpcDebugMsg msg =
|
||||
@@ -213,10 +213,10 @@ prettyRlpcDebugMsg msg =
|
||||
Text ts = msg ^. msgDiagnostic
|
||||
SevDebug tag = msg ^. msgSeverity
|
||||
|
||||
docRlpcErr :: MsgEnvelope RlpcError -> Doc
|
||||
docRlpcErr msg = header
|
||||
$$ nest 2 bullets
|
||||
$$ source
|
||||
docRlpcErr :: MsgEnvelope RlpcError -> Doc ann
|
||||
docRlpcErr msg = vcat [ header
|
||||
, nest 2 bullets
|
||||
, source ]
|
||||
where
|
||||
source = vcat $ zipWith (<+>) rule srclines
|
||||
where
|
||||
@@ -231,11 +231,10 @@ docRlpcErr msg = header
|
||||
<> errorColour "error" <> msgColour ":"
|
||||
|
||||
bullets = let Text ts = msg ^. msgDiagnostic
|
||||
in vcat $ hang "•" 2 . ttext . msgColour <$> ts
|
||||
in vcat $ ("•" <>) . hang 2 . ttext . msgColour <$> ts
|
||||
|
||||
msgColour = Ansi.white . Ansi.bold
|
||||
errorColour = Ansi.red . Ansi.bold
|
||||
ttext = text . T.unpack
|
||||
tshow :: (Show a) => a -> Text
|
||||
tshow = T.pack . show
|
||||
|
||||
|
||||
@@ -16,22 +16,9 @@ module Core.HindleyMilner
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Lens hiding (Context', Context)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Pretty (rpretty)
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Functor
|
||||
import Data.Functor.Identity
|
||||
import Compiler.RLPC
|
||||
import Compiler.Types
|
||||
import Compiler.RlpcError
|
||||
import Control.Monad (foldM, void, forM)
|
||||
import Data.Text qualified as T
|
||||
import Control.Monad.Errorful
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Utils (mapAccumLM, generalise)
|
||||
import Text.Printf
|
||||
import Core.Syntax
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
@@ -60,21 +47,7 @@ data TypeError
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance IsRlpcError TypeError where
|
||||
liftRlpcError = \case
|
||||
-- todo: use anti-parser instead of show
|
||||
TyErrCouldNotUnify t u -> Text
|
||||
[ T.pack $ printf "Could not match type `%s` with `%s`."
|
||||
(rpretty @String t) (rpretty @String u)
|
||||
, "Expected: " <> rpretty t
|
||||
, "Got: " <> rpretty u
|
||||
]
|
||||
TyErrUntypedVariable n -> Text
|
||||
[ "Untyped (likely undefined) variable `" <> n <> "`"
|
||||
]
|
||||
TyErrRecursiveType t x -> Text
|
||||
[ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
|
||||
(rpretty @String t) (rpretty @String x)
|
||||
]
|
||||
liftRlpcError = undefined
|
||||
|
||||
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
|
||||
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
|
||||
|
||||
@@ -29,8 +29,8 @@ module Core.Syntax
|
||||
, pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
|
||||
, pattern Case, pattern Type, pattern Lit
|
||||
|
||||
-- * Pretty-printing
|
||||
, Pretty(pretty), WithTerseBinds(..)
|
||||
-- * pretty-printing
|
||||
, Out(out), WithTerseBinds(..)
|
||||
|
||||
-- * Optics
|
||||
, HasArrowSyntax(..)
|
||||
@@ -335,11 +335,11 @@ 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
|
||||
instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
|
||||
=> Out (WithTerseBinds (Program b)) where
|
||||
out (WithTerseBinds p)
|
||||
= vsep [ (datatags <> "\n")
|
||||
, defs ]
|
||||
where
|
||||
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
|
||||
defs = vlinesOf (programJoinedDefs . to prettyGroup) p
|
||||
@@ -355,17 +355,17 @@ instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
|
||||
thatSc = foldMap $ \sc ->
|
||||
H.singleton (sc ^. _lhs . _1) (That sc)
|
||||
|
||||
prettyGroup :: These (b, Type) (ScDef b) -> Doc
|
||||
prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
|
||||
prettyGroup = bifoldr vs vs mempty
|
||||
. bimap (uncurry prettyTySig')
|
||||
(pretty . WithTerseBinds)
|
||||
where vs = vsepTerm ";"
|
||||
(out . WithTerseBinds)
|
||||
where vs a b = a <> ";" <> line <> b
|
||||
|
||||
cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
|
||||
cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
|
||||
|
||||
instance (Hashable b, Pretty b) => Pretty (Program b) where
|
||||
pretty p = (datatags <> "\n")
|
||||
$+$ defs
|
||||
instance (Hashable b, Out b) => Out (Program b) where
|
||||
out p = vsep [ datatags <> "\n"
|
||||
, defs ]
|
||||
where
|
||||
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
|
||||
defs = vlinesOf (programJoinedDefs . to prettyGroup) p
|
||||
@@ -381,139 +381,139 @@ instance (Hashable b, Pretty b) => Pretty (Program b) where
|
||||
thatSc = foldMap $ \sc ->
|
||||
H.singleton (sc ^. _lhs . _1) (That sc)
|
||||
|
||||
prettyGroup :: These (b, Type) (ScDef b) -> Doc
|
||||
prettyGroup :: These (b, Type) (ScDef b) -> Doc ann
|
||||
prettyGroup = bifoldr vs vs mempty
|
||||
. bimap (uncurry prettyTySig) pretty
|
||||
where vs = vsepTerm ";"
|
||||
. bimap (uncurry prettyTySig) out
|
||||
where vs a b = a <> ";" <> line <> b
|
||||
|
||||
cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
|
||||
cataDataTag n (t,a) acc = prettyDataTag n t a <> line <> acc
|
||||
|
||||
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 :: (Out n, Out t, Out a)
|
||||
=> n -> t -> a -> Doc ann
|
||||
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 :: (Out n, Out t) => n -> t -> Doc ann
|
||||
prettyTySig n t = hsep [ttext n, ":", out t]
|
||||
|
||||
prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc
|
||||
prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t]
|
||||
prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
|
||||
prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
|
||||
|
||||
-- Pretty Type
|
||||
-- out 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>appPrec-1) $
|
||||
hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b]
|
||||
prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $
|
||||
prettyPrec appPrec f <+> prettyPrec appPrec1 x
|
||||
prettyPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
|
||||
"∀" <+> (prettyPrec appPrec1 a <> ".") <+> pretty m
|
||||
prettyPrec _ TyKindType = "Type"
|
||||
instance Out Type where
|
||||
outPrec _ (TyVar n) = ttext n
|
||||
outPrec _ TyFun = "(->)"
|
||||
outPrec _ (TyCon n) = ttext n
|
||||
outPrec p (a :-> b) = maybeParens (p>appPrec-1) $
|
||||
hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
|
||||
outPrec p (TyApp f x) = maybeParens (p>appPrec) $
|
||||
outPrec appPrec f <+> outPrec appPrec1 x
|
||||
outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
|
||||
"∀" <+> (outPrec appPrec1 a <> ".") <+> out m
|
||||
outPrec _ TyKindType = "Type"
|
||||
|
||||
instance (Pretty b, Pretty (AsTerse b), MakeTerse b)
|
||||
=> Pretty (WithTerseBinds (ScDef b)) where
|
||||
pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e]
|
||||
instance (Out b, Out (AsTerse b), MakeTerse b)
|
||||
=> Out (WithTerseBinds (ScDef b)) where
|
||||
out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
|
||||
where
|
||||
name = ttext $ sc ^. _lhs . _1 . to asTerse
|
||||
as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext)
|
||||
e = pretty $ sc ^. _rhs
|
||||
e = out $ sc ^. _rhs
|
||||
|
||||
instance (Pretty b) => Pretty (ScDef b) where
|
||||
pretty sc = hsep [name, as, "=", hang empty 1 e]
|
||||
instance (Out b) => Out (ScDef b) where
|
||||
out sc = hsep [name, as, "=", hang 1 e]
|
||||
where
|
||||
name = ttext $ sc ^. _lhs . _1
|
||||
as = sc & hsepOf (_lhs . _2 . each . to ttext)
|
||||
e = pretty $ sc ^. _rhs
|
||||
e = out $ sc ^. _rhs
|
||||
|
||||
-- Pretty Expr
|
||||
-- out Expr
|
||||
-- LamF | appPrec1 | right
|
||||
-- AppF | appPrec | left
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (ExprF b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
-- prettyPrec _ (VarF n) = ttext n
|
||||
-- prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
|
||||
-- prettyPrec p (LamF bs e) = maybeParens (p>0) $
|
||||
-- hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e]
|
||||
-- prettyPrec p (LetF r bs e) = maybeParens (p>0)
|
||||
-- $ hsep [pretty r, explicitLayout bs]
|
||||
-- $+$ hsep ["in", pretty e]
|
||||
-- prettyPrec p (AppF f x) = maybeParens (p>appPrec) $
|
||||
-- prettyPrec appPrec f <+> prettyPrec appPrec1 x
|
||||
-- prettyPrec p (LitF l) = prettyPrec p l
|
||||
-- prettyPrec p (CaseF e as) = maybeParens (p>0) $
|
||||
-- "case" <+> pretty e <+> "of"
|
||||
-- outPrec _ (VarF n) = ttext n
|
||||
-- outPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
|
||||
-- outPrec p (LamF bs e) = maybeParens (p>0) $
|
||||
-- hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", out e]
|
||||
-- outPrec p (LetF r bs e) = maybeParens (p>0)
|
||||
-- $ hsep [out r, explicitLayout bs]
|
||||
-- $+$ hsep ["in", out e]
|
||||
-- outPrec p (AppF f x) = maybeParens (p>appPrec) $
|
||||
-- outPrec appPrec f <+> outPrec appPrec1 x
|
||||
-- outPrec p (LitF l) = outPrec p l
|
||||
-- outPrec p (CaseF e as) = maybeParens (p>0) $
|
||||
-- "case" <+> out e <+> "of"
|
||||
-- $+$ nest 2 (explicitLayout as)
|
||||
-- prettyPrec p (TypeF t) = "@" <> prettyPrec appPrec1 t
|
||||
-- outPrec p (TypeF t) = "@" <> outPrec appPrec1 t
|
||||
|
||||
instance (Pretty b) => Pretty1 (ExprF b) where
|
||||
liftPrettyPrec pr _ (VarF n) = ttext n
|
||||
liftPrettyPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
|
||||
liftPrettyPrec pr p (LamF bs e) = maybeParens (p>0) $
|
||||
hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pr 0 e]
|
||||
liftPrettyPrec pr p (LetF r bs e) = maybeParens (p>0)
|
||||
$ hsep [pretty r, bs']
|
||||
$+$ hsep ["in", pr 0 e]
|
||||
where bs' = liftExplicitLayout (liftPrettyPrec pr 0) bs
|
||||
liftPrettyPrec pr p (AppF f x) = maybeParens (p>appPrec) $
|
||||
instance (Out b) => Out1 (ExprF b) where
|
||||
liftOutPrec pr _ (VarF n) = ttext n
|
||||
liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
|
||||
liftOutPrec pr p (LamF bs e) = maybeParens (p>0) $
|
||||
hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", pr 0 e]
|
||||
liftOutPrec pr p (LetF r bs e) = maybeParens (p>0)
|
||||
$ vsep [ hsep [out r, bs']
|
||||
, hsep ["in", pr 0 e] ]
|
||||
where bs' = liftExplicitLayout (liftOutPrec pr 0) bs
|
||||
liftOutPrec pr p (AppF f x) = maybeParens (p>appPrec) $
|
||||
pr appPrec f <+> pr appPrec1 x
|
||||
liftPrettyPrec pr p (LitF l) = prettyPrec p l
|
||||
liftPrettyPrec pr p (CaseF e as) = maybeParens (p>0) $
|
||||
"case" <+> pr 0 e <+> "of"
|
||||
$+$ nest 2 as'
|
||||
where as' = liftExplicitLayout (liftPrettyPrec pr 0) as
|
||||
liftPrettyPrec pr p (TypeF t) = "@" <> prettyPrec appPrec1 t
|
||||
liftOutPrec pr p (LitF l) = outPrec p l
|
||||
liftOutPrec pr p (CaseF e as) = maybeParens (p>0) $
|
||||
vsep [ "case" <+> pr 0 e <+> "of"
|
||||
, nest 2 as' ]
|
||||
where as' = liftExplicitLayout (liftOutPrec pr 0) as
|
||||
liftOutPrec pr p (TypeF t) = "@" <> outPrec appPrec1 t
|
||||
|
||||
instance Pretty Rec where
|
||||
pretty Rec = "letrec"
|
||||
pretty NonRec = "let"
|
||||
instance Out Rec where
|
||||
out Rec = "letrec"
|
||||
out NonRec = "let"
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (AlterF b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance (Pretty b) => Pretty1 (AlterF b) where
|
||||
liftPrettyPrec pr _ (AlterF c as e) =
|
||||
hsep [pretty c, hsep (pretty <$> as), "->", liftPrettyPrec pr 0 e]
|
||||
instance (Out b) => Out1 (AlterF b) where
|
||||
liftOutPrec pr _ (AlterF c as e) =
|
||||
hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
|
||||
|
||||
instance Pretty AltCon where
|
||||
pretty (AltData n) = ttext n
|
||||
pretty (AltLit l) = pretty l
|
||||
pretty (AltTag t) = "<" <> ttext t <> ">"
|
||||
pretty AltDefault = "_"
|
||||
instance Out AltCon where
|
||||
out (AltData n) = ttext n
|
||||
out (AltLit l) = out l
|
||||
out (AltTag t) = "<" <> ttext t <> ">"
|
||||
out AltDefault = "_"
|
||||
|
||||
instance Pretty Lit where
|
||||
pretty (IntL n) = ttext n
|
||||
instance Out Lit where
|
||||
out (IntL n) = ttext n
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (BindingF b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance Pretty b => Pretty1 (BindingF b) where
|
||||
liftPrettyPrec pr _ (BindingF k v) = hsep [pretty k, "=", liftPrettyPrec pr 0 v]
|
||||
instance Out b => Out1 (BindingF b) where
|
||||
liftOutPrec pr _ (BindingF k v) = hsep [out k, "=", liftOutPrec pr 0 v]
|
||||
|
||||
liftExplicitLayout :: (a -> Doc) -> [a] -> Doc
|
||||
liftExplicitLayout :: (a -> Doc ann) -> [a] -> Doc ann
|
||||
liftExplicitLayout pr as = vcat inner <+> "}" where
|
||||
inner = zipWith (<+>) delims (pr <$> as)
|
||||
delims = "{" : repeat ";"
|
||||
|
||||
explicitLayout :: (Pretty a) => [a] -> Doc
|
||||
explicitLayout :: (Out a) => [a] -> Doc ann
|
||||
explicitLayout as = vcat inner <+> "}" where
|
||||
inner = zipWith (<+>) delims (pretty <$> as)
|
||||
inner = zipWith (<+>) delims (out <$> as)
|
||||
delims = "{" : repeat ";"
|
||||
|
||||
instance Pretty Var where
|
||||
prettyPrec p (MkVar n t) = maybeParens (p>0) $
|
||||
hsep [pretty n, ":", pretty t]
|
||||
instance Out Var where
|
||||
outPrec p (MkVar n t) = maybeParens (p>0) $
|
||||
hsep [out n, ":", out t]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@@ -91,14 +91,14 @@ instance IsRlpcError SystemFError where
|
||||
undefinedVariableErr n
|
||||
SystemFErrorKindMismatch k k' ->
|
||||
Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
|
||||
(pretty k) (pretty k')
|
||||
(out k) (out k')
|
||||
]
|
||||
SystemFErrorCouldNotMatch t t' ->
|
||||
Text [ T.pack $ printf "Could not match type `%s' with `%s'"
|
||||
(pretty t) (pretty t')
|
||||
(out t) (out t')
|
||||
]
|
||||
|
||||
justLintCoreExpr = fmap (fmap (prettyPrec appPrec1)) . lintE demoContext
|
||||
justLintCoreExpr = fmap (fmap (outPrec appPrec1)) . lintE demoContext
|
||||
|
||||
lintE :: Gamma -> Expr Var -> SysF ET
|
||||
lintE g = \case
|
||||
|
||||
@@ -37,7 +37,7 @@ core2core p = undefined
|
||||
gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
|
||||
gmPrepR p = do
|
||||
let p' = gmPrep p
|
||||
addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p'
|
||||
addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
|
||||
pure p'
|
||||
|
||||
-- | G-machine-specific preprocessing.
|
||||
|
||||
@@ -1,26 +1,26 @@
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
|
||||
module Data.Pretty
|
||||
( Pretty(..), Pretty1(..)
|
||||
, prettyPrec1
|
||||
, rpretty
|
||||
( Out(..), Out1(..)
|
||||
, outPrec1
|
||||
, rout
|
||||
, ttext
|
||||
, Showing(..)
|
||||
-- * Pretty-printing lens combinators
|
||||
, hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm
|
||||
, vsep
|
||||
, module Text.PrettyPrint
|
||||
-- * Out-printing lens combinators
|
||||
, hsepOf, vsepOf, vcatOf, vlinesOf
|
||||
, module Prettyprinter
|
||||
, maybeParens
|
||||
, appPrec
|
||||
, appPrec1
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Text.PrettyPrint.HughesPJ hiding ((<>))
|
||||
import Prettyprinter
|
||||
import Text.Printf
|
||||
import Data.String (IsString(..))
|
||||
import Data.Text.Lens hiding ((:<))
|
||||
import Data.Monoid hiding (Sum)
|
||||
import Data.Bool
|
||||
import Control.Lens
|
||||
|
||||
-- instances
|
||||
@@ -30,83 +30,80 @@ import Data.Functor.Sum
|
||||
import Data.Fix (Fix(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
class Pretty a where
|
||||
pretty :: a -> Doc
|
||||
prettyPrec :: Int -> a -> Doc
|
||||
class Out a where
|
||||
out :: a -> Doc ann
|
||||
outPrec :: Int -> a -> Doc ann
|
||||
|
||||
{-# MINIMAL pretty | prettyPrec #-}
|
||||
pretty = prettyPrec 0
|
||||
prettyPrec = const pretty
|
||||
{-# MINIMAL out | outPrec #-}
|
||||
out = outPrec 0
|
||||
outPrec = const out
|
||||
|
||||
rpretty :: (IsString s, Pretty a) => a -> s
|
||||
rpretty = fromString . render . pretty
|
||||
rout :: (IsString s, Out a) => a -> s
|
||||
rout = fromString . show . out
|
||||
|
||||
instance Pretty Doc where
|
||||
pretty = id
|
||||
-- instance Out (Doc ann) where
|
||||
-- out = id
|
||||
|
||||
instance Pretty String where
|
||||
pretty = Text.PrettyPrint.text
|
||||
instance Out String where
|
||||
out = pretty
|
||||
|
||||
instance Pretty T.Text where
|
||||
pretty = Text.PrettyPrint.text . view unpacked
|
||||
instance Out T.Text where
|
||||
out = pretty
|
||||
|
||||
newtype Showing a = Showing a
|
||||
|
||||
instance (Show a) => Pretty (Showing a) where
|
||||
prettyPrec p (Showing a) = fromString $ showsPrec p a ""
|
||||
instance (Show a) => Out (Showing a) where
|
||||
outPrec p (Showing a) = fromString $ showsPrec p a ""
|
||||
|
||||
deriving via Showing Int instance Pretty Int
|
||||
deriving via Showing Int instance Out Int
|
||||
|
||||
class (forall a. Pretty a => Pretty (f a)) => Pretty1 f where
|
||||
liftPrettyPrec :: (Int -> a -> Doc) -> Int -> f a -> Doc
|
||||
class (forall a. Out a => Out (f a)) => Out1 f where
|
||||
liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
|
||||
|
||||
prettyPrec1 :: (Pretty1 f, Pretty a) => Int -> f a -> Doc
|
||||
prettyPrec1 = liftPrettyPrec prettyPrec
|
||||
outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
|
||||
outPrec1 = liftOutPrec outPrec
|
||||
|
||||
instance (Pretty1 f, Pretty1 g, Pretty a) => Pretty (Sum f g a) where
|
||||
prettyPrec p (InL fa) = prettyPrec1 p fa
|
||||
prettyPrec p (InR ga) = prettyPrec1 p ga
|
||||
instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
|
||||
outPrec p (InL fa) = outPrec1 p fa
|
||||
outPrec p (InR ga) = outPrec1 p ga
|
||||
|
||||
instance (Pretty1 f, Pretty1 g) => Pretty1 (Sum f g) where
|
||||
liftPrettyPrec pr p (InL fa) = liftPrettyPrec pr p fa
|
||||
liftPrettyPrec pr p (InR ga) = liftPrettyPrec pr p ga
|
||||
instance (Out1 f, Out1 g) => Out1 (Sum f g) where
|
||||
liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
|
||||
liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
|
||||
|
||||
instance (Pretty (f (Fix f))) => Pretty (Fix f) where
|
||||
prettyPrec d (Fix f) = prettyPrec d f
|
||||
instance (Out (f (Fix f))) => Out (Fix f) where
|
||||
outPrec d (Fix f) = outPrec d f
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
ttext :: Pretty t => t -> Doc
|
||||
ttext = pretty
|
||||
ttext :: Out t => t -> Doc ann
|
||||
ttext = out
|
||||
|
||||
hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
|
||||
hsepOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
|
||||
hsepOf l = foldrOf l (<+>) mempty
|
||||
|
||||
vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
|
||||
vsepOf l = foldrOf l ($+$) mempty
|
||||
vsepOf :: _ -> s -> Doc ann
|
||||
vsepOf l = vsep . toListOf l
|
||||
|
||||
vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc
|
||||
vcatOf l = foldrOf l ($$) mempty
|
||||
vcatOf :: _ -> s -> Doc ann
|
||||
vcatOf l = vcat . toListOf l
|
||||
|
||||
vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc
|
||||
vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty
|
||||
vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
|
||||
vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
|
||||
-- hack(?) to separate chunks with a blankline
|
||||
|
||||
vsepTerm :: Doc -> Doc -> Doc -> Doc
|
||||
vsepTerm term a b = (a <> term) $+$ b
|
||||
|
||||
vsep :: [Doc] -> Doc
|
||||
vsep = foldr ($+$) mempty
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
maybeParens :: Bool -> Doc ann -> Doc ann
|
||||
maybeParens = bool id parens
|
||||
|
||||
appPrec, appPrec1 :: Int
|
||||
appPrec = 10
|
||||
appPrec1 = 11
|
||||
|
||||
instance PrintfArg Doc where
|
||||
instance PrintfArg (Doc ann) where
|
||||
formatArg d fmt
|
||||
| fmtChar (vFmt 'D' fmt) == 'D' = formatString (render d) fmt'
|
||||
| fmtChar (vFmt 'D' fmt) == 'D' = formatString (show d) fmt'
|
||||
| otherwise = errorBadFormat $ fmtChar fmt
|
||||
where
|
||||
fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }
|
||||
|
||||
69
src/GM.hs
69
src/GM.hs
@@ -29,9 +29,9 @@ import Data.Tuple (swap)
|
||||
import Control.Lens
|
||||
import Data.Text.Lens (IsText, packed, unpacked)
|
||||
import Text.Printf
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Text.PrettyPrint.HughesPJ (maybeParens)
|
||||
import Data.Foldable (traverse_)
|
||||
import Prettyprinter
|
||||
import Data.Pretty
|
||||
import System.IO (Handle, hPutStrLn)
|
||||
-- TODO: an actual output system
|
||||
-- TODO: an actual output system
|
||||
@@ -165,7 +165,7 @@ hdbgProg p hio = do
|
||||
renderOut . showStats $ sts
|
||||
pure final
|
||||
where
|
||||
renderOut r = hPutStrLn hio $ render r ++ "\n"
|
||||
renderOut r = hPutStrLn hio $ show r ++ "\n"
|
||||
|
||||
states = eval $ compile p
|
||||
final = last states
|
||||
@@ -182,7 +182,7 @@ evalProgR p = do
|
||||
renderOut . showStats $ sts
|
||||
pure (res, sts)
|
||||
where
|
||||
renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n"
|
||||
renderOut r = addDebugMsg "dump-eval" $ show r ++ "\n"
|
||||
states = eval . compile $ p
|
||||
final = last states
|
||||
|
||||
@@ -823,13 +823,13 @@ showCon t n = printf "Pack{%d %d}" t n ^. packed
|
||||
pprTabstop :: Int
|
||||
pprTabstop = 4
|
||||
|
||||
qquotes :: Doc -> Doc
|
||||
qquotes :: Doc ann -> Doc ann
|
||||
qquotes d = "`" <> d <> "'"
|
||||
|
||||
showStats :: Stats -> Doc
|
||||
showStats sts = "==== Stats ============" $$ stats
|
||||
showStats :: Stats -> Doc ann
|
||||
showStats sts = "==== Stats ============" <> line <> stats
|
||||
where
|
||||
stats = text $ printf
|
||||
stats = textt @String $ printf
|
||||
"Reductions : %5d\n\
|
||||
\Prim Reductions : %5d\n\
|
||||
\Allocations : %5d\n\
|
||||
@@ -839,10 +839,10 @@ showStats sts = "==== Stats ============" $$ stats
|
||||
(sts ^. stsAllocations)
|
||||
(sts ^. stsGCCycles)
|
||||
|
||||
showState :: GmState -> Doc
|
||||
showState :: GmState -> Doc ann
|
||||
showState st = vcat
|
||||
[ "==== GmState " <> int stnum <> " "
|
||||
<> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
|
||||
<> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
|
||||
, "-- Next instructions -------"
|
||||
, info $ showCodeShort c
|
||||
, "-- Stack -------------------"
|
||||
@@ -859,23 +859,23 @@ showState st = vcat
|
||||
-- indent data
|
||||
info = nest pprTabstop
|
||||
|
||||
showCodeShort :: Code -> Doc
|
||||
showCodeShort :: Code -> Doc ann
|
||||
showCodeShort c = braces c'
|
||||
where
|
||||
c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
|
||||
| otherwise = list (showInstr <$> c)
|
||||
list = hcat . punctuate "; "
|
||||
|
||||
showStackShort :: Stack -> Doc
|
||||
showStackShort :: Stack -> Doc ann
|
||||
showStackShort s = brackets s'
|
||||
where
|
||||
-- no access to heap, otherwise we'd use showNodeAt
|
||||
s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
|
||||
| otherwise = list (showEntry <$> s)
|
||||
list = hcat . punctuate ", "
|
||||
showEntry = text . show
|
||||
showEntry = textt . show
|
||||
|
||||
showStack :: GmState -> Doc
|
||||
showStack :: GmState -> Doc ann
|
||||
showStack st = vcat $ uncurry showEntry <$> si
|
||||
where
|
||||
h = st ^. gmHeap
|
||||
@@ -887,10 +887,9 @@ showStack st = vcat $ uncurry showEntry <$> si
|
||||
w = maxWidth (addresses h)
|
||||
showIndex n = padInt w n <> ": "
|
||||
|
||||
showEntry :: Int -> Addr -> Doc
|
||||
showEntry n a = showIndex n <> showNodeAt st a
|
||||
|
||||
showDump :: GmState -> Doc
|
||||
showDump :: GmState -> Doc ann
|
||||
showDump st = vcat $ uncurry showEntry <$> di
|
||||
where
|
||||
d = st ^. gmDump
|
||||
@@ -899,14 +898,13 @@ showDump st = vcat $ uncurry showEntry <$> di
|
||||
showIndex n = padInt w n <> ": "
|
||||
w = maxWidth (fst <$> di)
|
||||
|
||||
showEntry :: Int -> (Code, Stack) -> Doc
|
||||
showEntry n (c,s) = showIndex n <> nest pprTabstop entry
|
||||
where
|
||||
entry = ("Stack : " <> showCodeShort c)
|
||||
$$ ("Code : " <> showStackShort s)
|
||||
entry = vsep [ "Stack : " <> showCodeShort c
|
||||
, "Code : " <> showStackShort s ]
|
||||
|
||||
padInt :: Int -> Int -> Doc
|
||||
padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n
|
||||
padInt :: Int -> Int -> Doc ann
|
||||
padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
|
||||
|
||||
maxWidth :: [Int] -> Int
|
||||
maxWidth ns = digitalWidth $ maximum ns
|
||||
@@ -914,7 +912,7 @@ maxWidth ns = digitalWidth $ maximum ns
|
||||
digitalWidth :: Int -> Int
|
||||
digitalWidth = length . show
|
||||
|
||||
showHeap :: GmState -> Doc
|
||||
showHeap :: GmState -> Doc ann
|
||||
showHeap st = vcat $ showEntry <$> addrs
|
||||
where
|
||||
showAddr n = padInt w n <> ": "
|
||||
@@ -923,13 +921,12 @@ showHeap st = vcat $ showEntry <$> addrs
|
||||
h = st ^. gmHeap
|
||||
addrs = addresses h
|
||||
|
||||
showEntry :: Addr -> Doc
|
||||
showEntry a = showAddr a <> showNodeAt st a
|
||||
|
||||
showNodeAt :: GmState -> Addr -> Doc
|
||||
showNodeAt :: GmState -> Addr -> Doc ann
|
||||
showNodeAt = showNodeAtP 0
|
||||
|
||||
showNodeAtP :: Int -> GmState -> Addr -> Doc
|
||||
showNodeAtP :: Int -> GmState -> Addr -> Doc ann
|
||||
showNodeAtP p st a = case hLookup a h of
|
||||
Just (NNum n) -> int n <> "#"
|
||||
Just (NGlobal _ _) -> textt name
|
||||
@@ -953,9 +950,9 @@ showNodeAtP p st a = case hLookup a h of
|
||||
h = st ^. gmHeap
|
||||
pprec = maybeParens (p > 0)
|
||||
|
||||
showSc :: GmState -> (Name, Addr) -> Doc
|
||||
showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon
|
||||
$$ code
|
||||
showSc :: GmState -> (Name, Addr) -> Doc ann
|
||||
showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
|
||||
, code ]
|
||||
where
|
||||
code = case hLookup a (st ^. gmHeap) of
|
||||
Just (NGlobal _ c) -> showCode c
|
||||
@@ -966,19 +963,21 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
|
||||
errTxtInvalidObject = "<invalid object>"
|
||||
errTxtInvalidAddress = "<invalid address>"
|
||||
|
||||
showCode :: Code -> Doc
|
||||
showCode :: Code -> Doc ann
|
||||
showCode c = "Code" <+> braces instrs
|
||||
where instrs = vcat $ showInstr <$> c
|
||||
|
||||
showInstr :: Instr -> Doc
|
||||
showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives
|
||||
showInstr :: Instr -> Doc ann
|
||||
showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ]
|
||||
where
|
||||
showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
|
||||
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts
|
||||
showInstr i = text $ show i
|
||||
alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
|
||||
showInstr i = textt $ show i
|
||||
|
||||
textt :: (IsText a) => a -> Doc
|
||||
textt t = t ^. unpacked & text
|
||||
int = pretty
|
||||
|
||||
textt :: (Pretty a) => a -> Doc ann
|
||||
textt = pretty
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@@ -116,67 +116,67 @@ pattern Finr ga = Fix (InR ga)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (ExprF b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (Alter b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (Alter b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance (Pretty b) => Pretty1 (Alter b) where
|
||||
liftPrettyPrec pr _ (Alter p e) =
|
||||
hsep [ pretty p, "->", pr 0 e]
|
||||
instance (Out b) => Out1 (Alter b) where
|
||||
liftOutPrec pr _ (Alter p e) =
|
||||
hsep [ out p, "->", pr 0 e]
|
||||
|
||||
instance Pretty b => Pretty1 (ExprF b) where
|
||||
liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $
|
||||
pr 1 a <+> pretty o <+> pr 1 b
|
||||
liftPrettyPrec pr p (CaseEF e as) = maybeParens (p>0) $
|
||||
hsep [ "case", pr 0 e, "of" ]
|
||||
$+$ nest 2 (vcat $ liftPrettyPrec pr 0 <$> as)
|
||||
instance Out b => Out1 (ExprF b) where
|
||||
liftOutPrec pr p (InfixEF o a b) = maybeParens (p>0) $
|
||||
pr 1 a <+> out o <+> pr 1 b
|
||||
liftOutPrec pr p (CaseEF e as) = maybeParens (p>0) $
|
||||
vsep [ hsep [ "case", pr 0 e, "of" ]
|
||||
, nest 2 (vcat $ liftOutPrec pr 0 <$> as) ]
|
||||
|
||||
instance (Pretty b, Pretty a) => Pretty (Decl b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out b, Out a) => Out (Decl b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance (Pretty b) => Pretty1 (Decl b) where
|
||||
liftPrettyPrec pr _ (FunD f as e) =
|
||||
hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as)
|
||||
instance (Out b) => Out1 (Decl b) where
|
||||
liftOutPrec pr _ (FunD f as e) =
|
||||
hsep [ ttext f, hsep (outPrec appPrec1 <$> as)
|
||||
, "=", pr 0 e ]
|
||||
|
||||
liftPrettyPrec _ _ (DataD f as []) =
|
||||
hsep [ "data", ttext f, hsep (pretty <$> as) ]
|
||||
liftOutPrec _ _ (DataD f as []) =
|
||||
hsep [ "data", ttext f, hsep (out <$> as) ]
|
||||
|
||||
liftPrettyPrec _ _ (DataD f as ds) =
|
||||
hsep [ "data", ttext f, hsep (pretty <$> as), cons ]
|
||||
liftOutPrec _ _ (DataD f as ds) =
|
||||
hsep [ "data", ttext f, hsep (out <$> as), cons ]
|
||||
where
|
||||
cons = vcat $ zipWith (<+>) delims (pretty <$> ds)
|
||||
cons = vcat $ zipWith (<+>) delims (out <$> ds)
|
||||
delims = "=" : repeat "|"
|
||||
|
||||
liftPrettyPrec _ _ (TySigD n t) =
|
||||
hsep [ ttext n, ":", pretty t ]
|
||||
liftOutPrec _ _ (TySigD n t) =
|
||||
hsep [ ttext n, ":", out t ]
|
||||
|
||||
instance (Pretty b) => Pretty (DataCon b) where
|
||||
pretty (DataCon n as) = ttext n <+> hsep (prettyPrec appPrec1 <$> as)
|
||||
instance (Out b) => Out (DataCon b) where
|
||||
out (DataCon n as) = ttext n <+> hsep (outPrec appPrec1 <$> as)
|
||||
|
||||
-- (->) is given prec `appPrec-1`
|
||||
instance (Pretty b) => Pretty (Type b) where
|
||||
prettyPrec _ (VarT n) = ttext n
|
||||
prettyPrec _ (ConT n) = ttext n
|
||||
prettyPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $
|
||||
hsep [ prettyPrec appPrec s, "->", prettyPrec (appPrec-1) t ]
|
||||
prettyPrec p (AppT f x) = maybeParens (p>appPrec) $
|
||||
prettyPrec appPrec f <+> prettyPrec appPrec1 x
|
||||
prettyPrec p FunT = maybeParens (p>0) "->"
|
||||
instance (Out b) => Out (Type b) where
|
||||
outPrec _ (VarT n) = ttext n
|
||||
outPrec _ (ConT n) = ttext n
|
||||
outPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $
|
||||
hsep [ outPrec appPrec s, "->", outPrec (appPrec-1) t ]
|
||||
outPrec p (AppT f x) = maybeParens (p>appPrec) $
|
||||
outPrec appPrec f <+> outPrec appPrec1 x
|
||||
outPrec p FunT = maybeParens (p>0) "->"
|
||||
|
||||
instance (Pretty b) => Pretty (Pat b) where
|
||||
prettyPrec p (VarP b) = prettyPrec p b
|
||||
prettyPrec p (ConP b) = prettyPrec p b
|
||||
prettyPrec p (AppP c x) = maybeParens (p>appPrec) $
|
||||
prettyPrec appPrec c <+> prettyPrec appPrec1 x
|
||||
instance (Out b) => Out (Pat b) where
|
||||
outPrec p (VarP b) = outPrec p b
|
||||
outPrec p (ConP b) = outPrec p b
|
||||
outPrec p (AppP c x) = maybeParens (p>appPrec) $
|
||||
outPrec appPrec c <+> outPrec appPrec1 x
|
||||
|
||||
instance (Pretty a, Pretty b) => Pretty (Program b a) where
|
||||
prettyPrec = prettyPrec1
|
||||
instance (Out a, Out b) => Out (Program b a) where
|
||||
outPrec = outPrec1
|
||||
|
||||
instance (Pretty b) => Pretty1 (Program b) where
|
||||
liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds
|
||||
instance (Out b) => Out1 (Program b) where
|
||||
liftOutPrec pr p (Program ds) = vsep $ liftOutPrec pr p <$> ds
|
||||
|
||||
makePrisms ''Pat
|
||||
makePrisms ''Binding
|
||||
|
||||
@@ -20,7 +20,7 @@ import Control.Monad
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Monad.Writer.Strict
|
||||
import Data.Text qualified as T
|
||||
import Data.Pretty
|
||||
import Data.Pretty hiding (annotate)
|
||||
import Data.Hashable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as H
|
||||
@@ -153,11 +153,11 @@ subst n t' = para \case
|
||||
| otherwise -> ForallT x post
|
||||
t -> embed $ t <&> view _2
|
||||
|
||||
prettyHM :: (Pretty a)
|
||||
prettyHM :: (Out a)
|
||||
=> Either [TypeError] (a, [Constraint])
|
||||
-> Either [TypeError] (String, [String])
|
||||
prettyHM = over (mapped . _1) rpretty
|
||||
. over (mapped . _2 . each) rpretty
|
||||
prettyHM = over (mapped . _1) rout
|
||||
. over (mapped . _2 . each) rout
|
||||
|
||||
fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b
|
||||
fixtend c (Fix f) = c f :< fmap (fixtend c) f
|
||||
|
||||
@@ -73,16 +73,16 @@ instance IsRlpcError TypeError where
|
||||
-- todo: use anti-parser instead of show
|
||||
TyErrCouldNotUnify t u -> Text
|
||||
[ T.pack $ printf "Could not match type `%s` with `%s`."
|
||||
(rpretty @String t) (rpretty @String u)
|
||||
, "Expected: " <> rpretty t
|
||||
, "Got: " <> rpretty u
|
||||
(rout @String t) (rout @String u)
|
||||
, "Expected: " <> rout t
|
||||
, "Got: " <> rout u
|
||||
]
|
||||
TyErrUntypedVariable n -> Text
|
||||
[ "Untyped (likely undefined) variable `" <> n <> "`"
|
||||
]
|
||||
TyErrRecursiveType t x -> Text
|
||||
[ T.pack $ printf "Recursive type: `%s' occurs in `%s'"
|
||||
(rpretty @String t) (rpretty @String x)
|
||||
(rout @String t) (rout @String x)
|
||||
]
|
||||
|
||||
-- type Memo t = HashMap t (Type PsName, PartialJudgement)
|
||||
@@ -156,7 +156,7 @@ demoContext = Context
|
||||
constraintTypes :: Traversal' Constraint (Type PsName)
|
||||
constraintTypes k (Equality s t) = Equality <$> k s <*> k t
|
||||
|
||||
instance Pretty Constraint where
|
||||
pretty (Equality s t) =
|
||||
hsep [prettyPrec appPrec1 s, "~", prettyPrec appPrec1 t]
|
||||
instance Out Constraint where
|
||||
out (Equality s t) =
|
||||
hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]
|
||||
|
||||
|
||||
@@ -9,7 +9,7 @@ import Control.Monad
|
||||
import System.IO
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO qualified as T
|
||||
import Data.Pretty
|
||||
import Data.Pretty hiding (annotate)
|
||||
import Data.String (IsString(..))
|
||||
import Data.Foldable
|
||||
import Misc.CofreeF
|
||||
@@ -77,14 +77,14 @@ withTooltip normal hover =
|
||||
-- -- ! onload "installHoverListener(this)"
|
||||
-- $ normal
|
||||
|
||||
annExpr :: (ann -> Doc) -> AnnExpr ann -> Html
|
||||
annExpr :: (a -> Doc ann) -> AnnExpr a -> Html
|
||||
annExpr sf = code . cata \case
|
||||
t :<$ InL (LitF l) -> withTooltip (rpretty l) (sf' t)
|
||||
t :<$ InL (VarF n) -> withTooltip (rpretty n) (sf' t)
|
||||
t :<$ InL (LitF l) -> withTooltip (rout l) (sf' t)
|
||||
t :<$ InL (VarF n) -> withTooltip (rout n) (sf' t)
|
||||
t :<$ InL (AppF f x) -> withTooltip (f *> " " *> x) (sf' t)
|
||||
t :<$ InL (LamF bs e) -> withTooltip ("λ" *> bs' *> " -> " *> e) (sf' t)
|
||||
where
|
||||
bs' = fromString . render . hsep $ prettyPrec appPrec1 <$> bs
|
||||
bs' = fromString . show . hsep $ outPrec appPrec1 <$> bs
|
||||
where
|
||||
sf' = fromString . show . sf
|
||||
|
||||
@@ -129,5 +129,5 @@ renderExpr e = case runHM' . annotate $ e of
|
||||
renderExpr' :: RlpExpr PsName -> IO ()
|
||||
renderExpr' e = case runHM' . solve $ e of
|
||||
Left es -> error (show es)
|
||||
Right e' -> renderTmp' . annExpr pretty $ e'
|
||||
Right e' -> renderTmp' . annExpr out $ e'
|
||||
|
||||
|
||||
@@ -38,7 +38,7 @@ import Text.Show.Deriving
|
||||
import Core.Syntax as Core
|
||||
import Rlp.AltSyntax as Rlp
|
||||
import Compiler.Types
|
||||
import Data.Pretty (render, pretty)
|
||||
import Data.Pretty
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Tree a = Either Name (Name, Branch a)
|
||||
@@ -64,7 +64,7 @@ desugarRlpProgR :: forall m a. (Monad m)
|
||||
-> RLPCT m Core.Program'
|
||||
desugarRlpProgR p = do
|
||||
let p' = desugarRlpProg p
|
||||
addDebugMsg "dump-desugared" $ render (pretty p')
|
||||
addDebugMsg "dump-desugared" $ show (out p')
|
||||
pure p'
|
||||
|
||||
desugarRlpProg = undefined
|
||||
|
||||
Reference in New Issue
Block a user