shithub: MicroHs

Download patch

ref: 534875dc5a17ca4ccf213ec1d699060928a17033
parent: 83017c4a014b40cd64fef7e4b5cfd8df78534eb2
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Sep 15 05:58:35 EDT 2023 

Add Infix constructor.


--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v3.3
-781
-(($A :0 ((_587 _540) (($B ((($S' ($C ((($C' ($S' _587)) (($B ($C _2)) _526)) (($B ($B (_587 _615))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _588)) ((($C' $B) (($B _678) (($B _605) ((($C' _716) _8) 0)))) (($B (_678 _608)) (($B (_621 "top level defns: ")) _569)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _588)) ((($C' $B) (($B _678) (($B _605) ((($C' _716) _8) 1)))) (_604 ($T (($B ($B (_678 _608))) ((($C' $B) (($B _621) _531)) (($B (_621 " = ")) _363))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _588))) ((($C' $B) ($B' (($B _678) (($B _610) _11)))) (($B ($B (_621 _1))) (($B (($C' _621) _569)) (_621 (($O 10) $K))))))) (($B ($B (_587 _615))) ((($C' $B) ($B' (($B _678) (($B _605) ((($C' _716) _8) 0))))) (($B ($B (_678 _608))) (($B ($B (_621 "final pass            "))) ((($C' ($C' _621)) (($B ($B (_582 6))) (($B ($B _569)) _710))) "ms")))))))) _3)))) _566))) (($B (($C' $C) (($B ($C _626)) _363))) (($C _639) (_656 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_621 "(($A :"))))) (($B ($B (($C' $B) (($B _621) _569)))) (($B ($B ($B (_621 (($O 32) $K))))) ((($C' $B) (($B ($C' _621)) ($B _363))) (($B (_621 ") ")) (($C _621) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _340)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _678) (($B _675) (($B (_678 _725)) (($B (_621 "main: findIdent: ")) _531))))) (($C' _559) _528)))) (($B ($B _563)) (($B (($C' _623) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _528))) $K)))))) (($C _639) (_656 0)))))) (($B (_678 _339)) (($B (_678 _526)) (($B (_621 (($O 95) $K))) _569)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _638) (_625 (_580 "-v")))) ((_655 _580) "-r"))) (($B (_619 (($O 46) $K))) (($B _677) (_624 ((_643 _701) "-i")))))) (($B (_678 _650)) ((($C' _621) (($B _677) (_624 ((_643 _701) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _712) _638) 1)) (_725 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _650)) (_625 ((_679 _721) ((_679 (_580 (($O 45) $K))) (_636 1))))))) (_646 ((_679 _721) (_580 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _587)) _16) (($B ($B ($B (_587 _615)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _588) (($B (_678 _606)) (($B (_678 (_637 1000000))) _187)))))) (($B ($B ($B ($B (_587 _615))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _588))) ((($C' $B) ($B' (($B _678) (($B _605) ((($C' _716) _8) 0))))) (($B ($B (_678 _608))) (($B ($B (_621 "combinator conversion "))) ((($C' ($C' _621)) (($B ($B (_582 6))) (($B ($B _569)) _710))) "ms"))))))) (($B ($B _589)) (($B $P) (($C _533) (_526 "main")))))))) (_623 ($T ((($C' ($C' $O)) ((($C' $B) $P) _366)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_587 _540)))) (($B ($B ($B (($C' _541) ((($C' _705) (($B _638) (_646 ((_679 _721) (_580 "--"))))) 1))))) (($B ($B ($B (_678 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _517))) (($C' ($C' _623)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _678) (($B _675) (($B (_678 _725)) (($B (_621 "not found ")) _531))))) ($C _518))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _365))) (($B (_678 (_675 (_725 "primlookup")))) (($C (_661 _580)) _5)))) $K))) (_725 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P 
\ No newline at end of file
+782
+(($A :0 ((_588 _541) (($B ((($S' ($C ((($C' ($S' _588)) (($B ($C _2)) _527)) (($B ($B (_588 _616))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _589)) ((($C' $B) (($B _679) (($B _606) ((($C' _717) _8) 0)))) (($B (_679 _609)) (($B (_622 "top level defns: ")) _570)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _589)) ((($C' $B) (($B _679) (($B _606) ((($C' _717) _8) 1)))) (_605 ($T (($B ($B (_679 _609))) ((($C' $B) (($B _622) _532)) (($B (_622 " = ")) _359))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _589))) ((($C' $B) ($B' (($B _679) (($B _611) _11)))) (($B ($B (_622 _1))) (($B (($C' _622) _570)) (_622 (($O 10) $K))))))) (($B ($B (_588 _616))) ((($C' $B) ($B' (($B _679) (($B _606) ((($C' _717) _8) 0))))) (($B ($B (_679 _609))) (($B ($B (_622 "final pass            "))) ((($C' ($C' _622)) (($B ($B (_583 6))) (($B ($B _570)) _711))) "ms")))))))) _3)))) _567))) (($B (($C' $C) (($B ($C _627)) _359))) (($C _640) (_657 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_622 "(($A :"))))) (($B ($B (($C' $B) (($B _622) _570)))) (($B ($B ($B (_622 (($O 32) $K))))) ((($C' $B) (($B ($C' _622)) ($B _359))) (($B (_622 ") ")) (($C _622) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _336)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _679) (($B _676) (($B (_679 _726)) (($B (_622 "main: findIdent: ")) _532))))) (($C' _560) _529)))) (($B ($B _564)) (($B (($C' _624) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _529))) $K)))))) (($C _640) (_657 0)))))) (($B (_679 _335)) (($B (_679 _527)) (($B (_622 (($O 95) $K))) _570)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _639) (_626 (_581 "-v")))) ((_656 _581) "-r"))) (($B (_620 (($O 46) $K))) (($B _678) (_625 ((_644 _702) "-i")))))) (($B (_679 _651)) ((($C' _622) (($B _678) (_625 ((_644 _702) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _713) _639) 1)) (_726 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _651)) (_626 ((_680 _722) ((_680 (_581 (($O 45) $K))) (_637 1))))))) (_647 ((_680 _722) (_581 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _588)) _16) (($B ($B ($B (_588 _616)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _589) (($B (_679 _607)) (($B (_679 (_638 1000000))) _187)))))) (($B ($B ($B ($B (_588 _616))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _589))) ((($C' $B) ($B' (($B _679) (($B _606) ((($C' _717) _8) 0))))) (($B ($B (_679 _609))) (($B ($B (_622 "combinator conversion "))) ((($C' ($C' _622)) (($B ($B (_583 6))) (($B ($B _570)) _711))) "ms"))))))) (($B ($B _590)) (($B $P) (($C _534) (_527 "main")))))))) (_624 ($T ((($C' ($C' $O)) ((($C' $B) $P) _362)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_588 _541)))) (($B ($B ($B (($C' _542) ((($C' _706) (($B _639) (_647 ((_680 _722) (_581 "--"))))) 1))))) (($B ($B ($B (_679 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _518))) (($C' ($C' _624)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _679) (($B _676) (($B (_679 _726)) (($B (_622 "not found ")) _532))))) ($C _519))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _361))) (($B (_679 (_676 (_726 "primlookup")))) (($C (_662 _581)) _5)))) $K))) (_726 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P 
\ No newline at end of file
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -26,7 +26,8 @@
   subst,
   allVarsExpr, allVarsBind,
   getSLocExpr, setSLocExpr,
-  errorMessage
+  errorMessage,
+  Assoc(..), eqAssoc, Fixity
   ) where
 import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
 import Data.List
@@ -57,6 +58,7 @@
   | Sign Ident ETypeScheme
   | Import ImportSpec
   | ForImp String Ident EType
+  | Infix Fixity [Ident]
   --Xderiving (Show, Eq)
 
 data ImportSpec = ImportSpec Bool Ident (Maybe Ident)
@@ -197,6 +199,19 @@
 
 ---------------------------------
 
+data Assoc = AssocLeft | AssocRight | AssocNone
+  --Xderiving (Eq, Show)
+
+eqAssoc :: Assoc -> Assoc -> Bool
+eqAssoc AssocLeft AssocLeft = True
+eqAssoc AssocRight AssocRight = True
+eqAssoc AssocNone AssocNone = True
+eqAssoc _ _ = False
+
+type Fixity = (Assoc, Int)
+
+---------------------------------
+
 -- Enough to handle subsitution in types
 subst :: [(Ident, Expr)] -> Expr -> Expr
 subst s =
@@ -318,6 +333,8 @@
     Sign i t -> showIdent i ++ " :: " ++ showETypeScheme t
     Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mm
     ForImp ie i t -> "foreign import ccall " ++ showString ie ++ " " ++ showIdent i ++ " :: " ++ showEType t
+    Infix (a, p) is -> "infix" ++ f a ++ " " ++ showInt p ++ " " ++ intercalate ", " (map showIdent is)
+      where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
 
 showConstr :: Constr -> String
 showConstr (i, ts) = unwords (showIdent i : map showEType ts)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -892,16 +892,6 @@
       unify loc t (tArrow a r)
       T.return (a, r)
 
-data Assoc = AssocLeft | AssocRight | AssocNone
-  --Xderiving (Show)
-
-eqAssoc :: Assoc -> Assoc -> Bool
-eqAssoc AssocLeft AssocLeft = True
-eqAssoc AssocRight AssocRight = True
-eqAssoc AssocNone AssocNone = True
-eqAssoc _ _ = False
-
-type Fixity = (Assoc, Int)
 type FixTable = [(String, Fixity)]
 
 -- A hack until we do it right
-- 
⑨