9ee79c6 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Show relevant term in type error

commit9ee79c6a5bd958dca5dc5e6b4364cface44d3116 authorPhil Freeman <paf31@cantab.net> dateTue 29 Oct 2013, 21:56 (13 years ago) parenta17d147

7 files changed+450−263

compare with golang

unifiedsplit

PureScript.cabal+17−18 examples/failing/KindError.ps+1−1 examples/failing/TypeError.ps+3−1 src/PureScript/CodeGen/JS.hs+3−30 src/PureScript/CodeGen/Pretty/Values.hs+184 src/PureScript/TypeChecker/Kinds.hs+59−44 src/PureScript/TypeChecker/Types.hs+183−169

PureScript.cabal+17−18

@@ -11,34 +11,33 @@ synopsis: PureScript Programming Language Compiler

1111description: A small compile-to-JS language with extensible records and type-safe blocks

1212author: Phil Freeman <paf31@cantab.net>

1313data-dir: ""

14−

14+

1515library

1616 build-depends: base -any, syb -any, cmdtheline -any,

1717 containers -any, mtl -any, transformers -any, parsec -any,

1818 utf8-string -any

19− exposed-modules: PureScript.CodeGen.Pretty.Types PureScript

20− PureScript.Declarations PureScript.Names

21− PureScript.TypeChecker.Synonyms PureScript.CodeGen.Externs

22− PureScript.CodeGen.JS PureScript.CodeGen.Common.Gen

23− PureScript.CodeGen.Common Main PureScript.CodeGen PureScript.Kinds

24− PureScript.Parser PureScript.TypeChecker PureScript.Types

25− PureScript.Values PureScript.Parser.Common

26− PureScript.Parser.Declarations PureScript.Parser.Types

27− PureScript.Parser.Values PureScript.TypeChecker.Kinds

28− PureScript.TypeChecker.Monad PureScript.TypeChecker.Types

29− PureScript.Parser.State

19+ exposed-modules: PureScript.CodeGen.Pretty.Values

20+ PureScript.CodeGen.Pretty.Types PureScript PureScript.Declarations

21+ PureScript.Names PureScript.TypeChecker.Synonyms

22+ PureScript.CodeGen.Externs PureScript.CodeGen.JS

23+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

24+ PureScript.CodeGen PureScript.Kinds PureScript.Parser

25+ PureScript.TypeChecker PureScript.Types PureScript.Values

26+ PureScript.Parser.Common PureScript.Parser.Declarations

27+ PureScript.Parser.Types PureScript.Parser.Values

28+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

29+ PureScript.TypeChecker.Types PureScript.Parser.State

30+ PureScript.Parser.Kinds PureScript.CodeGen.Pretty.Kinds

3031 exposed: True

3132 buildable: True

3233 hs-source-dirs: src

33− other-modules: PureScript.Parser.Kinds

34− PureScript.CodeGen.Pretty.Kinds

35−

34+ other-modules:

35+

3636executable psc

3737 build-depends: base -any, cmdtheline -any, containers -any,

3838 mtl -any, transformers -any, parsec -any, utf8-string -any

3939 main-is: Main.hs

4040 buildable: True

4141 hs-source-dirs: src

42− other-modules: PureScript.Parser.Kinds

43− PureScript.CodeGen.Pretty.Kinds PureScript.CodeGen.Pretty.Types

44−

42+ other-modules:

43+

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

3131import PureScript.CodeGen.Common.Gen

3232

3333declToJs :: 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 ++ "; }"

3535declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"

3636declToJs (DataDeclaration _ _ ctors) =

3737 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->

@@ -148,33 +148,6 @@ valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

148148 , [ binary Or "||" ]

149149 ]

150150

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−

178151binderToJs :: String -> String -> Binder -> Gen String

179152binderToJs varName done NullBinder = return done

180153binderToJs varName done (StringBinder str) =

@@ -219,8 +192,8 @@ binderToJs varName done (ArrayBinder bs rest) = do

219192binderToJs varName done (NamedBinder ident binder) = do

220193 js <- binderToJs varName done binder

221194 return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js

222−binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder

223− where

195+binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder

196+ where

224197 done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"

225198

