git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Show relevant term in type error
9ee79c6Phil Freeman
PureScript.cabal+17−18
compare with golang
unifiedsplit
@@ -11,34 +11,33 @@ synopsis: PureScript Programming Language Compiler
11description: A small compile-to-JS language with extensible records and type-safe blocks
11description: A small compile-to-JS language with extensible records and type-safe blocks
12author: Phil Freeman <paf31@cantab.net>
12author: Phil Freeman <paf31@cantab.net>
13data-dir: ""
13data-dir: ""
14−
14+
15library
15library
16 build-depends: base -any, syb -any, cmdtheline -any,
16 build-depends: base -any, syb -any, cmdtheline -any,
17 containers -any, mtl -any, transformers -any, parsec -any,
17 containers -any, mtl -any, transformers -any, parsec -any,
18 utf8-string -any
18 utf8-string -any
19− exposed-modules: PureScript.CodeGen.Pretty.Types PureScript
19+ exposed-modules: PureScript.CodeGen.Pretty.Values
20− PureScript.Declarations PureScript.Names
20+ PureScript.CodeGen.Pretty.Types PureScript PureScript.Declarations
21− PureScript.TypeChecker.Synonyms PureScript.CodeGen.Externs
21+ PureScript.Names PureScript.TypeChecker.Synonyms
22+ PureScript.CodeGen.Externs PureScript.CodeGen.JS
22− PureScript.CodeGen.JS PureScript.CodeGen.Common.Gen
23+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
23− PureScript.CodeGen.Common Main PureScript.CodeGen PureScript.Kinds
24+ PureScript.CodeGen PureScript.Kinds PureScript.Parser
24− PureScript.Parser PureScript.TypeChecker PureScript.Types
25+ PureScript.TypeChecker PureScript.Types PureScript.Values
25− PureScript.Values PureScript.Parser.Common
26− PureScript.Parser.Declarations PureScript.Parser.Types
26+ PureScript.Parser.Common PureScript.Parser.Declarations
27+ PureScript.Parser.Types PureScript.Parser.Values
27− PureScript.Parser.Values PureScript.TypeChecker.Kinds
28+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
28− PureScript.TypeChecker.Monad PureScript.TypeChecker.Types
29− PureScript.Parser.State
29+ PureScript.TypeChecker.Types PureScript.Parser.State
30+ PureScript.Parser.Kinds PureScript.CodeGen.Pretty.Kinds
30 exposed: True
31 exposed: True
31 buildable: True
32 buildable: True
32 hs-source-dirs: src
33 hs-source-dirs: src
33− other-modules: PureScript.Parser.Kinds
34+ other-modules:
34− PureScript.CodeGen.Pretty.Kinds
35+
35−
36executable psc
36executable psc
37 build-depends: base -any, cmdtheline -any, containers -any,
37 build-depends: base -any, cmdtheline -any, containers -any,
38 mtl -any, transformers -any, parsec -any, utf8-string -any
38 mtl -any, transformers -any, parsec -any, utf8-string -any
39 main-is: Main.hs
39 main-is: Main.hs
40 buildable: True
40 buildable: True
41 hs-source-dirs: src
41 hs-source-dirs: src
42− other-modules: PureScript.Parser.Kinds
42+ other-modules:
43− PureScript.CodeGen.Pretty.Kinds PureScript.CodeGen.Pretty.Types
43+
44−
examples/failing/KindError.ps+1−1
@@ -1 +1 @@
1−data KindError f g a = One f a | Two f
1+data KindError f a = One f | Two f a
examples/failing/TypeError.ps+3−1
@@ -1 +1,3 @@
1−test = \f -> \x, y, z -> f x y + f x y z
1+test = do
2+ var x = 0
3+ return x ++ "A"
src/PureScript/CodeGen/JS.hs+3−30
@@ -31,7 +31,7 @@ import PureScript.CodeGen.Common
31import PureScript.CodeGen.Common.Gen
31import PureScript.CodeGen.Common.Gen
32
32
33declToJs :: Declaration -> Maybe String
33declToJs :: Declaration -> Maybe String
34−declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"
34+declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"
35declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
35declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
36declToJs (DataDeclaration _ _ ctors) =
36declToJs (DataDeclaration _ _ ctors) =
37 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
37 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
@@ -148,33 +148,6 @@ valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
148 , [ binary Or "||" ]
148 , [ binary Or "||" ]
149 ]
149 ]
150
150
151−unaryOperatorString :: UnaryOperator -> String
152−unaryOperatorString Negate = "-"
153−unaryOperatorString Not = "!"
154−unaryOperatorString BitwiseNot = "~"
155−
156−binaryOperatorString :: BinaryOperator -> String
157−binaryOperatorString Add = "+"
158−binaryOperatorString Subtract = "-"
159−binaryOperatorString Multiply = "*"
160−binaryOperatorString Divide = "/"
161−binaryOperatorString Modulus = "%"
162−binaryOperatorString LessThan = "<"
163−binaryOperatorString LessThanOrEqualTo = "<="
164−binaryOperatorString GreaterThan = ">"
165−binaryOperatorString GreaterThanOrEqualTo = ">="
166−binaryOperatorString BitwiseAnd = "&"
167−binaryOperatorString BitwiseOr = "|"
168−binaryOperatorString BitwiseXor = "^"
169−binaryOperatorString ShiftLeft = "<<"
170−binaryOperatorString ShiftRight = ">>"
171−binaryOperatorString ZeroFillShiftRight = ">>>"
172−binaryOperatorString EqualTo = "==="
173−binaryOperatorString NotEqualTo = "!=="
174−binaryOperatorString And = "&&"
175−binaryOperatorString Or = "||"
176−binaryOperatorString Concat = "+"
177−
178binderToJs :: String -> String -> Binder -> Gen String
151binderToJs :: String -> String -> Binder -> Gen String
179binderToJs varName done NullBinder = return done
152binderToJs varName done NullBinder = return done
180binderToJs varName done (StringBinder str) =
153binderToJs varName done (StringBinder str) =
@@ -219,8 +192,8 @@ binderToJs varName done (ArrayBinder bs rest) = do
219binderToJs varName done (NamedBinder ident binder) = do
192binderToJs varName done (NamedBinder ident binder) = do
220 js <- binderToJs varName done binder
193 js <- binderToJs varName done binder
221 return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js
194 return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js
222−binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
195+binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
223− where
196+ where
224 done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"
197 done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"
225
198
226objectPropertyToJs :: (String, Value) -> String
199objectPropertyToJs :: (String, Value) -> String
src/PureScript/CodeGen/Pretty/Values.hsnew file+184
@@ -0,0 +1,184 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Pretty.Values
4+-- Copyright : Kinds.hs(c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module PureScript.CodeGen.Pretty.Values (
16+ prettyPrintValue,
17+ prettyPrintBinder,
18+ prettyPrintAssignmentTarget
19+) where
20+
21+import Data.Char
22+import Data.Maybe (fromMaybe)
23+import Data.List (intercalate)
24+import qualified Control.Arrow as A
25+import Control.Arrow ((<+>))
26+import Control.Applicative
27+
28+import PureScript.Types
29+import PureScript.Values
30+import PureScript.Names
31+import PureScript.CodeGen.Common
32+
33+literals :: Pattern Value String
34+literals = Pattern $ A.Kleisli match
35+ where
36+ match (NumericLiteral n) = Just $ either show show n
37+ match (StringLiteral s) = Just $ show s
38+ match (BooleanLiteral True) = Just "true"
39+ match (BooleanLiteral False) = Just "false"
40+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
41+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
42+ match (Constructor name) = Just name
43+ match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
44+ match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
45+ match (Var ident) = Just $ show ident
46+ match _ = Nothing
47+
48+prettyPrintCaseAlternative :: Binder -> Value -> String
49+prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
50+
51+ifThenElse :: Pattern Value ((Value, Value), Value)
52+ifThenElse = Pattern $ A.Kleisli match
53+ where
54+ match (IfThenElse cond th el) = Just ((th, el), cond)
55+ match _ = Nothing
56+
57+accessor :: Pattern Value (String, Value)
58+accessor = Pattern $ A.Kleisli match
59+ where
60+ match (Accessor prop val) = Just (prop, val)
61+ match _ = Nothing
62+
63+indexer :: Pattern Value (String, Value)
64+indexer = Pattern $ A.Kleisli match
65+ where
66+ match (Indexer index val) = Just (prettyPrintValue index, val)
67+ match _ = Nothing
68+
69+app :: Pattern Value (String, Value)
70+app = Pattern $ A.Kleisli match
71+ where
72+ match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
73+ match _ = Nothing
74+
75+lam :: Pattern Value ([String], Value)
76+lam = Pattern $ A.Kleisli match
77+ where
78+ match (Abs args val) = Just (map show args, val)
79+ match _ = Nothing
80+
81+unary :: UnaryOperator -> String -> Operator Value String
82+unary op str = Wrap pattern (++)
83+ where
84+ pattern :: Pattern Value (String, Value)
85+ pattern = Pattern $ A.Kleisli match
86+ where
87+ match (Unary op' val) | op' == op = Just (str, val)
88+ match _ = Nothing
89+
90+binary :: BinaryOperator -> String -> Operator Value String
91+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
92+ where
93+ pattern :: Pattern Value (Value, Value)
94+ pattern = Pattern $ A.Kleisli match
95+ where
96+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)
97+ match _ = Nothing
98+
99+prettyPrintValue :: Value -> String
100+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
101+ where
102+ matchValue :: Pattern Value String
103+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
104+ operators :: OperatorTable Value String
105+ operators =
106+ OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
107+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
108+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
109+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]
110+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
111+ , [ binary LessThan "<" ]
112+ , [ binary LessThanOrEqualTo "<=" ]
113+ , [ binary GreaterThan ">" ]
114+ , [ binary GreaterThanOrEqualTo ">=" ]
115+ , [ unary Not "!" ]
116+ , [ unary BitwiseNot "~" ]
117+ , [ unary Negate "-" ]
118+ , [ binary Multiply "*" ]
119+ , [ binary Divide "/" ]
120+ , [ binary Modulus "%" ]
121+ , [ binary Concat "++" ]
122+ , [ binary Add "+" ]
123+ , [ binary Subtract "-" ]
124+ , [ binary ShiftLeft "<<" ]
125+ , [ binary ShiftRight ">>" ]
126+ , [ binary ZeroFillShiftRight ">>>" ]
127+ , [ binary EqualTo "==" ]
128+ , [ binary NotEqualTo "!=" ]
129+ , [ binary BitwiseAnd "&" ]
130+ , [ binary BitwiseXor "^" ]
131+ , [ binary BitwiseOr "|" ]
132+ , [ binary And "&&" ]
133+ , [ binary Or "||" ]
134+ ]
135+
136+prettyPrintBinder :: Binder -> String
137+prettyPrintBinder NullBinder = "_"
138+prettyPrintBinder (StringBinder str) = show str
139+prettyPrintBinder (NumberBinder num) = either show show num
140+prettyPrintBinder (BooleanBinder True) = "true"
141+prettyPrintBinder (BooleanBinder False) = "false"
142+prettyPrintBinder (VarBinder ident) = show ident
143+prettyPrintBinder (NullaryBinder ctor) = ctor
144+prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b
145+prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
146+prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
147+prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
148+prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
149+
150+prettyPrintObjectPropertyBinder :: String -> Binder -> String
151+prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
152+
153+prettyPrintObjectProperty :: String -> Value -> String
154+prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
155+
156+prettyPrintStatement :: Statement -> String
157+prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value
158+prettyPrintStatement (Assignment target value) = prettyPrintAssignmentTarget target ++ " = " ++ prettyPrintValue value
159+prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"
160+prettyPrintStatement (For ident start end sts) = "for " ++ show ident
161+ ++ " <- " ++ prettyPrintValue start
162+ ++ " until " ++ prettyPrintValue end ++ ": {"
163+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
164+prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident
165+ ++ " in " ++ prettyPrintValue arr ++ ": {"
166+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
167+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst
168+prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
169+
170+prettyPrintIfStatement :: IfStatement -> String
171+prettyPrintIfStatement (IfStatement cond thens elst) =
172+ "if "
173+ ++ prettyPrintValue cond ++ ": {"
174+ ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"
175+ ++ maybe "" prettyPrintElseStatement elst
176+
177+prettyPrintElseStatement :: ElseStatement -> String
178+prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
179+prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst
180+
181+prettyPrintAssignmentTarget :: AssignmentTarget -> String
182+prettyPrintAssignmentTarget (AssignVariable ident) = identToJs ident
183+prettyPrintAssignmentTarget (AssignArrayIndex index tgt) = prettyPrintAssignmentTarget tgt ++ "[" ++ prettyPrintValue index ++ "]"
184+prettyPrintAssignmentTarget (AssignObjectProperty prop tgt) = prettyPrintAssignmentTarget tgt ++ "." ++ prop
src/PureScript/TypeChecker/Kinds.hs+59−44
@@ -12,6 +12,8 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
15module PureScript.TypeChecker.Kinds (
17module PureScript.TypeChecker.Kinds (
16 KindConstraint(..),
18 KindConstraint(..),
17 KindSolution(..),
19 KindSolution(..),
@@ -22,12 +24,14 @@ module PureScript.TypeChecker.Kinds (
22import Data.List
24import Data.List
23import Data.Maybe (fromMaybe)
25import Data.Maybe (fromMaybe)
24import Data.Function
26import Data.Function
27+import Data.Data
25
28
26import PureScript.Types
29import PureScript.Types
27import PureScript.Kinds
30import PureScript.Kinds
28import PureScript.Declarations
31import PureScript.Declarations
29import PureScript.TypeChecker.Monad
32import PureScript.TypeChecker.Monad
30import PureScript.CodeGen.Pretty.Kinds
33import PureScript.CodeGen.Pretty.Kinds
34+import PureScript.CodeGen.Pretty.Types
31
35
32import Control.Monad.State
36import Control.Monad.State
33import Control.Monad.Error
37import Control.Monad.Error
@@ -38,10 +42,17 @@ import qualified Control.Category as C
38
42
39import qualified Data.Map as M
43import qualified Data.Map as M
40
44
41−data KindConstraint = KindConstraint Int Kind
45+data KindConstraintOrigin
46+ = DataDeclOrigin
47+ | TypeOrigin Type
48+ | RowOrigin Row deriving (Show, Data, Typeable)
49+
50+prettyPrintKindConstraintOrigin :: KindConstraintOrigin -> String
51+prettyPrintKindConstraintOrigin (DataDeclOrigin) = "data declaration"
52+prettyPrintKindConstraintOrigin (TypeOrigin ty) = prettyPrintType ty
53+prettyPrintKindConstraintOrigin (RowOrigin row) = prettyPrintRow row
42
54
43−instance Show KindConstraint where
55+data KindConstraint = KindConstraint Int Kind KindConstraintOrigin deriving (Show, Data, Typeable)
44− show (KindConstraint n k) = show n ++ " = " ++ show k
45
56
46newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }
57newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }
47
58
@@ -60,7 +71,9 @@ kindsOf name args ts = do
60 tyCon <- fresh
71 tyCon <- fresh
61 nargs <- replicateM (length args) fresh
72 nargs <- replicateM (length args) fresh
62 (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts
73 (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts
74+ let extraConstraints =
63− let extraConstraints = KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) : map (flip KindConstraint Star) ns
75+ KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) DataDeclOrigin
76+ : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts
64 solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution
77 solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution
65 return $ starIfUnknown $ runKindSolution solution tyCon
78 return $ starIfUnknown $ runKindSolution solution tyCon
66
79
@@ -74,71 +87,73 @@ kindConstraintsAll m [] = return ([], [], m)
74kindConstraintsAll m (t:ts) = do
87kindConstraintsAll m (t:ts) = do
75 (cs, n1, m') <- kindConstraints m t
88 (cs, n1, m') <- kindConstraints m t
76 (cs', ns, m'') <- kindConstraintsAll m' ts
89 (cs', ns, m'') <- kindConstraintsAll m' ts
77− return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, m'')
90+ return ((KindConstraint n1 Star (TypeOrigin t)) : cs ++ cs', n1:ns, m'')
78
91
79kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
92kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
80−kindConstraints m (Array t) = do
93+kindConstraints m a@(Array t) = do
81 me <- fresh
94 me <- fresh
82 (cs, n1, m') <- kindConstraints m t
95 (cs, n1, m') <- kindConstraints m t
83− return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, m')
96+ return ((KindConstraint n1 Star (TypeOrigin t)) : (KindConstraint me Star (TypeOrigin a)) : cs, me, m')
84−kindConstraints m (Object row) = do
97+kindConstraints m o@(Object row) = do
85 me <- fresh
98 me <- fresh
86− (cs, row, m') <- kindConstraintsForRow m row
99+ (cs, r, m') <- kindConstraintsForRow m row
87− return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, m')
100+ return ((KindConstraint me Star (TypeOrigin o)) : (KindConstraint r Row (RowOrigin row)) : cs, me, m')
88−kindConstraints m (Function args ret) = do
101+kindConstraints m f@(Function args ret) = do
89 me <- fresh
102 me <- fresh
90 (cs, ns, m') <- kindConstraintsAll m args
103 (cs, ns, m') <- kindConstraintsAll m args
91 (cs', retN, m'') <- kindConstraints m' ret
104 (cs', retN, m'') <- kindConstraints m' ret
92− return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs ++ cs', me, m'')
105+ return ((KindConstraint retN Star (TypeOrigin ret)) : (KindConstraint me Star (TypeOrigin f)) : (zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args) ++ cs ++ cs', me, m'')
93kindConstraints m (TypeVar v) = do
106kindConstraints m (TypeVar v) = do
94 case M.lookup v m of
107 case M.lookup v m of
95 Just u -> return ([], u, m)
108 Just u -> return ([], u, m)
96 Nothing -> throwError $ "Unbound type variable " ++ v
109 Nothing -> throwError $ "Unbound type variable " ++ v
97−kindConstraints m (TypeConstructor v) = do
110+kindConstraints m c@(TypeConstructor v) = do
98 env <- getEnv
111 env <- getEnv
99 me <- fresh
112 me <- fresh
100 case M.lookup v m of
113 case M.lookup v m of
101 Nothing -> case M.lookup v (types env) of
114 Nothing -> case M.lookup v (types env) of
102 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
115 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
103− Just (kind, _) -> return ([KindConstraint me kind], me, m)
116+ Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)
104 Just u -> do
117 Just u -> do
105− return ([KindConstraint me (KUnknown u)], me, m)
118+ return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)
106−kindConstraints m (TypeApp t1 t2) = do
119+kindConstraints m a@(TypeApp t1 t2) = do
107 me <- fresh
120 me <- fresh
108 (cs1, n1, m1) <- kindConstraints m t1
121 (cs1, n1, m1) <- kindConstraints m t1
109 (cs2, n2, m2) <- kindConstraints m1 t2
122 (cs2, n2, m2) <- kindConstraints m1 t2
110− return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me))) : cs1 ++ cs2, me, m2)
123+ return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a)) : cs1 ++ cs2, me, m2)
111−kindConstraints m _ = do
124+kindConstraints m t = do
112 me <- fresh
125 me <- fresh
113− return ([KindConstraint me Star], me, m)
126+ return ([KindConstraint me Star (TypeOrigin t)], me, m)
114
127
115kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
128kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
116−kindConstraintsForRow m (RowVar v) = do
129+kindConstraintsForRow m r@(RowVar v) = do
117 me <- case M.lookup v m of
130 me <- case M.lookup v m of
118 Just u -> return u
131 Just u -> return u
119 Nothing -> fresh
132 Nothing -> fresh
120− return ([KindConstraint me Row], me, M.insert v me m)
133+ return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)
121−kindConstraintsForRow m REmpty = do
134+kindConstraintsForRow m r@REmpty = do
122 me <- fresh
135 me <- fresh
123− return ([KindConstraint me Row], me, m)
136+ return ([KindConstraint me Row (RowOrigin r)], me, m)
124−kindConstraintsForRow m (RCons _ ty row) = do
137+kindConstraintsForRow m r@(RCons _ ty row) = do
125 me <- fresh
138 me <- fresh
126 (cs1, n1, m1) <- kindConstraints m ty
139 (cs1, n1, m1) <- kindConstraints m ty
127 (cs2, n2, m2) <- kindConstraintsForRow m1 row
140 (cs2, n2, m2) <- kindConstraintsForRow m1 row
128− return ((KindConstraint me Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, me, m2)
141+ return ((KindConstraint me Row (RowOrigin r)) : (KindConstraint n1 Star (TypeOrigin ty)) : (KindConstraint n2 Row (RowOrigin r)) : cs1 ++ cs2, me, m2)
129
142
130solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
143solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
131solveKindConstraints [] s = return s
144solveKindConstraints [] s = return s
132−solveKindConstraints all@(KindConstraint n k:cs) s = do
145+solveKindConstraints all@(KindConstraint n k t : cs) s = do
146+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintKindConstraintOrigin t ++ ": " ++ err) $ do
133− guardWith "Occurs check failed" $ not $ kindOccursCheck False n k
147+ guardWith "Occurs check failed" $ not $ kindOccursCheck False n k
134− let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s
148+ let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s
135− cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs
149+ cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs
150+ return (cs', s')
136 solveKindConstraints cs' s'
151 solveKindConstraints cs' s'
137
152
138substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]
153substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]
139−substituteKindConstraint n k (KindConstraint m l)
154+substituteKindConstraint n k (KindConstraint m l t)
140− | n == m = unifyKinds k l
155+ | n == m = unifyKinds t k l
141− | otherwise = return [KindConstraint m (replaceUnknownKind n k l)]
156+ | otherwise = return [KindConstraint m (replaceUnknownKind n k l) t]
142
157
143replaceUnknownKind :: Int -> Kind -> Kind -> Kind
158replaceUnknownKind :: Int -> Kind -> Kind -> Kind
144replaceUnknownKind n k = f
159replaceUnknownKind n k = f
@@ -147,21 +162,21 @@ replaceUnknownKind n k = f
147 f (FunKind k1 k2) = FunKind (f k2) (f k2)
162 f (FunKind k1 k2) = FunKind (f k2) (f k2)
148 f other = other
163 f other = other
149
164
150−unifyKinds :: Kind -> Kind -> Check [KindConstraint]
165+unifyKinds :: KindConstraintOrigin -> Kind -> Kind -> Check [KindConstraint]
151−unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []
166+unifyKinds _ (KUnknown u1) (KUnknown u2) | u1 == u2 = return []
152−unifyKinds (KUnknown u) k = do
167+unifyKinds t (KUnknown u) k = do
153 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
168 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
154− return [KindConstraint u k]
169+ return [KindConstraint u k t]
155−unifyKinds k (KUnknown u) = do
170+unifyKinds t k (KUnknown u) = do
156 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
171 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
157− return [KindConstraint u k]
172+ return [KindConstraint u k t]
158−unifyKinds Star Star = return []
173+unifyKinds _ Star Star = return []
159−unifyKinds Row Row = return []
174+unifyKinds _ Row Row = return []
160−unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do
175+unifyKinds t (FunKind k1 k2) (FunKind k3 k4) = do
161− cs1 <- unifyKinds k1 k3
176+ cs1 <- unifyKinds t k1 k3
162− cs2 <- unifyKinds k2 k4
177+ cs2 <- unifyKinds t k2 k4
163 return $ cs1 ++ cs2
178 return $ cs1 ++ cs2
164−unifyKinds k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
179+unifyKinds _ k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
165
180
166kindOccursCheck :: Bool -> Int -> Kind -> Bool
181kindOccursCheck :: Bool -> Int -> Kind -> Bool
167kindOccursCheck b u (KUnknown u') | u == u' = b
182kindOccursCheck b u (KUnknown u') | u == u' = b
src/PureScript/TypeChecker/Types.hs+183−169
@@ -34,6 +34,7 @@ import PureScript.TypeChecker.Kinds
34import PureScript.TypeChecker.Synonyms
34import PureScript.TypeChecker.Synonyms
35import PureScript.CodeGen.Pretty.Types
35import PureScript.CodeGen.Pretty.Types
36import PureScript.CodeGen.Pretty.Kinds
36import PureScript.CodeGen.Pretty.Kinds
37+import PureScript.CodeGen.Pretty.Values
37
38
38import Control.Monad.State
39import Control.Monad.State
39import Control.Monad.Error
40import Control.Monad.Error
@@ -44,9 +45,19 @@ import qualified Control.Category as C
44
45
45import qualified Data.Map as M
46import qualified Data.Map as M
46
47
48+data TypeConstraintOrigin
49+ = ValueOrigin Value
50+ | BinderOrigin Binder
51+ | AssignmentTargetOrigin AssignmentTarget deriving (Show, D.Data, D.Typeable)
52+
53+prettyPrintOrigin :: TypeConstraintOrigin -> String
54+prettyPrintOrigin (ValueOrigin val) = prettyPrintValue val
55+prettyPrintOrigin (BinderOrigin binder) = prettyPrintBinder binder
56+prettyPrintOrigin (AssignmentTargetOrigin assign) = prettyPrintAssignmentTarget assign
57+
47data TypeConstraint
58data TypeConstraint
48− = TypeConstraint Int Type
59+ = TypeConstraint Int Type TypeConstraintOrigin
49− | RowConstraint Int Row deriving (Show, D.Data, D.Typeable)
60+ | RowConstraint Int Row TypeConstraintOrigin deriving (Show, D.Data, D.Typeable)
50
61
51newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }
62newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }
52
63
@@ -59,7 +70,7 @@ typeOf name val = do
59 Abs _ _ -> do
70 Abs _ _ -> do
60 me <- fresh
71 me <- fresh
61 (cs, n) <- typeConstraints (M.singleton name me) val
72 (cs, n) <- typeConstraints (M.singleton name me) val
62− return (TypeConstraint me (TUnknown n) : cs, n)
73+ return (TypeConstraint me (TUnknown n) (ValueOrigin val): cs, n)
63 _ -> typeConstraints M.empty val
74 _ -> typeConstraints M.empty val
64 desugared <- replaceAllTypeSynonyms cs
75 desugared <- replaceAllTypeSynonyms cs
65 solution <- solveTypeConstraints desugared emptyTypeSolution
76 solution <- solveTypeConstraints desugared emptyTypeSolution
@@ -72,15 +83,15 @@ allUnknownsBecameQuantified cs solution ty = do
72 let
83 let
73 typesMentioned = findUnknownTypes ty
84 typesMentioned = findUnknownTypes ty
74 unknownTypes = nub $ flip concatMap cs $ \c -> case c of
85 unknownTypes = nub $ flip concatMap cs $ \c -> case c of
75− TypeConstraint u t -> u : findUnknownTypes t
86+ TypeConstraint u t _ -> u : findUnknownTypes t
76− RowConstraint _ r -> findUnknownTypes r
87+ RowConstraint _ r _ -> findUnknownTypes r
77 unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes
88 unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes
78 guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned
89 guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned
79 let
90 let
80 rowsMentioned = findUnknownRows ty
91 rowsMentioned = findUnknownRows ty
81 unknownRows = nub $ flip concatMap cs $ \c -> case c of
92 unknownRows = nub $ flip concatMap cs $ \c -> case c of
82− TypeConstraint _ t -> findUnknownRows t
93+ TypeConstraint _ t _ -> findUnknownRows t
83− RowConstraint u r -> u : findUnknownRows r
94+ RowConstraint u r _ -> u : findUnknownRows r
84 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
95 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
85 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
96 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
86
97
@@ -206,61 +217,61 @@ occursCheck u = everything (||) $ flip extQ g $ mkQ False f
206 g _ = False
217 g _ = False
207
218
208typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)
219typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)
209−typeConstraints _ (NumericLiteral _) = do
220+typeConstraints _ v@(NumericLiteral _) = do
210 me <- fresh
221 me <- fresh
211− return ([TypeConstraint me Number], me)
222+ return ([TypeConstraint me Number (ValueOrigin v)], me)
212−typeConstraints _ (StringLiteral _) = do
223+typeConstraints _ v@(StringLiteral _) = do
213 me <- fresh
224 me <- fresh
214− return ([TypeConstraint me String], me)
225+ return ([TypeConstraint me String (ValueOrigin v)], me)
215−typeConstraints _ (BooleanLiteral _) = do
226+typeConstraints _ v@(BooleanLiteral _) = do
216 me <- fresh
227 me <- fresh
217− return ([TypeConstraint me Boolean], me)
228+ return ([TypeConstraint me Boolean (ValueOrigin v)], me)
218−typeConstraints m (ArrayLiteral vals) = do
229+typeConstraints m v@(ArrayLiteral vals) = do
219 all <- mapM (typeConstraints m) vals
230 all <- mapM (typeConstraints m) vals
220 let (cs, ns) = (concat . map fst &&& map snd) all
231 let (cs, ns) = (concat . map fst &&& map snd) all
221 me <- fresh
232 me <- fresh
222− return (cs ++ map (TypeConstraint me . Array . TUnknown) ns, me)
233+ return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me)
223−typeConstraints m (Unary op val) = do
234+typeConstraints m u@(Unary op val) = do
224 (cs, n1) <- typeConstraints m val
235 (cs, n1) <- typeConstraints m val
225 me <- fresh
236 me <- fresh
226− return (cs ++ unaryOperatorConstraints op n1 me, me)
237+ return (cs ++ unaryOperatorConstraints u op n1 me, me)
227−typeConstraints m (Binary op left right) = do
238+typeConstraints m b@(Binary op left right) = do
228 (cs1, n1) <- typeConstraints m left
239 (cs1, n1) <- typeConstraints m left
229 (cs2, n2) <- typeConstraints m right
240 (cs2, n2) <- typeConstraints m right
230 me <- fresh
241 me <- fresh
231− return (cs1 ++ cs2 ++ binaryOperatorConstraints op n1 n2 me, me)
242+ return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)
232−typeConstraints m (ObjectLiteral ps) = do
243+typeConstraints m v@(ObjectLiteral ps) = do
233 all <- mapM (typeConstraints m . snd) ps
244 all <- mapM (typeConstraints m . snd) ps
234 let (cs, ns) = (concat . map fst &&& map snd) all
245 let (cs, ns) = (concat . map fst &&& map snd) all
235 me <- fresh
246 me <- fresh
236 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns
247 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns
237− return ((TypeConstraint me (Object (typesToRow tys))) : cs, me)
248+ return ((TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v)) : cs, me)
238 where
249 where
239 typesToRow [] = REmpty
250 typesToRow [] = REmpty
240 typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
251 typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
241−typeConstraints m (Indexer index val) = do
252+typeConstraints m v@(Indexer index val) = do
242 (cs1, n1) <- typeConstraints m index
253 (cs1, n1) <- typeConstraints m index
243 (cs2, n2) <- typeConstraints m val
254 (cs2, n2) <- typeConstraints m val
244 me <- fresh
255 me <- fresh
245− return ((TypeConstraint n1 Number) : (TypeConstraint n2 (Array (TUnknown me))) : cs1 ++ cs2, me)
256+ return ((TypeConstraint n1 Number (ValueOrigin index)) : (TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)
246−typeConstraints m (Accessor prop val) = do
257+typeConstraints m v@(Accessor prop val) = do
247 (cs, n1) <- typeConstraints m val
258 (cs, n1) <- typeConstraints m val
248 me <- fresh
259 me <- fresh
249 rest <- fresh
260 rest <- fresh
250− return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest)))) : cs, me)
261+ return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v)) : cs, me)
251−typeConstraints m (Abs args ret) = do
262+typeConstraints m v@(Abs args ret) = do
252 ns <- replicateM (length args) fresh
263 ns <- replicateM (length args) fresh
253 let m' = m `M.union` M.fromList (zipWith (,) args ns)
264 let m' = m `M.union` M.fromList (zipWith (,) args ns)
254 (cs, n') <- typeConstraints m' ret
265 (cs, n') <- typeConstraints m' ret
255 me <- fresh
266 me <- fresh
256− return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me)
267+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v)) : cs, me)
257−typeConstraints m (App f xs) = do
268+typeConstraints m v@(App f xs) = do
258 (cs1, n1) <- typeConstraints m f
269 (cs1, n1) <- typeConstraints m f
259 all <- mapM (typeConstraints m) xs
270 all <- mapM (typeConstraints m) xs
260 let (cs2, ns) = (concat . map fst &&& map snd) all
271 let (cs2, ns) = (concat . map fst &&& map snd) all
261 me <- fresh
272 me <- fresh
262− return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me))) : cs1 ++ cs2, me)
273+ return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)
263−typeConstraints m (Var var) =
274+typeConstraints m v@(Var var) =
264 case M.lookup var m of
275 case M.lookup var m of
265 Nothing -> do
276 Nothing -> do
266 env <- getEnv
277 env <- getEnv
@@ -269,134 +280,134 @@ typeConstraints m (Var var) =
269 Just (PolyType idents ty, _) -> do
280 Just (PolyType idents ty, _) -> do
270 me <- fresh
281 me <- fresh
271 replaced <- replaceVarsWithUnknowns idents ty
282 replaced <- replaceVarsWithUnknowns idents ty
272− return ([TypeConstraint me replaced], me)
283+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
273 Just u -> do
284 Just u -> do
274 me <- fresh
285 me <- fresh
275− return ([TypeConstraint u (TUnknown me)], me)
286+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)
276typeConstraints m (Block ss) = do
287typeConstraints m (Block ss) = do
277 ret <- fresh
288 ret <- fresh
278 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
289 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
279 guardWith "Block is missing a return statement" allCodePathsReturn
290 guardWith "Block is missing a return statement" allCodePathsReturn
280 return (cs, ret)
291 return (cs, ret)
281−typeConstraints m (Constructor c) = do
292+typeConstraints m v@(Constructor c) = do
282 env <- getEnv
293 env <- getEnv
283 case M.lookup c (dataConstructors env) of
294 case M.lookup c (dataConstructors env) of
284 Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
295 Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"
285 Just (PolyType idents ty) -> do
296 Just (PolyType idents ty) -> do
286 me <- fresh
297 me <- fresh
287 replaced <- replaceVarsWithUnknowns idents ty
298 replaced <- replaceVarsWithUnknowns idents ty
288− return ([TypeConstraint me replaced], me)
299+ return ([TypeConstraint me replaced (ValueOrigin v)], me)
289typeConstraints m (Case val binders) = do
300typeConstraints m (Case val binders) = do
290 (cs1, n1) <- typeConstraints m val
301 (cs1, n1) <- typeConstraints m val
291 ret <- fresh
302 ret <- fresh
292 cs2 <- typeConstraintsForBinders m n1 ret binders
303 cs2 <- typeConstraintsForBinders m n1 ret binders
293 return (cs1 ++ cs2, ret)
304 return (cs1 ++ cs2, ret)
294−typeConstraints m (IfThenElse cond th el) = do
305+typeConstraints m v@(IfThenElse cond th el) = do
295 (cs1, n1) <- typeConstraints m cond
306 (cs1, n1) <- typeConstraints m cond
296 (cs2, n2) <- typeConstraints m th
307 (cs2, n2) <- typeConstraints m th
297 (cs3, n3) <- typeConstraints m el
308 (cs3, n3) <- typeConstraints m el
298− return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)
309+ return (TypeConstraint n1 Boolean (ValueOrigin cond) : TypeConstraint n2 (TUnknown n3) (ValueOrigin v) : cs1 ++ cs2 ++ cs3, n2)
299−typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
310+typeConstraints m v@(TypedValue val poly@(PolyType idents ty)) = do
300 kind <- kindOf poly
311 kind <- kindOf poly
301 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
312 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
302 (cs, n1) <- typeConstraints m val
313 (cs, n1) <- typeConstraints m val
303− return (TypeConstraint n1 ty : cs, n1)
314+ return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1)
304−
315+
305−unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]
316+unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]
306−unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]
317+unaryOperatorConstraints v Negate val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]
307−unaryOperatorConstraints Not val result = [TypeConstraint val Boolean, TypeConstraint result Boolean]
318+unaryOperatorConstraints v Not val result = [TypeConstraint val Boolean (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]
308−unaryOperatorConstraints BitwiseNot val result = [TypeConstraint val Number, TypeConstraint result Number]
319+unaryOperatorConstraints v BitwiseNot val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]
309−
320+
310−binaryOperatorConstraints :: BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]
321+binaryOperatorConstraints :: Value -> BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]
311−binaryOperatorConstraints Add = symBinOpConstraints Number
322+binaryOperatorConstraints v Add = symBinOpConstraints v Number
312−binaryOperatorConstraints Subtract = symBinOpConstraints Number
323+binaryOperatorConstraints v Subtract = symBinOpConstraints v Number
313−binaryOperatorConstraints Multiply = symBinOpConstraints Number
324+binaryOperatorConstraints v Multiply = symBinOpConstraints v Number
314−binaryOperatorConstraints Divide = symBinOpConstraints Number
325+binaryOperatorConstraints v Divide = symBinOpConstraints v Number
315−binaryOperatorConstraints Modulus = symBinOpConstraints Number
326+binaryOperatorConstraints v Modulus = symBinOpConstraints v Number
316−binaryOperatorConstraints LessThan = asymBinOpConstraints Number Boolean
327+binaryOperatorConstraints v LessThan = asymBinOpConstraints v Number Boolean
317−binaryOperatorConstraints LessThanOrEqualTo = asymBinOpConstraints Number Boolean
328+binaryOperatorConstraints v LessThanOrEqualTo = asymBinOpConstraints v Number Boolean
318−binaryOperatorConstraints GreaterThan = asymBinOpConstraints Number Boolean
329+binaryOperatorConstraints v GreaterThan = asymBinOpConstraints v Number Boolean
319−binaryOperatorConstraints GreaterThanOrEqualTo = asymBinOpConstraints Number Boolean
330+binaryOperatorConstraints v GreaterThanOrEqualTo = asymBinOpConstraints v Number Boolean
320−binaryOperatorConstraints BitwiseAnd = symBinOpConstraints Number
331+binaryOperatorConstraints v BitwiseAnd = symBinOpConstraints v Number
321−binaryOperatorConstraints BitwiseOr = symBinOpConstraints Number
332+binaryOperatorConstraints v BitwiseOr = symBinOpConstraints v Number
322−binaryOperatorConstraints BitwiseXor = symBinOpConstraints Number
333+binaryOperatorConstraints v BitwiseXor = symBinOpConstraints v Number
323−binaryOperatorConstraints ShiftLeft = symBinOpConstraints Number
334+binaryOperatorConstraints v ShiftLeft = symBinOpConstraints v Number
324−binaryOperatorConstraints ShiftRight = symBinOpConstraints Number
335+binaryOperatorConstraints v ShiftRight = symBinOpConstraints v Number
325−binaryOperatorConstraints ZeroFillShiftRight = symBinOpConstraints Number
336+binaryOperatorConstraints v ZeroFillShiftRight = symBinOpConstraints v Number
326−binaryOperatorConstraints EqualTo = equalityBinOpConstraints
337+binaryOperatorConstraints v EqualTo = equalityBinOpConstraints v
327−binaryOperatorConstraints NotEqualTo = equalityBinOpConstraints
338+binaryOperatorConstraints v NotEqualTo = equalityBinOpConstraints v
328−binaryOperatorConstraints And = symBinOpConstraints Boolean
339+binaryOperatorConstraints v And = symBinOpConstraints v Boolean
329−binaryOperatorConstraints Or = symBinOpConstraints Boolean
340+binaryOperatorConstraints v Or = symBinOpConstraints v Boolean
330−binaryOperatorConstraints Concat = symBinOpConstraints String
341+binaryOperatorConstraints v Concat = symBinOpConstraints v String
331−
342+
332−equalityBinOpConstraints :: Int -> Int -> Int -> [TypeConstraint]
343+equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint]
333−equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown right), TypeConstraint result Boolean]
344+equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]
334−
345+
335−symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]
346+symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint]
336−symBinOpConstraints ty left right result = asymBinOpConstraints ty ty left right result
347+symBinOpConstraints v ty left right result = asymBinOpConstraints v ty ty left right result
337−
348+
338−asymBinOpConstraints :: Type -> Type -> Int -> Int -> Int -> [TypeConstraint]
349+asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint]
339−asymBinOpConstraints ty res left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result res]
350+asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)]
340
351
341typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)
352typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)
342typeConstraintsForBinder _ NullBinder = return ([], M.empty)
353typeConstraintsForBinder _ NullBinder = return ([], M.empty)
343−typeConstraintsForBinder val (StringBinder _) = constantBinder val String
354+typeConstraintsForBinder val b@(StringBinder _) = constantBinder b val String
344−typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number
355+typeConstraintsForBinder val b@(NumberBinder _) = constantBinder b val Number
345−typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean
356+typeConstraintsForBinder val b@(BooleanBinder _) = constantBinder b val Boolean
346−typeConstraintsForBinder val (VarBinder name) = do
357+typeConstraintsForBinder val b@(VarBinder name) = do
347 me <- fresh
358 me <- fresh
348− return ([TypeConstraint me (TUnknown val)], M.singleton name me)
359+ return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)
349−typeConstraintsForBinder val (NullaryBinder ctor) = do
360+typeConstraintsForBinder val b@(NullaryBinder ctor) = do
350 env <- getEnv
361 env <- getEnv
351 case M.lookup ctor (dataConstructors env) of
362 case M.lookup ctor (dataConstructors env) of
352 Just (PolyType args ret) -> do
363 Just (PolyType args ret) -> do
353 ret' <- replaceVarsWithUnknowns args ret
364 ret' <- replaceVarsWithUnknowns args ret
354− return ([TypeConstraint val ret'], M.empty)
365+ return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)
355 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
366 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
356−typeConstraintsForBinder val (UnaryBinder ctor binder) = do
367+typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do
357 env <- getEnv
368 env <- getEnv
358 case M.lookup ctor (dataConstructors env) of
369 case M.lookup ctor (dataConstructors env) of
359 Just (PolyType idents f@(Function [_] _)) -> do
370 Just (PolyType idents f@(Function [_] _)) -> do
360 obj <- fresh
371 obj <- fresh
361 (Function [ty] ret) <- replaceVarsWithUnknowns idents f
372 (Function [ty] ret) <- replaceVarsWithUnknowns idents f
362 (cs, m1) <- typeConstraintsForBinder obj binder
373 (cs, m1) <- typeConstraintsForBinder obj binder
363− return ((TypeConstraint val ret) : (TypeConstraint obj ty) : cs, m1)
374+ return ((TypeConstraint val ret (BinderOrigin b)) : (TypeConstraint obj ty (BinderOrigin b)) : cs, m1)
364 Just _ -> throwError $ ctor ++ " is not a unary constructor"
375 Just _ -> throwError $ ctor ++ " is not a unary constructor"
365 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
376 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
366−typeConstraintsForBinder val (ObjectBinder props) = do
377+typeConstraintsForBinder val b@(ObjectBinder props) = do
367 row <- fresh
378 row <- fresh
368 rest <- fresh
379 rest <- fresh
369 (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props
380 (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props
370− return ((TypeConstraint val (Object (RUnknown row))) : cs, m1)
381+ return ((TypeConstraint val (Object (RUnknown row)) (BinderOrigin b)) : cs, m1)
371 where
382 where
372 typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)
383 typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)
373− typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row], M.empty)
384+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row (BinderOrigin b)], M.empty)
374 typeConstraintsForProperties nrow row ((name, binder):binders) = do
385 typeConstraintsForProperties nrow row ((name, binder):binders) = do
375 propTy <- fresh
386 propTy <- fresh
376 (cs1, m1) <- typeConstraintsForBinder propTy binder
387 (cs1, m1) <- typeConstraintsForBinder propTy binder
377 (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders
388 (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders
378 return (cs1 ++ cs2, M.union m1 m2)
389 return (cs1 ++ cs2, M.union m1 m2)
379−typeConstraintsForBinder val (ArrayBinder binders rest) = do
390+typeConstraintsForBinder val b@(ArrayBinder binders rest) = do
380 el <- fresh
391 el <- fresh
381 all <- mapM (typeConstraintsForBinder el) binders
392 all <- mapM (typeConstraintsForBinder el) binders
382 let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all
393 let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all
383− let arrayConstraint = TypeConstraint val (Array (TUnknown el))
394+ let arrayConstraint = TypeConstraint val (Array (TUnknown el)) (BinderOrigin b)
384 case rest of
395 case rest of
385 Nothing -> return (arrayConstraint : cs1, m1)
396 Nothing -> return (arrayConstraint : cs1, m1)
386 Just binder -> do
397 Just binder -> do
387 (cs2, m2) <- typeConstraintsForBinder val binder
398 (cs2, m2) <- typeConstraintsForBinder val binder
388 return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)
399 return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)
389−typeConstraintsForBinder val (NamedBinder name binder) = do
400+typeConstraintsForBinder val b@(NamedBinder name binder) = do
390 me <- fresh
401 me <- fresh
391 (cs, m) <- typeConstraintsForBinder val binder
402 (cs, m) <- typeConstraintsForBinder val binder
392− return (TypeConstraint me (TUnknown val) : cs, M.insert name me m)
403+ return (TypeConstraint me (TUnknown val) (BinderOrigin b) : cs, M.insert name me m)
393−typeConstraintsForBinder val (GuardedBinder cond binder) = do
404+typeConstraintsForBinder val b@(GuardedBinder cond binder) = do
394 (cs1, m) <- typeConstraintsForBinder val binder
405 (cs1, m) <- typeConstraintsForBinder val binder
395 (cs2, n) <- typeConstraints m cond
406 (cs2, n) <- typeConstraints m cond
396− return (TypeConstraint n Boolean : cs1 ++ cs2, m)
407+ return (TypeConstraint n Boolean (ValueOrigin cond) : cs1 ++ cs2, m)
397
408
398−constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)
409+constantBinder :: Binder -> Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)
399−constantBinder val ty = return ([TypeConstraint val ty], M.empty)
410+constantBinder b val ty = return ([TypeConstraint val ty (BinderOrigin b)], M.empty)
400
411
401typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]
412typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]
402typeConstraintsForBinders _ _ _ [] = return []
413typeConstraintsForBinders _ _ _ [] = return []
@@ -404,7 +415,7 @@ typeConstraintsForBinders m nval ret ((binder, val):bs) = do
404 (cs1, m1) <- typeConstraintsForBinder nval binder
415 (cs1, m1) <- typeConstraintsForBinder nval binder
405 (cs2, n2) <- typeConstraints (M.union m m1) val
416 (cs2, n2) <- typeConstraints (M.union m m1) val
406 cs3 <- typeConstraintsForBinders m nval ret bs
417 cs3 <- typeConstraintsForBinders m nval ret bs
407− return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3)
418+ return ((TypeConstraint n2 (TUnknown ret) (BinderOrigin binder)) : cs1 ++ cs2 ++ cs3)
408
419
409assignVariable :: Ident -> M.Map Ident Int -> Check ()
420assignVariable :: Ident -> M.Map Ident Int -> Check ()
410assignVariable name m =
421assignVariable name m =
@@ -424,7 +435,7 @@ typeConstraintsForStatement m mass ret (Assignment tgt val) = do
424typeConstraintsForStatement m mass ret (While val inner) = do
435typeConstraintsForStatement m mass ret (While val inner) = do
425 (cs1, n1) <- typeConstraints m val
436 (cs1, n1) <- typeConstraints m val
426 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner
437 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner
427− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)
438+ return $ ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, allCodePathsReturn, mass)
428typeConstraintsForStatement m mass ret (If ifst) = do
439typeConstraintsForStatement m mass ret (If ifst) = do
429 (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst
440 (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst
430 return $ (cs, allCodePathsReturn, mass)
441 return $ (cs, allCodePathsReturn, mass)
@@ -434,7 +445,7 @@ typeConstraintsForStatement m mass ret (For ident start end inner) = do
434 (cs2, n2) <- typeConstraints (m `M.union` mass) end
445 (cs2, n2) <- typeConstraints (m `M.union` mass) end
435 let mass1 = M.insert ident n1 mass
446 let mass1 = M.insert ident n1 mass
436 (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
447 (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
437− return $ ((TypeConstraint n1 Number) : (TypeConstraint n2 Number) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)
448+ return $ ((TypeConstraint n1 Number (ValueOrigin start)) : (TypeConstraint n2 Number (ValueOrigin end)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)
438typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do
449typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do
439 assignVariable ident (m `M.union` mass)
450 assignVariable ident (m `M.union` mass)
440 val <- fresh
451 val <- fresh
@@ -442,21 +453,21 @@ typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do
442 let mass1 = M.insert ident val mass
453 let mass1 = M.insert ident val mass
443 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
454 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner
444 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
455 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
445− return $ ((TypeConstraint n1 (Array (TUnknown val))) : cs1 ++ cs2, False, mass)
456+ return $ ((TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals)) : cs1 ++ cs2, False, mass)
446typeConstraintsForStatement m mass ret (Return val) = do
457typeConstraintsForStatement m mass ret (Return val) = do
447 (cs1, n1) <- typeConstraints (m `M.union` mass) val
458 (cs1, n1) <- typeConstraints (m `M.union` mass) val
448− return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)
459+ return ((TypeConstraint n1 (TUnknown ret) (ValueOrigin val)) : cs1, True, mass)
449
460
450typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)
461typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)
451typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do
462typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do
452 (cs1, n1) <- typeConstraints m val
463 (cs1, n1) <- typeConstraints m val
453 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens
464 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens
454− return ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn)
465+ return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, allCodePathsReturn)
455typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do
466typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do
456 (cs1, n1) <- typeConstraints m val
467 (cs1, n1) <- typeConstraints m val
457 (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens
468 (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens
458 (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses
469 (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses
459− return ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)
470+ return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)
460
471
461typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)
472typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)
462typeConstraintsForElseStatement m mass ret (Else elses) = do
473typeConstraintsForElseStatement m mass ret (Else elses) = do
@@ -467,21 +478,21 @@ typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do
467 return (cs, allCodePathsReturn)
478 return (cs, allCodePathsReturn)
468
479
469typeConstraintsForAssignmentTarget :: M.Map Ident Int -> M.Map Ident Int -> Int -> AssignmentTarget -> Check [TypeConstraint]
480typeConstraintsForAssignmentTarget :: M.Map Ident Int -> M.Map Ident Int -> Int -> AssignmentTarget -> Check [TypeConstraint]
470−typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =
481+typeConstraintsForAssignmentTarget m mass nval a@(AssignVariable var) =
471 case M.lookup var mass of
482 case M.lookup var mass of
472 Nothing -> throwError $ "No local variable with name " ++ show var
483 Nothing -> throwError $ "No local variable with name " ++ show var
473 Just ty -> do
484 Just ty -> do
474− return [TypeConstraint nval (TUnknown ty)]
485+ return [TypeConstraint nval (TUnknown ty) (AssignmentTargetOrigin a)]
475−typeConstraintsForAssignmentTarget m mass nval (AssignArrayIndex index tgt) = do
486+typeConstraintsForAssignmentTarget m mass nval a@(AssignArrayIndex index tgt) = do
476 arr <- fresh
487 arr <- fresh
477 (cs1, n1) <- typeConstraints (m `M.union` mass) index
488 (cs1, n1) <- typeConstraints (m `M.union` mass) index
478 cs2 <- typeConstraintsForAssignmentTarget m mass arr tgt
489 cs2 <- typeConstraintsForAssignmentTarget m mass arr tgt
479− return $ (TypeConstraint arr (Array (TUnknown nval))) : (TypeConstraint n1 Number) : cs1 ++ cs2
490+ return $ (TypeConstraint arr (Array (TUnknown nval)) (AssignmentTargetOrigin a)) : (TypeConstraint n1 Number (ValueOrigin index)) : cs1 ++ cs2
480−typeConstraintsForAssignmentTarget m mass nval (AssignObjectProperty prop tgt) = do
491+typeConstraintsForAssignmentTarget m mass nval a@(AssignObjectProperty prop tgt) = do
481 obj <- fresh
492 obj <- fresh
482 row <- fresh
493 row <- fresh
483 cs <- typeConstraintsForAssignmentTarget m mass obj tgt
494 cs <- typeConstraintsForAssignmentTarget m mass obj tgt
484− return $ (TypeConstraint obj (Object (RCons prop (TUnknown nval) $ RUnknown row))) : cs
495+ return $ (TypeConstraint obj (Object (RCons prop (TUnknown nval) $ RUnknown row)) (AssignmentTargetOrigin a)) : cs
485
496
486typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)
497typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)
487typeConstraintsForBlock _ mass _ [] = return ([], False, mass)
498typeConstraintsForBlock _ mass _ [] = return ([], False, mass)
@@ -496,97 +507,100 @@ typeConstraintsForBlock m mass ret (s:ss) = do
496
507
497solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution
508solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution
498solveTypeConstraints [] s = return s
509solveTypeConstraints [] s = return s
499−solveTypeConstraints all@(TypeConstraint n t:cs) s = do
510+solveTypeConstraints all@(TypeConstraint n t o:cs) s = do
511+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do
500− typeOccursCheck n t
512+ typeOccursCheck n t
501− let s' = let (f, g) = runTypeSolution s
513+ let s' = let (f, g) = runTypeSolution s
502− in TypeSolution (replaceType n t . f, replaceType n t . g)
514+ in TypeSolution (replaceType n t . f, replaceType n t . g)
503− cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs
515+ cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs
516+ return (cs', s')
504 solveTypeConstraints cs' s'
517 solveTypeConstraints cs' s'
505−solveTypeConstraints (RowConstraint n r:cs) s = do
518+solveTypeConstraints (RowConstraint n r o:cs) s = do
519+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do
506− rowOccursCheck n r
520+ rowOccursCheck n r
507− let s' = let (f, g) = runTypeSolution s
521+ let s' = let (f, g) = runTypeSolution s
508− in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)
522+ in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)
509− cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs
523+ cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs
524+ return (cs', s')
510 solveTypeConstraints cs' s'
525 solveTypeConstraints cs' s'
511
526
512substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]
527substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]
513−substituteTypeInConstraint n s (TypeConstraint m t)
528+substituteTypeInConstraint n s (TypeConstraint m t v)
514− | n == m = unifyTypes s t
529+ | n == m = unifyTypes v s t
515− | otherwise = return [TypeConstraint m (replaceType n s t)]
530+ | otherwise = return [TypeConstraint m (replaceType n s t) v]
516−substituteTypeInConstraint n s (RowConstraint m r)
531+substituteTypeInConstraint n s (RowConstraint m r v)
517− = return [RowConstraint m (replaceType n s r)]
532+ = return [RowConstraint m (replaceType n s r) v]
518
533
519substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]
534substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]
520−substituteRowInConstraint n r (TypeConstraint m t)
535+substituteRowInConstraint n r (TypeConstraint m t v)
521− = return [TypeConstraint m (replaceRow n r t)]
536+ = return [TypeConstraint m (replaceRow n r t) v]
522−substituteRowInConstraint n r (RowConstraint m r1)
537+substituteRowInConstraint n r (RowConstraint m r1 v)
523− | m == n = unifyRows r r1
538+ | m == n = unifyRows v r r1
524− | otherwise = return [RowConstraint m (replaceRow n r r1)]
539+ | otherwise = return [RowConstraint m (replaceRow n r r1) v]
525−
540+
526−unifyTypes :: Type -> Type -> Check [TypeConstraint]
541+unifyTypes :: TypeConstraintOrigin -> Type -> Type -> Check [TypeConstraint]
527−unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []
542+unifyTypes _ (TUnknown u1) (TUnknown u2) | u1 == u2 = return []
528−unifyTypes (TUnknown u) t = do
543+unifyTypes o (TUnknown u) t = do
529 typeOccursCheck u t
544 typeOccursCheck u t
530− return [TypeConstraint u t]
545+ return [TypeConstraint u t o]
531−unifyTypes t (TUnknown u) = do
546+unifyTypes o t (TUnknown u) = do
532 typeOccursCheck u t
547 typeOccursCheck u t
533− return [TypeConstraint u t]
548+ return [TypeConstraint u t o]
534−unifyTypes (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =
549+unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =
535− fmap concat $ zipWithM unifyTypes args1 args2
550+ fmap concat $ zipWithM (unifyTypes o) args1 args2
536−unifyTypes (SaturatedTypeSynonym name args) ty = do
551+unifyTypes o (SaturatedTypeSynonym name args) ty = do
537 env <- getEnv
552 env <- getEnv
538 case M.lookup name (typeSynonyms env) of
553 case M.lookup name (typeSynonyms env) of
539 Just (synArgs, body) -> do
554 Just (synArgs, body) -> do
540 let m = M.fromList $ zip synArgs args
555 let m = M.fromList $ zip synArgs args
541 let replaced = replaceTypeVars m body
556 let replaced = replaceTypeVars m body
542− unifyTypes replaced ty
557+ unifyTypes o replaced ty
543 Nothing -> error "Type synonym was not defined"
558 Nothing -> error "Type synonym was not defined"
544−unifyTypes ty s@(SaturatedTypeSynonym _ _) = unifyTypes s ty
559+unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty
545−unifyTypes Number Number = return []
560+unifyTypes _ Number Number = return []
546−unifyTypes String String = return []
561+unifyTypes _ String String = return []
547−unifyTypes Boolean Boolean = return []
562+unifyTypes _ Boolean Boolean = return []
548−unifyTypes (Array s) (Array t) = unifyTypes s t
563+unifyTypes o (Array s) (Array t) = unifyTypes o s t
549−unifyTypes (Object row1) (Object row2) = unifyRows row1 row2
564+unifyTypes o (Object row1) (Object row2) = unifyRows o row1 row2
550−unifyTypes (Function args1 ret1) (Function args2 ret2) = do
565+unifyTypes o (Function args1 ret1) (Function args2 ret2) = do
551 guardWith "Function applied to incorrect number of args" $ length args1 == length args2
566 guardWith "Function applied to incorrect number of args" $ length args1 == length args2
552− cs1 <- fmap concat $ zipWithM unifyTypes args1 args2
567+ cs1 <- fmap concat $ zipWithM (unifyTypes o) args1 args2
553− cs2 <- unifyTypes ret1 ret2
568+ cs2 <- unifyTypes o ret1 ret2
554 return $ cs1 ++ cs2
569 return $ cs1 ++ cs2
555−unifyTypes (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
570+unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []
556−unifyTypes (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []
571+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []
557−unifyTypes (TypeVar v1) (TypeVar v2) = return []
558−unifyTypes (TypeApp t1 t2) (TypeApp t3 t4) = do
572+unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do
559− cs1 <- unifyTypes t1 t3
573+ cs1 <- unifyTypes o t1 t3
560− cs2 <- unifyTypes t2 t4
574+ cs2 <- unifyTypes o t2 t4
561 return $ cs1 ++ cs2
575 return $ cs1 ++ cs2
562−unifyTypes t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
576+unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
563
577
564−unifyRows :: Row -> Row -> Check [TypeConstraint]
578+unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]
565−unifyRows r1 r2 =
579+unifyRows o r1 r2 =
566 let
580 let
567 (s1, r1') = toList r1
581 (s1, r1') = toList r1
568 (s2, r2') = toList r2
582 (s2, r2') = toList r2
569 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
583 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
570 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]
584 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]
571 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]
585 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]
572− in rethrow (\e -> "Cannot unify " ++ prettyPrintRow r1 ++ " with " ++ prettyPrintRow r2 ++ ": " ++ e) $ do
586+ in do
573− cs1 <- fmap concat $ mapM (uncurry unifyTypes) int
587+ cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int
574− cs2 <- unifyRows' sd1 r1' sd2 r2'
588+ cs2 <- unifyRows' o sd1 r1' sd2 r2'
575 return $ cs1 ++ cs2
589 return $ cs1 ++ cs2
576 where
590 where
577− unifyRows' :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]
591+ unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]
578− unifyRows' [] (RUnknown u) sd r = do
592+ unifyRows' o [] (RUnknown u) sd r = do
579 rowOccursCheck u r
593 rowOccursCheck u r
580− return [RowConstraint u (fromList (sd, r))]
594+ return [RowConstraint u (fromList (sd, r)) o]
581− unifyRows' sd r [] (RUnknown u) = do
595+ unifyRows' o sd r [] (RUnknown u) = do
582 rowOccursCheck u r
596 rowOccursCheck u r
583− return [RowConstraint u (fromList (sd, r))]
597+ return [RowConstraint u (fromList (sd, r)) o]
584− unifyRows' ((name, ty):row) r others (RUnknown u) = do
598+ unifyRows' o ((name, ty):row) r others (RUnknown u) = do
585 u' <- fresh
599 u' <- fresh
586− cs <- unifyRows' row r others (RUnknown u')
600+ cs <- unifyRows' o row r others (RUnknown u')
587− return (RowConstraint u (RCons name ty (RUnknown u')) : cs)
601+ return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)
588− unifyRows' [] REmpty [] REmpty = return []
602+ unifyRows' _ [] REmpty [] REmpty = return []
589− unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."
603+ unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."
590 toList :: Row -> ([(String, Type)], Row)
604 toList :: Row -> ([(String, Type)], Row)
591 toList (RCons name ty row) = let (tys, rest) = toList row
605 toList (RCons name ty row) = let (tys, rest) = toList row
592 in ((name, ty):tys, rest)
606 in ((name, ty):tys, rest)