ae6037f · rowtype-yoga/purescript-native

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

on golang help sign in

Better code gen, better support for arrays, more patterns, more examples.

ae6037fPhil Freeman13 years ago

README.md+2−3

compare with golang

unifiedsplit

@@ -13,14 +13,13 @@ A small strongly, statically typed compile-to-JS language with basic extensible

14## TODO

16−- Array indexing

16+- IfThenElse expressions

17+- Accessors and indices in assignments

17- Type Synonyms

18- Type Synonyms

18−- Better code generation, fewer parens

19- User defined operators

20- Mutually recursive functions

21- Modules

22- FFI

23- Top level pattern matching

24−- Pattern matching booleans

25- Guards

24- Guards

26- Type classes

25- Type classes

examples/Arrays.psnew file+16

@@ -0,0 +1,16 @@

1+test1 = \arr -> arr[0] + arr[1]

3+test2 = \arr -> case arr of

4+ { [x, y] -> x + y

5+ ; [x] -> x

6+ ; [] -> 0

7+ ; [x, y : _] -> x + y

8+ }

10+data Tree = One Number | Some [Tree]

11+

12+test3 = \tree, sum -> case tree of

13+ { One n -> n

14+ ; Some [n1, n2 : rest] -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)

15+ }

16+

examples/Objects.psnew file+1

@@ -0,0 +1 @@

1+test = \x, f -> f(x.foo, x.bar)

examples/Operators.psnew file+5

@@ -0,0 +1,5 @@

1+test1 = \x, y, z -> x * y + z(x)(y)

3+test2 = (\x -> (x.foo)(false))({ foo : \_ -> 1 })

5+test3 = (\x, y -> x)(1 + 2 * (1 + 2), true && (false || false))

examples/Patterns.psnew file+5

@@ -0,0 +1,5 @@

1+test = \x -> case x of

2+ { { str = "Foo", bool = true } -> true

3+ ; { str = "Bar", bool = b } -> b

4+ ; _ -> false

5+ }

src/PureScript/CodeGen.hs+209−43

@@ -12,14 +12,90 @@

12--

13-----------------------------------------------------------------------------

15+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}

16+

15module PureScript.CodeGen (

17module PureScript.CodeGen (

16 declToJs

18 declToJs

17) where

19) where

21+import Data.Maybe (fromMaybe)

19import Data.List (nub, intersperse, intercalate)

22import Data.List (nub, intersperse, intercalate)

23+import Data.Function (fix)

24+import Control.Monad.State

25+import Control.Applicative (Applicative(..), Alternative(..))

26+import qualified Control.Category as C

27+import Control.Category ((>>>))

28+import qualified Control.Arrow as A

29+import Control.Arrow ((***))

30+

20import PureScript.Values

31import PureScript.Values

21import PureScript.Declarations

32import PureScript.Declarations

34+-- First Order Patterns

35+

36+newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)

37+

38+pattern :: Pattern a b -> a -> Maybe b

39+pattern = A.runKleisli . runPattern

40+

41+instance Functor (Pattern a) where

42+ fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p

43+

44+instance Applicative (Pattern a) where

45+ pure = Pattern . A.Kleisli . const . pure

46+ f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a

47+

48+instance Alternative (Pattern a) where

49+ empty = Pattern $ A.Kleisli $ \a -> empty

50+ (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a

51+

52+parens :: String -> String

53+parens s = ('(':s) ++ ")"

54+

55+chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

56+chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p

57+

58+chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

59+chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p

60+

61+wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r

62+wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p

63+

64+split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r

65+split s f p = (s >>> A.arr (uncurry f)) <|> p

66+

67+data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }

68+

69+data Operator a r where

70+ AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r

71+ AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r

72+ Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r

73+ Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r

74+

75+buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r

76+buildPrettyPrinter table p = foldl (\p' op ->

77+ case op of

78+ AssocL pat g -> chainl pat g p'

79+ AssocR pat g -> chainr pat g p'

80+ Wrap pat g -> wrap pat g p'

81+ Split pat g -> split pat g p'

82+ ) p $ runOperatorTable table

83+

84+-- Variable Name Generation

85+

86+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Monad, MonadState Int)

87+

88+runGen :: Gen a -> a

89+runGen = flip evalState 0 . unGen

90+

91+fresh :: Gen String

92+fresh = do

93+ n <- get

94+ modify (+ 1)

95+ return $ "_" ++ show n

96+

97+-- Pretty Printing

98+

23declToJs :: Declaration -> Maybe String

99declToJs :: Declaration -> Maybe String

24declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"

100declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"

25declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =

101declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =

@@ -29,27 +105,102 @@ declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =

29 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"

105 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"

30declToJs _ = Nothing

106declToJs _ = Nothing

107

108+literals :: Pattern Value String

109+literals = Pattern $ A.Kleisli match

110+ where

111+ match (NumericLiteral n) = Just $ either show show n

112+ match (StringLiteral s) = Just $ show s

113+ match (BooleanLiteral True) = Just "true"

114+ match (BooleanLiteral False) = Just "false"

115+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"

116+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"

117+ match (Constructor name) = Just name

118+ match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

119+ match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"

120+ where

121+ bindersToJs :: [(Binder, Value)] -> Gen String

122+ bindersToJs binders = do

123+ valName <- fresh

124+ jss <- flip mapM binders $ \(binder, result) -> do

125+ let js = valueToJs result

126+ binderToJs valName ("return " ++ js ++ ";") binder

127+ return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"

128+ match (Var ident) = Just ident

129+ match _ = Nothing

130+

131+accessor :: Pattern Value (String, Value)

132+accessor = Pattern $ A.Kleisli match

133+ where

134+ match (Accessor prop val) = Just (prop, val)

135+ match _ = Nothing

136+

137+indexer :: Pattern Value (String, Value)

138+indexer = Pattern $ A.Kleisli match

139+ where

140+ match (Indexer index val) = Just (valueToJs index, val)

141+ match _ = Nothing

142+

143+app :: Pattern Value (String, Value)

144+app = Pattern $ A.Kleisli match

145+ where

146+ match (App val args) = Just (intercalate "," (map valueToJs args), val)

147+ match _ = Nothing

148+

149+lam :: Pattern Value ([String], Value)

150+lam = Pattern $ A.Kleisli match

151+ where

152+ match (Abs args val) = Just (args, val)

153+ match _ = Nothing

154+

155+unary :: UnaryOperator -> String -> Operator Value String

156+unary op str = Wrap pattern (++)

157+ where

158+ pattern :: Pattern Value (String, Value)

159+ pattern = Pattern $ A.Kleisli match

160+ where

161+ match (Unary op' val) | op' == op = Just (str, val)

162+ match _ = Nothing

163+

164+binary :: BinaryOperator -> String -> Operator Value String

165+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

166+ where

167+ pattern :: Pattern Value (Value, Value)

168+ pattern = Pattern $ A.Kleisli match

169+ where

170+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)

171+ match _ = Nothing

172+

32valueToJs :: Value -> String

173valueToJs :: Value -> String

33−valueToJs (NumericLiteral n) = show n

174+valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

34−valueToJs (StringLiteral s) = show s

175+ where

35−valueToJs (BooleanLiteral True) = "true"

176+ matchValue :: Pattern Value String

36−valueToJs (BooleanLiteral False) = "false"

177+ matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)

37−valueToJs (Unary op value) = unaryOperatorString op ++ "(" ++ valueToJs value ++ ")"

178+ operators :: OperatorTable Value String

38−valueToJs (Binary op left right) = "(" ++ valueToJs left ++ ") " ++ binaryOperatorString op ++ " (" ++ valueToJs right ++ ")"

179+ operators =

39−valueToJs (ArrayLiteral xs) = "[" ++ intercalate "," (map valueToJs xs) ++ "]"

