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

ppr datatags

Browse Source
This commit is contained in:
crumbtoo
2024-02-08 12:12:57 -07:00
parent fba46296db
commit 1c3286f047
1 changed files with 24 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

43
src/Core/Syntax.hs
View File

@@ -145,8 +145,8 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
data Program b = Program data Program b = Program
{ _programScDefs :: [ScDef b] { _programScDefs :: [ScDef b]
, _programTypeSigs :: HashMap b Type , _programTypeSigs :: HashMap b Type
-- map constructors to their tag and arity
, _programDataTags :: HashMap b (Tag, Int) , _programDataTags :: HashMap b (Tag, Int)
-- ^ map constructors to their tag and arity
} }
deriving (Show, Lift, Generic) deriving (Show, Lift, Generic)
deriving (Semigroup, Monoid) deriving (Semigroup, Monoid)
@@ -223,28 +223,33 @@ instance HasLHS (Binding b) (Binding b) b b where
-- TODO: print type sigs with corresponding scdefs -- TODO: print type sigs with corresponding scdefs
-- TODO: emit pragmas for datatags -- TODO: emit pragmas for datatags
instance (Hashable b, Pretty b) => Pretty (Program b) where instance (Hashable b, Pretty b) => Pretty (Program b) where
-- pretty = vsepOf (programScDefs . each . to pretty) pretty p = ifoldrOf (programDataTags . ifolded) cataDataTag mempty p
pretty = vlinesOf (programJoinedDefs . to prettyGroup) where $+$ vlinesOf (programJoinedDefs . to prettyGroup) p
programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b)) where
programJoinedDefs = folding $ \p -> programJoinedDefs :: Fold (Program b) (These (b, Type) (ScDef b))
foldMapOf programTypeSigs thing1 p programJoinedDefs = folding $ \p ->
`u` foldMapOf programScDefs thing2 p foldMapOf programTypeSigs thisTs p
where u = H.unionWith unionThese `u` foldMapOf programScDefs thatSc p
where u = H.unionWith unionThese
thing1 = ifoldMap @b @(HashMap b) thisTs = ifoldMap @b @(HashMap b)
(\n t -> H.singleton n (This (n,t))) (\n t -> H.singleton n (This (n,t)))
thing2 = 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
prettyGroup = bifoldr ($$) ($$) mempty . bimap prettyTySig pretty prettyGroup = bifoldr ($$) ($$) mempty . bimap prettyTySig pretty
prettyTySig (n,t) = hsep [ttext n, "::", pretty t] prettyTySig (n,t) = hsep [ttext n, "::", pretty t]
unionThese :: forall a b. 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
cataDataTag n (t,a) acc = prettyDataTag n t a $+$ acc
prettyDataTag n t a =
hsep ["{-#", "PackData", ttext n, ttext t, ttext a, "#-}"]
instance Pretty Type where instance Pretty Type where
prettyPrec _ (TyVar n) = ttext n prettyPrec _ (TyVar n) = ttext n