git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Better code gen, better support for arrays, more patterns, more examples.
commitae6037fec474a3fbea15f5544e24bb0b1a52a5c4 authorPhil Freeman <paf31@cantab.net> dateFri 4 Oct 2013, 17:17 (13 years ago) parenta10616f
12 files changed+583−313
compare with golang
unifiedsplit
README.md+2−3 examples/Arrays.ps+16 examples/Objects.ps+1 examples/Operators.ps+5 examples/Patterns.ps+5 src/PureScript/CodeGen.hs+209−43 src/PureScript/Parser/Values.hs+42−23 src/PureScript/TypeChecker.hs+6−6 src/PureScript/TypeChecker/Kinds.hs+67−57 src/PureScript/TypeChecker/Monad.hs+16−2 src/PureScript/TypeChecker/Types.hs+206−176 src/PureScript/Values.hs+8−3
README.md+2−3
@@ -13,14 +13,13 @@ A small strongly, statically typed compile-to-JS language with basic extensible
1313
1414## TODO
1515
16−- Array indexing
16+- IfThenElse expressions
17+- Accessors and indices in assignments
1718- Type Synonyms
18−- Better code generation, fewer parens
1919- User defined operators
2020- Mutually recursive functions
2121- Modules
2222- FFI
2323- Top level pattern matching
24−- Pattern matching booleans
2524- Guards
2625- Type classes
examples/Arrays.psnew file+16
@@ -0,0 +1,16 @@
1+test1 = \arr -> arr[0] + arr[1]
2+
3+test2 = \arr -> case arr of
4+ { [x, y] -> x + y
5+ ; [x] -> x
6+ ; [] -> 0
7+ ; [x, y : _] -> x + y
8+ }
9+
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)
2+
3+test2 = (\x -> (x.foo)(false))({ foo : \_ -> 1 })
4+
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 @@
1212--
1313-----------------------------------------------------------------------------
1414
15+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
16+
1517module PureScript.CodeGen (
1618 declToJs
1719) where
1820
21+import Data.Maybe (fromMaybe)
1922import 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+
2031import PureScript.Values
2132import PureScript.Declarations
2233
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+
2399declToJs :: Declaration -> Maybe String
24100declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
25101declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =
@@ -29,27 +105,102 @@ declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =
29105 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
30106declToJs _ = Nothing
31107
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+
32173valueToJs :: Value -> String
33−valueToJs (NumericLiteral n) = show n
34−valueToJs (StringLiteral s) = show s
35−valueToJs (BooleanLiteral True) = "true"
36−valueToJs (BooleanLiteral False) = "false"
37−valueToJs (Unary op value) = unaryOperatorString op ++ "(" ++ valueToJs value ++ ")"
38−valueToJs (Binary op left right) = "(" ++ valueToJs left ++ ") " ++ binaryOperatorString op ++ " (" ++ valueToJs right ++ ")"
39−valueToJs (ArrayLiteral xs) = "[" ++ intercalate "," (map valueToJs xs) ++ "]"
40−valueToJs (ObjectLiteral ps) = "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
41−valueToJs (Accessor prop val) = "(" ++ valueToJs val ++ ")." ++ prop
42−valueToJs (Abs args value) = "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs value ++ "; }"
43−valueToJs (Var ident) = ident
44−valueToJs (App f xs) = "(" ++ valueToJs f ++ ") (" ++ intercalate "," (map valueToJs xs) ++ ")"
45−valueToJs (Block sts) = "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
46−valueToJs (Constructor name) = name
47−valueToJs (Case value binders) =
48− "(function (_0) {"
49− ++ concatMap (\(b, val) -> fst $ binderToJs 0 0 b $ "return " ++ valueToJs val ++ ";") binders
50− ++ "throw \"Failed pattern match\";"
51− ++ "})(" ++ valueToJs value ++ ")"
52−valueToJs (TypedValue value _) = valueToJs value
174+valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
175+ where
176+ matchValue :: Pattern Value String
177+ matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)
178+ operators :: OperatorTable Value String
179+ operators =
180+ OperatorTable $ [ Wrap accessor $ \prop val -> val ++ "." ++ prop
181+ , Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]"
182+ , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"
183+ , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"
184+ , unary Not "!"
185+ , unary BitwiseNot "~"
186+ , unary Negate "-"
187+ , binary Multiply "*"
188+ , binary Divide "/"
189+ , binary Modulus "%"
190+ , binary Concat "++"
191+ , binary Add "+"
192+ , binary Subtract "-"
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+ ]
53204
54205unaryOperatorString :: UnaryOperator -> String
55206unaryOperatorString Negate = "-"
@@ -78,31 +229,46 @@ binaryOperatorString And = "&&"
78229binaryOperatorString Or = "||"
79230binaryOperatorString Concat = "+"
80231
81−binderToJs :: Int -> Int -> Binder -> String -> (String, Int)
82−binderToJs varName fresh (VarBinder s) done = ("var " ++ s ++ " = _" ++ show varName ++ "; " ++ done, fresh)
83−binderToJs varName fresh (NullaryBinder ctor) done =
84− ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"
85− ++ done
86− ++ "}", fresh)
87−binderToJs varName fresh (UnaryBinder ctor b) done =
88− ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"
89− ++ "var _" ++ show fresh' ++ " = _" ++ show varName ++ ".value;"
90− ++ js
91− ++ "}", fresh'')
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 ++ " }"
241+binderToJs varName done (VarBinder s) =
242+ return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
243+binderToJs varName done (NullaryBinder ctor) =
244+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
245+binderToJs varName done (UnaryBinder ctor b) = do
246+ value <- fresh
247+ js <- binderToJs value done b
248+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
249+binderToJs varName done (ObjectBinder bs) = go done bs
92250 where
93− fresh' = succ fresh
94− (js, fresh'') = binderToJs fresh' fresh' b done
95−binderToJs varName fresh (ObjectBinder bs) done = go fresh bs done
251+ go done [] = return done
252+ go done ((prop, binder):bs) = do
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 ++ " }"
96260 where
97− go fresh [] done = (done, fresh)
98− go fresh ((prop, binder):bs') done =
99− ( "var _" ++ show fresh' ++ " = _" ++ show varName ++ "." ++ prop ++ ";"
100− ++ js
101− , fresh''')
102− where
103− fresh' = succ fresh
104− (done', fresh'') = go fresh' bs' done
105− (js, fresh''') = binderToJs fresh' fresh'' binder done'
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
267+ go done rest index (binder:bs) = do
268+ elVar <- fresh
269+ done' <- go done rest (index + 1) bs
270+ js <- binderToJs elVar done' binder
271+ return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
106272
107273objectPropertyToJs :: (String, Value) -> String
108274objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
src/PureScript/Parser/Values.hs+42−23
@@ -26,15 +26,17 @@ import Control.Arrow (Arrow(..))
2626import PureScript.Parser.Types
2727import PureScript.Types
2828
29+booleanLiteral :: P.Parsec String () Bool
30+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
31+
2932parseNumericLiteral :: P.Parsec String () Value
30−parseNumericLiteral = NumericLiteral <$> either fromIntegral id <$> C.naturalOrFloat
33+parseNumericLiteral = NumericLiteral <$> C.naturalOrFloat
3134
3235parseStringLiteral :: P.Parsec String () Value
3336parseStringLiteral = StringLiteral <$> C.stringLiteral
3437
3538parseBooleanLiteral :: P.Parsec String () Value
36−parseBooleanLiteral = BooleanLiteral <$> ((P.string "true" >> return True)
37− P.<|> (P.string "false" >> return False))
39+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
3840
3941parseArrayLiteral :: P.Parsec String () Value
4042parseArrayLiteral = ArrayLiteral <$> (C.squares $ C.commaSep parseValue)
@@ -51,8 +53,8 @@ parseIdentifierAndValue = do
5153
5254parseAbs :: P.Parsec String () Value
5355parseAbs = do
54− P.char '\\'
55− args <- C.commaSep1 C.identifier
56+ C.lexeme $ P.char '\\'
57+ args <- C.commaSep C.identifier
5658 C.lexeme $ P.string "->"
5759 value <- parseValue
5860 return $ Abs args value
@@ -93,26 +95,27 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l
9395 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue
9496 funArgs = C.parens $ C.commaSep parseValue
9597 parseTypeAnnotation = C.lexeme (P.string "::") *> parseType
96− operators = [ [ Postfix $ (Accessor <$> (C.dot *> C.identifier)) ]
97− , [ Infix (C.lexeme (P.try (P.string "||")) >> return (Binary Or)) AssocRight ]
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 ]
98+ operators = [ [ Postfix $ Accessor <$> (C.dot *> C.identifier)
99+ , Postfix $ Indexer <$> C.squares parseValue ]
113100 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)
114101 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)
115102 , 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 ]
116119 ]
117120
118121parseVariableIntroduction :: P.Parsec String () Statement
@@ -165,6 +168,15 @@ parseStatement = P.choice $ map P.try
165168 , parseIfThenElse
166169 , parseReturn ]
167170
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+
168180parseVarBinder :: P.Parsec String () Binder
169181parseVarBinder = VarBinder <$> C.lexeme C.identifier
170182
@@ -177,6 +189,9 @@ parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder
177189parseObjectBinder :: P.Parsec String () Binder
178190parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep parseIdentifierAndBinder)
179191
192+parseArrayBinder :: P.Parsec String () Binder
193+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep parseBinder) <*> P.optionMaybe (C.colon *> parseBinder)
194+
180195parseIdentifierAndBinder :: P.Parsec String () (String, Binder)
181196parseIdentifierAndBinder = do
182197 name <- C.lexeme C.identifier
@@ -186,8 +201,12 @@ parseIdentifierAndBinder = do
186201
187202parseBinder :: P.Parsec String () Binder
188203parseBinder = P.choice $ map P.try
189− [ parseVarBinder
204+ [ parseStringBinder
205+ , parseBooleanBinder
206+ , parseNumberBinder
207+ , parseVarBinder
190208 , parseUnaryBinder
191209 , parseNullaryBinder
192210 , parseObjectBinder
211+ , parseArrayBinder
193212 , C.parens parseBinder ]
src/PureScript/TypeChecker.hs+6−6
@@ -46,24 +46,24 @@ typeCheck (DataDeclaration dcs@(DataConstructors
4646 , typeArguments = args
4747 , dataConstructors = ctors
4848 })) = rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
49− env <- get
49+ env <- getEnv
5050 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
5151 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) }
5353 flip mapM_ ctors $ \(dctor, maybeTy) ->
5454 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
55− env' <- get
55+ env' <- getEnv
5656 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor
5757 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
5858 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') }
6060typeCheck (ValueDeclaration name val) = rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do
61− env <- get
61+ env <- getEnv
6262 case M.lookup name (names env) of
6363 Just ty -> throwError $ name ++ " is already defined"
6464 Nothing -> do
6565 ty <- typeOf name val
66− put (env { names = M.insert name ty (names env) })
66+ putEnv (env { names = M.insert name ty (names env) })
6767
6868typeCheckAll :: [Declaration] -> Check ()
6969typeCheckAll = mapM_ typeCheck
src/PureScript/TypeChecker/Kinds.hs+67−57
@@ -47,71 +47,81 @@ emptyKindSolution = KindSolution KUnknown
4747
4848kindsOf :: String -> [String] -> [Type] -> Check Kind
4949kindsOf name args ts = do
50− let tyCon = 0
51− let nargs = [1..length args]
52− (cs, ns, _, m) <- kindConstraintsAll (length args + 1) (M.insert name tyCon $ M.fromList (zipWith (,) args nargs)) ts
50+ tyCon <- fresh
51+ nargs <- replicateM (length args) fresh
52+ (cs, ns, m) <- kindConstraintsAll (M.insert name tyCon $ M.fromList (zipWith (,) args nargs)) ts
5353 let extraConstraints = KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) : map (flip KindConstraint Star) ns
5454 solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution
55− return $ starIfUnknown $ runKindSolution solution 0
55+ return $ starIfUnknown $ runKindSolution solution tyCon
5656
5757starIfUnknown :: Kind -> Kind
5858starIfUnknown (KUnknown _) = Star
5959starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
6060starIfUnknown k = k
6161
62−kindConstraintsAll :: Int -> M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], Int, M.Map String Int)
63−kindConstraintsAll n m [] = return ([], [], n, m)
64−kindConstraintsAll n m (t:ts) = do
65− (cs, n1, max1, m') <- kindConstraints n m t
66− (cs', ns, max2, m'') <- kindConstraintsAll (max1 + 1) m' ts
67− return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, max2, m'')
68−
69−kindConstraints :: Int -> M.Map String Int -> Type -> Check ([KindConstraint], Int, Int, M.Map String Int)
70−kindConstraints n m (Array t) = do
71− let me = n
72− (cs, n1, max1, m') <- kindConstraints (n + 1) m t
73− return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, max1, m')
74−kindConstraints n m (Object row) = do
75− let me = n
76− (cs, row, max1, m') <- kindConstraintsForRow (n + 1) m row
77− return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, max1, m')
78−kindConstraints n m (Function args ret) = do
79− let me = n
80− (cs, ns, max1, m') <- kindConstraintsAll (n + 1) m args
81− (cs', retN, max2, m'') <- kindConstraints (max1 + 1) m' ret
82− return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs, me, max2, m'')
83−kindConstraints n m (TypeVar v) =
84− let n' = maybe n id (M.lookup v m)
85− in return ([], n', n, M.insert v n' m)
86−kindConstraints n m (TypeConstructor v) = do
87− env <- get
88− kind <- case M.lookup v m of
62+kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)
63+kindConstraintsAll m [] = return ([], [], m)
64+kindConstraintsAll m (t:ts) = do
65+ (cs, n1, m') <- kindConstraints m t
66+ (cs', ns, m'') <- kindConstraintsAll m' ts
67+ return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, m'')
68+
69+kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)
70+kindConstraints m (Array t) = do
71+ me <- fresh
72+ (cs, n1, m') <- kindConstraints m t
73+ return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, m')
74+kindConstraints m (Object row) = do
75+ me <- fresh
76+ (cs, row, m') <- kindConstraintsForRow m row
77+ return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, m')
78+kindConstraints m (Function args ret) = do
79+ me <- fresh
80+ (cs, ns, m') <- kindConstraintsAll m args
81+ (cs', retN, m'') <- kindConstraints m' ret
82+ return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs, me, m'')
83+kindConstraints m (TypeVar v) = do
84+ me <- case M.lookup v m of
85+ Just u -> return u
86+ Nothing -> fresh
87+ return ([], me, M.insert v me m)
88+kindConstraints m (TypeConstructor v) = do
89+ env <- getEnv
90+ me <- fresh
91+ case M.lookup v m of
8992 Nothing -> case M.lookup v (types env) of
9093 Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"
91− Just k -> return k
92− Just u -> return (KUnknown u)
93− return ([KindConstraint n kind], n, n, m)
94−kindConstraints n m (TypeApp t1 t2) = do
95− let me = n
96− (cs1, n1, max1, m1) <- kindConstraints (n + 1) m t1
97− (cs2, n2, max2, m2) <- kindConstraints (max1 + 1) m1 t2
98− return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me))) : cs1 ++ cs2, me, max2, m2)
99−kindConstraints n m _ = return ([KindConstraint n Star], n, n, m)
100−
101−kindConstraintsForRow :: Int -> M.Map String Int -> Row -> Check ([KindConstraint], Int, Int, M.Map String Int)
102−kindConstraintsForRow n m (RowVar v) =
103− let n' = maybe n id (M.lookup v m)
104− in return ([KindConstraint n' Row], n', n, M.insert v n' m)
105−kindConstraintsForRow n m REmpty = return ([KindConstraint n Row], n, n, m)
106−kindConstraintsForRow n m (RCons _ ty row) = do
107− (cs1, n1, max1, m1) <- kindConstraints (n + 1) m ty
108− (cs2, n2, max2, m2) <- kindConstraintsForRow (max1 + 1) m1 row
109− return ((KindConstraint n Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, n, max2, m2)
94+ Just kind -> return ([KindConstraint me kind], me, m)
95+ Just u -> do
96+ return ([KindConstraint me (KUnknown u)], me, m)
97+kindConstraints m (TypeApp t1 t2) = do
98+ me <- fresh
99+ (cs1, n1, m1) <- kindConstraints m t1
100+ (cs2, n2, m2) <- kindConstraints m1 t2
101+ return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me))) : cs1 ++ cs2, me, m2)
102+kindConstraints m _ = do
103+ me <- fresh
104+ return ([KindConstraint me Star], me, m)
105+
106+kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)
107+kindConstraintsForRow m (RowVar v) = do
108+ me <- case M.lookup v m of
109+ Just u -> return u
110+ Nothing -> fresh
111+ return ([KindConstraint me Row], me, M.insert v me m)
112+kindConstraintsForRow m REmpty = do
113+ me <- fresh
114+ return ([KindConstraint me Row], me, m)
115+kindConstraintsForRow m (RCons _ ty row) = do
116+ me <- fresh
117+ (cs1, n1, m1) <- kindConstraints m ty
118+ (cs2, n2, m2) <- kindConstraintsForRow m1 row
119+ return ((KindConstraint me Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, me, m2)
110120
111121solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution
112122solveKindConstraints [] s = return s
113123solveKindConstraints 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
115125 let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s
116126 cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs
117127 solveKindConstraints cs' s'
@@ -131,10 +141,10 @@ replaceUnknownKind n k = f
131141unifyKinds :: Kind -> Kind -> Check [KindConstraint]
132142unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []
133143unifyKinds (KUnknown u) k = do
134− guardWith "Occurs check failed" $ not $ kindOccursCheck u k
144+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
135145 return [KindConstraint u k]
136146unifyKinds k (KUnknown u) = do
137− guardWith "Occurs check failed" $ not $ kindOccursCheck u k
147+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k
138148 return [KindConstraint u k]
139149unifyKinds Star Star = return []
140150unifyKinds Row Row = return []
@@ -144,7 +154,7 @@ unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do
144154 return $ cs1 ++ cs2
145155unifyKinds k1 k2 = throwError $ "Cannot unify " ++ show k1 ++ " with " ++ show k2 ++ "."
146156
147−kindOccursCheck :: Int -> Kind -> Bool
148−kindOccursCheck u (KUnknown u') | u == u' = True
149−kindOccursCheck u (FunKind k1 k2) = kindOccursCheck u k1 || kindOccursCheck u k2
150−kindOccursCheck _ _ = False
157+kindOccursCheck :: Bool -> Int -> Kind -> Bool
158+kindOccursCheck b u (KUnknown u') | u == u' = b
159+kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2
160+kindOccursCheck _ _ _ = False
src/PureScript/TypeChecker/Monad.hs+16−2
@@ -23,6 +23,8 @@ import Control.Applicative
2323import Control.Monad.State
2424import Control.Monad.Error
2525
26+import Control.Arrow ((***))
27+
2628import qualified Data.Map as M
2729
2830data Environment = Environment
@@ -33,10 +35,22 @@ data Environment = Environment
3335emptyEnvironment :: Environment
3436emptyEnvironment = Environment M.empty M.empty
3537
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
3751
3852check :: Check a -> Either String (a, Environment)
39−check = flip runStateT emptyEnvironment . unCheck
53+check = fmap (id *** fst) . flip runStateT (emptyEnvironment, 0) . unCheck
4054
4155guardWith :: (MonadError e m) => e -> Bool -> m ()
4256guardWith _ True = return ()
src/PureScript/TypeChecker/Types.hs+206−176
@@ -18,8 +18,6 @@ module PureScript.TypeChecker.Types (
1818 typeOf
1919) where
2020
21−import Debug.Trace
22−
2321import Data.List
2422import Data.Function
2523
@@ -31,7 +29,7 @@ import Control.Monad.State
3129import Control.Monad.Error
3230
3331import Control.Applicative
34−import Control.Arrow (Kleisli(..), (***))
32+import Control.Arrow (Kleisli(..), (***), (&&&))
3533import qualified Control.Category as C
3634
3735import qualified Data.Map as M
@@ -47,8 +45,8 @@ emptyTypeSolution = TypeSolution (TUnknown, RUnknown)
4745
4846typeOf :: String -> Value -> Check Type
4947typeOf name val = do
50− let me = 0
51− (cs, n, _) <- typeConstraints 1 (M.singleton name me) val
48+ me <- fresh
49+ (cs, n) <- typeConstraints (M.singleton name me) val
5250 solution <- solveTypeConstraints ((TypeConstraint me (TUnknown n)) : cs) emptyTypeSolution
5351 return $ varIfUnknown $ fst (runTypeSolution solution) n
5452
@@ -81,103 +79,124 @@ varIfUnknown = flip evalState M.empty . varIfUnknown'
8179 varIfUnknown'' (RCons name ty row) = RCons name ty <$> varIfUnknown'' row
8280 varIfUnknown'' r = return r
8381
84−replaceVarsWithUnknowns :: Int -> Type -> (Type, Int)
85−replaceVarsWithUnknowns n = (id *** fst) . flip runState (n, M.empty) . replaceVarsWithUnknowns'
82+replaceVarsWithUnknowns :: Type -> Check Type
83+replaceVarsWithUnknowns = flip evalStateT M.empty . replaceVarsWithUnknowns'
8684 where
87− replaceVarsWithUnknowns' :: Type -> State (Int, M.Map String Int) Type
85+ replaceVarsWithUnknowns' :: Type -> StateT (M.Map String Int) Check Type
8886 replaceVarsWithUnknowns' (Array t) = Array <$> replaceVarsWithUnknowns' t
8987 replaceVarsWithUnknowns' (Object row) = Object <$> replaceVarsWithUnknowns'' row
9088 replaceVarsWithUnknowns' (Function args ret) = Function <$> mapM replaceVarsWithUnknowns' args <*> replaceVarsWithUnknowns' ret
9189 replaceVarsWithUnknowns' (TypeApp t1 t2) = TypeApp <$> replaceVarsWithUnknowns' t1 <*> replaceVarsWithUnknowns' t2
9290 replaceVarsWithUnknowns' (TypeVar var) = do
93− (n, m) <- get
91+ m <- get
92+ n <- lift fresh
9493 case M.lookup var m of
9594 Nothing -> do
96− put (n + 1, M.insert var n m)
95+ put (M.insert var n m)
9796 return $ TUnknown n
9897 Just u -> return $ TUnknown u
9998 replaceVarsWithUnknowns' t = return t
100− replaceVarsWithUnknowns'' :: Row -> State (Int, M.Map String Int) Row
99+ replaceVarsWithUnknowns'' :: Row -> StateT (M.Map String Int) Check Row
101100 replaceVarsWithUnknowns'' (RowVar var) = do
102− (n, m) <- get
101+ m <- get
102+ n <- lift fresh
103103 case M.lookup var m of
104104 Nothing -> do
105− put (n + 1, M.insert var n m)
105+ put (M.insert var n m)
106106 return $ RUnknown n
107107 Just u -> return $ RUnknown u
108108 replaceVarsWithUnknowns'' (RCons name ty row) = RCons name <$> replaceVarsWithUnknowns' ty <*> replaceVarsWithUnknowns'' row
109109 replaceVarsWithUnknowns'' r = return r
110110
111−typeConstraints :: Int -> M.Map String Int -> Value -> Check ([TypeConstraint], Int, Int)
112−typeConstraints n _ (NumericLiteral _) = return ([TypeConstraint n Number], n, n)
113−typeConstraints n _ (StringLiteral _) = return ([TypeConstraint n String], n, n)
114−typeConstraints n _ (BooleanLiteral _) = return ([TypeConstraint n Boolean], n, n)
115−typeConstraints n m (ArrayLiteral vals) = do
116− (cs, ns, max1) <- typeConstraintsAll n m vals
117− let me = max1 + 1
118− return (cs ++ map (TypeConstraint me . Array . TUnknown) ns, me, me)
119−typeConstraints n m (Unary op val) = do
120− (cs, n1, max1) <- typeConstraints n m val
121− let me = max1 + 1
122− return (cs ++ unaryOperatorConstraints op n1 me, me, me)
123−typeConstraints n m (Binary op left right) = do
124− (cs1, n1, max1) <- typeConstraints n m left
125− (cs2, n2, max2) <- typeConstraints (max1 + 1) m right
126− let me = max1 + 1
127− return (cs1 ++ cs2 ++ binaryOperatorConstraints op n1 n2 me, me, me)
128−typeConstraints n m (ObjectLiteral ps) = do
129− (cs, ns, max1) <- typeConstraintsAll n m (map snd ps)
130− let me = max1 + 1
111+typeConstraints :: M.Map String Int -> Value -> Check ([TypeConstraint], Int)
112+typeConstraints _ (NumericLiteral _) = do
113+ me <- fresh
114+ return ([TypeConstraint me Number], me)
115+typeConstraints _ (StringLiteral _) = do
116+ me <- fresh
117+ return ([TypeConstraint me String], me)
118+typeConstraints _ (BooleanLiteral _) = do
119+ me <- fresh
120+ return ([TypeConstraint me Boolean], me)
121+typeConstraints m (ArrayLiteral vals) = do
122+ all <- mapM (typeConstraints m) vals
123+ let (cs, ns) = (concat . map fst &&& map snd) all
124+ me <- fresh
125+ return (cs ++ map (TypeConstraint me . Array . TUnknown) ns, me)
126+typeConstraints m (Unary op val) = do
127+ (cs, n1) <- typeConstraints m val
128+ me <- fresh
129+ return (cs ++ unaryOperatorConstraints op n1 me, me)
130+typeConstraints m (Binary op left right) = do
131+ (cs1, n1) <- typeConstraints m left
132+ (cs2, n2) <- typeConstraints m right
133+ me <- fresh
134+ return (cs1 ++ cs2 ++ binaryOperatorConstraints op n1 n2 me, me)
135+typeConstraints m (ObjectLiteral ps) = do
136+ all <- mapM (typeConstraints m . snd) ps
137+ let (cs, ns) = (concat . map fst &&& map snd) all
138+ me <- fresh
131139 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)
133141 where
134142 typesToRow [] = REmpty
135143 typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
136−typeConstraints n m (Accessor prop val) = do
137− (cs, n1, max1) <- typeConstraints n m val
138− let me = max1 + 1
139− let rest = max1 + 2
140− return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest)))) : cs, me, rest)
141−typeConstraints n m (Abs args ret) = do
142− let ns = [n..n + length args - 1]
143− let next = n + length args
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)
149+typeConstraints m (Accessor prop val) = do
150+ (cs, n1) <- typeConstraints m val
151+ me <- fresh
152+ rest <- fresh
153+ return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest)))) : cs, me)
154+typeConstraints m (Abs args ret) = do
155+ ns <- replicateM (length args) fresh
144156 let m' = m `M.union` M.fromList (zipWith (,) args ns)
145− (cs, n', max1) <- typeConstraints next m' ret
146− let me = max1 + 1
147− return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me, me)
148−typeConstraints n m (App f xs) = do
149− (cs1, n1, max1) <- typeConstraints n m f
150− (cs2, ns, max2) <- typeConstraintsAll (max1 + 1) m xs
151− let me = max2 + 1
152− return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me))) : cs1 ++ cs2, me, me)
153−typeConstraints n m (Var var) =
157+ (cs, n') <- typeConstraints m' ret
158+ me <- fresh
159+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me)
160+typeConstraints m (App f xs) = do
161+ (cs1, n1) <- typeConstraints m f
162+ all <- mapM (typeConstraints m) xs
163+ let (cs2, ns) = (concat . map fst &&& map snd) all
164+ me <- fresh
165+ return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me))) : cs1 ++ cs2, me)
166+typeConstraints m (Var var) =
154167 case M.lookup var m of
155168 Nothing -> do
156− env <- get
169+ env <- getEnv
157170 case M.lookup var (names env) of
158171 Nothing -> throwError $ var ++ " is undefined"
159− Just ty -> let (replaced, max1) = replaceVarsWithUnknowns (n + 1) ty
160− in return ([TypeConstraint n replaced], n, max1)
161− Just u -> return ([TypeConstraint u (TUnknown n)], n, n)
162−typeConstraints n m (Block ss) = do
163− let ret = n + 1
164− (cs, allCodePathsReturn, max1, _) <- typeConstraintsForBlock (ret + 1) m M.empty ret ss
172+ Just ty -> do
173+ me <- fresh
174+ replaced <- replaceVarsWithUnknowns ty
175+ return ([TypeConstraint me replaced], me)
176+ Just u -> do
177+ me <- fresh
178+ return ([TypeConstraint u (TUnknown me)], me)
179+typeConstraints m (Block ss) = do
180+ ret <- fresh
181+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss
165182 guardWith "Block is missing a return statement" allCodePathsReturn
166− return (cs, ret, max1)
167−typeConstraints n m (Constructor c) = do
168− env <- get
183+ return (cs, ret)
184+typeConstraints m (Constructor c) = do
185+ env <- getEnv
169186 case M.lookup c (names env) of
170187 Nothing -> throwError $ c ++ " is undefined"
171− Just ty -> let (replaced, max1) = replaceVarsWithUnknowns (n + 1) ty
172− in return ([TypeConstraint n replaced], n, max1)
173−typeConstraints n m (Case val binders) = do
174− (cs1, n1, max1) <- typeConstraints n m val
175− let ret = max1 + 1
176− (cs2, max2) <- typeConstraintsForBinders (ret + 1) m n1 ret binders
177− return (cs1 ++ cs2, ret, max2)
178−typeConstraints n m (TypedValue val ty) = do
179− (cs, n1, max1) <- typeConstraints n m val
180− return ([TypeConstraint n1 ty], n1, max1)
188+ Just ty -> do
189+ me <- fresh
190+ replaced <- replaceVarsWithUnknowns ty
191+ return ([TypeConstraint me replaced], me)
192+typeConstraints m (Case val binders) = do
193+ (cs1, n1) <- typeConstraints m val
194+ ret <- fresh
195+ cs2 <- typeConstraintsForBinders m n1 ret binders
196+ return (cs1 ++ cs2, ret)
197+typeConstraints m (TypedValue val ty) = do
198+ (cs, n1) <- typeConstraints m val
199+ return ([TypeConstraint n1 ty], n1)
181200 -- TODO: Kind-check the type
182201
183202unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]
@@ -213,114 +232,124 @@ equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown righ
213232symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]
214233symBinOpConstraints ty left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result ty]
215234
216−typeConstraintsForBinder :: Int -> M.Map String Int -> Int -> Binder -> Check ([TypeConstraint], Int, M.Map String Int)
217−typeConstraintsForBinder n m val (VarBinder name) =
218− return ([TypeConstraint n (TUnknown val)], n, M.insert name n m)
219−typeConstraintsForBinder n m val (NullaryBinder ctor) = do
220− env <- get
235+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map String Int)
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
241+ return ([TypeConstraint me (TUnknown val)], M.singleton name me)
242+typeConstraintsForBinder val (NullaryBinder ctor) = do
243+ env <- getEnv
221244 case M.lookup ctor (names env) of
222245 Just ret -> do
223− let (ret', max1) = replaceVarsWithUnknowns n ret
224− return ([TypeConstraint val ret'], max1, m)
246+ ret' <- replaceVarsWithUnknowns ret
247+ return ([TypeConstraint val ret'], M.empty)
225248 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
226−typeConstraintsForBinder n m val (UnaryBinder ctor binder) = do
227− env <- get
249+typeConstraintsForBinder val (UnaryBinder ctor binder) = do
250+ env <- getEnv
228251 case M.lookup ctor (names env) of
229252 Just f@(Function [ty] ret) -> do
230− let obj = n
231− let (Function [ty'] ret', max1) = replaceVarsWithUnknowns (n + 1) f
232− (cs, max2, m1) <- typeConstraintsForBinder (max1 + 1) m obj binder
233− return ((TypeConstraint val ret') : (TypeConstraint obj ty') : cs, max2, m1)
253+ obj <- fresh
254+ Function [ty'] ret' <- replaceVarsWithUnknowns f
255+ (cs, m1) <- typeConstraintsForBinder obj binder
256+ return ((TypeConstraint val ret') : (TypeConstraint obj ty') : cs, m1)
234257 Just _ -> throwError $ ctor ++ " is not a unary constructor"
235258 _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"
236−typeConstraintsForBinder n m val (ObjectBinder props) = do
237− let row = n
238− let rest = n + 1
239− (cs, max1, m1) <- typeConstraintsForProperties (n + 2) m row (RUnknown rest) props
240− return ((TypeConstraint val (Object (RUnknown row))) : cs, max1, m1)
259+typeConstraintsForBinder val (ObjectBinder props) = do
260+ row <- fresh
261+ rest <- fresh
262+ (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props
263+ return ((TypeConstraint val (Object (RUnknown row))) : cs, m1)
241264 where
242− typeConstraintsForProperties :: Int -> M.Map String Int -> Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], Int, M.Map String Int)
243− typeConstraintsForProperties n m nrow row [] = return ([RowConstraint nrow row], n, m)
244− typeConstraintsForProperties n m nrow row ((name, binder):binders) = do
245− let propTy = n
246− (cs1, max1, m1) <- typeConstraintsForBinder (n + 1) m propTy binder
247− (cs2, max2, m2) <- typeConstraintsForProperties (max1 + 1) m1 nrow (RCons name (TUnknown propTy) row) binders
248− return (cs1 ++ cs2, max2, m2)
249−
250−typeConstraintsForBinders :: Int -> M.Map String Int -> Int -> Int -> [(Binder, Value)] -> Check ([TypeConstraint], Int)
251−typeConstraintsForBinders n _ _ _ [] = return ([], n)
252−typeConstraintsForBinders n m nval ret ((binder, val):bs) = do
253− (cs1, max1, m1) <- typeConstraintsForBinder n m nval binder
254− (cs2, n2, max2) <- typeConstraints (max1 + 1) m1 val
255− (cs3, max3) <- typeConstraintsForBinders (max2 + 1) m nval ret bs
256− return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3, max3)
257−
258−typeConstraintsForStatement :: Int -> M.Map String Int -> M.Map String Int -> Int -> Statement -> Check ([TypeConstraint], Bool, Int, M.Map String Int)
259−typeConstraintsForStatement n m mass ret (VariableIntroduction name val) = do
265+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map String Int)
266+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row], M.empty)
267+ typeConstraintsForProperties nrow row ((name, binder):binders) = do
268+ propTy <- fresh
269+ (cs1, m1) <- typeConstraintsForBinder propTy binder
270+ (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders
271+ return (cs1 ++ cs2, M.union m1 m2)
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+
286+typeConstraintsForBinders :: M.Map String Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]
287+typeConstraintsForBinders _ _ _ [] = return []
288+typeConstraintsForBinders m nval ret ((binder, val):bs) = do
289+ (cs1, m1) <- typeConstraintsForBinder nval binder
290+ (cs2, n2) <- typeConstraints (M.union m m1) val
291+ cs3 <- typeConstraintsForBinders m nval ret bs
292+ return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3)
293+
294+typeConstraintsForStatement :: M.Map String Int -> M.Map String Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map String Int)
295+typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do
260296 case M.lookup name (m `M.union` mass) of
261297 Nothing -> do
262− (cs1, n1, max1) <- typeConstraints n m val
263− return $ (cs1, False, max1, M.insert name n1 mass)
298+ (cs1, n1) <- typeConstraints m val
299+ return $ (cs1, False, M.insert name n1 mass)
264300 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
266302 case M.lookup name (m `M.union` mass) of
267303 Nothing -> throwError $ "No local variable with name " ++ name
268304 Just ty -> do
269− (cs1, n1, max1) <- typeConstraints n m val
270− return ((TypeConstraint n1 (TUnknown ty)) : cs1, False, max1, mass)
271−typeConstraintsForStatement n m mass ret (While val inner) = do
272− (cs1, n1, max1) <- typeConstraints n m val
273− (cs2, allCodePathsReturn, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret inner
274− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, max2, mass)
275−typeConstraintsForStatement n m mass ret (IfThenElse val thens Nothing) = do
276− (cs1, n1, max1) <- typeConstraints n m val
277− (cs2, allCodePathsReturn, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret thens
278− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, max2, mass)
279−typeConstraintsForStatement n m mass ret (IfThenElse val thens (Just elses)) = do
280− (cs1, n1, max1) <- typeConstraints n m val
281− (cs2, allCodePathsReturn1, max2, _) <- typeConstraintsForBlock (max1 + 1) m mass ret thens
282− (cs3, allCodePathsReturn2, max3, _) <- typeConstraintsForBlock (max2 + 1) m mass ret elses
283− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2, max3, mass)
284−typeConstraintsForStatement n m mass ret (For (init, cond, cont) inner) = do
285− (cs1, b1, max1, mass1) <- typeConstraintsForStatement n m mass ret init
305+ (cs1, n1) <- typeConstraints m val
306+ return ((TypeConstraint n1 (TUnknown ty)) : cs1, False, mass)
307+typeConstraintsForStatement m mass ret (While val inner) = do
308+ (cs1, n1) <- typeConstraints m val
309+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner
310+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)
311+typeConstraintsForStatement m mass ret (IfThenElse val thens Nothing) = do
312+ (cs1, n1) <- typeConstraints m val
313+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens
314+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)
315+typeConstraintsForStatement m mass ret (IfThenElse val thens (Just elses)) = do
316+ (cs1, n1) <- typeConstraints m val
317+ (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens
318+ (cs3, allCodePathsReturn2, _) <- typeConstraintsForBlock m mass ret elses
319+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2, mass)
320+typeConstraintsForStatement m mass ret (For (init, cond, cont) inner) = do
321+ (cs1, b1, mass1) <- typeConstraintsForStatement m mass ret init
286322 guardWith "Cannot return from inside for" $ not b1
287− (cs2, n1, max2) <- typeConstraints (max1 + 1) (m `M.union` mass1) cond
288− (cs3, b2, max3, mass2) <- typeConstraintsForStatement (max2 + 1) (m `M.union` mass1) mass1 ret cont
323+ (cs2, n1) <- typeConstraints (m `M.union` mass1) cond
324+ (cs3, b2, mass2) <- typeConstraintsForStatement (m `M.union` mass1) mass1 ret cont
289325 guardWith "Cannot return from inside for" $ not b2
290− (cs4, allCodePathsReturn, max4, _) <- typeConstraintsForBlock (max3 + 1) (m `M.union` mass2) mass2 ret inner
291− return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3 ++ cs4, allCodePathsReturn, max4, mass)
292−typeConstraintsForStatement n m mass ret (Return val) = do
293− (cs1, n1, max1) <- typeConstraints n m val
294− return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, max1, mass)
295−
296−typeConstraintsForBlock :: Int -> M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, Int, M.Map String Int)
297−typeConstraintsForBlock n _ mass _ [] = return ([], False, n, mass)
298−typeConstraintsForBlock n m mass ret (s:ss) = do
299− (cs1, b1, max1, mass1) <- typeConstraintsForStatement n (m `M.union` mass) mass ret s
326+ (cs4, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass2) mass2 ret inner
327+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3 ++ cs4, allCodePathsReturn, mass)
328+typeConstraintsForStatement m mass ret (Return val) = do
329+ (cs1, n1) <- typeConstraints m val
330+ return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)
331+
332+typeConstraintsForBlock :: M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map String Int)
333+typeConstraintsForBlock _ mass _ [] = return ([], False, mass)
334+typeConstraintsForBlock m mass ret (s:ss) = do
335+ (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s
300336 case (b1, ss) of
301− (True, []) -> return (cs1, True, max1, mass1)
337+ (True, []) -> return (cs1, True, mass1)
302338 (True, _) -> throwError "Unreachable code"
303339 (False, ss) -> do
304− (cs2, b2, max2, mass2) <- typeConstraintsForBlock (max1 + 1) m mass1 ret ss
305− return (cs1 ++ cs2, b2, max2, 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)
340+ (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss
341+ return (cs1 ++ cs2, b2, mass2)
313342
314343solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution
315344solveTypeConstraints [] s = return s
316345solveTypeConstraints 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
318347 let s' = let (f, g) = runTypeSolution s
319348 in TypeSolution (replaceTypeInType n t . f, replaceTypeInRow n t . g)
320349 cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs
321350 solveTypeConstraints cs' s'
322351solveTypeConstraints (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
324353 let s' = let (f, g) = runTypeSolution s
325354 in TypeSolution $ (replaceRowInType n r . f, replaceRowInRow n r . g)
326355 cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs
@@ -367,10 +396,10 @@ replaceRowInRow _ _ other = other
367396unifyTypes :: Type -> Type -> Check [TypeConstraint]
368397unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []
369398unifyTypes (TUnknown u) t = do
370− guardWith "Occurs check failed for " $ not $ typeOccursCheck u t
399+ guardWith "Occurs check failed" $ not $ typeOccursCheck False u t
371400 return [TypeConstraint u t]
372401unifyTypes t (TUnknown u) = do
373− guardWith "Occurs check failed" $ not $ typeOccursCheck u t
402+ guardWith "Occurs check failed" $ not $ typeOccursCheck False u t
374403 return [TypeConstraint u t]
375404unifyTypes Number Number = return []
376405unifyTypes String String = return []
@@ -378,6 +407,7 @@ unifyTypes Boolean Boolean = return []
378407unifyTypes (Array s) (Array t) = unifyTypes s t
379408unifyTypes (Object row1) (Object row2) = unifyRows row1 row2
380409unifyTypes (Function args1 ret1) (Function args2 ret2) = do
410+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2
381411 cs1 <- fmap concat $ zipWithM unifyTypes args1 args2
382412 cs2 <- unifyTypes ret1 ret2
383413 return $ cs1 ++ cs2
@@ -400,19 +430,19 @@ unifyRows r1 r2 =
400430 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]
401431 in rethrow (const $ "Cannot unify " ++ show r1 ++ " with " ++ show r2) $ do
402432 cs1 <- fmap concat $ mapM (uncurry unifyTypes) int
403− cs2 <- unifyRows' (fromList (sd1, r1')) (fromList (sd2, r2'))
433+ cs2 <- unifyRows' sd1 r1' sd2 r2'
404434 return $ cs1 ++ cs2
405435 where
406− unifyRows' :: Row -> Row -> Check [TypeConstraint]
407− unifyRows' r (RUnknown u) = do
408− guardWith "Occurs check failed" $ not $ rowOccursCheck u r
409− return [RowConstraint u r]
410− unifyRows' (RUnknown u) r = do
411− guardWith "Occurs check failed" $ not $ rowOccursCheck u r
412− return [RowConstraint u r]
413− unifyRows' (RowVar v1) (RowVar v2) | v1 == v2 = return []
414− unifyRows' REmpty REmpty = return []
415− unifyRows' r1 r2 = throwError $ "Cannot unify " ++ show r1 ++ " with " ++ show r2 ++ "."
436+ unifyRows' :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]
437+ unifyRows' [] (RUnknown u) sd r = do
438+ guardWith "Occurs check failed" $ not $ rowOccursCheck False u r
439+ return [RowConstraint u (fromList (sd, r))]
440+ unifyRows' ((name, ty):row) r others (RUnknown u) = do
441+ u' <- fresh
442+ cs <- unifyRows' row r others (RUnknown u')
443+ return [ RowConstraint u (RCons name ty (RUnknown u')) ]
444+ unifyRows' [] REmpty [] REmpty = return []
445+ unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ show (fromList (sd1, r1)) ++ " with " ++ show (fromList (sd2, r2)) ++ "."
416446 toList :: Row -> ([(String, Type)], Row)
417447 toList (RCons name ty row) = let (tys, rest) = toList row
418448 in ((name, ty):tys, rest)
@@ -421,15 +451,15 @@ unifyRows r1 r2 =
421451 fromList ([], r) = r
422452 fromList ((name, t):ts, r) = RCons name t (fromList (ts, r))
423453
424−typeOccursCheck :: Int -> Type -> Bool
425−typeOccursCheck u (TUnknown u') | u == u' = True
426−typeOccursCheck u (Array t) = typeOccursCheck u t
427−typeOccursCheck u (Object row) = rowOccursCheck u row
428−typeOccursCheck u (Function args ret) = any (typeOccursCheck u) args || typeOccursCheck u ret
429−typeOccursCheck u (TypeApp s t) = typeOccursCheck u s || typeOccursCheck u t
430−typeOccursCheck _ _ = False
431−
432−rowOccursCheck :: Int -> Row -> Bool
433−rowOccursCheck u (RUnknown u') | u == u' = True
434−rowOccursCheck u (RCons name ty row) = typeOccursCheck u ty || rowOccursCheck u row
435−rowOccursCheck _ _ = False
454+typeOccursCheck :: Bool -> Int -> Type -> Bool
455+typeOccursCheck b u (TUnknown u') | u == u' = b
456+typeOccursCheck _ u (Array t) = typeOccursCheck True u t
457+typeOccursCheck _ u (Object row) = rowOccursCheck True u row
458+typeOccursCheck _ u (Function args ret) = any (typeOccursCheck True u) args || typeOccursCheck True u ret
459+typeOccursCheck _ u (TypeApp s t) = typeOccursCheck True u s || typeOccursCheck True u t
460+typeOccursCheck _ _ _ = False
461+
462+rowOccursCheck :: Bool -> Int -> Row -> Bool
463+rowOccursCheck b u (RUnknown u') | u == u' = b
464+rowOccursCheck _ u (RCons name ty row) = typeOccursCheck True u ty || rowOccursCheck True u row
465+rowOccursCheck _ _ _ = False
src/PureScript/Values.hs+8−3
@@ -50,12 +50,13 @@ data BinaryOperator
5050 | Concat deriving (Show, Eq)
5151
5252data Value
53− = NumericLiteral Double
53+ = NumericLiteral (Either Integer Double)
5454 | StringLiteral String
5555 | BooleanLiteral Bool
5656 | Unary UnaryOperator Value
5757 | Binary BinaryOperator Value Value
5858 | ArrayLiteral [Value]
59+ | Indexer Value Value
5960 | ObjectLiteral [(String, Value)]
6061 | Accessor String Value
6162 | Abs [String] Value
@@ -75,7 +76,11 @@ data Statement
7576 | Return Value deriving Show
7677
7778data Binder
78− = VarBinder String
79+ = BooleanBinder Bool
80+ | StringBinder String
81+ | NumberBinder (Either Integer Double)
82+ | VarBinder String
7983 | NullaryBinder String
8084 | UnaryBinder String Binder
81− | ObjectBinder [(String, Binder)] deriving Show
85+ | ObjectBinder [(String, Binder)]
86+ | ArrayBinder [Binder] (Maybe Binder) deriving Show