180+ OperatorTable $ [ Wrap accessor $ \prop val -> val ++ "." ++ prop

40−valueToJs (ObjectLiteral ps) = "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"

181+ , Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]"

41−valueToJs (Accessor prop val) = "(" ++ valueToJs val ++ ")." ++ prop

182+ , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"

42−valueToJs (Abs args value) = "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs value ++ "; }"

183+ , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"

43−valueToJs (Var ident) = ident

184+ , unary Not "!"

44−valueToJs (App f xs) = "(" ++ valueToJs f ++ ") (" ++ intercalate "," (map valueToJs xs) ++ ")"

185+ , unary BitwiseNot "~"

45−valueToJs (Block sts) = "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

186+ , unary Negate "-"

46−valueToJs (Constructor name) = name

187+ , binary Multiply "*"

47−valueToJs (Case value binders) =

188+ , binary Divide "/"

48− "(function (_0) {"

189+ , binary Modulus "%"

49− ++ concatMap (\(b, val) -> fst $ binderToJs 0 0 b $ "return " ++ valueToJs val ++ ";") binders

190+ , binary Concat "++"

50− ++ "throw \"Failed pattern match\";"

191+ , binary Add "+"

51− ++ "})(" ++ valueToJs value ++ ")"

192+ , binary Subtract "-"

52−valueToJs (TypedValue value _) = valueToJs value

193+ , binary ShiftLeft "<<"

194+ , binary ShiftRight ">>"

195+ , binary ZeroFillShiftRight ">>>"

196+ , binary EqualTo "==="

197+ , binary NotEqualTo "!=="

198+ , binary BitwiseAnd "&"

199+ , binary BitwiseXor "^"

200+ , binary BitwiseOr "|"

201+ , binary And "&&"

202+ , binary Or "||"

203+ ]

204

54unaryOperatorString :: UnaryOperator -> String

205unaryOperatorString :: UnaryOperator -> String

55unaryOperatorString Negate = "-"

206unaryOperatorString Negate = "-"

@@ -78,31 +229,46 @@ binaryOperatorString And = "&&"

78binaryOperatorString Or = "||"

229binaryOperatorString Or = "||"

79binaryOperatorString Concat = "+"

230binaryOperatorString Concat = "+"

231

81−binderToJs :: Int -> Int -> Binder -> String -> (String, Int)

232+binderToJs :: String -> String -> Binder -> Gen String

233+binderToJs varName done (StringBinder str) =

234+ return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"

235+binderToJs varName done (NumberBinder num) =

236+ return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"

237+binderToJs varName done (BooleanBinder True) =

238+ return $ "if (" ++ varName ++ ") {" ++ done ++ " }"

239+binderToJs varName done (BooleanBinder False) =

240+ return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"

82−binderToJs varName fresh (VarBinder s) done = ("var " ++ s ++ " = _" ++ show varName ++ "; " ++ done, fresh)

241+binderToJs varName done (VarBinder s) =

242+ return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done

83−binderToJs varName fresh (NullaryBinder ctor) done =

243+binderToJs varName done (NullaryBinder ctor) =

84− ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"

244+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"

85− ++ done

86− ++ "}", fresh)

87−binderToJs varName fresh (UnaryBinder ctor b) done =

245+binderToJs varName done (UnaryBinder ctor b) = do

246+ value <- fresh

247+ js <- binderToJs value done b

88− ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"

248+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"

89− ++ "var _" ++ show fresh' ++ " = _" ++ show varName ++ ".value;"

249+binderToJs varName done (ObjectBinder bs) = go done bs

90− ++ js

91− ++ "}", fresh'')

92 where

250 where

93− fresh' = succ fresh

251+ go done [] = return done

94− (js, fresh'') = binderToJs fresh' fresh' b done

252+ go done ((prop, binder):bs) = do

95−binderToJs varName fresh (ObjectBinder bs) done = go fresh bs done

253+ propVar <- fresh

254+ done' <- go done bs

255+ js <- binderToJs propVar done' binder

256+ return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js

257+binderToJs done varName (ArrayBinder bs rest) = do

258+ js <- go done rest 0 bs

259+ return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"

96 where

260 where

97− go fresh [] done = (done, fresh)

261+ cmp = maybe "===" (const ">=") rest

262+ go done Nothing _ [] = return done

263+ go done (Just binder) index [] = do

264+ restVar <- fresh

265+ js <- binderToJs restVar done binder

266+ return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js

98− go fresh ((prop, binder):bs') done =

267+ go done rest index (binder:bs) = do

99− ( "var _" ++ show fresh' ++ " = _" ++ show varName ++ "." ++ prop ++ ";"

268+ elVar <- fresh

100− ++ js

269+ done' <- go done rest (index + 1) bs

101− , fresh''')

270+ js <- binderToJs elVar done' binder

102− where

271+ return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js

103− fresh' = succ fresh

104− (done', fresh'') = go fresh' bs' done

105− (js, fresh''') = binderToJs fresh' fresh'' binder done'

106

272

107objectPropertyToJs :: (String, Value) -> String

273objectPropertyToJs :: (String, Value) -> String

108objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

274objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

src/PureScript/Parser/Values.hs+42−23

@@ -26,15 +26,17 @@ import Control.Arrow (Arrow(..))

26import PureScript.Parser.Types

27import PureScript.Types

29+booleanLiteral :: P.Parsec String () Bool

30+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

31+

29parseNumericLiteral :: P.Parsec String () Value

32parseNumericLiteral :: P.Parsec String () Value

30−parseNumericLiteral = NumericLiteral <$> either fromIntegral id <$> C.naturalOrFloat

33+parseNumericLiteral = NumericLiteral <$> C.naturalOrFloat

32parseStringLiteral :: P.Parsec String () Value

35parseStringLiteral :: P.Parsec String () Value

33parseStringLiteral = StringLiteral <$> C.stringLiteral

36parseStringLiteral = StringLiteral <$> C.stringLiteral

35parseBooleanLiteral :: P.Parsec String () Value

38parseBooleanLiteral :: P.Parsec String () Value

36−parseBooleanLiteral = BooleanLiteral <$> ((P.string "true" >> return True)

39+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

37− P.<|> (P.string "false" >> return False))

39parseArrayLiteral :: P.Parsec String () Value

41parseArrayLiteral :: P.Parsec String () Value

40parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)

42parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)

@@ -51,8 +53,8 @@ parseIdentifierAndValue = do

52parseAbs :: P.Parsec String () Value

54parseAbs :: P.Parsec String () Value

53parseAbs = do

55parseAbs = do

54− P.char '\\'

56+ C.lexeme $ P.char '\\'

55− args <- C.commaSep1 C.identifier

57+ args <- C.commaSep C.identifier

56 C.lexeme $ P.string "->"

58 C.lexeme $ P.string "->"

57 value <- parseValue

59 value <- parseValue

58 return $ Abs args value

60 return $ Abs args value

@@ -93,26 +95,27 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

93 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

95 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

94 funArgs = C.parens $ C.commaSep parseValue

96 funArgs = C.parens $ C.commaSep parseValue

95 parseTypeAnnotation = C.lexeme (P.string "::") *> parseType

97 parseTypeAnnotation = C.lexeme (P.string "::") *> parseType

96− operators = [ [ Postfix $ (Accessor <$> (C.dot *> C.identifier)) ]

98+ operators = [ [ Postfix $ Accessor <$> (C.dot *> C.identifier)

97− , [ Infix (C.lexeme (P.try (P.string "||")) >> return (Binary Or)) AssocRight ]

99+ , Postfix $ Indexer <$> C.squares parseValue ]

98− , [ Infix (C.lexeme (P.try (P.string "&&")) >> return (Binary And)) AssocRight ]

99− , [ Infix (C.lexeme (P.char '|') >> return (Binary BitwiseOr)) AssocRight ]

100− , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]

101− , [ Infix (C.lexeme (P.char '&') >> return (Binary BitwiseAnd)) AssocRight ]

102− , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight

103− , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]

104− , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight

105− , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight

106− , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]

107− , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight

108− , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight

109− , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]

110− , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight

111− , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight

112− , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]

113 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)

100 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)

114 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)

101 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)

115 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]

102 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]

103+ , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight

104+ , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight

105+ , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]

106+ , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight

107+ , Infix (C.lexeme (P.char '+') >> return (Binary Add)) AssocRight

108+ , Infix (C.lexeme (P.char '-') >> return (Binary Subtract)) AssocRight ]

109+ , [ Infix (C.lexeme (P.string "<<") >> return (Binary ShiftLeft)) AssocRight

110+ , Infix (C.lexeme (P.try (P.string ">>>")) >> return (Binary ZeroFillShiftRight)) AssocRight

111+ , Infix (C.lexeme (P.string ">>") >> return (Binary ShiftRight)) AssocRight ]

112+ , [ Infix (C.lexeme (P.string "==") >> return (Binary EqualTo)) AssocRight

113+ , Infix (C.lexeme (P.try (P.string "!=")) >> return (Binary NotEqualTo)) AssocRight ]

114+ , [ Infix (C.lexeme (P.try (P.char '&' <* P.notFollowedBy (P.char '&'))) >> return (Binary BitwiseAnd)) AssocRight ]

115+ , [ Infix (C.lexeme (P.char '^') >> return (Binary BitwiseXor)) AssocRight ]

116+ , [ Infix (C.lexeme (P.try (P.char '|' <* P.notFollowedBy (P.char '|'))) >> return (Binary BitwiseOr)) AssocRight ]

117+ , [ Infix (C.lexeme (P.string "&&") >> return (Binary And)) AssocRight ]

118+ , [ Infix (C.lexeme (P.string "||") >> return (Binary Or)) AssocRight ]

116 ]

119 ]

117

120

118parseVariableIntroduction :: P.Parsec String () Statement

121parseVariableIntroduction :: P.Parsec String () Statement

@@ -165,6 +168,15 @@ parseStatement = P.choice $ map P.try

165 , parseIfThenElse

168 , parseIfThenElse

166 , parseReturn ]

169 , parseReturn ]

167

170

171+parseStringBinder :: P.Parsec String () Binder

172+parseStringBinder = StringBinder <$> C.stringLiteral

173+

174+parseBooleanBinder :: P.Parsec String () Binder

175+parseBooleanBinder = BooleanBinder <$> booleanLiteral

176+

177+parseNumberBinder :: P.Parsec String () Binder

178+parseNumberBinder = NumberBinder <$> C.naturalOrFloat

179+

168parseVarBinder :: P.Parsec String () Binder

180parseVarBinder :: P.Parsec String () Binder

169parseVarBinder = VarBinder <$> C.lexeme C.identifier

181parseVarBinder = VarBinder <$> C.lexeme C.identifier

170

182

@@ -177,6 +189,9 @@ parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder

177parseObjectBinder :: P.Parsec String () Binder

189parseObjectBinder :: P.Parsec String () Binder

178parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)

190parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)

179

191

192+parseArrayBinder :: P.Parsec String () Binder

193+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep parseBinder) <*> P.optionMaybe (C.colon *> parseBinder)

194+

180parseIdentifierAndBinder :: P.Parsec String () (String, Binder)

195parseIdentifierAndBinder :: P.Parsec String () (String, Binder)

181parseIdentifierAndBinder = do

196parseIdentifierAndBinder = do

182 name <- C.lexeme C.identifier

197 name <- C.lexeme C.identifier

@@ -186,8 +201,12 @@ parseIdentifierAndBinder = do

186

201

187parseBinder :: P.Parsec String () Binder

202parseBinder :: P.Parsec String () Binder

188parseBinder = P.choice $ map P.try

203parseBinder = P.choice $ map P.try

204+ [ parseStringBinder

205+ , parseBooleanBinder

206+ , parseNumberBinder

189− [ parseVarBinder

207+ , parseVarBinder

190 , parseUnaryBinder

208 , parseUnaryBinder

191 , parseNullaryBinder

209 , parseNullaryBinder

192 , parseObjectBinder

210 , parseObjectBinder

211+ , parseArrayBinder

193 , C.parens parseBinder ]

212 , C.parens parseBinder ]

src/PureScript/TypeChecker.hs+6−6

@@ -46,24 +46,24 @@ typeCheck (DataDeclaration dcs@(DataConstructors

46 , typeArguments = args

47 , dataConstructors = ctors

48 })) = rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

49− env <- get

49+ env <- getEnv

50 guardWith (name ++ " is already defined") $ not $ M.member name (types env)

51 ctorKind <- kindsOf name args (catMaybes $ map snd ctors)

52− put $ env { types = M.insert name ctorKind (types env) }

52+ putEnv $ env { types = M.insert name ctorKind (types env) }

53 flip mapM_ ctors $ \(dctor, maybeTy) ->

54 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

55− env' <- get

55+ env' <- getEnv

56 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor

57 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)

58 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

59− put $ env' { names = M.insert dctor dctorTy (names env') }

59+ putEnv $ env' { names = M.insert dctor dctorTy (names env') }

60typeCheck (ValueDeclaration name val) = rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do

61− env <- get

61+ env <- getEnv

62 case M.lookup name (names env) of

63 Just ty -> throwError $ name ++ " is already defined"

64 Nothing -> do

65 ty <- typeOf name val

66− put (env { names = M.insert name ty (names env) })

66+ putEnv (env { names = M.insert name ty (names env) })

68typeCheckAll :: [Declaration] -> Check ()

69typeCheckAll = mapM_ typeCheck

src/PureScript/TypeChecker/Kinds.hs+67−57

@@ -47,71 +47,81 @@ emptyKindSolution = KindSolution KUnknown

48kindsOf :: String -> [String] -> [Type] -> Check Kind

49kindsOf name args ts = do

50− let tyCon = 0

50+ tyCon <- fresh

51− let nargs = [1..length args]

51+ nargs <- replicateM (length args) fresh

52− (cs, ns, _, m) <- kindConstraintsAll (length args + 1) (M.insert name tyCon $ M.fromList (zipWith (,) args nargs)) ts

52+ (cs, ns, m) <- kindConstraintsAll (M.insert name tyCon $ M.fromList (zipWith (,) args nargs)) ts

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

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

55− return $ starIfUnknown $ runKindSolution solution 0

55+ return $ starIfUnknown $ runKindSolution solution tyCon

57starIfUnknown :: Kind -> Kind

58starIfUnknown (KUnknown _) = Star

59starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

60starIfUnknown k = k

62−kindConstraintsAll :: Int -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], Int, M.Map String Int)

62+kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)

63−kindConstraintsAll n m [] = return ([], [], n, m)

63+kindConstraintsAll m [] = return ([], [], m)

64−kindConstraintsAll n m (t:ts) = do

64+kindConstraintsAll m (t:ts) = do

