ref: 754c2a59b0a78f7aa23cc1166b2cfc18d7209bfe
parent: f24f4d2c372bd4751af62c6253e315fd03848233
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Apr 1 12:22:45 EDT 2024
Generate predictable instance identifiers.
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -42,6 +42,7 @@
eDummy,
impossible, impossibleShow,
getArrow, getArrows,
+ showExprRaw,
) where
import Prelude hiding ((<>))
import Control.Arrow(first)
@@ -549,6 +550,9 @@
showExpr :: Expr -> String
showExpr = render . ppExpr
+showExprRaw :: Expr -> String
+showExprRaw = render . ppExprRaw
+
showEDefs :: [EDef] -> String
showEDefs = render . ppEDefs
@@ -645,47 +649,59 @@
ppAlt :: Doc -> EAlt -> Doc
ppAlt asep (ss, e) = text " |" <+> hsep (punctuate (text ",") (map ppEStmt ss)) <+> asep <+> ppExpr e
+ppExprRaw :: Expr -> Doc
+ppExprRaw = ppExprR True
+
ppExpr :: Expr -> Doc
-ppExpr ae =
- case ae of
- EVar i | isOperChar cop -> parens (text op)
- | otherwise -> text s
- where op = unIdent (unQualIdent i)
- s = if "inst$" `isPrefixOf` op then unIdent i else op
- cop = head op
- EApp _ _ -> ppApp [] ae
- EOper e ies -> ppExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
- ELam qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
- ELit _ i -> text (showLit i)
- ECase e as -> text "case" <+> ppExpr e <+> text "of" $$ nest 2 (vcat (map ppCaseArm as))
- ELet bs e -> text "let" $$ nest 2 (vcat (map ppEBind bs)) $$ text "in" <+> ppExpr e
- ETuple es -> parens $ hsep $ punctuate (text ",") (map ppExpr es)
- EDo mn ss -> maybe (text "do") (\ n -> ppIdent n <> text ".do") mn $$ nest 2 (vcat (map ppEStmt ss))
- ESectL e i -> parens $ ppExpr e <+> ppIdent i
- ESectR i e -> parens $ ppIdent i <+> ppExpr e
- EIf e1 e2 e3 -> parens $ sep [text "if" <+> ppExpr e1, text "then" <+> ppExpr e2, text "else" <+> ppExpr e3]
- EListish l -> ppListish l
- ESign e t -> parens $ ppExpr e <+> text "::" <+> ppEType t
- ENegApp e -> text "-" <+> ppExpr e
- EUpdate ee ies -> ppExpr ee <> text "{" <+> hsep (punctuate (text ",") (map ppField ies)) <+> text "}"- ESelect is -> parens $ hcat $ map (\ i -> text "." <> ppIdent i) is
- EAt i e -> ppIdent i <> text "@" <> ppExpr e
- EViewPat e p -> parens $ ppExpr e <+> text "->" <+> ppExpr p
- ELazy True p -> text "~" <> ppExpr p
- ELazy False p -> text "!" <> ppExpr p
- EUVar i -> text ("_a" ++ show i)- ECon c -> ppCon c
- EForall iks e -> ppForall iks <+> ppEType e
--- where
-ppApp :: [Expr] -> Expr -> Doc
-ppApp as (EApp f a) = ppApp (a:as) f
-ppApp as (EVar i) | isOperChar cop, [a, b] <- as = parens $ ppExpr a <+> text op <+> ppExpr b
- | isOperChar cop, [a] <- as = parens $ ppExpr a <+> text op
- | cop == ',' = ppExpr (ETuple as)
- | op == "[]", length as == 1 = ppExpr (EListish (LList as))
- where op = unIdent (unQualIdent i)
- cop = head op
-ppApp as f = parens $ hsep (map ppExpr (f:as))
+ppExpr = ppExprR False
+
+ppExprR :: Bool -> Expr -> Doc
+ppExprR raw = ppE
+ where
+ ppE :: Expr -> Doc
+ ppE ae =
+ case ae of
+ EVar i | raw -> text (unIdent i)
+ | isOperChar cop -> parens (text op)
+ | otherwise -> text s
+ where op = unIdent (unQualIdent i)
+ s = if "inst$" `isPrefixOf` op then unIdent i else op
+ cop = head op
+ EApp _ _ -> ppApp [] ae
+ EOper e ies -> ppE (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
+ ELam qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
+ ELit _ i -> text (showLit i)
+ ECase e as -> text "case" <+> ppE e <+> text "of" $$ nest 2 (vcat (map ppCaseArm as))
+ ELet bs e -> text "let" $$ nest 2 (vcat (map ppEBind bs)) $$ text "in" <+> ppE e
+ ETuple es -> parens $ hsep $ punctuate (text ",") (map ppE es)
+ EDo mn ss -> maybe (text "do") (\ n -> ppIdent n <> text ".do") mn $$ nest 2 (vcat (map ppEStmt ss))
+ ESectL e i -> parens $ ppE e <+> ppIdent i
+ ESectR i e -> parens $ ppIdent i <+> ppE e
+ EIf e1 e2 e3 -> parens $ sep [text "if" <+> ppE e1, text "then" <+> ppE e2, text "else" <+> ppE e3]
+ EListish l -> ppListish l
+ ESign e t -> parens $ ppE e <+> text "::" <+> ppEType t
+ ENegApp e -> text "-" <+> ppE e
+ EUpdate ee ies -> ppE ee <> text "{" <+> hsep (punctuate (text ",") (map ppField ies)) <+> text "}"+ ESelect is -> parens $ hcat $ map (\ i -> text "." <> ppIdent i) is
+ EAt i e -> ppIdent i <> text "@" <> ppE e
+ EViewPat e p -> parens $ ppE e <+> text "->" <+> ppE p
+ ELazy True p -> text "~" <> ppE p
+ ELazy False p -> text "!" <> ppE p
+ EUVar i -> text ("_a" ++ show i)+ ECon c -> ppCon c
+ EForall iks e -> ppForall iks <+> ppEType e
+
+ ppApp :: [Expr] -> Expr -> Doc
+ ppApp as (EApp f a) = ppApp (a:as) f
+ ppApp as f | raw = ppApply f as
+ ppApp as (EVar i) | isOperChar cop, [a, b] <- as = parens $ ppE a <+> text op <+> ppExpr b
+ | isOperChar cop, [a] <- as = parens $ ppE a <+> text op
+ | cop == ',' = ppE (ETuple as)
+ | op == "[]", length as == 1 = ppE (EListish (LList as))
+ where op = unIdent (unQualIdent i)
+ cop = head op
+ ppApp as f = ppApply f as
+ ppApply f as = parens $ hsep (map ppE (f:as))
ppField :: EField -> Doc
ppField (EField is e) = hcat (punctuate (text ".") (map ppIdent is)) <+> text "=" <+> ppExpr e
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -329,7 +329,7 @@
let
usyms (ImportSpec qual _ _ _, TModule _ _ tes _ _ _ ves _) =
if qual then [] else
- [ (i, [e]) | ValueExport i e <- ves, not (isInternalId i) ] ++
+ [ (i, [e]) | ValueExport i e <- ves, not (isInstId i) ] ++
[ (i, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs ]
qsyms (ImportSpec _ _ mas _, TModule mn _ tes _ cls _ ves _) =
let m = fromMaybe mn mas in
@@ -389,9 +389,13 @@
eqInstDict (e, _, _) (e', _, _) = eqExpr e e'
-- Identifier should only be seen with it's qualified name.
-isInternalId :: Ident -> Bool
-isInternalId i = (instPrefix ++ uniqIdentSep) `isPrefixOf` unIdent i
+isInstId :: Ident -> Bool
+isInstId i = (instPrefix ++ uniqIdentSep) `isPrefixOf` unIdent i
+mkInstId :: SLoc -> EType -> Ident
+mkInstId loc ct = mkIdentSLoc loc $ instPrefix ++ uniqIdentSep ++ clsTy
+ where clsTy = map (\ c -> if isSpace c then '@' else c) $ showExprRaw ct
+
instPrefix :: String
instPrefix = "inst"
@@ -1183,8 +1187,9 @@
(vks, ctx, cc) <- splitInst <$> expandSyn act
let loc = getSLoc act
qiCls = getAppCon cc
- iInst <- newIdent loc instPrefix
- let sign = Sign [iInst] act
+ let iInst = mkInstId loc cc
+ sign = Sign [iInst] act
+-- traceM ("expandInst " ++ show iInst)-- (e, _) <- tLookupV iCls
ct <- gets classTable
-- let qiCls = getAppCon e
--
⑨