226199objectPropertyToJs :: (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 @@

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

1517module PureScript.TypeChecker.Kinds (

1618 KindConstraint(..),

1719 KindSolution(..),

@@ -22,12 +24,14 @@ module PureScript.TypeChecker.Kinds (

2224import Data.List

2325import Data.Maybe (fromMaybe)

2426import Data.Function

27+import Data.Data

2528

2629import PureScript.Types

2730import PureScript.Kinds

2831import PureScript.Declarations

2932import PureScript.TypeChecker.Monad

3033import PureScript.CodeGen.Pretty.Kinds

34+import PureScript.CodeGen.Pretty.Types

3135

3236import Control.Monad.State

3337import Control.Monad.Error

@@ -38,10 +42,17 @@ import qualified Control.Category as C

3842

3943import qualified Data.Map as M

4044

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

4254

43−instance Show KindConstraint where

44− show (KindConstraint n k) = show n ++ " = " ++ show k

55+data KindConstraint = KindConstraint Int Kind KindConstraintOrigin deriving (Show, Data, Typeable)

4556

4657newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }

4758

@@ -60,7 +71,9 @@ kindsOf name args ts = do

6071 tyCon <- fresh

6172 nargs <- replicateM (length args) fresh

6273 (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts

63− let extraConstraints = KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) : map (flip KindConstraint Star) ns

74+ let extraConstraints =

75+ KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) DataDeclOrigin

76+ : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts

6477 solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution

6578 return $ starIfUnknown $ runKindSolution solution tyCon

6679

@@ -74,71 +87,73 @@ kindConstraintsAll m [] = return ([], [], m)

7487kindConstraintsAll m (t:ts) = do

7588 (cs, n1, m') <- kindConstraints m t

7689 (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'')

7891

7992kindConstraints :: 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

8194 me <- fresh

8295 (cs, n1, m') <- kindConstraints m t

83− return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, m')

84−kindConstraints m (Object row) = do

96+ return ((KindConstraint n1 Star (TypeOrigin t)) : (KindConstraint me Star (TypeOrigin a)) : cs, me, m')

97+kindConstraints m o@(Object row) = do

8598 me <- fresh

86− (cs, row, m') <- kindConstraintsForRow m row

87− return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, m')

88−kindConstraints m (Function args ret) = do

99+ (cs, r, m') <- kindConstraintsForRow m row

100+ return ((KindConstraint me Star (TypeOrigin o)) : (KindConstraint r Row (RowOrigin row)) : cs, me, m')

101+kindConstraints m f@(Function args ret) = do

89102 me <- fresh

90103 (cs, ns, m') <- kindConstraintsAll m args

91104 (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'')

93106kindConstraints m (TypeVar v) = do

94107 case M.lookup v m of

95108 Just u -> return ([], u, m)

96109 Nothing -> throwError $ "Unbound type variable " ++ v

97−kindConstraints m (TypeConstructor v) = do

110+kindConstraints m c@(TypeConstructor v) = do

98111 env <- getEnv

99112 me <- fresh

100113 case M.lookup v m of

101114 Nothing -> case M.lookup v (types env) of

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

104117 Just u -> do

105− return ([KindConstraint me (KUnknown u)], me, m)

106−kindConstraints m (TypeApp t1 t2) = do

118+ return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)

119+kindConstraints m a@(TypeApp t1 t2) = do

107120 me <- fresh

108121 (cs1, n1, m1) <- kindConstraints m t1

109122 (cs2, n2, m2) <- kindConstraints m1 t2

110− return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me))) : cs1 ++ cs2, me, m2)

111−kindConstraints m _ = do

123+ return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a)) : cs1 ++ cs2, me, m2)

124+kindConstraints m t = do

112125 me <- fresh

113− return ([KindConstraint me Star], me, m)

126+ return ([KindConstraint me Star (TypeOrigin t)], me, m)

114127

115128kindConstraintsForRow :: 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

117130 me <- case M.lookup v m of

118131 Just u -> return u

119132 Nothing -> fresh

120− return ([KindConstraint me Row], me, M.insert v me m)

121−kindConstraintsForRow m REmpty = do

133+ return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)

134+kindConstraintsForRow m r@REmpty = do

122135 me <- fresh

123− return ([KindConstraint me Row], me, m)

124−kindConstraintsForRow m (RCons _ ty row) = do

136+ return ([KindConstraint me Row (RowOrigin r)], me, m)

137+kindConstraintsForRow m r@(RCons _ ty row) = do

125138 me <- fresh

126139 (cs1, n1, m1) <- kindConstraints m ty

127140 (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)

129142

130143solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution

131144solveKindConstraints [] s = return s

132−solveKindConstraints all@(KindConstraint n k:cs) s = do

133− guardWith "Occurs check failed" $ not $ kindOccursCheck False n k

134− let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

135− cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs

145+solveKindConstraints all@(KindConstraint n k t : cs) s = do

146+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintKindConstraintOrigin t ++ ": " ++ err) $ do

147+ guardWith "Occurs check failed" $ not $ kindOccursCheck False n k

148+ let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

149+ cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs

150+ return (cs', s')

136151 solveKindConstraints cs' s'

137152

138153substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]

139−substituteKindConstraint n k (KindConstraint m l)

140− | n == m = unifyKinds k l

141− | otherwise = return [KindConstraint m (replaceUnknownKind n k l)]

154+substituteKindConstraint n k (KindConstraint m l t)

155+ | n == m = unifyKinds t k l

156+ | otherwise = return [KindConstraint m (replaceUnknownKind n k l) t]

142157

