git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Monotype check
f6055cbPhil Freeman
src/Language/PureScript/Parser/Types.hs+21−8
compare with golang
unifiedsplit
@@ -25,6 +25,7 @@ import Control.Applicative
25import qualified Text.Parsec as P
25import qualified Text.Parsec as P
26import qualified Text.Parsec.Expr as P
26import qualified Text.Parsec.Expr as P
27import Control.Arrow (Arrow(..))
27import Control.Arrow (Arrow(..))
28+import Control.Monad (unless)
28
29
29parseNumber :: P.Parsec String ParseState Type
30parseNumber :: P.Parsec String ParseState Type
30parseNumber = const Number <$> reserved "Number"
31parseNumber = const Number <$> reserved "Number"
@@ -43,7 +44,7 @@ parseObject = braces $ Object <$> parseRow
43
44
44parseFunction :: P.Parsec String ParseState Type
45parseFunction :: P.Parsec String ParseState Type
45parseFunction = do
46parseFunction = do
46− args <- lexeme $ parens $ commaSep parseType
47+ args <- lexeme $ parens $ commaSep parsePolyType
47 lexeme $ P.string "->"
48 lexeme $ P.string "->"
48 resultType <- parseType
49 resultType <- parseType
49 return $ Function args resultType
50 return $ Function args resultType
@@ -54,6 +55,10 @@ parseTypeVariable = TypeVar <$> identifier
54parseTypeConstructor :: P.Parsec String ParseState Type
55parseTypeConstructor :: P.Parsec String ParseState Type
55parseTypeConstructor = TypeConstructor <$> parseQualified properName
56parseTypeConstructor = TypeConstructor <$> parseQualified properName
56
57
58+parseForAll :: P.Parsec String ParseState Type
59+parseForAll = (ForAll <$> (P.try (reserved "forall") *> many (indented *> identifier) <* indented <* dot)
60+ <*> parseType)
61+
57parseTypeAtom :: P.Parsec String ParseState Type
62parseTypeAtom :: P.Parsec String ParseState Type
58parseTypeAtom = indented *> P.choice (map P.try
63parseTypeAtom = indented *> P.choice (map P.try
59 [ parseNumber
64 [ parseNumber
@@ -64,20 +69,28 @@ parseTypeAtom = indented *> P.choice (map P.try
64 , parseFunction
69 , parseFunction
65 , parseTypeVariable
70 , parseTypeVariable
66 , parseTypeConstructor
71 , parseTypeConstructor
72+ , parseForAll
67 , parens parseType ])
73 , parens parseType ])
68
74
69−parsePolyType :: P.Parsec String ParseState PolyType
70−parsePolyType = (ForAll <$> (P.try (reserved "forall") *> many (indented *> identifier) <* indented <* dot)
71− <*> parseType) <|>
72− (ForAll [] <$> parseType)
73−
74−parseType :: P.Parsec String ParseState Type
75+parseAnyType :: P.Parsec String ParseState Type
75−parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
76+parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
76 where
77 where
77 postfixTable :: [P.Parsec String ParseState (Type -> Type)]
78 postfixTable :: [P.Parsec String ParseState (Type -> Type)]
78 postfixTable = [ flip TypeApp <$> P.try (indented *> parseTypeAtom) ]
79 postfixTable = [ flip TypeApp <$> P.try (indented *> parseTypeAtom) ]
79 operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
80 operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
80
81
82+parseType :: P.Parsec String ParseState Type
83+parseType = do
84+ ty <- parseAnyType
85+ unless (isMonoType ty) $ P.unexpected "polymorphic type"
86+ return ty
87+
88+parsePolyType :: P.Parsec String ParseState PolyType
89+parsePolyType = do
90+ ty <- parseAnyType
91+ unless (isPolyType ty) $ P.unexpected "polymorphic type"
92+ return ty
93+
81parseNameAndType :: P.Parsec String ParseState (String, Type)
94parseNameAndType :: P.Parsec String ParseState (String, Type)
82parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
95parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
83
96
src/Language/PureScript/TypeChecker/Types.hs−13
@@ -229,19 +229,6 @@ occursCheck u = everything (||) $ flip extQ g $ mkQ False f
229 g (RUnknown u') | u' == u = True
229 g (RUnknown u') | u' == u = True
230 g _ = False
230 g _ = False
231
231
232−typesToRow :: [(String, Type)] -> Row
233−typesToRow [] = REmpty
234−typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
235−
236−rowToList :: Row -> ([(String, Type)], Row)
237−rowToList (RCons name ty row) = let (tys, rest) = rowToList row
238− in ((name, ty):tys, rest)
239−rowToList r = ([], r)
240−
241−rowFromList :: ([(String, Type)], Row) -> Row
242−rowFromList ([], r) = r
243−rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
244−
245ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
232ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
246ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
233ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
247
234
src/Language/PureScript/Types.hs+27−1
@@ -26,7 +26,7 @@ data Type
26 | Boolean
26 | Boolean
27 | Array Type
27 | Array Type
28 | Object Row
28 | Object Row
29− | Function [Type] Type
29+ | Function [PolyType] Type
30 | TypeVar String
30 | TypeVar String
31 | TypeConstructor (Qualified ProperName)
31 | TypeConstructor (Qualified ProperName)
32 | TypeApp Type Type
32 | TypeApp Type Type
@@ -41,3 +41,29 @@ data Row
41 | RowVar String
41 | RowVar String
42 | REmpty
42 | REmpty
43 | RCons String Type Row deriving (Show, Eq, Data, Typeable)
43 | RCons String Type Row deriving (Show, Eq, Data, Typeable)
44+
45+typesToRow :: [(String, Type)] -> Row
46+typesToRow [] = REmpty
47+typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
48+
49+rowToList :: Row -> ([(String, Type)], Row)
50+rowToList (RCons name ty row) = let (tys, rest) = rowToList row
51+ in ((name, ty):tys, rest)
52+rowToList r = ([], r)
53+
54+rowFromList :: ([(String, Type)], Row) -> Row
55+rowFromList ([], r) = r
56+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
57+
58+isMonoType :: Type -> Bool
59+isMonoType (ForAll _ _) = False
60+isMonoType ty = isPolyType ty
61+
62+isPolyType :: Type -> Bool
63+isPolyType (Array ty) = isMonoType ty
64+isPolyType (Object ps) = all isMonoType (map snd . fst $ rowToList ps)
65+isPolyType (Function args ret) = all isPolyType args && isMonoType ret
66+isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2
67+isPolyType (SaturatedTypeSynonym _ args) = all isMonoType args
68+isPolyType (ForAll idents ty) = isPolyType ty
69+isPolyType _ = True