shithub: MicroHs

--- a/comb/mhs.comb

+++ b/comb/mhs.comb

@@ -1,3 +1,3 @@

 v4.0

-1014

-((A :0 _898) ((A :1 ((B _944) _0)) ((A :2 (((S' _944) _0) I)) ((A :3 _868) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _897) ((C _75) _5))) ((A :7 (((C' _6) (_915 _72)) ((_75 _913) _71))) ((A :8 ((B ((S _944) _913)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _826)))) ((A :19 ((B (_74 _9)) (BK (P _826)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :23 ((B Y) ((B (B (P (_14 _826)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _826))) ((A :26 (_22 _76)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _873) ((A :36 _874) ((A :37 (((S' _28) (_865 #97)) ((C _865) #122))) ((A :38 (((S' _28) (_865 #65)) ((C _865) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_865 #48)) ((C _865) #57))) ((A :41 (((S' _28) (_865 #32)) ((C _865) #126))) ((A :42 _862) ((A :43 _863) ((A :44 _865) ((A :45 _864) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_824 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_824 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #97))) (_36 #65))))) ((A :49 _833) ((A :50 _834) ((A :51 _835) ((A :52 _836) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _837) ((A :59 _838) ((A :60 _58) ((A :61 _59) ((A :62 _839) ((A :63 _840) ((A :64 _841) ((A :65 _842) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _843) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _869) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _827) ((A :83 _828) ((A :84 _829) ((A :85 _830) ((A :86 _831) ((A :87 _832) ((A :88 (_83 #0)) ((A :89 _850) ((A :90 _851) ((A :91 _852) ((A :92 _853) ((A :93 _854) ((A :94 _855) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_824 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B

\ No newline at end of file

+1082

+((A :0 _966) ((A :1 ((B _1012) _0)) ((A :2 (((S' _1012) _0) I)) ((A :3 _936) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _965) ((C _76) _5))) ((A :7 (((C' _6) (_983 _72)) ((_76 _981) _71))) ((A :8 ((B ((S _1012) _981)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _191)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _894)))) ((A :19 ((B (_74 _9)) (BK (P _894)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _116)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _117)))))) ((A :23 ((B Y) ((B (B (P (_14 _894)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _894))) ((A :26 (_22 _77)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _941) ((A :36 _942) ((A :37 (((S' _28) (_933 #97)) ((C _933) #122))) ((A :38 (((S' _28) (_933 #65)) ((C _933) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_933 #48)) ((C _933) #57))) ((A :41 (((S' _28) (_933 #32)) ((C _933) #126))) ((A :42 _930) ((A :43 _931) ((A :44 _933) ((A :45 _932) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_892 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_892 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _901) ((A :50 _902) ((A :51 _903) ((A :52 _904) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _905) ((A :59 _906) ((A :60 _58) ((A :61 _59) ((A :62 _907) ((A :63 _908) ((A :64 _909) ((A :65 _910) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _911) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _938)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _937) ((A :81 ((C ((C S') _191)) _192)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _895) ((A :84 _896) ((A :85 _897) ((A :86 _898) ((A :87 _899) ((A :88 _900) ((A :89 (_84 #0)) ((A :90 _918) ((A :91 _919) ((A :92 _920) ((A :93 _921) ((A :94 _922) ((A :95 _923) ((A :96 _90) ((A :97 (BK K)) ((A :98 ((B BK) ((B (B BK)) P))) ((A :99 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :100 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_93 #0))) (_90 #0)))) ((B (B ((C' P) (_88 #1)))) _83))) (C P))) _86)) _87)) ((A :101 _97) ((A :102 (((S' C) ((B (P _179)) (((C' (C' B)) (((C' C) _90) _179)) _180))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_90 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_90 #1)))) ((B ((C' C) ((B ((C' S') (_90 #2))) (C _102)))) (C _102))))) (C _102))))) (C _102)))) (T K))) (T A)))) ((C _100) #4)))) ((A :103 (_109 _78)) ((A :104 ((_124 (_81 _103)) _101)) ((A :105 ((C (((C' B) ((P _116) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _106)))) (((S' (C' (C' B))) ((B (B (B _106))) (((S' (C' B)) ((B (B _106)) (((C' B) ((B _122) (T #0))) _105))) (((C' B) ((B _122) (T #1))) _105)))) (((C' B) ((B _122) (T #2))) _105)))) (((C' B) ((B _122) (T #3))) _105)))) ((B T) ((B (B P)) ((C' _83) (_85 #4)))))) ((A :106 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _92)))) ((B ((C' B) _117)) _106)))))) ((B ((C' B) _117)) (C _106)))))))))) (((_892 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _191)) _105)) ((A :108 (((C' C) (((C' C) (C _102)) (_3 "Data.IntMap.!"))) I)) ((A :109 ((B ((C' B) T)) ((B (B Y)) (((C

\ No newline at end of file

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -353,3 +353,160 @@

 ----------------

+showExpr :: Expr -> String

+showExpr = render . ppExpr

+showEDefs :: [EDef] -> String

+showEDefs = render . ppEDefs

+showEBind :: EBind -> String

+showEBind = render . ppEBind

+showEType :: EType -> String

+showEType = render . ppEType

+ppImportItem :: ImportItem -> Doc

+ppImportItem ae =

+  case ae of

+    ImpTypeCon i -> ppIdent i <> text "(..)"

+    ImpType i -> ppIdent i

+    ImpValue i -> ppIdent i

+ppEDef :: EDef -> Doc

+ppEDef def =

+  case def of

+    Data lhs [] -> text "data" <+> ppLHS lhs

+    Data lhs cs -> text "data" <+> ppLHS lhs <+> text "=" <+> hsep (punctuate (text " |") (map ppConstr cs))

+    Newtype lhs c -> text "newtype" <+> ppLHS lhs <+> text "=" <+> ppConstr c

+    Type lhs t -> text "type" <+> ppLHS lhs <+> text "=" <+> ppEType t

+    Fcn i eqns -> vcat (map (\ (Eqn ps alts) -> sep [ppIdent i <+> hsep (map ppEPat ps), ppAlts (text "=") alts]) eqns)

+    Sign i t -> ppIdent i <+> text "::" <+> ppEType t

+    Import (ImportSpec q m mm mis) -> text "import" <+> (if q then text "qualified" else empty) <+> ppIdent m <> text (maybe "" ((" as " ++) . unIdent) mm) <>

+      case mis of

+        Nothing -> empty

+        Just (h, is) -> text (if h then " hiding" else "") <> parens (hsep $ punctuate (text ", ") (map ppImportItem is))

+    ForImp ie i t -> text ("foreign import ccall " ++ showString ie) <+> ppIdent i <+> text "::" <+> ppEType t

+    Infix (a, p) is -> text ("infix" ++ f a) <+> text (showInt p) <+> hsep (punctuate (text ", ") (map ppIdent is))

+      where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""

+    Class sup lhs bs -> text "class" <+> ctx sup <+> ppLHS lhs <> ppWhere bs

+    Instance vs ct ty bs -> text "instance" <+> ppForall vs <+> ctx ct <+> ppEType ty <> ppWhere bs

+ where ctx [] = empty

+       ctx ts = ppEType (ETuple ts) <+> text "=>"

+ppConstr :: Constr -> Doc

+ppConstr (Constr c (Left  ts)) = hsep (ppIdent c : map ppEType ts)

+ppConstr (Constr c (Right fs)) = ppIdent c <> braces (hsep $ map f fs)

+  where f (i, t) = ppIdent i <+> text "::" <+> ppEType t <> text ","

+ppLHS :: LHS -> Doc

+ppLHS (f, vs) = hsep (ppIdent f : map ppIdKind vs)

+ppIdKind :: IdKind -> Doc

+ppIdKind (IdKind i k) = parens $ ppIdent i <> text "::" <> ppEKind k

+ppEDefs :: [EDef] -> Doc

+ppEDefs ds = vcat (map ppEDef ds)

+ppAlts :: Doc -> EAlts -> Doc

+ppAlts asep (EAlts alts bs) = ppAltsL asep alts <> ppWhere bs

+ppWhere :: [EBind] -> Doc

+ppWhere [] = empty

+ppWhere bs = text "where" $+$ nest 2 (vcat (map ppEBind bs))

+ppAltsL :: Doc -> [EAlt] -> Doc

+ppAltsL asep [([], e)] = text "" <+> asep <+> ppExpr e

+ppAltsL asep alts = vcat (map (ppAlt asep) alts)

+ppAlt :: Doc -> EAlt -> Doc

+ppAlt asep (ss, e) = text " |" <+> hsep (punctuate (text ",") (map ppEStmt ss)) <+> asep <+> ppExpr e

+ppExpr :: Expr -> Doc

+ppExpr ae =

+  case ae of

+    EVar v -> ppIdent v

+    EApp _ _ -> ppApp [] ae

+    EOper e ies -> ppExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)

+    ELam ps e -> parens $ text "\\" <> hsep (map ppExpr ps) <+> text "->" <+> ppExpr e

+    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)

+    EListish (LList es) -> ppList 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 -> ppExpr e <+> text "::" <+> ppEType t

+    EAt i e -> ppIdent i <> text "@" <> ppExpr e

+    EUVar i -> text ("a" ++ showInt i)

+    ECon c -> ppCon c

+    EForall iks e -> ppForall iks <+> ppEType e

+  where

+    ppApp as (EApp f a) = ppApp (a:as) f

+    ppApp as (EVar i) | eqString op "->", [a, b] <- as = parens $ ppExpr a <+> text "->" <+> ppExpr b

+                      | eqChar (head op) ',' = ppExpr (ETuple as)

+                      | eqString op "[]", length as == 1 = ppExpr (EListish (LList as))

+                        where op = unQualString (unIdent i)

+    ppApp as f = parens $ hsep (map ppExpr (f:as))

+ppForall :: [IdKind] -> Doc

+ppForall [] = empty

+ppForall iks = text "forall" <+> hsep (map ppIdKind iks) <+> text "."

+ppListish :: Listish -> Doc

+ppListish _ = text "<<Listish>>"

+ppCon :: Con -> Doc

+ppCon (ConData _ s) = ppIdent s

+ppCon (ConNew s) = ppIdent s

+ppCon (ConLit l) = text (showLit l)

+-- Literals are tagged the way they appear in the combinator file:

+--  #   Int

+--  %   Double

+--  '   Char    (not in file)

+--  "   String

+--  ^   FFI function

+--      primitive

+showLit :: Lit -> String

+showLit l =

+  case l of

+    LInt i    -> '#' : showInt i

+    LDouble d -> '%' : D.showDouble d

+    LChar c   -> showChar c

+    LStr s    -> showString s

+    LPrim s   -> s

+    LForImp s -> '^' : s

+ppEStmt :: EStmt -> Doc

+ppEStmt as =

+  case as of

+    SBind p e -> ppEPat p <+> text "<-" <+> ppExpr e

+    SThen e -> ppExpr e

+    SLet bs -> text "let" $$ nest 2 (vcat (map ppEBind bs))

+ppEBind :: EBind -> Doc

+ppEBind ab =

+  case ab of

+    BFcn i eqns -> ppEDef (Fcn i eqns)

+    BPat p e -> ppEPat p <+> text "=" <+> ppExpr e

+    BSign i t -> ppIdent i <+> text "::" <+> ppEType t

+ppCaseArm :: ECaseArm -> Doc

+ppCaseArm arm =

+  case arm of

+    (p, alts) -> ppEPat p <> ppAlts (text "->") alts

+ppEPat :: EPat -> Doc

+ppEPat = ppExpr

+ppEType :: EType -> Doc

+ppEType = ppExpr

+ppEKind :: EKind -> Doc

+ppEKind = ppEType

+ppList :: forall a . (a -> Doc) -> [a] -> Doc

+ppList pp xs = brackets $ hsep $ punctuate (text ",") (map pp xs)

--

⑨