ref: 83017c4a014b40cd64fef7e4b5cfd8df78534eb2
parent: 2e82c90c7e8a63d18009c11267d33d9639de6f6a
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Sep 13 18:10:58 EDT 2023
Do fixity reolution during type checking. First step towords imported fixities.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.3
-772
-(($A :0 ((_578 _531) (($B ((($S' ($C ((($C' ($S' _578)) (($B ($C _2)) _518)) (($B ($B (_578 _606))) ((($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' _579)) ((($C' $B) (($B _669) (($B _596) ((($C' _707) _8) 0)))) (($B (_669 _599)) (($B (_612 "top level defns: ")) _560)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _579)) ((($C' $B) (($B _669) (($B _596) ((($C' _707) _8) 1)))) (_595 ($T (($B ($B (_669 _599))) ((($C' $B) (($B _612) _522)) (($B (_612 " = ")) _359))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _579))) ((($C' $B) ($B' (($B _669) (($B _601) _11)))) (($B ($B (_612 _1))) (($B (($C' _612) _560)) (_612 (($O 10) $K))))))) (($B ($B (_578 _606))) ((($C' $B) ($B' (($B _669) (($B _596) ((($C' _707) _8) 0))))) (($B ($B (_669 _599))) (($B ($B (_612 "final pass "))) ((($C' ($C' _612)) (($B ($B (_573 6))) (($B ($B _560)) _701))) "ms")))))))) _3)))) _557))) (($B (($C' $C) (($B ($C _617)) _359))) (($C _630) (_647 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_612 "(($A :"))))) (($B ($B (($C' $B) (($B _612) _560)))) (($B ($B ($B (_612 (($O 32) $K))))) ((($C' $B) (($B ($C' _612)) ($B _359))) (($B (_612 ") ")) (($C _612) (($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' _669) (($B _666) (($B (_669 _716)) (($B (_612 "main: findIdent: ")) _522))))) (($C' _550) _520)))) (($B ($B _554)) (($B (($C' _614) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _520))) $K)))))) (($C _630) (_647 0)))))) (($B (_669 _335)) (($B (_669 _518)) (($B (_612 (($O 95) $K))) _560)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _629) (_616 (_571 "-v")))) ((_646 _571) "-r"))) (($B (_610 (($O 46) $K))) (($B _668) (_615 ((_634 _692) "-i")))))) (($B (_669 _641)) ((($C' _612) (($B _668) (_615 ((_634 _692) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _703) _629) 1)) (_716 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _641)) (_616 ((_670 _712) ((_670 (_571 (($O 45) $K))) (_627 1))))))) (_637 ((_670 _712) (_571 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _578)) _16) (($B ($B ($B (_578 _606)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _579) (($B (_669 _597)) (($B (_669 (_628 1000000))) _190)))))) (($B ($B ($B ($B (_578 _606))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _579))) ((($C' $B) ($B' (($B _669) (($B _596) ((($C' _707) _8) 0))))) (($B ($B (_669 _599))) (($B ($B (_612 "combinator conversion "))) ((($C' ($C' _612)) (($B ($B (_573 6))) (($B ($B _560)) _701))) "ms"))))))) (($B ($B _580)) (($B $P) (($C _524) (_518 "main")))))))) (_614 ($T ((($C' ($C' $O)) ((($C' $B) $P) _362)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_578 _531)))) (($B ($B ($B (($C' _532) ((($C' _696) (($B _629) (_637 ((_670 _712) (_571 "--"))))) 1))))) (($B ($B ($B (_669 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _509))) (($C' ($C' _614)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _669) (($B _666) (($B (_669 _716)) (($B (_612 "not found ")) _522))))) ($C _510))))) (($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 (_669 (_666 (_716 "primlookup")))) (($C (_652 _571)) _5)))) $K))) (_716 "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
+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
--- a/lib/Control/Monad/State/Strict.hs
+++ b/lib/Control/Monad/State/Strict.hs
@@ -68,3 +68,7 @@
fail :: forall s a . String -> State s a
fail = error
+
+when :: forall s . Bool -> State s () -> State s ()
+when True s = s
+when False _ = Control.Monad.State.Strict.return ()
\ No newline at end of file
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -25,7 +25,7 @@
tupleConstr, untupleConstr,
subst,
allVarsExpr, allVarsBind,
- getSLocExpr,
+ getSLocExpr, setSLocExpr,
errorMessage
) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
@@ -65,6 +65,7 @@
data Expr
= EVar Ident
| EApp Expr Expr
+ | EOper Expr [(Ident, Expr)]
| ELam [EPat] Expr
| ELit SLoc Lit
| ECase Expr [ECaseArm]
@@ -75,7 +76,6 @@
| ESectL Expr Ident
| ESectR Ident Expr
| EIf Expr Expr Expr
--- | EOpers Expr [(Ident, Expr)]
| ESign Expr EType
| EAt Ident Expr -- only in patterns
-- Only while type checking
@@ -175,17 +175,6 @@
-- * before desugaring: EApp, EVar, ETuple, EList
type EType = Expr
-{--validType :: Expr -> Bool
-validType ae =
- case ae of
- EVar _ -> True
- EApp f a -> validType f && validType a
- EList es -> length es <= 1 && all validType (take 1 es)
- ETuple es -> all validType es
- _ -> False
--}
-
data ETypeScheme = ETypeScheme [IdKind] EType
--Xderiving (Show, Eq)
@@ -246,6 +235,7 @@
case aexpr of
EVar i -> [i]
EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2
+ EOper e1 ies -> allVarsExpr e1 ++ concatMap (\ (i,e2) -> i : allVarsExpr e2) ies
ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e
ELit _ _ -> []
ECase e as -> allVarsExpr e ++ concatMap allVarsCaseArm as
@@ -284,9 +274,19 @@
getSLocExpr :: Expr -> SLoc
getSLocExpr e = head $ map getSLocIdent (allVarsExpr e) ++ [noSLoc]
+setSLocExpr :: SLoc -> Expr -> Expr
+setSLocExpr l (EVar i) = EVar (setSLocIdent l i)
+setSLocExpr l (ECon c) = ECon (setSLocCon l c)
+setSLocExpr _ _ = undefined -- what other cases do we need?
+
+setSLocCon :: SLoc -> Con -> Con
+setSLocCon l (ConData ti i) = ConData ti (setSLocIdent l i)
+setSLocCon l (ConNew i) = ConNew (setSLocIdent l i)
+setSLocCon _ c = c
+
errorMessage :: --XHasCallStack =>
forall a . SLoc -> String -> a
-errorMessage loc msg = error $ showSLoc loc ++ msg
+errorMessage loc msg = error $ showSLoc loc ++ ": " ++ msg
----------------
@@ -352,6 +352,7 @@
case ae of
EVar v -> showIdent v
EApp _ _ -> showApp [] ae
+ EOper e ies -> showExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
ELit _ i -> showLit i
ECase e as -> "case " ++ showExpr e ++ " of {\n" ++ unlines (map showCaseArm as) ++ "}"--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -1,7 +1,7 @@
module MicroHs.Ident(
Line, Col, Loc,
Ident(..),
- mkIdent, mkIdentLoc, unIdent, eqIdent, qualIdent, showIdent, getSLocIdent,
+ mkIdent, mkIdentLoc, unIdent, eqIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
isLower_, isIdentChar, isOperChar, isConIdent,
unQualString,
SLoc(..), noSLoc, showSLoc
@@ -34,6 +34,9 @@
getSLocIdent :: Ident -> SLoc
getSLocIdent (Ident loc _) = loc
+
+setSLocIdent :: SLoc -> Ident -> Ident
+setSLocIdent l (Ident _ s) = Ident l s
showIdent :: Ident -> String
showIdent (Ident _ i) = i
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -173,7 +173,7 @@
P.pure s
reservedOps :: [String]
-reservedOps = ["=", "|", "::", "<-", "@", ".."]
+reservedOps = ["=", "|", "::", "<-", "@", "..", "->"]
pUQIdentSym :: P Ident
pUQIdentSym = pUQIdent <|< pParens pUQSymOper
@@ -270,24 +270,11 @@
pType = pTypeOp
pTypeOp :: P EType
-pTypeOp =
- let
-{-- p10 = pTypeArg
- p9 = p10
- p8 = p9
- p7 = p8
- p6 = p7
- p5 = p6
- p4 = p5
- p3 = p4
- p2 = p3
- p1 = p2
- p0 = pRightAssoc (pOpers ["->"]) p1
--}
- p0 = pRightAssoc (pOpers ["->"]) pTypeArg
- in p0
+pTypeOp = pOperators pTypeOper pTypeArg
+pTypeOper :: P Ident
+pTypeOper = pOper <|> (mkIdent "->" <$ pSymbol "->")
+
pTypeArg :: P EType
pTypeArg = pTypeApp
@@ -329,23 +316,7 @@
pPat = pPatOp
pPatOp :: P EPat
-pPatOp =
- let
-{-- p10 = pPatArg
- p9 = p10
- p8 = p9
- p7 = p8
- p6 = p7
- p5 = pRightAssoc (pOpers [":"]) p6
- p4 = p5
- p3 = p4
- p2 = p3
- p1 = p2
- p0 = p1
--}
- p0 = pRightAssoc (pOpers [":"]) pPatArg
- in p0
+pPatOp = pOperators pOper pPatArg
pPatArg :: P EPat
pPatArg = pPatApp
@@ -479,24 +450,13 @@
<|< P.pure (LList [e1])
pExprOp :: P Expr
-pExprOp =
- let
- p10 = pExprArg
- p9 = pRightAssoc (pOpers ["."]) $
- pLeftAssoc (pOpers ["?", "!!", "<?>"]) p10
- p8 = p9
- p7 = pLeftAssoc (pOpers ["*", "quot", "rem"]) p8
- p6 = pLeftAssoc (pOpers ["+", "-"]) p7
- p5 = pRightAssoc (pOpers [":", "++"]) p6
- p4 = pNonAssoc (pOpers ["==", "/=", "<", "<=", ">", ">="]) $
- pLeftAssoc (pOpers ["<*>", "<*", "*>", "<$>", "<$"]) p5
- p3 = pRightAssoc (pOpers ["&&"]) $
- pLeftAssoc (pOpers ["<|>","<|<"]) p4
- p2 = pRightAssoc (pOpers ["||"]) p3
- p1 = pLeftAssoc (pOpers [">>=", ">>"]) p2
- p0 = pRightAssoc (pOpers ["$"]) p1
- in p0
+pExprOp = pOperators pOper pExprArg
+pOperators :: P Ident -> P Expr -> P Expr
+pOperators oper one = eOper <$> one <*> emany (pair <$> oper <*> one)
+ where eOper e [] = e
+ eOper e ies = EOper e ies
+
-------------
-- Bindings
@@ -507,49 +467,10 @@
-------------
-pRightAssoc :: P Ident -> P Expr -> P Expr
-pRightAssoc pOp p = P.do
- e1 <- p
- let
- rest =
- P.do
- op <- pOp
- e2 <- pRightAssoc pOp p
- pure $ appOp op e1 e2
- rest <|< pure e1
-
-pNonAssoc :: P Ident -> P Expr -> P Expr
-pNonAssoc pOp p = P.do
- e1 <- p
- let
- rest =
- P.do
- op <- pOp
- e2 <- p
- pure $ appOp op e1 e2
- rest <|< pure e1
-
-pLeftAssoc :: P Ident -> P Expr -> P Expr
-pLeftAssoc pOp p = P.do
- e1 <- p
- es <- emany (pair <$> pOp <*> p)
- pure $ foldl (\ x (op, y) -> appOp op x y) e1 es
-
-pOpers :: [String] -> P Ident
-pOpers ops = P.do
- op <- pOper
- guard (elemBy eqString (unIdent op) ops)
- pure op
-
--------------
-
eTuple :: [Expr] -> Expr
eTuple [] = undefined
eTuple [e] = e
eTuple es = ETuple es
-
-appOp :: Ident -> Expr -> Expr -> Expr
-appOp op e1 e2 = EApp (EApp (EVar op) e1) e2
isAlpha_ :: Char -> Bool
isAlpha_ c = isLower_ c || isUpper c
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -5,6 +5,7 @@
(>>=), (>>), return, fail,
get, put, gets,
mapM, mapM_,
+ when,
tcError
) where
--Ximport Control.Monad hiding(ap)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -451,16 +451,8 @@
case M.lookup i env of
Nothing -> tcError (getSLocIdent i) $ ": undefined " ++ msg ++ ": " ++ showIdent i
-- ++ "\n" ++ show env ;
- Just aes ->
- case aes of
- [] -> impossible
- eee : es ->
- case eee of -- XXX why parse error if combined with pre
- Entry e s ->
- if null es then
- T.return (e, s)
- else
- tcError (getSLocIdent i) $ ": ambiguous " ++ showIdent i
+ Just [Entry e s] -> T.return (setSLocExpr (getSLocIdent i) e, s)
+ Just _ -> tcError (getSLocIdent i) $ ": ambiguous " ++ showIdent i
tInst :: ETypeScheme -> T EType
tInst as =
@@ -726,6 +718,7 @@
tr <- unMType mt
(ef, _) <- tcExpr (Just (tArrow ta tr)) f
T.return (EApp ef ea, tr)
+ EOper e ies -> tcOper mt e ies
ELam is e -> tcExprLam mt is e
ELit loc l -> tcLit mt loc l
ECase a arms -> T.do
@@ -841,6 +834,53 @@
T.return (ELit loc l, t)
LForImp _ -> impossible
+
+tcOper :: Maybe EType -> Expr -> [(Ident, Expr)] -> T (Typed Expr)
+tcOper mt ae aies = T.do
+ let
+ appOp (f, ft) (e1, t1) (e2, t2) = T.do
+ let l = getSLocExpr f
+ (fta1, ftr1) <- unArrow l (Just ft)
+ (fta2, ftr2) <- unArrow l (Just ftr1)
+ unify l fta1 t1
+ unify l fta2 t2
+-- traceM (showExpr (EApp (EApp f e1) e2))
+ T.return (EApp (EApp f e1) e2, ftr2)
+
+ -- XXX clc should calc. It's an ugly hack until we get mutual recursion
+ doOp clc (e1:e2:es) o os ies = T.do
+ e <- appOp o e2 e1
+ clc (e:es) os ies
+ doOp _ _ _ _ _ = impossible
+
+ --Xcalc :: [Typed Expr] -> [(Typed Expr, Fixity)] -> [((Typed Expr, Fixity), Expr)] -> T (Typed Expr)
+ calc [et@(_, t)] [] [] = T.do munify (getSLocExpr ae) mt t; T.return et
+ calc es ((o, _):os) [] = doOp calc es o os []
+ calc es oos@((oy, (ay, py)):os) iies@((oo@(ox, (ax, px)), e) : ies) = T.do
+-- traceM (show ((unIdent (getIdent (fst o)), ay, py), (unIdent i, ax, px)))
+ if px == py && (not (eqAssoc ax ay) || eqAssoc ax AssocNone) then
+ tcError (getSLocExpr (fst ox)) "Ambiguous operator expression"
+ else if px < py || eqAssoc ax AssocLeft && px == py then
+ doOp calc es oy os iies
+ else T.do
+ et <- tcExpr Nothing e
+ calc (et:es) (oo : oos) ies
+ calc es [] ((o, e) : ies) = T.do
+ ee <- tcExpr Nothing e
+ calc (ee:es) [o] ies
+ calc _ _ _ = impossible
+
+ opfix fixs (i, e) = T.do
+ o@(ei, _) <- tcExpr Nothing (EVar i)
+ let fx = getFixity fixs (getIdent ei)
+ T.return ((o, fx), e)
+
+ aet <- tcExpr Nothing ae
+ ites <- T.mapM (opfix fixities) aies
+ et@(_, t) <- calc [aet] [] ites
+ munify (getSLocExpr ae) mt t
+ T.return et
+
unArrow :: SLoc -> Maybe EType -> T (EType, EType)
unArrow _ Nothing = T.do { a <- newUVar; r <- newUVar; T.return (a, r) }unArrow loc (Just t) =
@@ -852,6 +892,46 @@
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
+getFixity :: FixTable -> Ident -> Fixity
+getFixity fixs i = fromMaybe (AssocLeft, 9) $ lookupBy eqString (unQualString (unIdent i)) fixs
+
+fixities :: FixTable
+fixities = concat
+ [infixr_ 9 ["."]
+ ,infixl_ 9 ["?", "!!", "<?>"]
+ ,infixr_ 8 ["^","^^","**"]
+ ,infixl_ 7 ["*","quot","`rem`"]
+ ,infixl_ 6 ["+","-"]
+ ,infixr_ 5 [":","++"]
+ ,infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"]
+ ,infixl_ 4 ["<$>","<$","<*>","<*","*>"]
+ ,infixr_ 3 ["&&"]
+ ,infixl_ 3 ["<|>","<|<"]
+ ,infixr_ 2 ["||"]
+ ,infixl_ 1 [">>",">>="]
+ ,infixr_ 1 ["=<<"]
+ ,infixr_ 0 ["$","seq"]
+ ,infixr_ 0 ["->"]
+ ]
+ where
+ fixity a p = map (\ s -> (s, (a, p)))
+ infixr_ = fixity AssocRight
+ infixl_ = fixity AssocLeft
+ infix_ = fixity AssocNone
+
tcPats :: forall a . EType -> [EPat] -> (EType -> [Typed EPat] -> T a) -> T a
tcPats t [] ta = ta t []
tcPats t (p:ps) ta = T.do
@@ -953,6 +1033,7 @@
case at of
EVar _ -> at
EApp f a -> EApp (dsType f) (dsType a)
+ EOper t ies -> EOper (dsType t) [(i, dsType e) | (i, e) <- ies]
EListish (LList [t]) -> tApps listConstr [dsType t]
ETuple ts -> tApps (tupleConstr (length ts)) (map dsType ts)
ESign t k -> ESign (dsType t) k
--
⑨