msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

pretty -> prettyprinter

Browse Source
This commit is contained in:
crumbtoo
2024-03-14 06:04:22 -06:00
parent 175e58f13c
commit 623acb3454
13 changed files with 266 additions and 298 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/Compiler/JustRun.hs
View File

@@ -65,11 +65,11 @@ justTypeCheckCore s = typechk (T.pack s)
& rlpcToEither & rlpcToEither
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
makeItPretty :: (Pretty a) => Either e a -> Either e Doc makeItPretty :: (Out a) => Either e a -> Either e (Doc ann)
makeItPretty = fmap pretty makeItPretty = fmap out
makeItPretty' :: (Pretty (WithTerseBinds a)) => Either e a -> Either e Doc makeItPretty' :: (Out (WithTerseBinds a)) => Either e a -> Either e (Doc ann)
makeItPretty' = fmap (pretty . WithTerseBinds) makeItPretty' = fmap (out . WithTerseBinds)
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
rlpcToEither r = case evalRLPC def r of rlpcToEither r = case evalRLPC def r of

15
src/Compiler/RLPC.hs
View File

@@ -54,6 +54,7 @@ import Data.Default.Class
import Data.Foldable import Data.Foldable
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Data.Maybe import Data.Maybe
import Data.Pretty
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import Data.HashSet qualified as S import Data.HashSet qualified as S
@@ -63,7 +64,6 @@ import Data.Text qualified as T
import Data.Text.IO qualified as T import Data.Text.IO qualified as T
import System.IO import System.IO
import Text.ANSI qualified as Ansi import Text.ANSI qualified as Ansi
import Text.PrettyPrint hiding ((<>))
import Control.Lens import Control.Lens
import Data.Text.Lens (packed, unpacked, IsText) import Data.Text.Lens (packed, unpacked, IsText)
import System.Exit import System.Exit
@@ -203,7 +203,7 @@ renderRlpcErrs opts = (if don'tBother then id else filter byTag)
prettyRlpcMsg :: MsgEnvelope RlpcError -> String prettyRlpcMsg :: MsgEnvelope RlpcError -> String
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
prettyRlpcMsg m = render $ docRlpcErr m prettyRlpcMsg m = show $ docRlpcErr m
prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
prettyRlpcDebugMsg msg = prettyRlpcDebugMsg msg =
@@ -213,10 +213,10 @@ prettyRlpcDebugMsg msg =
Text ts = msg ^. msgDiagnostic Text ts = msg ^. msgDiagnostic
SevDebug tag = msg ^. msgSeverity SevDebug tag = msg ^. msgSeverity
docRlpcErr :: MsgEnvelope RlpcError -> Doc docRlpcErr :: MsgEnvelope RlpcError -> Doc ann
docRlpcErr msg = header docRlpcErr msg = vcat [ header
$$ nest 2 bullets , nest 2 bullets
$$ source , source ]
where where
source = vcat $ zipWith (<+>) rule srclines source = vcat $ zipWith (<+>) rule srclines
where where
@@ -231,11 +231,10 @@ docRlpcErr msg = header
<> errorColour "error" <> msgColour ":" <> errorColour "error" <> msgColour ":"
bullets = let Text ts = msg ^. msgDiagnostic 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 msgColour = Ansi.white . Ansi.bold
errorColour = Ansi.red . Ansi.bold errorColour = Ansi.red . Ansi.bold
ttext = text . T.unpack
tshow :: (Show a) => a -> Text tshow :: (Show a) => a -> Text
tshow = T.pack . show tshow = T.pack . show

31
src/Core/HindleyMilner.hs
View File

@@ -16,22 +16,9 @@ module Core.HindleyMilner
) )
where 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.RLPC
import Compiler.Types import Data.Text qualified as T
import Compiler.RlpcError
import Control.Monad (foldM, void, forM)
import Control.Monad.Errorful import Control.Monad.Errorful
import Control.Monad.State
import Control.Monad.Utils (mapAccumLM, generalise)
import Text.Printf
import Core.Syntax import Core.Syntax
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -60,21 +47,7 @@ data TypeError
deriving (Show, Eq) deriving (Show, Eq)
instance IsRlpcError TypeError where instance IsRlpcError TypeError where
liftRlpcError = \case liftRlpcError = undefined
-- 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)
]
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@. -- throw any number of fatal or nonfatal errors. Run with @runErrorful@.

200
src/Core/Syntax.hs
View File

