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 c5a293acf8
commit c85ba57247
14 changed files with 267 additions and 299 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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