65− (cs, n1, max1, m') <- kindConstraints n m t

65+ (cs, n1, m') <- kindConstraints m t

66− (cs', ns, max2, m'') <- kindConstraintsAll (max1 + 1) m' ts

66+ (cs', ns, m'') <- kindConstraintsAll m' ts

67− return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, max2, m'')

67+ return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, m'')

68−

68+

69−kindConstraints :: Int -> M.Map String Int -> Type -> Check ([KindConstraint], Int, Int, M.Map String Int)

69+kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)

70−kindConstraints n m (Array t) = do

70+kindConstraints m (Array t) = do

71− let me = n

71+ me <- fresh

72− (cs, n1, max1, m') <- kindConstraints (n + 1) m t

72+ (cs, n1, m') <- kindConstraints m t

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

73+ return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, m')

74−kindConstraints n m (Object row) = do

74+kindConstraints m (Object row) = do

75− let me = n

75+ me <- fresh

76− (cs, row, max1, m') <- kindConstraintsForRow (n + 1) m row

76+ (cs, row, m') <- kindConstraintsForRow m row

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

77+ return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, m')

78−kindConstraints n m (Function args ret) = do

78+kindConstraints m (Function args ret) = do

79− let me = n

79+ me <- fresh

80− (cs, ns, max1, m') <- kindConstraintsAll (n + 1) m args

80+ (cs, ns, m') <- kindConstraintsAll m args

81− (cs', retN, max2, m'') <- kindConstraints (max1 + 1) m' ret

81+ (cs', retN, m'') <- kindConstraints m' ret

82− return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs, me, max2, m'')

82+ return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs, me, m'')

83−kindConstraints n m (TypeVar v) =

83+kindConstraints m (TypeVar v) = do

84− let n' = maybe n id (M.lookup v m)

84+ me <- case M.lookup v m of

85+ Just u -> return u

86+ Nothing -> fresh

85− in return ([], n', n, M.insert v n' m)

87+ return ([], me, M.insert v me m)

86−kindConstraints n m (TypeConstructor v) = do

88+kindConstraints m (TypeConstructor v) = do

87− env <- get

89+ env <- getEnv

90+ me <- fresh

88− kind <- case M.lookup v m of

91+ case M.lookup v m of

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

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

90 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"

93 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"

91− Just k -> return k

94+ Just kind -> return ([KindConstraint me kind], me, m)

92− Just u -> return (KUnknown u)

95+ Just u -> do

93− return ([KindConstraint n kind], n, n, m)

96+ return ([KindConstraint me (KUnknown u)], me, m)

94−kindConstraints n m (TypeApp t1 t2) = do

97+kindConstraints m (TypeApp t1 t2) = do

95− let me = n

98+ me <- fresh

96− (cs1, n1, max1, m1) <- kindConstraints (n + 1) m t1

99+ (cs1, n1, m1) <- kindConstraints m t1

97− (cs2, n2, max2, m2) <- kindConstraints (max1 + 1) m1 t2

100+ (cs2, n2, m2) <- kindConstraints m1 t2

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

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

102+kindConstraints m _ = do

103+ me <- fresh

99−kindConstraints n m _ = return ([KindConstraint n Star], n, n, m)

104+ return ([KindConstraint me Star], me, m)

100−

105+

101−kindConstraintsForRow :: Int -> M.Map String Int -> Row -> Check ([KindConstraint], Int, Int, M.Map String Int)

106+kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)

102−kindConstraintsForRow n m (RowVar v) =

107+kindConstraintsForRow m (RowVar v) = do

103− let n' = maybe n id (M.lookup v m)

108+ me <- case M.lookup v m of

109+ Just u -> return u

110+ Nothing -> fresh

104− in return ([KindConstraint n' Row], n', n, M.insert v n' m)

111+ return ([KindConstraint me Row], me, M.insert v me m)

105−kindConstraintsForRow n m REmpty = return ([KindConstraint n Row], n, n, m)

112+kindConstraintsForRow m REmpty = do

113+ me <- fresh

114+ return ([KindConstraint me Row], me, m)

106−kindConstraintsForRow n m (RCons _ ty row) = do

115+kindConstraintsForRow m (RCons _ ty row) = do

116+ me <- fresh

107− (cs1, n1, max1, m1) <- kindConstraints (n + 1) m ty

117+ (cs1, n1, m1) <- kindConstraints m ty

108− (cs2, n2, max2, m2) <- kindConstraintsForRow (max1 + 1) m1 row

118+ (cs2, n2, m2) <- kindConstraintsForRow m1 row

109− return ((KindConstraint n Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, n, max2, m2)

119+ return ((KindConstraint me Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, me, m2)

110

120

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

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

112solveKindConstraints [] s = return s

122solveKindConstraints [] s = return s

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

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

114− guardWith "Occurs check failed" $ not $ kindOccursCheck n k

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

115 let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

125 let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

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

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

117 solveKindConstraints cs' s'

127 solveKindConstraints cs' s'

@@ -131,10 +141,10 @@ replaceUnknownKind n k = f

131unifyKinds :: Kind -> Kind -> Check [KindConstraint]

141unifyKinds :: Kind -> Kind -> Check [KindConstraint]

132unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

142unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

133unifyKinds (KUnknown u) k = do

143unifyKinds (KUnknown u) k = do

134− guardWith "Occurs check failed" $ not $ kindOccursCheck u k

144+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

135 return [KindConstraint u k]

145 return [KindConstraint u k]

136unifyKinds k (KUnknown u) = do

146unifyKinds k (KUnknown u) = do

137− guardWith "Occurs check failed" $ not $ kindOccursCheck u k

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

138 return [KindConstraint u k]

148 return [KindConstraint u k]

139unifyKinds Star Star = return []

149unifyKinds Star Star = return []

140unifyKinds Row Row = return []

150unifyKinds Row Row = return []

@@ -144,7 +154,7 @@ unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do

144 return $ cs1 ++ cs2

154 return $ cs1 ++ cs2

145unifyKinds k1 k2 = throwError $ "Cannot unify " ++ show k1 ++ " with " ++ show k2 ++ "."

155unifyKinds k1 k2 = throwError $ "Cannot unify " ++ show k1 ++ " with " ++ show k2 ++ "."

146

156

147−kindOccursCheck :: Int -> Kind -> Bool

157+kindOccursCheck :: Bool -> Int -> Kind -> Bool

148−kindOccursCheck u (KUnknown u') | u == u' = True

158+kindOccursCheck b u (KUnknown u') | u == u' = b

149−kindOccursCheck u (FunKind k1 k2) = kindOccursCheck u k1 || kindOccursCheck u k2

159+kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2

150−kindOccursCheck _ _ = False

160+kindOccursCheck _ _ _ = False

src/PureScript/TypeChecker/Monad.hs+16−2

@@ -23,6 +23,8 @@ import Control.Applicative

23import Control.Monad.State

24import Control.Monad.Error

26+import Control.Arrow ((***))

27+

26import qualified Data.Map as M

28import qualified Data.Map as M

28data Environment = Environment

30data Environment = Environment

@@ -33,10 +35,22 @@ data Environment = Environment

33emptyEnvironment :: Environment

35emptyEnvironment :: Environment

34emptyEnvironment = Environment M.empty M.empty

36emptyEnvironment = Environment M.empty M.empty

36−newtype Check a = Check { unCheck :: StateT Environment (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState Environment, MonadError String)

38+newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)

39+

40+getEnv :: Check Environment

41+getEnv = fmap fst get

42+

43+putEnv :: Environment -> Check ()

44+putEnv env = fmap (const env *** id) get >>= put

45+

46+fresh :: Check Int

47+fresh = do

48+ (env, n) <- get

49+ put (env, n + 1)

50+ return n

38check :: Check a -> Either String (a, Environment)

52check :: Check a -> Either String (a, Environment)

39−check = flip runStateT emptyEnvironment . unCheck

53+check = fmap (id *** fst) . flip runStateT (emptyEnvironment, 0) . unCheck

41guardWith :: (MonadError e m) => e -> Bool -> m ()

55guardWith :: (MonadError e m) => e -> Bool -> m ()

42guardWith _ True = return ()

56guardWith _ True = return ()

src/PureScript/TypeChecker/Types.hs+206−176

@@ -18,8 +18,6 @@ module PureScript.TypeChecker.Types (

18 typeOf

19) where

21−import Debug.Trace

22−

23import Data.List

21import Data.List

24import Data.Function

22import Data.Function

@@ -31,7 +29,7 @@ import Control.Monad.State

31import Control.Monad.Error

29import Control.Monad.Error

33import Control.Applicative

31import Control.Applicative

34−import Control.Arrow (Kleisli(..), (***))

32+import Control.Arrow (Kleisli(..), (***), (&&&))

35import qualified Control.Category as C

33import qualified Control.Category as C

37import qualified Data.Map as M

35import qualified Data.Map as M

@@ -47,8 +45,8 @@ emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

48typeOf :: String -> Value -> Check Type

46typeOf :: String -> Value -> Check Type

49typeOf name val = do

47typeOf name val = do

50− let me = 0

48+ me <- fresh

51− (cs, n, _) <- typeConstraints 1 (M.singleton name me) val

49+ (cs, n) <- typeConstraints (M.singleton name me) val

52 solution <- solveTypeConstraints ((TypeConstraint me (TUnknown n)) : cs) emptyTypeSolution

50 solution <- solveTypeConstraints ((TypeConstraint me (TUnknown n)) : cs) emptyTypeSolution

53 return $ varIfUnknown $ fst (runTypeSolution solution) n

51 return $ varIfUnknown $ fst (runTypeSolution solution) n

@@ -81,103 +79,124 @@ varIfUnknown = flip evalState M.empty . varIfUnknown'

81 varIfUnknown'' (RCons name ty row) = RCons name ty <$> varIfUnknown'' row

79 varIfUnknown'' (RCons name ty row) = RCons name ty <$> varIfUnknown'' row

82 varIfUnknown'' r = return r

80 varIfUnknown'' r = return r

84−replaceVarsWithUnknowns :: Int -> Type -> (Type, Int)

82+replaceVarsWithUnknowns :: Type -> Check Type

85−replaceVarsWithUnknowns n = (id *** fst) . flip runState (n, M.empty) . replaceVarsWithUnknowns'

83+replaceVarsWithUnknowns = flip evalStateT M.empty . replaceVarsWithUnknowns'

86 where

84 where

87− replaceVarsWithUnknowns' :: Type -> State (Int, M.Map String Int) Type

85+ replaceVarsWithUnknowns' :: Type -> StateT (M.Map String Int) Check Type

88 replaceVarsWithUnknowns' (Array t) = Array <$> replaceVarsWithUnknowns' t

86 replaceVarsWithUnknowns' (Array t) = Array <$> replaceVarsWithUnknowns' t

89 replaceVarsWithUnknowns' (Object row) = Object <$> replaceVarsWithUnknowns'' row

87 replaceVarsWithUnknowns' (Object row) = Object <$> replaceVarsWithUnknowns'' row

90 replaceVarsWithUnknowns' (Function args ret) = Function <$> mapM replaceVarsWithUnknowns' args <*> replaceVarsWithUnknowns' ret

88 replaceVarsWithUnknowns' (Function args ret) = Function <$> mapM replaceVarsWithUnknowns' args <*> replaceVarsWithUnknowns' ret

91 replaceVarsWithUnknowns' (TypeApp t1 t2) = TypeApp <$> replaceVarsWithUnknowns' t1 <*> replaceVarsWithUnknowns' t2

89 replaceVarsWithUnknowns' (TypeApp t1 t2) = TypeApp <$> replaceVarsWithUnknowns' t1 <*> replaceVarsWithUnknowns' t2

92 replaceVarsWithUnknowns' (TypeVar var) = do

90 replaceVarsWithUnknowns' (TypeVar var) = do

93− (n, m) <- get

91+ m <- get

92+ n <- lift fresh

94 case M.lookup var m of

93 case M.lookup var m of

95 Nothing -> do

94 Nothing -> do

96− put (n + 1, M.insert var n m)

95+ put (M.insert var n m)

97 return $ TUnknown n

96 return $ TUnknown n

98 Just u -> return $ TUnknown u

97 Just u -> return $ TUnknown u

99 replaceVarsWithUnknowns' t = return t

98 replaceVarsWithUnknowns' t = return t

100− replaceVarsWithUnknowns'' :: Row -> State (Int, M.Map String Int) Row

99+ replaceVarsWithUnknowns'' :: Row -> StateT (M.Map String Int) Check Row

101 replaceVarsWithUnknowns'' (RowVar var) = do

100 replaceVarsWithUnknowns'' (RowVar var) = do

102− (n, m) <- get

101+ m <- get

102+ n <- lift fresh

103 case M.lookup var m of

104 Nothing -> do

105− put (n + 1, M.insert var n m)

105+ put (M.insert var n m)

106 return $ RUnknown n

107 Just u -> return $ RUnknown u

108 replaceVarsWithUnknowns'' (RCons name ty row) = RCons name <$> replaceVarsWithUnknowns' ty <*> replaceVarsWithUnknowns'' row

109 replaceVarsWithUnknowns'' r = return r

110

111−typeConstraints :: Int -> M.Map String Int -> Value -> Check ([TypeConstraint], Int, Int)

111+typeConstraints :: M.Map String Int -> Value -> Check ([TypeConstraint], Int)

112−typeConstraints n _ (NumericLiteral _) = return ([TypeConstraint n Number], n, n)

112+typeConstraints _ (NumericLiteral _) = do

113+ me <- fresh

114+ return ([TypeConstraint me Number], me)

113−typeConstraints n _ (StringLiteral _) = return ([TypeConstraint n String], n, n)

115+typeConstraints _ (StringLiteral _) = do

116+ me <- fresh

117+ return ([TypeConstraint me String], me)

114−typeConstraints n _ (BooleanLiteral _) = return ([TypeConstraint n Boolean], n, n)

118+typeConstraints _ (BooleanLiteral _) = do

119+ me <- fresh

120+ return ([TypeConstraint me Boolean], me)

115−typeConstraints n m (ArrayLiteral vals) = do

121+typeConstraints m (ArrayLiteral vals) = do

116− (cs, ns, max1) <- typeConstraintsAll n m vals

122+ all <- mapM (typeConstraints m) vals

117− let me = max1 + 1

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

124+ me <- fresh

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

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

119−typeConstraints n m (Unary op val) = do

126+typeConstraints m (Unary op val) = do

120− (cs, n1, max1) <- typeConstraints n m val

127+ (cs, n1) <- typeConstraints m val

121− let me = max1 + 1

128+ me <- fresh

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

129+ return (cs ++ unaryOperatorConstraints op n1 me, me)

123−typeConstraints n m (Binary op left right) = do

130+typeConstraints m (Binary op left right) = do

124− (cs1, n1, max1) <- typeConstraints n m left

131+ (cs1, n1) <- typeConstraints m left

125− (cs2, n2, max2) <- typeConstraints (max1 + 1) m right

132+ (cs2, n2) <- typeConstraints m right

126− let me = max1 + 1

133+ me <- fresh

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

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

128−typeConstraints n m (ObjectLiteral ps) = do

135+typeConstraints m (ObjectLiteral ps) = do

129− (cs, ns, max1) <- typeConstraintsAll n m (map snd ps)

136+ all <- mapM (typeConstraints m . snd) ps

130− let me = max1 + 1

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

138+ me <- fresh

131 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

139 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

132− return ((TypeConstraint me (Object (typesToRow tys))) : cs, me, me)

140+ return ((TypeConstraint me (Object (typesToRow tys))) : cs, me)

133 where

141 where

134 typesToRow [] = REmpty

142 typesToRow [] = REmpty

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

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

144+typeConstraints m (Indexer index val) = do

145+ (cs1, n1) <- typeConstraints m index

146+ (cs2, n2) <- typeConstraints m val

147+ me <- fresh

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

136−typeConstraints n m (Accessor prop val) = do

149+typeConstraints m (Accessor prop val) = do

137− (cs, n1, max1) <- typeConstraints n m val

150+ (cs, n1) <- typeConstraints m val

138− let me = max1 + 1

151+ me <- fresh

139− let rest = max1 + 2

152+ rest <- fresh

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

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

141−typeConstraints n m (Abs args ret) = do

154+typeConstraints m (Abs args ret) = do

142− let ns = [n..n + length args - 1]

155+ ns <- replicateM (length args) fresh

143− let next = n + length args

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

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

145− (cs, n', max1) <- typeConstraints next m' ret

157+ (cs, n') <- typeConstraints m' ret

146− let me = max1 + 1

158+ me <- fresh

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

159+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me)

148−typeConstraints n m (App f xs) = do

160+typeConstraints m (App f xs) = do

149− (cs1, n1, max1) <- typeConstraints n m f

161+ (cs1, n1) <- typeConstraints m f

150− (cs2, ns, max2) <- typeConstraintsAll (max1 + 1) m xs

162+ all <- mapM (typeConstraints m) xs

151− let me = max2 + 1

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

164+ me <- fresh

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

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

153−typeConstraints n m (Var var) =

166+typeConstraints m (Var var) =

154 case M.lookup var m of

167 case M.lookup var m of

155 Nothing -> do

168 Nothing -> do

156− env <- get

169+ env <- getEnv

157 case M.lookup var (names env) of

170 case M.lookup var (names env) of

158 Nothing -> throwError $ var ++ " is undefined"

171 Nothing -> throwError $ var ++ " is undefined"

172+ Just ty -> do

173+ me <- fresh

159− Just ty -> let (replaced, max1) = replaceVarsWithUnknowns (n + 1) ty

174+ replaced <- replaceVarsWithUnknowns ty

160− in return ([TypeConstraint n replaced], n, max1)

175+ return ([TypeConstraint me replaced], me)

176+ Just u -> do

177+ me <- fresh

161− Just u -> return ([TypeConstraint u (TUnknown n)], n, n)

178+ return ([TypeConstraint u (TUnknown me)], me)

162−typeConstraints n m (Block ss) = do

179+typeConstraints m (Block ss) = do

163− let ret = n + 1

180+ ret <- fresh

164− (cs, allCodePathsReturn, max1, _) <- typeConstraintsForBlock (ret + 1) m M.empty ret ss

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

165 guardWith "Block is missing a return statement" allCodePathsReturn

182 guardWith "Block is missing a return statement" allCodePathsReturn

166− return (cs, ret, max1)

183+ return (cs, ret)

167−typeConstraints n m (Constructor c) = do

184+typeConstraints m (Constructor c) = do

168− env <- get

185+ env <- getEnv

169 case M.lookup c (names env) of

186 case M.lookup c (names env) of

170 Nothing -> throwError $ c ++ " is undefined"

187 Nothing -> throwError $ c ++ " is undefined"

188+ Just ty -> do

189+ me <- fresh

171− Just ty -> let (replaced, max1) = replaceVarsWithUnknowns (n + 1) ty

190+ replaced <- replaceVarsWithUnknowns ty

172− in return ([TypeConstraint n replaced], n, max1)

191+ return ([TypeConstraint me replaced], me)

173−typeConstraints n m (Case val binders) = do

192+typeConstraints m (Case val binders) = do

174− (cs1, n1, max1) <- typeConstraints n m val

193+ (cs1, n1) <- typeConstraints m val

175− let ret = max1 + 1

194+ ret <- fresh

176− (cs2, max2) <- typeConstraintsForBinders (ret + 1) m n1 ret binders

195+ cs2 <- typeConstraintsForBinders m n1 ret binders

177− return (cs1 ++ cs2, ret, max2)

196+ return (cs1 ++ cs2, ret)

178−typeConstraints n m (TypedValue val ty) = do

197+typeConstraints m (TypedValue val ty) = do

179− (cs, n1, max1) <- typeConstraints n m val

198+ (cs, n1) <- typeConstraints m val

180− return ([TypeConstraint n1 ty], n1, max1)

199+ return ([TypeConstraint n1 ty], n1)

181 -- TODO: Kind-check the type

200 -- TODO: Kind-check the type

182

201

183unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]

202unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]

@@ -213,114 +232,124 @@ equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown righ

213symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]

232symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]

214symBinOpConstraints ty left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result ty]

233symBinOpConstraints ty left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result ty]

215

234

216−typeConstraintsForBinder :: Int -> M.Map String Int -> Int -> Binder -> Check ([TypeConstraint], Int, M.Map String Int)

235+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map String Int)

217−typeConstraintsForBinder n m val (VarBinder name) =

236+typeConstraintsForBinder val (StringBinder _) = constantBinder val String

237+typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

238+typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

239+typeConstraintsForBinder val (VarBinder name) = do

240+ me <- fresh

218− return ([TypeConstraint n (TUnknown val)], n, M.insert name n m)

241+ return ([TypeConstraint me (TUnknown val)], M.singleton name me)

219−typeConstraintsForBinder n m val (NullaryBinder ctor) = do

242+typeConstraintsForBinder val (NullaryBinder ctor) = do

220− env <- get

243+ env <- getEnv

221 case M.lookup ctor (names env) of

244 case M.lookup ctor (names env) of

222 Just ret -> do

245 Just ret -> do

223− let (ret', max1) = replaceVarsWithUnknowns n ret

246+ ret' <- replaceVarsWithUnknowns ret

224− return ([TypeConstraint val ret'], max1, m)

247+ return ([TypeConstraint val ret'], M.empty)

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

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

226−typeConstraintsForBinder n m val (UnaryBinder ctor binder) = do

249+typeConstraintsForBinder val (UnaryBinder ctor binder) = do

227− env <- get

250+ env <- getEnv

228 case M.lookup ctor (names env) of

251 case M.lookup ctor (names env) of

229 Just f@(Function [ty] ret) -> do

252 Just f@(Function [ty] ret) -> do

230− let obj = n

253+ obj <- fresh

231− let (Function [ty'] ret', max1) = replaceVarsWithUnknowns (n + 1) f

254+ Function [ty'] ret' <- replaceVarsWithUnknowns f

232− (cs, max2, m1) <- typeConstraintsForBinder (max1 + 1) m obj binder

255+ (cs, m1) <- typeConstraintsForBinder obj binder

233− return ((TypeConstraint val ret') : (TypeConstraint obj ty') : cs, max2, m1)

256+ return ((TypeConstraint val ret') : (TypeConstraint obj ty') : cs, m1)

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

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

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

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

236−typeConstraintsForBinder n m val (ObjectBinder props) = do

259+typeConstraintsForBinder val (ObjectBinder props) = do

237− let row = n

260+ row <- fresh

238− let rest = n + 1

261+ rest <- fresh

239− (cs, max1, m1) <- typeConstraintsForProperties (n + 2) m row (RUnknown rest) props

262+ (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props

240− return ((TypeConstraint val (Object (RUnknown row))) : cs, max1, m1)

263+ return ((TypeConstraint val (Object (RUnknown row))) : cs, m1)

241 where

264 where

242− typeConstraintsForProperties :: Int -> M.Map String Int -> Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], Int, M.Map String Int)

265+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map String Int)

243− typeConstraintsForProperties n m nrow row [] = return ([RowConstraint nrow row], n, m)

266+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row], M.empty)

244− typeConstraintsForProperties n m nrow row ((name, binder):binders) = do

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

245− let propTy = n

268+ propTy <- fresh

246− (cs1, max1, m1) <- typeConstraintsForBinder (n + 1) m propTy binder

269+ (cs1, m1) <- typeConstraintsForBinder propTy binder

247− (cs2, max2, m2) <- typeConstraintsForProperties (max1 + 1) m1 nrow (RCons name (TUnknown propTy) row) binders

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

248− return (cs1 ++ cs2, max2, m2)

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

249−

272+typeConstraintsForBinder val (ArrayBinder binders rest) = do

273+ el <- fresh

274+ all <- mapM (typeConstraintsForBinder el) binders

275+ let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all

276+ let arrayConstraint = TypeConstraint val (Array (TUnknown el))

277+ case rest of

278+ Nothing -> return (arrayConstraint : cs1, m1)

279+ Just binder -> do

280+ (cs2, m2) <- typeConstraintsForBinder val binder

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

282+

283+constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map String Int)

284+constantBinder val ty = return ([TypeConstraint val ty], M.empty)

285+

250−typeConstraintsForBinders :: Int -> M.Map String Int -> Int -> Int -> [(Binder, Value)] -> Check ([TypeConstraint], Int)

286+typeConstraintsForBinders :: M.Map String Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

251−typeConstraintsForBinders n _ _ _ [] = return ([], n)

287+typeConstraintsForBinders _ _ _ [] = return []

252−typeConstraintsForBinders n m nval ret ((binder, val):bs) = do

288+typeConstraintsForBinders m nval ret ((binder, val):bs) = do

253− (cs1, max1, m1) <- typeConstraintsForBinder n m nval binder

289+ (cs1, m1) <- typeConstraintsForBinder nval binder

254− (cs2, n2, max2) <- typeConstraints (max1 + 1) m1 val

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

255− (cs3, max3) <- typeConstraintsForBinders (max2 + 1) m nval ret bs

291+ cs3 <- typeConstraintsForBinders m nval ret bs

256− return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3, max3)

292+ return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3)

257−

293+

258−typeConstraintsForStatement :: Int -> M.Map String Int -> M.Map String Int -> Int -> Statement -> Check ([TypeConstraint], Bool, Int, M.Map String Int)

294+typeConstraintsForStatement :: M.Map String Int -> M.Map String Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map String Int)

259−typeConstraintsForStatement n m mass ret (VariableIntroduction name val) = do

295+typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do

260 case M.lookup name (m `M.union` mass) of

296 case M.lookup name (m `M.union` mass) of

261 Nothing -> do

297 Nothing -> do

262− (cs1, n1, max1) <- typeConstraints n m val

298+ (cs1, n1) <- typeConstraints m val

263− return $ (cs1, False, max1, M.insert name n1 mass)

299+ return $ (cs1, False, M.insert name n1 mass)

264 Just ty -> throwError $ "Variable with name " ++ name ++ " already exists."

300 Just ty -> throwError $ "Variable with name " ++ name ++ " already exists."

265−typeConstraintsForStatement n m mass ret (Assignment name val) = do

301+typeConstraintsForStatement m mass ret (Assignment name val) = do

266 case M.lookup name (m `M.union` mass) of

302 case M.lookup name (m `M.union` mass) of

267 Nothing -> throwError $ "No local variable with name " ++ name

303 Nothing -> throwError $ "No local variable with name " ++ name

268 Just ty -> do

304 Just ty -> do

269− (cs1, n1, max1) <- typeConstraints n m val

305+ (cs1, n1) <- typeConstraints m val

270− return ((TypeConstraint n1 (TUnknown ty)) : cs1, False, max1, mass)

306+ return ((TypeConstraint n1 (TUnknown ty)) : cs1, False, mass)

271−typeConstraintsForStatement n m mass ret (While val inner) = do

307+typeConstraintsForStatement m mass ret (While val inner) = do

272− (cs1, n1, max1) <- typeConstraints n m val

308+ (cs1, n1) <- typeConstraints m val

273− (cs2, allCodePathsReturn, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret inner

309+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner

274− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, max2, mass)

310+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)

275−typeConstraintsForStatement n m mass ret (IfThenElse val thens Nothing) = do

311+typeConstraintsForStatement m mass ret (IfThenElse val thens Nothing) = do

276− (cs1, n1, max1) <- typeConstraints n m val

312+ (cs1, n1) <- typeConstraints m val

277− (cs2, allCodePathsReturn, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret thens

313+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens

278− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, max2, mass)

314+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)

279−typeConstraintsForStatement n m mass ret (IfThenElse val thens (Just elses)) = do

315+typeConstraintsForStatement m mass ret (IfThenElse val thens (Just elses)) = do

280− (cs1, n1, max1) <- typeConstraints n m val

316+ (cs1, n1) <- typeConstraints m val

281− (cs2, allCodePathsReturn1, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret thens

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

282− (cs3, allCodePathsReturn2, max3, _) <- typeConstraintsForBlock (max2 + 1) m mass ret elses

318+ (cs3, allCodePathsReturn2, _) <- typeConstraintsForBlock m mass ret elses

283− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2, max3, mass)

319+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2, mass)

284−typeConstraintsForStatement n m mass ret (For (init, cond, cont) inner) = do

320+typeConstraintsForStatement m mass ret (For (init, cond, cont) inner) = do

285− (cs1, b1, max1, mass1) <- typeConstraintsForStatement n m mass ret init

321+ (cs1, b1, mass1) <- typeConstraintsForStatement m mass ret init

286 guardWith "Cannot return from inside for" $ not b1

322 guardWith "Cannot return from inside for" $ not b1

287− (cs2, n1, max2) <- typeConstraints (max1 + 1) (m `M.union` mass1) cond

323+ (cs2, n1) <- typeConstraints (m `M.union` mass1) cond

288− (cs3, b2, max3, mass2) <- typeConstraintsForStatement (max2 + 1) (m `M.union` mass1) mass1 ret cont

324+ (cs3, b2, mass2) <- typeConstraintsForStatement (m `M.union` mass1) mass1 ret cont

289 guardWith "Cannot return from inside for" $ not b2

325 guardWith "Cannot return from inside for" $ not b2

290− (cs4, allCodePathsReturn, max4, _) <- typeConstraintsForBlock (max3 + 1) (m `M.union` mass2) mass2 ret inner

326+ (cs4, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass2) mass2 ret inner

291− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3 ++ cs4, allCodePathsReturn, max4, mass)

327+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3 ++ cs4, allCodePathsReturn, mass)