@@ -29,8 +29,8 @@ module Core.Syntax
, pattern Con, pattern Var, pattern App, pattern Lam, pattern Let , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
, pattern Case, pattern Type, pattern Lit , pattern Case, pattern Type, pattern Lit
-- * Pretty-printing -- * pretty-printing
, Pretty(pretty), WithTerseBinds(..) , Out(out), WithTerseBinds(..)
-- * Optics -- * Optics
, HasArrowSyntax(..) , HasArrowSyntax(..)
@@ -335,11 +335,11 @@ instance MakeTerse Var where
type AsTerse Var = Name type AsTerse Var = Name
asTerse (MkVar n _) = n asTerse (MkVar n _) = n
instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b) instance (Hashable b, Out b, Out (AsTerse b), MakeTerse b)
=> Pretty (WithTerseBinds (Program b)) where => Out (WithTerseBinds (Program b)) where
pretty (WithTerseBinds p) out (WithTerseBinds p)
= (datatags <> "\n") = vsep [ (datatags <> "\n")
$+$ defs , defs ]
where where
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
defs = vlinesOf (programJoinedDefs . to prettyGroup) p defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -355,17 +355,17 @@ instance (Hashable b, Pretty b, Pretty (AsTerse b), MakeTerse b)
thatSc = foldMap $ \sc -> thatSc = foldMap $ \sc ->
H.singleton (sc ^. _lhs . _1) (That 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 prettyGroup = bifoldr vs vs mempty
. bimap (uncurry prettyTySig') . bimap (uncurry prettyTySig')
(pretty . WithTerseBinds) (out . WithTerseBinds)
where vs = vsepTerm ";" 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 instance (Hashable b, Out b) => Out (Program b) where
pretty p = (datatags <> "\n") out p = vsep [ datatags <> "\n"
$+$ defs , defs ]
where where
datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p datatags = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
defs = vlinesOf (programJoinedDefs . to prettyGroup) p defs = vlinesOf (programJoinedDefs . to prettyGroup) p
@@ -381,139 +381,139 @@ instance (Hashable b, Pretty b) => Pretty (Program b) where
thatSc = foldMap $ \sc -> thatSc = foldMap $ \sc ->
H.singleton (sc ^. _lhs . _1) (That 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 prettyGroup = bifoldr vs vs mempty
. bimap (uncurry prettyTySig) pretty . bimap (uncurry prettyTySig) out
where vs = vsepTerm ";" 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 :: These a b -> These a b -> These a b
unionThese (This a) (That b) = These a b unionThese (This a) (That b) = These a b
unionThese (That b) (This a) = These a b unionThese (That b) (This a) = These a b
unionThese (These a b) _ = These a b unionThese (These a b) _ = These a b
prettyDataTag :: (Pretty n, Pretty t, Pretty a) prettyDataTag :: (Out n, Out t, Out a)
=> n -> t -> a -> Doc => n -> t -> a -> Doc ann
prettyDataTag n t a = prettyDataTag n t a =
hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"] hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
prettyTySig :: (Pretty n, Pretty t) => n -> t -> Doc prettyTySig :: (Out n, Out t) => n -> t -> Doc ann
prettyTySig n t = hsep [ttext n, ":", pretty t] prettyTySig n t = hsep [ttext n, ":", out t]
prettyTySig' :: (MakeTerse n, Pretty (AsTerse n), Pretty t) => n -> t -> Doc prettyTySig' :: (MakeTerse n, Out (AsTerse n), Out t) => n -> t -> Doc ann
prettyTySig' n t = hsep [ttext (asTerse n), ":", pretty t] prettyTySig' n t = hsep [ttext (asTerse n), ":", out t]
-- Pretty Type -- out Type
-- TyApp | appPrec | left -- TyApp | appPrec | left
-- (:->) | appPrec-1 | right -- (:->) | appPrec-1 | right
instance Pretty Type where instance Out Type where
prettyPrec _ (TyVar n) = ttext n outPrec _ (TyVar n) = ttext n
prettyPrec _ TyFun = "(->)" outPrec _ TyFun = "(->)"
prettyPrec _ (TyCon n) = ttext n outPrec _ (TyCon n) = ttext n
prettyPrec p (a :-> b) = maybeParens (p>appPrec-1) $ outPrec p (a :-> b) = maybeParens (p>appPrec-1) $
hsep [prettyPrec appPrec a, "->", prettyPrec (appPrec-1) b] hsep [outPrec appPrec a, "->", outPrec (appPrec-1) b]
prettyPrec p (TyApp f x) = maybeParens (p>appPrec) $ outPrec p (TyApp f x) = maybeParens (p>appPrec) $
prettyPrec appPrec f <+> prettyPrec appPrec1 x outPrec appPrec f <+> outPrec appPrec1 x
prettyPrec p (TyForall a m) = maybeParens (p>appPrec-2) $ outPrec p (TyForall a m) = maybeParens (p>appPrec-2) $
"∀" <+> (prettyPrec appPrec1 a <> ".") <+> pretty m "∀" <+> (outPrec appPrec1 a <> ".") <+> out m
prettyPrec _ TyKindType = "Type" outPrec _ TyKindType = "Type"
instance (Pretty b, Pretty (AsTerse b), MakeTerse b) instance (Out b, Out (AsTerse b), MakeTerse b)
=> Pretty (WithTerseBinds (ScDef b)) where => Out (WithTerseBinds (ScDef b)) where
pretty (WithTerseBinds sc) = hsep [name, as, "=", hang empty 1 e] out (WithTerseBinds sc) = hsep [name, as, "=", hang 1 e]
where where
name = ttext $ sc ^. _lhs . _1 . to asTerse name = ttext $ sc ^. _lhs . _1 . to asTerse
as = sc & hsepOf (_lhs . _2 . each . to asTerse . to ttext) 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 instance (Out b) => Out (ScDef b) where
pretty sc = hsep [name, as, "=", hang empty 1 e] out sc = hsep [name, as, "=", hang 1 e]
where where
name = ttext $ sc ^. _lhs . _1 name = ttext $ sc ^. _lhs . _1
as = sc & hsepOf (_lhs . _2 . each . to ttext) as = sc & hsepOf (_lhs . _2 . each . to ttext)
e = pretty $ sc ^. _rhs e = out $ sc ^. _rhs
-- Pretty Expr -- out Expr
-- LamF | appPrec1 | right -- LamF | appPrec1 | right
-- AppF | appPrec | left -- AppF | appPrec | left
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where instance (Out b, Out a) => Out (ExprF b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
-- prettyPrec _ (VarF n) = ttext n -- outPrec _ (VarF n) = ttext n
-- prettyPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}" -- outPrec _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
-- prettyPrec p (LamF bs e) = maybeParens (p>0) $ -- outPrec p (LamF bs e) = maybeParens (p>0) $
-- hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pretty e] -- hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", out e]
-- prettyPrec p (LetF r bs e) = maybeParens (p>0) -- outPrec p (LetF r bs e) = maybeParens (p>0)
-- $ hsep [pretty r, explicitLayout bs] -- $ hsep [out r, explicitLayout bs]
-- $+$ hsep ["in", pretty e] -- $+$ hsep ["in", out e]
-- prettyPrec p (AppF f x) = maybeParens (p>appPrec) $ -- outPrec p (AppF f x) = maybeParens (p>appPrec) $
-- prettyPrec appPrec f <+> prettyPrec appPrec1 x -- outPrec appPrec f <+> outPrec appPrec1 x
-- prettyPrec p (LitF l) = prettyPrec p l -- outPrec p (LitF l) = outPrec p l
-- prettyPrec p (CaseF e as) = maybeParens (p>0) $ -- outPrec p (CaseF e as) = maybeParens (p>0) $
-- "case" <+> pretty e <+> "of" -- "case" <+> out e <+> "of"
-- $+$ nest 2 (explicitLayout as) -- $+$ 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 instance (Out b) => Out1 (ExprF b) where
liftPrettyPrec pr _ (VarF n) = ttext n liftOutPrec pr _ (VarF n) = ttext n
liftPrettyPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}" liftOutPrec pr _ (ConF t a) = "Pack{" <> (ttext t <+> ttext a) <> "}"
liftPrettyPrec pr p (LamF bs e) = maybeParens (p>0) $ liftOutPrec pr p (LamF bs e) = maybeParens (p>0) $
hsep ["λ", hsep (prettyPrec appPrec1 <$> bs), "->", pr 0 e] hsep ["λ", hsep (outPrec appPrec1 <$> bs), "->", pr 0 e]
liftPrettyPrec pr p (LetF r bs e) = maybeParens (p>0) liftOutPrec pr p (LetF r bs e) = maybeParens (p>0)
$ hsep [pretty r, bs'] $ vsep [ hsep [out r, bs']
$+$ hsep ["in", pr 0 e] , hsep ["in", pr 0 e] ]
where bs' = liftExplicitLayout (liftPrettyPrec pr 0) bs where bs' = liftExplicitLayout (liftOutPrec pr 0) bs
liftPrettyPrec pr p (AppF f x) = maybeParens (p>appPrec) $ liftOutPrec pr p (AppF f x) = maybeParens (p>appPrec) $
pr appPrec f <+> pr appPrec1 x pr appPrec f <+> pr appPrec1 x
liftPrettyPrec pr p (LitF l) = prettyPrec p l liftOutPrec pr p (LitF l) = outPrec p l
liftPrettyPrec pr p (CaseF e as) = maybeParens (p>0) $ liftOutPrec pr p (CaseF e as) = maybeParens (p>0) $
"case" <+> pr 0 e <+> "of" vsep [ "case" <+> pr 0 e <+> "of"
$+$ nest 2 as' , nest 2 as' ]
where as' = liftExplicitLayout (liftPrettyPrec pr 0) as where as' = liftExplicitLayout (liftOutPrec pr 0) as
liftPrettyPrec pr p (TypeF t) = "@" <> prettyPrec appPrec1 t liftOutPrec pr p (TypeF t) = "@" <> outPrec appPrec1 t
instance Pretty Rec where instance Out Rec where
pretty Rec = "letrec" out Rec = "letrec"
pretty NonRec = "let" out NonRec = "let"
instance (Pretty b, Pretty a) => Pretty (AlterF b a) where instance (Out b, Out a) => Out (AlterF b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance (Pretty b) => Pretty1 (AlterF b) where instance (Out b) => Out1 (AlterF b) where
liftPrettyPrec pr _ (AlterF c as e) = liftOutPrec pr _ (AlterF c as e) =
hsep [pretty c, hsep (pretty <$> as), "->", liftPrettyPrec pr 0 e] hsep [out c, hsep (out <$> as), "->", liftOutPrec pr 0 e]
instance Pretty AltCon where instance Out AltCon where
pretty (AltData n) = ttext n out (AltData n) = ttext n
pretty (AltLit l) = pretty l out (AltLit l) = out l
pretty (AltTag t) = "<" <> ttext t <> ">" out (AltTag t) = "<" <> ttext t <> ">"
pretty AltDefault = "_" out AltDefault = "_"
instance Pretty Lit where instance Out Lit where
pretty (IntL n) = ttext n out (IntL n) = ttext n
instance (Pretty b, Pretty a) => Pretty (BindingF b a) where instance (Out b, Out a) => Out (BindingF b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance Pretty b => Pretty1 (BindingF b) where instance Out b => Out1 (BindingF b) where
liftPrettyPrec pr _ (BindingF k v) = hsep [pretty k, "=", liftPrettyPrec pr 0 v] 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 liftExplicitLayout pr as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (pr <$> as) inner = zipWith (<+>) delims (pr <$> as)
delims = "{" : repeat ";" delims = "{" : repeat ";"
explicitLayout :: (Pretty a) => [a] -> Doc explicitLayout :: (Out a) => [a] -> Doc ann
explicitLayout as = vcat inner <+> "}" where explicitLayout as = vcat inner <+> "}" where
inner = zipWith (<+>) delims (pretty <$> as) inner = zipWith (<+>) delims (out <$> as)
delims = "{" : repeat ";" delims = "{" : repeat ";"
instance Pretty Var where instance Out Var where
prettyPrec p (MkVar n t) = maybeParens (p>0) $ outPrec p (MkVar n t) = maybeParens (p>0) $
hsep [pretty n, ":", pretty t] hsep [out n, ":", out t]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

6
src/Core/SystemF.hs
View File

@@ -91,14 +91,14 @@ instance IsRlpcError SystemFError where
undefinedVariableErr n undefinedVariableErr n
SystemFErrorKindMismatch k k' -> SystemFErrorKindMismatch k k' ->
Text [ T.pack $ printf "Could not match kind `%s' with `%s'" Text [ T.pack $ printf "Could not match kind `%s' with `%s'"
(pretty k) (pretty k') (out k) (out k')
] ]
SystemFErrorCouldNotMatch t t' -> SystemFErrorCouldNotMatch t t' ->
Text [ T.pack $ printf "Could not match type `%s' with `%s'" 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 :: Gamma -> Expr Var -> SysF ET
lintE g = \case lintE g = \case

2
src/Core2Core.hs
View File

@@ -37,7 +37,7 @@ core2core p = undefined
gmPrepR :: (Monad m) => Program' -> RLPCT m Program' gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
gmPrepR p = do gmPrepR p = do
let p' = gmPrep p let p' = gmPrep p
addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p' addDebugMsg "dump-gm-preprocessed" $ show . out $ p'
pure p' pure p'
-- | G-machine-specific preprocessing. -- | G-machine-specific preprocessing.

107
src/Data/Pretty.hs
View File

@@ -1,26 +1,26 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-} {-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
module Data.Pretty module Data.Pretty
( Pretty(..), Pretty1(..) ( Out(..), Out1(..)
, prettyPrec1 , outPrec1
, rpretty , rout
, ttext , ttext
, Showing(..) , Showing(..)
-- * Pretty-printing lens combinators -- * Out-printing lens combinators
, hsepOf, vsepOf, vcatOf, vlinesOf, vsepTerm , hsepOf, vsepOf, vcatOf, vlinesOf
, vsep , module Prettyprinter
, module Text.PrettyPrint
, maybeParens , maybeParens
, appPrec , appPrec
, appPrec1 , appPrec1
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Text.PrettyPrint hiding ((<>)) import Prettyprinter
import Text.PrettyPrint.HughesPJ hiding ((<>))
import Text.Printf import Text.Printf
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Text.Lens hiding ((:<)) import Data.Text.Lens hiding ((:<))
import Data.Monoid hiding (Sum) import Data.Monoid hiding (Sum)
import Data.Bool
import Control.Lens import Control.Lens
-- instances -- instances
@@ -30,83 +30,80 @@ import Data.Functor.Sum
import Data.Fix (Fix(..)) import Data.Fix (Fix(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
class Pretty a where class Out a where
pretty :: a -> Doc out :: a -> Doc ann
prettyPrec :: Int -> a -> Doc outPrec :: Int -> a -> Doc ann
{-# MINIMAL pretty | prettyPrec #-} {-# MINIMAL out | outPrec #-}
pretty = prettyPrec 0 out = outPrec 0
prettyPrec = const pretty outPrec = const out
rpretty :: (IsString s, Pretty a) => a -> s rout :: (IsString s, Out a) => a -> s
rpretty = fromString . render . pretty rout = fromString . show . out
instance Pretty Doc where -- instance Out (Doc ann) where
pretty = id -- out = id
instance Pretty String where instance Out String where
pretty = Text.PrettyPrint.text out = pretty
instance Pretty T.Text where instance Out T.Text where
pretty = Text.PrettyPrint.text . view unpacked out = pretty
newtype Showing a = Showing a newtype Showing a = Showing a
instance (Show a) => Pretty (Showing a) where instance (Show a) => Out (Showing a) where
prettyPrec p (Showing a) = fromString $ showsPrec p a "" 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 class (forall a. Out a => Out (f a)) => Out1 f where
liftPrettyPrec :: (Int -> a -> Doc) -> Int -> f a -> Doc liftOutPrec :: (Int -> a -> Doc ann) -> Int -> f a -> Doc ann
prettyPrec1 :: (Pretty1 f, Pretty a) => Int -> f a -> Doc outPrec1 :: (Out1 f, Out a) => Int -> f a -> Doc ann
prettyPrec1 = liftPrettyPrec prettyPrec outPrec1 = liftOutPrec outPrec
instance (Pretty1 f, Pretty1 g, Pretty a) => Pretty (Sum f g a) where instance (Out1 f, Out1 g, Out a) => Out (Sum f g a) where
prettyPrec p (InL fa) = prettyPrec1 p fa outPrec p (InL fa) = outPrec1 p fa
prettyPrec p (InR ga) = prettyPrec1 p ga outPrec p (InR ga) = outPrec1 p ga
instance (Pretty1 f, Pretty1 g) => Pretty1 (Sum f g) where instance (Out1 f, Out1 g) => Out1 (Sum f g) where
liftPrettyPrec pr p (InL fa) = liftPrettyPrec pr p fa liftOutPrec pr p (InL fa) = liftOutPrec pr p fa
liftPrettyPrec pr p (InR ga) = liftPrettyPrec pr p ga liftOutPrec pr p (InR ga) = liftOutPrec pr p ga
instance (Pretty (f (Fix f))) => Pretty (Fix f) where instance (Out (f (Fix f))) => Out (Fix f) where
prettyPrec d (Fix f) = prettyPrec d f outPrec d (Fix f) = outPrec d f
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
ttext :: Pretty t => t -> Doc ttext :: Out t => t -> Doc ann
ttext = pretty 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 hsepOf l = foldrOf l (<+>) mempty
vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc vsepOf :: _ -> s -> Doc ann
vsepOf l = foldrOf l ($+$) mempty vsepOf l = vsep . toListOf l
vcatOf :: Getting (Endo Doc) s Doc -> s -> Doc vcatOf :: _ -> s -> Doc ann
vcatOf l = foldrOf l ($$) mempty vcatOf l = vcat . toListOf l
vlinesOf :: Getting (Endo Doc) s Doc -> s -> Doc vlinesOf :: Getting (Endo (Doc ann)) s (Doc ann) -> s -> Doc ann
vlinesOf l = foldrOf l (\a b -> a $+$ "" $+$ b) mempty vlinesOf l = foldrOf l (\a b -> a <> line <> b) mempty
-- hack(?) to separate chunks with a blankline -- 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, appPrec1 :: Int
appPrec = 10 appPrec = 10
appPrec1 = 11 appPrec1 = 11
instance PrintfArg Doc where instance PrintfArg (Doc ann) where
formatArg d fmt 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 | otherwise = errorBadFormat $ fmtChar fmt
where where
fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing } fmt' = fmt { fmtChar = 's', fmtPrecision = Nothing }

69
src/GM.hs
View File

@@ -29,9 +29,9 @@ import Data.Tuple (swap)
import Control.Lens import Control.Lens
import Data.Text.Lens (IsText, packed, unpacked) import Data.Text.Lens (IsText, packed, unpacked)
import Text.Printf import Text.Printf
import Text.PrettyPrint hiding ((<>))
import Text.PrettyPrint.HughesPJ (maybeParens)
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import Prettyprinter
import Data.Pretty
import System.IO (Handle, hPutStrLn) import System.IO (Handle, hPutStrLn)
-- TODO: an actual output system -- TODO: an actual output system
-- TODO: an actual output system -- TODO: an actual output system
@@ -165,7 +165,7 @@ hdbgProg p hio = do
renderOut . showStats $ sts renderOut . showStats $ sts
pure final pure final
where where
renderOut r = hPutStrLn hio $ render r ++ "\n" renderOut r = hPutStrLn hio $ show r ++ "\n"
states = eval $ compile p states = eval $ compile p
final = last states final = last states
@@ -182,7 +182,7 @@ evalProgR p = do
renderOut . showStats $ sts renderOut . showStats $ sts
pure (res, sts) pure (res, sts)
where where
renderOut r = addDebugMsg "dump-eval" $ render r ++ "\n" renderOut r = addDebugMsg "dump-eval" $ show r ++ "\n"
states = eval . compile $ p states = eval . compile $ p
final = last states final = last states
@@ -823,13 +823,13 @@ showCon t n = printf "Pack{%d %d}" t n ^. packed
pprTabstop :: Int pprTabstop :: Int
pprTabstop = 4 pprTabstop = 4
qquotes :: Doc -> Doc qquotes :: Doc ann -> Doc ann
qquotes d = "`" <> d <> "'" qquotes d = "`" <> d <> "'"
showStats :: Stats -> Doc showStats :: Stats -> Doc ann
showStats sts = "==== Stats ============" $$ stats showStats sts = "==== Stats ============" <> line <> stats
where where
stats = text $ printf stats = textt @String $ printf
"Reductions : %5d\n\ "Reductions : %5d\n\
\Prim Reductions : %5d\n\ \Prim Reductions : %5d\n\
\Allocations : %5d\n\ \Allocations : %5d\n\
@@ -839,10 +839,10 @@ showStats sts = "==== Stats ============" $$ stats
(sts ^. stsAllocations) (sts ^. stsAllocations)
(sts ^. stsGCCycles) (sts ^. stsGCCycles)
showState :: GmState -> Doc showState :: GmState -> Doc ann
showState st = vcat showState st = vcat
[ "==== GmState " <> int stnum <> " " [ "==== GmState " <> int stnum <> " "
<> text (replicate (28 - 13 - 1 - digitalWidth stnum) '=') <> textt (replicate (28 - 13 - 1 - digitalWidth stnum) '=')
, "-- Next instructions -------" , "-- Next instructions -------"
, info $ showCodeShort c , info $ showCodeShort c
, "-- Stack -------------------" , "-- Stack -------------------"
@@ -859,23 +859,23 @@ showState st = vcat
-- indent data -- indent data
info = nest pprTabstop info = nest pprTabstop
showCodeShort :: Code -> Doc showCodeShort :: Code -> Doc ann
showCodeShort c = braces c' showCodeShort c = braces c'
where where
c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..." c' | length c > 3 = list (showInstr <$> take 3 c) <> "; ..."
| otherwise = list (showInstr <$> c) | otherwise = list (showInstr <$> c)
list = hcat . punctuate "; " list = hcat . punctuate "; "
showStackShort :: Stack -> Doc showStackShort :: Stack -> Doc ann
showStackShort s = brackets s' showStackShort s = brackets s'
where where
-- no access to heap, otherwise we'd use showNodeAt -- no access to heap, otherwise we'd use showNodeAt
s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..." s' | length s > 3 = list (showEntry <$> take 3 s) <> ", ..."
| otherwise = list (showEntry <$> s) | otherwise = list (showEntry <$> s)
list = hcat . punctuate ", " list = hcat . punctuate ", "
showEntry = text . show showEntry = textt . show
showStack :: GmState -> Doc showStack :: GmState -> Doc ann
showStack st = vcat $ uncurry showEntry <$> si showStack st = vcat $ uncurry showEntry <$> si
where where
h = st ^. gmHeap h = st ^. gmHeap
@@ -887,10 +887,9 @@ showStack st = vcat $ uncurry showEntry <$> si
w = maxWidth (addresses h) w = maxWidth (addresses h)
showIndex n = padInt w n <> ": " showIndex n = padInt w n <> ": "
showEntry :: Int -> Addr -> Doc
showEntry n a = showIndex n <> showNodeAt st a showEntry n a = showIndex n <> showNodeAt st a
showDump :: GmState -> Doc showDump :: GmState -> Doc ann
showDump st = vcat $ uncurry showEntry <$> di showDump st = vcat $ uncurry showEntry <$> di
where where
d = st ^. gmDump d = st ^. gmDump
@@ -899,14 +898,13 @@ showDump st = vcat $ uncurry showEntry <$> di
showIndex n = padInt w n <> ": " showIndex n = padInt w n <> ": "
w = maxWidth (fst <$> di) w = maxWidth (fst <$> di)
showEntry :: Int -> (Code, Stack) -> Doc
showEntry n (c,s) = showIndex n <> nest pprTabstop entry showEntry n (c,s) = showIndex n <> nest pprTabstop entry
where where
entry = ("Stack : " <> showCodeShort c) entry = vsep [ "Stack : " <> showCodeShort c
$$ ("Code : " <> showStackShort s) , "Code : " <> showStackShort s ]
padInt :: Int -> Int -> Doc padInt :: Int -> Int -> Doc ann
padInt m n = text (replicate (m - digitalWidth n) ' ') <> int n padInt m n = textt (replicate (m - digitalWidth n) ' ') <> int n
maxWidth :: [Int] -> Int maxWidth :: [Int] -> Int
maxWidth ns = digitalWidth $ maximum ns maxWidth ns = digitalWidth $ maximum ns
@@ -914,7 +912,7 @@ maxWidth ns = digitalWidth $ maximum ns
digitalWidth :: Int -> Int digitalWidth :: Int -> Int
digitalWidth = length . show digitalWidth = length . show
showHeap :: GmState -> Doc showHeap :: GmState -> Doc ann
showHeap st = vcat $ showEntry <$> addrs showHeap st = vcat $ showEntry <$> addrs
where where
showAddr n = padInt w n <> ": " showAddr n = padInt w n <> ": "
@@ -923,13 +921,12 @@ showHeap st = vcat $ showEntry <$> addrs
h = st ^. gmHeap h = st ^. gmHeap
addrs = addresses h addrs = addresses h
showEntry :: Addr -> Doc
showEntry a = showAddr a <> showNodeAt st a showEntry a = showAddr a <> showNodeAt st a
showNodeAt :: GmState -> Addr -> Doc showNodeAt :: GmState -> Addr -> Doc ann
showNodeAt = showNodeAtP 0 showNodeAt = showNodeAtP 0
showNodeAtP :: Int -> GmState -> Addr -> Doc showNodeAtP :: Int -> GmState -> Addr -> Doc ann
showNodeAtP p st a = case hLookup a h of showNodeAtP p st a = case hLookup a h of
Just (NNum n) -> int n <> "#" Just (NNum n) -> int n <> "#"
Just (NGlobal _ _) -> textt name Just (NGlobal _ _) -> textt name
@@ -953,9 +950,9 @@ showNodeAtP p st a = case hLookup a h of
h = st ^. gmHeap h = st ^. gmHeap
pprec = maybeParens (p > 0) pprec = maybeParens (p > 0)
showSc :: GmState -> (Name, Addr) -> Doc showSc :: GmState -> (Name, Addr) -> Doc ann
showSc st (k,a) = "Supercomb " <> qquotes (textt k) <> colon showSc st (k,a) = vcat [ "Supercomb " <> qquotes (textt k) <> colon
$$ code , code ]
where where
code = case hLookup a (st ^. gmHeap) of code = case hLookup a (st ^. gmHeap) of
Just (NGlobal _ c) -> showCode c Just (NGlobal _ c) -> showCode c
@@ -966,19 +963,21 @@ errTxtInvalidObject, errTxtInvalidAddress :: (IsString a) => a
errTxtInvalidObject = "<invalid object>" errTxtInvalidObject = "<invalid object>"
errTxtInvalidAddress = "<invalid address>" errTxtInvalidAddress = "<invalid address>"
showCode :: Code -> Doc showCode :: Code -> Doc ann
showCode c = "Code" <+> braces instrs showCode c = "Code" <+> braces instrs
where instrs = vcat $ showInstr <$> c where instrs = vcat $ showInstr <$> c
showInstr :: Instr -> Doc showInstr :: Instr -> Doc ann
showInstr (CaseJump alts) = "CaseJump" $$ nest pprTabstop alternatives showInstr (CaseJump alts) = vcat [ "CaseJump", nest pprTabstop alternatives ]
where where
showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c showAlt (t,c) = "<" <> int t <> ">" <> showCodeShort c
alternatives = foldr (\a acc -> showAlt a $$ acc) mempty alts alternatives = foldr (\a acc -> showAlt a <> line <> acc) mempty alts
showInstr i = text $ show i showInstr i = textt $ show i
textt :: (IsText a) => a -> Doc int = pretty
textt t = t ^. unpacked & text
textt :: (Pretty a) => a -> Doc ann
textt = pretty
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------

88
src/Rlp/AltSyntax.hs
View File

@@ -116,67 +116,67 @@ pattern Finr ga = Fix (InR ga)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
instance (Pretty b, Pretty a) => Pretty (ExprF b a) where instance (Out b, Out a) => Out (ExprF b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance (Pretty b, Pretty a) => Pretty (Alter b a) where instance (Out b, Out a) => Out (Alter b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance (Pretty b) => Pretty1 (Alter b) where instance (Out b) => Out1 (Alter b) where
liftPrettyPrec pr _ (Alter p e) = liftOutPrec pr _ (Alter p e) =
hsep [ pretty p, "->", pr 0 e] hsep [ out p, "->", pr 0 e]
instance Pretty b => Pretty1 (ExprF b) where instance Out b => Out1 (ExprF b) where
liftPrettyPrec pr p (InfixEF o a b) = maybeParens (p>0) $ liftOutPrec pr p (InfixEF o a b) = maybeParens (p>0) $
pr 1 a <+> pretty o <+> pr 1 b pr 1 a <+> out o <+> pr 1 b
liftPrettyPrec pr p (CaseEF e as) = maybeParens (p>0) $ liftOutPrec pr p (CaseEF e as) = maybeParens (p>0) $
hsep [ "case", pr 0 e, "of" ] vsep [ hsep [ "case", pr 0 e, "of" ]
$+$ nest 2 (vcat $ liftPrettyPrec pr 0 <$> as) , nest 2 (vcat $ liftOutPrec pr 0 <$> as) ]
instance (Pretty b, Pretty a) => Pretty (Decl b a) where instance (Out b, Out a) => Out (Decl b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance (Pretty b) => Pretty1 (Decl b) where instance (Out b) => Out1 (Decl b) where
liftPrettyPrec pr _ (FunD f as e) = liftOutPrec pr _ (FunD f as e) =
hsep [ ttext f, hsep (prettyPrec appPrec1 <$> as) hsep [ ttext f, hsep (outPrec appPrec1 <$> as)
, "=", pr 0 e ] , "=", pr 0 e ]
liftPrettyPrec _ _ (DataD f as []) = liftOutPrec _ _ (DataD f as []) =
hsep [ "data", ttext f, hsep (pretty <$> as) ] hsep [ "data", ttext f, hsep (out <$> as) ]
liftPrettyPrec _ _ (DataD f as ds) = liftOutPrec _ _ (DataD f as ds) =
hsep [ "data", ttext f, hsep (pretty <$> as), cons ] hsep [ "data", ttext f, hsep (out <$> as), cons ]
where where
cons = vcat $ zipWith (<+>) delims (pretty <$> ds) cons = vcat $ zipWith (<+>) delims (out <$> ds)
delims = "=" : repeat "|" delims = "=" : repeat "|"
liftPrettyPrec _ _ (TySigD n t) = liftOutPrec _ _ (TySigD n t) =
hsep [ ttext n, ":", pretty t ] hsep [ ttext n, ":", out t ]
instance (Pretty b) => Pretty (DataCon b) where instance (Out b) => Out (DataCon b) where
pretty (DataCon n as) = ttext n <+> hsep (prettyPrec appPrec1 <$> as) out (DataCon n as) = ttext n <+> hsep (outPrec appPrec1 <$> as)
-- (->) is given prec `appPrec-1` -- (->) is given prec `appPrec-1`
instance (Pretty b) => Pretty (Type b) where instance (Out b) => Out (Type b) where
prettyPrec _ (VarT n) = ttext n outPrec _ (VarT n) = ttext n
prettyPrec _ (ConT n) = ttext n outPrec _ (ConT n) = ttext n
prettyPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $ outPrec p (s Core.:-> t) = maybeParens (p>appPrec-1) $
hsep [ prettyPrec appPrec s, "->", prettyPrec (appPrec-1) t ] hsep [ outPrec appPrec s, "->", outPrec (appPrec-1) t ]
prettyPrec p (AppT f x) = maybeParens (p>appPrec) $ outPrec p (AppT f x) = maybeParens (p>appPrec) $
prettyPrec appPrec f <+> prettyPrec appPrec1 x outPrec appPrec f <+> outPrec appPrec1 x
prettyPrec p FunT = maybeParens (p>0) "->" outPrec p FunT = maybeParens (p>0) "->"
instance (Pretty b) => Pretty (Pat b) where instance (Out b) => Out (Pat b) where
prettyPrec p (VarP b) = prettyPrec p b outPrec p (VarP b) = outPrec p b
prettyPrec p (ConP b) = prettyPrec p b outPrec p (ConP b) = outPrec p b
prettyPrec p (AppP c x) = maybeParens (p>appPrec) $ outPrec p (AppP c x) = maybeParens (p>appPrec) $
prettyPrec appPrec c <+> prettyPrec appPrec1 x outPrec appPrec c <+> outPrec appPrec1 x
instance (Pretty a, Pretty b) => Pretty (Program b a) where instance (Out a, Out b) => Out (Program b a) where
prettyPrec = prettyPrec1 outPrec = outPrec1
instance (Pretty b) => Pretty1 (Program b) where instance (Out b) => Out1 (Program b) where
liftPrettyPrec pr p (Program ds) = vsep $ liftPrettyPrec pr p <$> ds liftOutPrec pr p (Program ds) = vsep $ liftOutPrec pr p <$> ds
makePrisms ''Pat makePrisms ''Pat
makePrisms ''Binding makePrisms ''Binding

8
src/Rlp/HindleyMilner.hs
View File

@@ -20,7 +20,7 @@ import Control.Monad
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Control.Monad.Writer.Strict import Control.Monad.Writer.Strict
import Data.Text qualified as T import Data.Text qualified as T
import Data.Pretty import Data.Pretty hiding (annotate)
import Data.Hashable import Data.Hashable
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H import Data.HashMap.Strict qualified as H
@@ -153,11 +153,11 @@ subst n t' = para \case
| otherwise -> ForallT x post | otherwise -> ForallT x post
t -> embed $ t <&> view _2 t -> embed $ t <&> view _2
prettyHM :: (Pretty a) prettyHM :: (Out a)
=> Either [TypeError] (a, [Constraint]) => Either [TypeError] (a, [Constraint])
-> Either [TypeError] (String, [String]) -> Either [TypeError] (String, [String])
prettyHM = over (mapped . _1) rpretty prettyHM = over (mapped . _1) rout
. over (mapped . _2 . each) rpretty . over (mapped . _2 . each) rout
fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b
fixtend c (Fix f) = c f :< fmap (fixtend c) f fixtend c (Fix f) = c f :< fmap (fixtend c) f

14
src/Rlp/HindleyMilner/Types.hs
View File

@@ -73,16 +73,16 @@ instance IsRlpcError TypeError where
-- todo: use anti-parser instead of show -- todo: use anti-parser instead of show
TyErrCouldNotUnify t u -> Text TyErrCouldNotUnify t u -> Text
[ T.pack $ printf "Could not match type `%s` with `%s`." [ T.pack $ printf "Could not match type `%s` with `%s`."
(rpretty @String t) (rpretty @String u) (rout @String t) (rout @String u)
, "Expected: " <> rpretty t , "Expected: " <> rout t
, "Got: " <> rpretty u , "Got: " <> rout u
] ]
TyErrUntypedVariable n -> Text TyErrUntypedVariable n -> Text
[ "Untyped (likely undefined) variable `" <> n <> "`" [ "Untyped (likely undefined) variable `" <> n <> "`"
] ]
TyErrRecursiveType t x -> Text TyErrRecursiveType t x -> Text
[ T.pack $ printf "Recursive type: `%s' occurs in `%s'" [ 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) -- type Memo t = HashMap t (Type PsName, PartialJudgement)
@@ -156,7 +156,7 @@ demoContext = Context
constraintTypes :: Traversal' Constraint (Type PsName) constraintTypes :: Traversal' Constraint (Type PsName)
constraintTypes k (Equality s t) = Equality <$> k s <*> k t constraintTypes k (Equality s t) = Equality <$> k s <*> k t
instance Pretty Constraint where instance Out Constraint where
pretty (Equality s t) = out (Equality s t) =
hsep [prettyPrec appPrec1 s, "~", prettyPrec appPrec1 t] hsep [outPrec appPrec1 s, "~", outPrec appPrec1 t]

12
src/Rlp/HindleyMilner/Visual.hs
View File

@@ -9,7 +9,7 @@ import Control.Monad
import System.IO import System.IO
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.IO qualified as T import Data.Text.IO qualified as T
import Data.Pretty import Data.Pretty hiding (annotate)
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Foldable import Data.Foldable
import Misc.CofreeF import Misc.CofreeF
@@ -77,14 +77,14 @@ withTooltip normal hover =
-- -- ! onload "installHoverListener(this)" -- -- ! onload "installHoverListener(this)"
-- $ normal -- $ normal
annExpr :: (ann -> Doc) -> AnnExpr ann -> Html annExpr :: (a -> Doc ann) -> AnnExpr a -> Html
annExpr sf = code . cata \case annExpr sf = code . cata \case
t :<$ InL (LitF l) -> withTooltip (rpretty l) (sf' t) t :<$ InL (LitF l) -> withTooltip (rout l) (sf' t)
t :<$ InL (VarF n) -> withTooltip (rpretty n) (sf' t) t :<$ InL (VarF n) -> withTooltip (rout n) (sf' t)
t :<$ InL (AppF f x) -> withTooltip (f *> " " *> x) (sf' t) t :<$ InL (AppF f x) -> withTooltip (f *> " " *> x) (sf' t)
t :<$ InL (LamF bs e) -> withTooltip ("λ" *> bs' *> " -> " *> e) (sf' t) t :<$ InL (LamF bs e) -> withTooltip ("λ" *> bs' *> " -> " *> e) (sf' t)
where where
bs' = fromString . render . hsep $ prettyPrec appPrec1 <$> bs bs' = fromString . show . hsep $ outPrec appPrec1 <$> bs
where where
sf' = fromString . show . sf sf' = fromString . show . sf
@@ -129,5 +129,5 @@ renderExpr e = case runHM' . annotate $ e of
renderExpr' :: RlpExpr PsName -> IO () renderExpr' :: RlpExpr PsName -> IO ()
renderExpr' e = case runHM' . solve $ e of renderExpr' e = case runHM' . solve $ e of
Left es -> error (show es) Left es -> error (show es)
Right e' -> renderTmp' . annExpr pretty $ e' Right e' -> renderTmp' . annExpr out $ e'

4
src/Rlp2Core.hs
View File

@@ -38,7 +38,7 @@ import Text.Show.Deriving
import Core.Syntax as Core import Core.Syntax as Core
import Rlp.AltSyntax as Rlp import Rlp.AltSyntax as Rlp
import Compiler.Types import Compiler.Types
import Data.Pretty (render, pretty) import Data.Pretty
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type Tree a = Either Name (Name, Branch a) type Tree a = Either Name (Name, Branch a)
@@ -64,7 +64,7 @@ desugarRlpProgR :: forall m a. (Monad m)
-> RLPCT m Core.Program' -> RLPCT m Core.Program'
desugarRlpProgR p = do desugarRlpProgR p = do
let p' = desugarRlpProg p let p' = desugarRlpProg p
addDebugMsg "dump-desugared" $ render (pretty p') addDebugMsg "dump-desugared" $ show (out p')
pure p' pure p'
desugarRlpProg = undefined desugarRlpProg = undefined