143158replaceUnknownKind :: Int -> Kind -> Kind -> Kind

144159replaceUnknownKind n k = f

@@ -147,21 +162,21 @@ replaceUnknownKind n k = f

147162 f (FunKind k1 k2) = FunKind (f k2) (f k2)

148163 f other = other

149164

150−unifyKinds :: Kind -> Kind -> Check [KindConstraint]

151−unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

152−unifyKinds (KUnknown u) k = do

165+unifyKinds :: KindConstraintOrigin -> Kind -> Kind -> Check [KindConstraint]

166+unifyKinds _ (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

167+unifyKinds t (KUnknown u) k = do

153168 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

154− return [KindConstraint u k]

155−unifyKinds k (KUnknown u) = do

169+ return [KindConstraint u k t]

170+unifyKinds t k (KUnknown u) = do

156171 guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

157− return [KindConstraint u k]

158−unifyKinds Star Star = return []

159−unifyKinds Row Row = return []

160−unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do

161− cs1 <- unifyKinds k1 k3

162− cs2 <- unifyKinds k2 k4

172+ return [KindConstraint u k t]

173+unifyKinds _ Star Star = return []

174+unifyKinds _ Row Row = return []

175+unifyKinds t (FunKind k1 k2) (FunKind k3 k4) = do

176+ cs1 <- unifyKinds t k1 k3

177+ cs2 <- unifyKinds t k2 k4

163178 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 ++ "."

165180

166181kindOccursCheck :: Bool -> Int -> Kind -> Bool

167182kindOccursCheck b u (KUnknown u') | u == u' = b

src/PureScript/TypeChecker/Types.hs+183−169

@@ -34,6 +34,7 @@ import PureScript.TypeChecker.Kinds

3434import PureScript.TypeChecker.Synonyms

3535import PureScript.CodeGen.Pretty.Types

3636import PureScript.CodeGen.Pretty.Kinds

37+import PureScript.CodeGen.Pretty.Values

3738

3839import Control.Monad.State

3940import Control.Monad.Error

@@ -44,9 +45,19 @@ import qualified Control.Category as C

4445

4546import qualified Data.Map as M

4647

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+

4758data TypeConstraint

48− = TypeConstraint Int Type

49− | RowConstraint Int Row deriving (Show, D.Data, D.Typeable)

59+ = TypeConstraint Int Type TypeConstraintOrigin

60+ | RowConstraint Int Row TypeConstraintOrigin deriving (Show, D.Data, D.Typeable)

5061

5162newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }

5263

@@ -59,7 +70,7 @@ typeOf name val = do

5970 Abs _ _ -> do

6071 me <- fresh

6172 (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)

6374 _ -> typeConstraints M.empty val

6475 desugared <- replaceAllTypeSynonyms cs

6576 solution <- solveTypeConstraints desugared emptyTypeSolution

@@ -72,15 +83,15 @@ allUnknownsBecameQuantified cs solution ty = do

7283 let

7384 typesMentioned = findUnknownTypes ty

7485 unknownTypes = nub $ flip concatMap cs $ \c -> case c of

75− TypeConstraint u t -> u : findUnknownTypes t

76− RowConstraint _ r -> findUnknownTypes r

86+ TypeConstraint u t _ -> u : findUnknownTypes t

87+ RowConstraint _ r _ -> findUnknownTypes r

7788 unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes

7889 guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned

7990 let

8091 rowsMentioned = findUnknownRows ty

8192 unknownRows = nub $ flip concatMap cs $ \c -> case c of

82− TypeConstraint _ t -> findUnknownRows t

83− RowConstraint u r -> u : findUnknownRows r

93+ TypeConstraint _ t _ -> findUnknownRows t

94+ RowConstraint u r _ -> u : findUnknownRows r

8495 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

8596 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

8697

@@ -206,61 +217,61 @@ occursCheck u = everything (||) $ flip extQ g $ mkQ False f

206217 g _ = False

207218

208219typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

209−typeConstraints _ (NumericLiteral _) = do

220+typeConstraints _ v@(NumericLiteral _) = do

210221 me <- fresh

211− return ([TypeConstraint me Number], me)

212−typeConstraints _ (StringLiteral _) = do

222+ return ([TypeConstraint me Number (ValueOrigin v)], me)

223+typeConstraints _ v@(StringLiteral _) = do

213224 me <- fresh

214− return ([TypeConstraint me String], me)

215−typeConstraints _ (BooleanLiteral _) = do

225+ return ([TypeConstraint me String (ValueOrigin v)], me)

226+typeConstraints _ v@(BooleanLiteral _) = do

216227 me <- fresh

217− return ([TypeConstraint me Boolean], me)

218−typeConstraints m (ArrayLiteral vals) = do

228+ return ([TypeConstraint me Boolean (ValueOrigin v)], me)

229+typeConstraints m v@(ArrayLiteral vals) = do

219230 all <- mapM (typeConstraints m) vals

220231 let (cs, ns) = (concat . map fst &&& map snd) all

221232 me <- fresh

222− return (cs ++ map (TypeConstraint me . Array . TUnknown) ns, me)

223−typeConstraints m (Unary op val) = do

233+ return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me)