292−typeConstraintsForStatement n m mass ret (Return val) = do

328+typeConstraintsForStatement m mass ret (Return val) = do

293− (cs1, n1, max1) <- typeConstraints n m val

329+ (cs1, n1) <- typeConstraints m val

294− return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, max1, mass)

330+ return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)

295−

331+

296−typeConstraintsForBlock :: Int -> M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, Int, M.Map String Int)

332+typeConstraintsForBlock :: M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map String Int)

297−typeConstraintsForBlock n _ mass _ [] = return ([], False, n, mass)

333+typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

298−typeConstraintsForBlock n m mass ret (s:ss) = do

334+typeConstraintsForBlock m mass ret (s:ss) = do

299− (cs1, b1, max1, mass1) <- typeConstraintsForStatement n (m `M.union` mass) mass ret s

335+ (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s

300 case (b1, ss) of

336 case (b1, ss) of

301− (True, []) -> return (cs1, True, max1, mass1)

337+ (True, []) -> return (cs1, True, mass1)

302 (True, _) -> throwError "Unreachable code"

338 (True, _) -> throwError "Unreachable code"

303 (False, ss) -> do

339 (False, ss) -> do

304− (cs2, b2, max2, mass2) <- typeConstraintsForBlock (max1 + 1) m mass1 ret ss

340+ (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss

305− return (cs1 ++ cs2, b2, max2, mass2)

341+ return (cs1 ++ cs2, b2, mass2)

306−

307−typeConstraintsAll :: Int -> M.Map String Int -> [Value] -> Check ([TypeConstraint], [Int], Int)

308−typeConstraintsAll n _ [] = return ([], [], n)

309−typeConstraintsAll n m (t:ts) = do

310− (cs, n', max1) <- typeConstraints n m t

311− (cs', ns, max2) <- typeConstraintsAll (max1 + 1) m ts

312− return (cs ++ cs', n':ns, max2)

313

342

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

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

315solveTypeConstraints [] s = return s

344solveTypeConstraints [] s = return s

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

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

317− guardWith "Occurs check failed" $ not $ typeOccursCheck n t

346+ guardWith "Occurs check failed" $ not $ typeOccursCheck False n t

318 let s' = let (f, g) = runTypeSolution s

347 let s' = let (f, g) = runTypeSolution s

319 in TypeSolution (replaceTypeInType n t . f, replaceTypeInRow n t . g)

348 in TypeSolution (replaceTypeInType n t . f, replaceTypeInRow n t . g)

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

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

321 solveTypeConstraints cs' s'

350 solveTypeConstraints cs' s'

322solveTypeConstraints (RowConstraint n r:cs) s = do

351solveTypeConstraints (RowConstraint n r:cs) s = do

323− guardWith "Occurs check failed" $ not $ rowOccursCheck n r

352+ guardWith "Occurs check failed" $ not $ rowOccursCheck False n r

324 let s' = let (f, g) = runTypeSolution s

353 let s' = let (f, g) = runTypeSolution s

325 in TypeSolution $ (replaceRowInType n r . f, replaceRowInRow n r . g)

354 in TypeSolution $ (replaceRowInType n r . f, replaceRowInRow n r . g)

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

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

@@ -367,10 +396,10 @@ replaceRowInRow _ _ other = other

367unifyTypes :: Type -> Type -> Check [TypeConstraint]

396unifyTypes :: Type -> Type -> Check [TypeConstraint]

368unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

397unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

369unifyTypes (TUnknown u) t = do

398unifyTypes (TUnknown u) t = do

370− guardWith "Occurs check failed for " $ not $ typeOccursCheck u t

399+ guardWith "Occurs check failed" $ not $ typeOccursCheck False u t

371 return [TypeConstraint u t]

400 return [TypeConstraint u t]

372unifyTypes t (TUnknown u) = do

401unifyTypes t (TUnknown u) = do

373− guardWith "Occurs check failed" $ not $ typeOccursCheck u t

402+ guardWith "Occurs check failed" $ not $ typeOccursCheck False u t

374 return [TypeConstraint u t]

403 return [TypeConstraint u t]

375unifyTypes Number Number = return []

404unifyTypes Number Number = return []

376unifyTypes String String = return []

405unifyTypes String String = return []

@@ -378,6 +407,7 @@ unifyTypes Boolean Boolean = return []

378unifyTypes (Array s) (Array t) = unifyTypes s t

407unifyTypes (Array s) (Array t) = unifyTypes s t

379unifyTypes (Object row1) (Object row2) = unifyRows row1 row2

408unifyTypes (Object row1) (Object row2) = unifyRows row1 row2

380unifyTypes (Function args1 ret1) (Function args2 ret2) = do

409unifyTypes (Function args1 ret1) (Function args2 ret2) = do

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

381 cs1 <- fmap concat $ zipWithM unifyTypes args1 args2

411 cs1 <- fmap concat $ zipWithM unifyTypes args1 args2

382 cs2 <- unifyTypes ret1 ret2

412 cs2 <- unifyTypes ret1 ret2

383 return $ cs1 ++ cs2

413 return $ cs1 ++ cs2

@@ -400,19 +430,19 @@ unifyRows r1 r2 =

400 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

430 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

401 in rethrow (const $ "Cannot unify " ++ show r1 ++ " with " ++ show r2) $ do

431 in rethrow (const $ "Cannot unify " ++ show r1 ++ " with " ++ show r2) $ do

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

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

403− cs2 <- unifyRows' (fromList (sd1, r1')) (fromList (sd2, r2'))

433+ cs2 <- unifyRows' sd1 r1' sd2 r2'

404 return $ cs1 ++ cs2

434 return $ cs1 ++ cs2

405 where

435 where

406− unifyRows' :: Row -> Row -> Check [TypeConstraint]

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

407− unifyRows' r (RUnknown u) = do

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

408− guardWith "Occurs check failed" $ not $ rowOccursCheck u r

438+ guardWith "Occurs check failed" $ not $ rowOccursCheck False u r

409− return [RowConstraint u r]

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

410− unifyRows' (RUnknown u) r = do

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

411− guardWith "Occurs check failed" $ not $ rowOccursCheck u r

441+ u' <- fresh

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

412− return [RowConstraint u r]

443+ return [ RowConstraint u (RCons name ty (RUnknown u')) ]

413− unifyRows' (RowVar v1) (RowVar v2) | v1 == v2 = return []

414− unifyRows' REmpty REmpty = return []

444+ unifyRows' [] REmpty [] REmpty = return []

415− unifyRows' r1 r2 = throwError $ "Cannot unify " ++ show r1 ++ " with " ++ show r2 ++ "."

445+ unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ show (fromList (sd1, r1)) ++ " with " ++ show (fromList (sd2, r2)) ++ "."

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

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

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

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

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

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

@@ -421,15 +451,15 @@ unifyRows r1 r2 =

421 fromList ([], r) = r

451 fromList ([], r) = r

422 fromList ((name, t):ts, r) = RCons name t (fromList (ts, r))

452 fromList ((name, t):ts, r) = RCons name t (fromList (ts, r))

423

453

424−typeOccursCheck :: Int -> Type -> Bool

454+typeOccursCheck :: Bool -> Int -> Type -> Bool

425−typeOccursCheck u (TUnknown u') | u == u' = True

455+typeOccursCheck b u (TUnknown u') | u == u' = b

426−typeOccursCheck u (Array t) = typeOccursCheck u t

456+typeOccursCheck _ u (Array t) = typeOccursCheck True u t

427−typeOccursCheck u (Object row) = rowOccursCheck u row

457+typeOccursCheck _ u (Object row) = rowOccursCheck True u row

428−typeOccursCheck u (Function args ret) = any (typeOccursCheck u) args || typeOccursCheck u ret

458+typeOccursCheck _ u (Function args ret) = any (typeOccursCheck True u) args || typeOccursCheck True u ret

429−typeOccursCheck u (TypeApp s t) = typeOccursCheck u s || typeOccursCheck u t

459+typeOccursCheck _ u (TypeApp s t) = typeOccursCheck True u s || typeOccursCheck True u t

430−typeOccursCheck _ _ = False

460+typeOccursCheck _ _ _ = False

431−

461+

432−rowOccursCheck :: Int -> Row -> Bool

462+rowOccursCheck :: Bool -> Int -> Row -> Bool

433−rowOccursCheck u (RUnknown u') | u == u' = True

463+rowOccursCheck b u (RUnknown u') | u == u' = b

434−rowOccursCheck u (RCons name ty row) = typeOccursCheck u ty || rowOccursCheck u row

464+rowOccursCheck _ u (RCons name ty row) = typeOccursCheck True u ty || rowOccursCheck True u row

435−rowOccursCheck _ _ = False

465+rowOccursCheck _ _ _ = False

src/PureScript/Values.hs+8−3

@@ -50,12 +50,13 @@ data BinaryOperator

50 | Concat deriving (Show, Eq)

52data Value

53− = NumericLiteral Double

53+ = NumericLiteral (Either Integer Double)

54 | StringLiteral String

55 | BooleanLiteral Bool

56 | Unary UnaryOperator Value

57 | Binary BinaryOperator Value Value

58 | ArrayLiteral [Value]

59+ | Indexer Value Value

59 | ObjectLiteral [(String, Value)]

60 | ObjectLiteral [(String, Value)]

60 | Accessor String Value

61 | Accessor String Value

61 | Abs [String] Value

62 | Abs [String] Value

@@ -75,7 +76,11 @@ data Statement

75 | Return Value deriving Show

76 | Return Value deriving Show

77data Binder

78data Binder

79+ = BooleanBinder Bool

80+ | StringBinder String

81+ | NumberBinder (Either Integer Double)

78− = VarBinder String

82+ | VarBinder String

79 | NullaryBinder String

83 | NullaryBinder String

80 | UnaryBinder String Binder

84 | UnaryBinder String Binder

81− | ObjectBinder [(String, Binder)] deriving Show

85+ | ObjectBinder [(String, Binder)]

86+ | ArrayBinder [Binder] (Maybe Binder) deriving Show