234+typeConstraints m u@(Unary op val) = do

224235 (cs, n1) <- typeConstraints m val

225236 me <- fresh

226− return (cs ++ unaryOperatorConstraints op n1 me, me)

227−typeConstraints m (Binary op left right) = do

237+ return (cs ++ unaryOperatorConstraints u op n1 me, me)

238+typeConstraints m b@(Binary op left right) = do

228239 (cs1, n1) <- typeConstraints m left

229240 (cs2, n2) <- typeConstraints m right

230241 me <- fresh

231− return (cs1 ++ cs2 ++ binaryOperatorConstraints op n1 n2 me, me)

232−typeConstraints m (ObjectLiteral ps) = do

242+ return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)

243+typeConstraints m v@(ObjectLiteral ps) = do

233244 all <- mapM (typeConstraints m . snd) ps

234245 let (cs, ns) = (concat . map fst &&& map snd) all

235246 me <- fresh

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

238249 where

239250 typesToRow [] = REmpty

240251 typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)

241−typeConstraints m (Indexer index val) = do

252+typeConstraints m v@(Indexer index val) = do

242253 (cs1, n1) <- typeConstraints m index

243254 (cs2, n2) <- typeConstraints m val

244255 me <- fresh

245− return ((TypeConstraint n1 Number) : (TypeConstraint n2 (Array (TUnknown me))) : cs1 ++ cs2, me)

246−typeConstraints m (Accessor prop val) = do

256+ return ((TypeConstraint n1 Number (ValueOrigin index)) : (TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

257+typeConstraints m v@(Accessor prop val) = do

247258 (cs, n1) <- typeConstraints m val

248259 me <- fresh

249260 rest <- fresh

250− return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest)))) : cs, me)

251−typeConstraints m (Abs args ret) = do

261+ return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v)) : cs, me)

262+typeConstraints m v@(Abs args ret) = do

252263 ns <- replicateM (length args) fresh

253264 let m' = m `M.union` M.fromList (zipWith (,) args ns)

254265 (cs, n') <- typeConstraints m' ret

255266 me <- fresh

256− return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me)

257−typeConstraints m (App f xs) = do

267+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v)) : cs, me)

268+typeConstraints m v@(App f xs) = do

258269 (cs1, n1) <- typeConstraints m f

259270 all <- mapM (typeConstraints m) xs

260271 let (cs2, ns) = (concat . map fst &&& map snd) all

261272 me <- fresh

262− return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me))) : cs1 ++ cs2, me)

263−typeConstraints m (Var var) =

273+ return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

274+typeConstraints m v@(Var var) =

264275 case M.lookup var m of

265276 Nothing -> do

266277 env <- getEnv

@@ -269,134 +280,134 @@ typeConstraints m (Var var) =

269280 Just (PolyType idents ty, _) -> do

270281 me <- fresh

271282 replaced <- replaceVarsWithUnknowns idents ty

272− return ([TypeConstraint me replaced], me)

283+ return ([TypeConstraint me replaced (ValueOrigin v)], me)

273284 Just u -> do

274285 me <- fresh

275− return ([TypeConstraint u (TUnknown me)], me)

286+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)

276287typeConstraints m (Block ss) = do

277288 ret <- fresh

278289 (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss

279290 guardWith "Block is missing a return statement" allCodePathsReturn

280291 return (cs, ret)

281−typeConstraints m (Constructor c) = do

292+typeConstraints m v@(Constructor c) = do

282293 env <- getEnv

283294 case M.lookup c (dataConstructors env) of

284295 Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"

285296 Just (PolyType idents ty) -> do

286297 me <- fresh

287298 replaced <- replaceVarsWithUnknowns idents ty

288− return ([TypeConstraint me replaced], me)

299+ return ([TypeConstraint me replaced (ValueOrigin v)], me)

289300typeConstraints m (Case val binders) = do

290301 (cs1, n1) <- typeConstraints m val

291302 ret <- fresh

292303 cs2 <- typeConstraintsForBinders m n1 ret binders

293304 return (cs1 ++ cs2, ret)

294−typeConstraints m (IfThenElse cond th el) = do

305+typeConstraints m v@(IfThenElse cond th el) = do

295306 (cs1, n1) <- typeConstraints m cond

296307 (cs2, n2) <- typeConstraints m th

297308 (cs3, n3) <- typeConstraints m el

298− return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)

299−typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do

309+ return (TypeConstraint n1 Boolean (ValueOrigin cond) : TypeConstraint n2 (TUnknown n3) (ValueOrigin v) : cs1 ++ cs2 ++ cs3, n2)

310+typeConstraints m v@(TypedValue val poly@(PolyType idents ty)) = do

300311 kind <- kindOf poly

301312 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

302313 (cs, n1) <- typeConstraints m val

303− return (TypeConstraint n1 ty : cs, n1)

304−

305−unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]

306−unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]

307−unaryOperatorConstraints Not val result = [TypeConstraint val Boolean, TypeConstraint result Boolean]

308−unaryOperatorConstraints BitwiseNot val result = [TypeConstraint val Number, TypeConstraint result Number]

309−

310−binaryOperatorConstraints :: BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]

311−binaryOperatorConstraints Add = symBinOpConstraints Number

312−binaryOperatorConstraints Subtract = symBinOpConstraints Number

313−binaryOperatorConstraints Multiply = symBinOpConstraints Number

314−binaryOperatorConstraints Divide = symBinOpConstraints Number

315−binaryOperatorConstraints Modulus = symBinOpConstraints Number

316−binaryOperatorConstraints LessThan = asymBinOpConstraints Number Boolean

317−binaryOperatorConstraints LessThanOrEqualTo = asymBinOpConstraints Number Boolean

318−binaryOperatorConstraints GreaterThan = asymBinOpConstraints Number Boolean

319−binaryOperatorConstraints GreaterThanOrEqualTo = asymBinOpConstraints Number Boolean

320−binaryOperatorConstraints BitwiseAnd = symBinOpConstraints Number

321−binaryOperatorConstraints BitwiseOr = symBinOpConstraints Number

322−binaryOperatorConstraints BitwiseXor = symBinOpConstraints Number

323−binaryOperatorConstraints ShiftLeft = symBinOpConstraints Number

324−binaryOperatorConstraints ShiftRight = symBinOpConstraints Number

325−binaryOperatorConstraints ZeroFillShiftRight = symBinOpConstraints Number

326−binaryOperatorConstraints EqualTo = equalityBinOpConstraints

327−binaryOperatorConstraints NotEqualTo = equalityBinOpConstraints

328−binaryOperatorConstraints And = symBinOpConstraints Boolean

329−binaryOperatorConstraints Or = symBinOpConstraints Boolean

330−binaryOperatorConstraints Concat = symBinOpConstraints String

331−

332−equalityBinOpConstraints :: Int -> Int -> Int -> [TypeConstraint]

333−equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown right), TypeConstraint result Boolean]

334−

335−symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]

336−symBinOpConstraints ty left right result = asymBinOpConstraints ty ty left right result

337−

338−asymBinOpConstraints :: Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

339−asymBinOpConstraints ty res left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result res]

314+ return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1)

315+

316+unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]

317+unaryOperatorConstraints v Negate val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]

318+unaryOperatorConstraints v Not val result = [TypeConstraint val Boolean (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]

319+unaryOperatorConstraints v BitwiseNot val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]

320+

321+binaryOperatorConstraints :: Value -> BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]

322+binaryOperatorConstraints v Add = symBinOpConstraints v Number

323+binaryOperatorConstraints v Subtract = symBinOpConstraints v Number

324+binaryOperatorConstraints v Multiply = symBinOpConstraints v Number

325+binaryOperatorConstraints v Divide = symBinOpConstraints v Number

326+binaryOperatorConstraints v Modulus = symBinOpConstraints v Number

327+binaryOperatorConstraints v LessThan = asymBinOpConstraints v Number Boolean

328+binaryOperatorConstraints v LessThanOrEqualTo = asymBinOpConstraints v Number Boolean

329+binaryOperatorConstraints v GreaterThan = asymBinOpConstraints v Number Boolean

330+binaryOperatorConstraints v GreaterThanOrEqualTo = asymBinOpConstraints v Number Boolean

331+binaryOperatorConstraints v BitwiseAnd = symBinOpConstraints v Number

332+binaryOperatorConstraints v BitwiseOr = symBinOpConstraints v Number

333+binaryOperatorConstraints v BitwiseXor = symBinOpConstraints v Number

334+binaryOperatorConstraints v ShiftLeft = symBinOpConstraints v Number

335+binaryOperatorConstraints v ShiftRight = symBinOpConstraints v Number

336+binaryOperatorConstraints v ZeroFillShiftRight = symBinOpConstraints v Number

337+binaryOperatorConstraints v EqualTo = equalityBinOpConstraints v

338+binaryOperatorConstraints v NotEqualTo = equalityBinOpConstraints v

339+binaryOperatorConstraints v And = symBinOpConstraints v Boolean

340+binaryOperatorConstraints v Or = symBinOpConstraints v Boolean

341+binaryOperatorConstraints v Concat = symBinOpConstraints v String

342+

343+equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint]

344+equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]

345+

346+symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint]

347+symBinOpConstraints v ty left right result = asymBinOpConstraints v ty ty left right result

348+

349+asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

350+asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)]

340351

341352typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)

342353typeConstraintsForBinder _ NullBinder = return ([], M.empty)

343−typeConstraintsForBinder val (StringBinder _) = constantBinder val String

344−typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

345−typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

346−typeConstraintsForBinder val (VarBinder name) = do

354+typeConstraintsForBinder val b@(StringBinder _) = constantBinder b val String

355+typeConstraintsForBinder val b@(NumberBinder _) = constantBinder b val Number

356+typeConstraintsForBinder val b@(BooleanBinder _) = constantBinder b val Boolean

357+typeConstraintsForBinder val b@(VarBinder name) = do

347358 me <- fresh

348− return ([TypeConstraint me (TUnknown val)], M.singleton name me)

349−typeConstraintsForBinder val (NullaryBinder ctor) = do

359+ return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)

360+typeConstraintsForBinder val b@(NullaryBinder ctor) = do

350361 env <- getEnv

351362 case M.lookup ctor (dataConstructors env) of

352363 Just (PolyType args ret) -> do

353364 ret' <- replaceVarsWithUnknowns args ret

354− return ([TypeConstraint val ret'], M.empty)

365+ return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)

355366 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

356−typeConstraintsForBinder val (UnaryBinder ctor binder) = do

367+typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do

357368 env <- getEnv

358369 case M.lookup ctor (dataConstructors env) of

359370 Just (PolyType idents f@(Function [_] _)) -> do

360371 obj <- fresh

361372 (Function [ty] ret) <- replaceVarsWithUnknowns idents f

362373 (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)

364375 Just _ -> throwError $ ctor ++ " is not a unary constructor"

365376 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

366−typeConstraintsForBinder val (ObjectBinder props) = do

377+typeConstraintsForBinder val b@(ObjectBinder props) = do

367378 row <- fresh

368379 rest <- fresh

369380 (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)

371382 where

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

374385 typeConstraintsForProperties nrow row ((name, binder):binders) = do

375386 propTy <- fresh

376387 (cs1, m1) <- typeConstraintsForBinder propTy binder

377388 (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders

378389 return (cs1 ++ cs2, M.union m1 m2)

379−typeConstraintsForBinder val (ArrayBinder binders rest) = do

390+typeConstraintsForBinder val b@(ArrayBinder binders rest) = do

380391 el <- fresh

381392 all <- mapM (typeConstraintsForBinder el) binders

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

384395 case rest of

385396 Nothing -> return (arrayConstraint : cs1, m1)

386397 Just binder -> do

387398 (cs2, m2) <- typeConstraintsForBinder val binder

388399 return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)

389−typeConstraintsForBinder val (NamedBinder name binder) = do

400+typeConstraintsForBinder val b@(NamedBinder name binder) = do

390401 me <- fresh

391402 (cs, m) <- typeConstraintsForBinder val binder

392− return (TypeConstraint me (TUnknown val) : cs, M.insert name me m)

393−typeConstraintsForBinder val (GuardedBinder cond binder) = do

403+ return (TypeConstraint me (TUnknown val) (BinderOrigin b) : cs, M.insert name me m)

404+typeConstraintsForBinder val b@(GuardedBinder cond binder) = do

394405 (cs1, m) <- typeConstraintsForBinder val binder

395406 (cs2, n) <- typeConstraints m cond

396− return (TypeConstraint n Boolean : cs1 ++ cs2, m)

407+ return (TypeConstraint n Boolean (ValueOrigin cond) : cs1 ++ cs2, m)

397408

398−constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)

399−constantBinder val ty = return ([TypeConstraint val ty], M.empty)

409+constantBinder :: Binder -> Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)

410+constantBinder b val ty = return ([TypeConstraint val ty (BinderOrigin b)], M.empty)

400411

401412typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

402413typeConstraintsForBinders _ _ _ [] = return []

@@ -404,7 +415,7 @@ typeConstraintsForBinders m nval ret ((binder, val):bs) = do

404415 (cs1, m1) <- typeConstraintsForBinder nval binder

405416 (cs2, n2) <- typeConstraints (M.union m m1) val

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

408419

409420assignVariable :: Ident -> M.Map Ident Int -> Check ()

410421assignVariable name m =

@@ -424,7 +435,7 @@ typeConstraintsForStatement m mass ret (Assignment tgt val) = do

424435typeConstraintsForStatement m mass ret (While val inner) = do

425436 (cs1, n1) <- typeConstraints m val

426437 (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)

428439typeConstraintsForStatement m mass ret (If ifst) = do

429440 (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

430441 return $ (cs, allCodePathsReturn, mass)

@@ -434,7 +445,7 @@ typeConstraintsForStatement m mass ret (For ident start end inner) = do

434445 (cs2, n2) <- typeConstraints (m `M.union` mass) end

435446 let mass1 = M.insert ident n1 mass

436447 (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)

438449typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

439450 assignVariable ident (m `M.union` mass)

440451 val <- fresh

@@ -442,21 +453,21 @@ typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

442453 let mass1 = M.insert ident val mass

443454 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

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

446457typeConstraintsForStatement m mass ret (Return val) = do

447458 (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)

449460

450461typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)

451462typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do

452463 (cs1, n1) <- typeConstraints m val

453464 (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)

455466typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do

456467 (cs1, n1) <- typeConstraints m val

457468 (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens

458469 (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)

460471

461472typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)

462473typeConstraintsForElseStatement m mass ret (Else elses) = do

@@ -467,21 +478,21 @@ typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do

467478 return (cs, allCodePathsReturn)

468479

469480typeConstraintsForAssignmentTarget :: 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) =

471482 case M.lookup var mass of

472483 Nothing -> throwError $ "No local variable with name " ++ show var

473484 Just ty -> do

474− return [TypeConstraint nval (TUnknown ty)]

475−typeConstraintsForAssignmentTarget m mass nval (AssignArrayIndex index tgt) = do

485+ return [TypeConstraint nval (TUnknown ty) (AssignmentTargetOrigin a)]

486+typeConstraintsForAssignmentTarget m mass nval a@(AssignArrayIndex index tgt) = do

476487 arr <- fresh

477488 (cs1, n1) <- typeConstraints (m `M.union` mass) index

478489 cs2 <- typeConstraintsForAssignmentTarget m mass arr tgt

479− return $ (TypeConstraint arr (Array (TUnknown nval))) : (TypeConstraint n1 Number) : cs1 ++ cs2

480−typeConstraintsForAssignmentTarget m mass nval (AssignObjectProperty prop tgt) = do

490+ return $ (TypeConstraint arr (Array (TUnknown nval)) (AssignmentTargetOrigin a)) : (TypeConstraint n1 Number (ValueOrigin index)) : cs1 ++ cs2

491+typeConstraintsForAssignmentTarget m mass nval a@(AssignObjectProperty prop tgt) = do

481492 obj <- fresh

482493 row <- fresh

483494 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

485496

486497typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)

487498typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

@@ -496,97 +507,100 @@ typeConstraintsForBlock m mass ret (s:ss) = do

496507

497508solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution

498509solveTypeConstraints [] s = return s

499−solveTypeConstraints all@(TypeConstraint n t:cs) s = do

500− typeOccursCheck n t

501− let s' = let (f, g) = runTypeSolution s

502− in TypeSolution (replaceType n t . f, replaceType n t . g)

503− cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs

510+solveTypeConstraints all@(TypeConstraint n t o:cs) s = do

511+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do

512+ typeOccursCheck n t

513+ let s' = let (f, g) = runTypeSolution s

514+ in TypeSolution (replaceType n t . f, replaceType n t . g)

515+ cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs

516+ return (cs', s')

504517 solveTypeConstraints cs' s'

505−solveTypeConstraints (RowConstraint n r:cs) s = do

506− rowOccursCheck n r

507− let s' = let (f, g) = runTypeSolution s

508− in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)

509− cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs

518+solveTypeConstraints (RowConstraint n r o:cs) s = do

519+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do

520+ rowOccursCheck n r

521+ let s' = let (f, g) = runTypeSolution s

522+ in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)

523+ cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs

524+ return (cs', s')

510525 solveTypeConstraints cs' s'

511526

512527substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]

513−substituteTypeInConstraint n s (TypeConstraint m t)

514− | n == m = unifyTypes s t

515− | otherwise = return [TypeConstraint m (replaceType n s t)]

516−substituteTypeInConstraint n s (RowConstraint m r)

517− = return [RowConstraint m (replaceType n s r)]

528+substituteTypeInConstraint n s (TypeConstraint m t v)

529+ | n == m = unifyTypes v s t

530+ | otherwise = return [TypeConstraint m (replaceType n s t) v]

531+substituteTypeInConstraint n s (RowConstraint m r v)

532+ = return [RowConstraint m (replaceType n s r) v]

518533

519534substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]

520−substituteRowInConstraint n r (TypeConstraint m t)

521− = return [TypeConstraint m (replaceRow n r t)]

522−substituteRowInConstraint n r (RowConstraint m r1)

523− | m == n = unifyRows r r1

524− | otherwise = return [RowConstraint m (replaceRow n r r1)]

525−

526−unifyTypes :: Type -> Type -> Check [TypeConstraint]

527−unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

528−unifyTypes (TUnknown u) t = do

535+substituteRowInConstraint n r (TypeConstraint m t v)

536+ = return [TypeConstraint m (replaceRow n r t) v]

537+substituteRowInConstraint n r (RowConstraint m r1 v)

538+ | m == n = unifyRows v r r1

539+ | otherwise = return [RowConstraint m (replaceRow n r r1) v]

540+

541+unifyTypes :: TypeConstraintOrigin -> Type -> Type -> Check [TypeConstraint]

542+unifyTypes _ (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

543+unifyTypes o (TUnknown u) t = do

529544 typeOccursCheck u t

530− return [TypeConstraint u t]

531−unifyTypes t (TUnknown u) = do

545+ return [TypeConstraint u t o]

546+unifyTypes o t (TUnknown u) = do

532547 typeOccursCheck u t

533− return [TypeConstraint u t]

534−unifyTypes (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =

535− fmap concat $ zipWithM unifyTypes args1 args2

536−unifyTypes (SaturatedTypeSynonym name args) ty = do

548+ return [TypeConstraint u t o]

549+unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =

550+ fmap concat $ zipWithM (unifyTypes o) args1 args2

551+unifyTypes o (SaturatedTypeSynonym name args) ty = do

537552 env <- getEnv

538553 case M.lookup name (typeSynonyms env) of

539554 Just (synArgs, body) -> do

540555 let m = M.fromList $ zip synArgs args

541556 let replaced = replaceTypeVars m body

542− unifyTypes replaced ty

557+ unifyTypes o replaced ty

543558 Nothing -> error "Type synonym was not defined"

544−unifyTypes ty s@(SaturatedTypeSynonym _ _) = unifyTypes s ty

545−unifyTypes Number Number = return []

546−unifyTypes String String = return []

547−unifyTypes Boolean Boolean = return []

548−unifyTypes (Array s) (Array t) = unifyTypes s t

549−unifyTypes (Object row1) (Object row2) = unifyRows row1 row2

550−unifyTypes (Function args1 ret1) (Function args2 ret2) = do

559+unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty

560+unifyTypes _ Number Number = return []

561+unifyTypes _ String String = return []

562+unifyTypes _ Boolean Boolean = return []

563+unifyTypes o (Array s) (Array t) = unifyTypes o s t

564+unifyTypes o (Object row1) (Object row2) = unifyRows o row1 row2

565+unifyTypes o (Function args1 ret1) (Function args2 ret2) = do

551566 guardWith "Function applied to incorrect number of args" $ length args1 == length args2

552− cs1 <- fmap concat $ zipWithM unifyTypes args1 args2

553− cs2 <- unifyTypes ret1 ret2

567+ cs1 <- fmap concat $ zipWithM (unifyTypes o) args1 args2

568+ cs2 <- unifyTypes o ret1 ret2

554569 return $ cs1 ++ cs2

555−unifyTypes (TypeVar v1) (TypeVar v2) | v1 == v2 = return []

556−unifyTypes (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []

557−unifyTypes (TypeVar v1) (TypeVar v2) = return []

558−unifyTypes (TypeApp t1 t2) (TypeApp t3 t4) = do

559− cs1 <- unifyTypes t1 t3

560− cs2 <- unifyTypes t2 t4

570+unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []

571+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []

572+unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do

573+ cs1 <- unifyTypes o t1 t3

574+ cs2 <- unifyTypes o t2 t4

561575 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 ++ "."

563577

564−unifyRows :: Row -> Row -> Check [TypeConstraint]

565−unifyRows r1 r2 =

578+unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

579+unifyRows o r1 r2 =

566580 let

567581 (s1, r1') = toList r1

568582 (s2, r2') = toList r2

569583 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

570584 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

571585 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

573− cs1 <- fmap concat $ mapM (uncurry unifyTypes) int

574− cs2 <- unifyRows' sd1 r1' sd2 r2'

586+ in do

587+ cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int

588+ cs2 <- unifyRows' o sd1 r1' sd2 r2'

575589 return $ cs1 ++ cs2

576590 where

577− unifyRows' :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

578− unifyRows' [] (RUnknown u) sd r = do

591+ unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

592+ unifyRows' o [] (RUnknown u) sd r = do

579593 rowOccursCheck u r

580− return [RowConstraint u (fromList (sd, r))]

581− unifyRows' sd r [] (RUnknown u) = do

594+ return [RowConstraint u (fromList (sd, r)) o]

595+ unifyRows' o sd r [] (RUnknown u) = do

582596 rowOccursCheck u r

583− return [RowConstraint u (fromList (sd, r))]

584− unifyRows' ((name, ty):row) r others (RUnknown u) = do

597+ return [RowConstraint u (fromList (sd, r)) o]

598+ unifyRows' o ((name, ty):row) r others (RUnknown u) = do

585599 u' <- fresh

586− cs <- unifyRows' row r others (RUnknown u')

587− return (RowConstraint u (RCons name ty (RUnknown u')) : cs)

588− unifyRows' [] REmpty [] REmpty = return []

589− unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."

600+ cs <- unifyRows' o row r others (RUnknown u')

601+ return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)

602+ unifyRows' _ [] REmpty [] REmpty = return []

603+ unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."

590604 toList :: Row -> ([(String, Type)], Row)

591605 toList (RCons name ty row) = let (tys, rest) = toList row

592606 in ((name, ty):tys, rest)