78f85b3 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix some typechecker bugs

78f85b3Phil Freeman13 years ago

src/Main.hs+1−2

compare with golang

unifiedsplit

@@ -15,7 +15,6 @@

15module Main where

17import PureScript

18−import Text.Parsec

19import Data.Maybe (mapMaybe)

18import Data.Maybe (mapMaybe)

20import Data.List (intercalate)

19import Data.List (intercalate)

21import System.Console.CmdTheLine

20import System.Console.CmdTheLine

@@ -26,7 +25,7 @@ import qualified System.IO.UTF8 as U

26compile :: [FilePath] -> Maybe FilePath -> IO ()

25compile :: [FilePath] -> Maybe FilePath -> IO ()

27compile inputFiles outputFile = do

26compile inputFiles outputFile = do

28 input <- fmap concat $ mapM U.readFile inputFiles

27 input <- fmap concat $ mapM U.readFile inputFiles

29− let ast = parse parseDeclarations "" input

28+ let ast = parseDeclarations input

30 case ast of

29 case ast of

31 Left err -> do

30 Left err -> do

32 U.print err

31 U.print err

src/PureScript/CodeGen.hs+9−2

@@ -23,7 +23,10 @@ import PureScript.Declarations

23declToJs :: Declaration -> Maybe String

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

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

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

27+ case maybeTy of

28+ Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"

26− Just $ concatMap (\(ctor, _) -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };") ctors

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

27declToJs _ = Nothing

30declToJs _ = Nothing

29valueToJs :: Value -> String

32valueToJs :: Value -> String

@@ -77,7 +80,11 @@ binaryOperatorString Concat = "+"

78binderToJs :: Int -> Int -> Binder -> String -> (String, Int)

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

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

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

80−binderToJs varName fresh (ConstructorBinder ctor b) done =

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 =

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

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

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

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

83 ++ js

90 ++ js

src/PureScript/Declarations.hs+1−1

@@ -28,5 +28,5 @@ data Declaration

28data DataConstructors = DataConstructors

29 { typeConstructorName :: String

30 , typeArguments :: [String]

31− , dataConstructors :: [(String, Type)]

31+ , dataConstructors :: [(String, Maybe Type)]

32 } deriving Show

src/PureScript/Parser/Declarations.hs+13−6

@@ -17,12 +17,16 @@ module PureScript.Parser.Declarations (

17 parseDeclarations

18) where

20−import PureScript.Values

20+import Data.Char

21−import PureScript.Types

21+import Data.List

22−import PureScript.Parser.Common

22+import Data.Function

23import Control.Applicative

24import qualified Text.Parsec as P

25import Control.Arrow (Arrow(..))

26+

27+import PureScript.Values

28+import PureScript.Types

29+import PureScript.Parser.Common

26import PureScript.Declarations

30import PureScript.Declarations

27import PureScript.Parser.Values

31import PureScript.Parser.Values

28import PureScript.Parser.Types

32import PureScript.Parser.Types

@@ -33,7 +37,7 @@ parseDataDeclaration = do

33 name <- properName

37 name <- properName

34 tyArgs <- many identifier

38 tyArgs <- many identifier

35 lexeme $ P.char '='

39 lexeme $ P.char '='

36− ctors <- P.sepBy1 ((,) <$> properName <*> parseType) (lexeme $ P.char '|')

40+ ctors <- P.sepBy1 ((,) <$> properName <*> P.optionMaybe parseType) (lexeme $ P.char '|')

37 return $ DataDeclaration $ DataConstructors name tyArgs ctors

41 return $ DataDeclaration $ DataConstructors name tyArgs ctors

39parseValueDeclaration :: P.Parsec String () Declaration

43parseValueDeclaration :: P.Parsec String () Declaration

@@ -43,5 +47,8 @@ parseDeclaration :: P.Parsec String () Declaration

43parseDeclaration = parseDataDeclaration

47parseDeclaration = parseDataDeclaration

44 P.<|> parseValueDeclaration

48 P.<|> parseValueDeclaration

46−parseDeclarations :: P.Parsec String () [Declaration]

50+parseDeclarations :: String -> Either P.ParseError [Declaration]

47−parseDeclarations = whiteSpace *> P.sepEndBy parseDeclaration semi <* P.eof

51+parseDeclarations = mapM (P.parse (parseDeclaration <* whiteSpace <* P.eof) "Declaration") . splitFileIntoDeclarations

52+

53+splitFileIntoDeclarations :: String -> [String]

54+splitFileIntoDeclarations = map unlines . filter (not . all isSpace . head) . groupBy ((==) `on` (all isSpace)) . lines

src/PureScript/Parser/Values.hs+10−7

@@ -62,7 +62,7 @@ parseApp = App <$> parseValue

62 <*> (C.parens $ C.commaSep parseValue)

64parseVar :: P.Parsec String () Value

65−parseVar = Var <$> C.identifier

65+parseVar = Var <$> (C.identifier <|> C.properName)

67parseCase :: P.Parsec String () Value

68parseCase = Case <$> P.between (C.reserved "case") (C.reserved "of") parseValue

@@ -88,9 +88,9 @@ parseValueAtom = P.choice $ map P.try

88 , C.parens parseValue ]

90parseValue :: P.Parsec String () Value

91−parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue') (C.lexeme funArgs) App

91+parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.lexeme funArgs) App

92 where

93− typedValue' = C.augment parseValueAtom parseTypeAnnotation TypedValue

93+ typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

94 funArgs = C.parens $ C.commaSep parseValue

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

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

@@ -168,9 +168,11 @@ parseStatement = P.choice $ map P.try

168parseVarBinder :: P.Parsec String () Binder

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

170

171−parseConstructorBinder :: P.Parsec String () Binder

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

172−parseConstructorBinder = ConstructorBinder <$> C.lexeme C.properName

172+parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName

173− <*> parseBinder

173+

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

175+parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> parseBinder

174

176

175parseObjectBinder :: P.Parsec String () Binder

177parseObjectBinder :: P.Parsec String () Binder

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

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

@@ -185,6 +187,7 @@ parseIdentifierAndBinder = do

185parseBinder :: P.Parsec String () Binder

187parseBinder :: P.Parsec String () Binder

186parseBinder = P.choice $ map P.try

188parseBinder = P.choice $ map P.try

187 [ parseVarBinder

189 [ parseVarBinder

188− , parseConstructorBinder

190+ , parseUnaryBinder

191+ , parseNullaryBinder

189 , parseObjectBinder

192 , parseObjectBinder

190 , C.parens parseBinder ]

193 , C.parens parseBinder ]

src/PureScript/TypeChecker.hs+10−8

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

27import PureScript.TypeChecker.Types

29import Data.List

30+import Data.Maybe

30import Data.Function

31import Data.Function

32import PureScript.Values

33import PureScript.Values

@@ -47,20 +48,21 @@ typeCheck (DataDeclaration dcs@(DataConstructors

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

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

48 env <- get

49 env <- get

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

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

50− kinds <- kindsOf args (map snd ctors)

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

51− let ctorKind = foldl FunKind Star kinds

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

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

53− flip mapM_ ctors $ \(dctor, ty) -> rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

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

54− env' <- get

55+ env' <- get

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

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

56− let ctorType = Function [ty] $ foldl TypeApp (TypeConstructor name) (map TypeVar args)

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

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

57− put $ env' { names = M.insert dctor ctorType (names env) }

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

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

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

59 env <- get

61 env <- get

60 case M.lookup name (names env) of

62 case M.lookup name (names env) of

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

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

62 Nothing -> do

64 Nothing -> do

63− ty <- typeOf val

65+ ty <- typeOf name val

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

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

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

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

src/PureScript/TypeChecker/Kinds.hs+53−34

@@ -35,65 +35,82 @@ import qualified Control.Category as C

36import qualified Data.Map as M

38−data KindConstraint = KindConstraint Int Kind deriving Show

38+data KindConstraint = KindConstraint Int Kind

39+

40+instance Show KindConstraint where

41+ show (KindConstraint n k) = show n ++ " = " ++ show k

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

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

42emptyKindSolution :: KindSolution

45emptyKindSolution :: KindSolution

43emptyKindSolution = KindSolution KUnknown

46emptyKindSolution = KindSolution KUnknown

45−kindsOf :: [String] -> [Type] -> Check [Kind]

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

46−kindsOf args ts = do

49+kindsOf name args ts = do

50+ let tyCon = 0

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

47− (cs, _, m) <- kindConstraintsAll 0 M.empty ts

52+ (cs, ns, _, m) <- kindConstraintsAll (length args + 1) (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

48− solution <- solveKindConstraints cs emptyKindSolution

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

49− return $ map (maybe Star starIfUnknown . fmap (runKindSolution solution) . flip M.lookup m) args

55+ return $ starIfUnknown $ runKindSolution solution 0

51starIfUnknown :: Kind -> Kind

57starIfUnknown :: Kind -> Kind

52starIfUnknown (KUnknown _) = Star

58starIfUnknown (KUnknown _) = Star

53starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

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

54starIfUnknown k = k

60starIfUnknown k = k

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

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

57−kindConstraintsAll _ m [] = return ([], [], m)

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

58kindConstraintsAll n m (t:ts) = do

64kindConstraintsAll n m (t:ts) = do

59− (cs, n', m') <- kindConstraints n m t

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

60− (cs', ns, m'') <- kindConstraintsAll (n' + 1) m' ts

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

61− return ((KindConstraint n' Star) : cs ++ cs', n':ns, m'')

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

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

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

64kindConstraints n m (Array t) = do

70kindConstraints n m (Array t) = do

71+ let me = n

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

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

66− return ((KindConstraint n' Star) : (KindConstraint (n' + 1) Star) : cs, n' + 1, m')

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

67kindConstraints n m (Object row) = do

74kindConstraints n m (Object row) = do

68 let me = n

75 let me = n

69− (cs, row, m') <- kindConstraintsForRow (n + 2) m row

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

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

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

71kindConstraints n m (Function args ret) = do

78kindConstraints n m (Function args ret) = do

79+ let me = n

72− (cs, ns, m') <- kindConstraintsAll n m args

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

73− let next = maximum ns + 1

74− (cs', retN, m'') <- kindConstraints next m' ret

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

75− let me = retN + 1

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

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

77kindConstraints n m (TypeVar v) =

83kindConstraints n m (TypeVar v) =

78− let

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

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

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

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

81kindConstraints n m (TypeConstructor v) = do

86kindConstraints n m (TypeConstructor v) = do

82 env <- get

87 env <- get

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

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

83− kind <- maybe (throwError "Unknown type constructor") return (M.lookup v (types env))

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

91+ Just k -> return k

92+ Just u -> return (KUnknown u)

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

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

85kindConstraints n m (TypeApp t1 t2) = do

94kindConstraints n m (TypeApp t1 t2) = do

95+ let me = n

86− (cs1, n1, m1) <- kindConstraints n m t1

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

87− (cs2, n2, m2) <- kindConstraints (n1 + 1) m1 t2

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

88− return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown (n2 + 1)))) : cs1 ++ cs2, n2 + 1, m2)

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

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

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

90−

100+

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

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

92−kindConstraintsForRow = undefined

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)

110

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

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

95solveKindConstraints [] s = return s

112solveKindConstraints [] s = return s

96−solveKindConstraints (KindConstraint n k:cs) s = do

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

97 guardWith "Occurs check failed" $ not $ kindOccursCheck n k

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

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

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

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

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

@@ -112,6 +129,7 @@ replaceUnknownKind n k = f

112 f other = other

129 f other = other

113

130

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

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

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

115unifyKinds (KUnknown u) k = do

133unifyKinds (KUnknown u) k = do

116 guardWith "Occurs check failed" $ not $ kindOccursCheck u k

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

117 return [KindConstraint u k]

135 return [KindConstraint u k]

@@ -119,6 +137,7 @@ unifyKinds k (KUnknown u) = do

119 guardWith "Occurs check failed" $ not $ kindOccursCheck u k

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

120 return [KindConstraint u k]

138 return [KindConstraint u k]

121unifyKinds Star Star = return []

139unifyKinds Star Star = return []

140+unifyKinds Row Row = return []

122unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do

141unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do

123 cs1 <- unifyKinds k1 k3

142 cs1 <- unifyKinds k1 k3

124 cs2 <- unifyKinds k2 k4

143 cs2 <- unifyKinds k2 k4

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

@@ -35,8 +35,8 @@ emptyEnvironment = Environment M.empty M.empty

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

38−check :: Check a -> Either String a

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

39−check = flip evalStateT emptyEnvironment . unCheck

39+check = flip runStateT emptyEnvironment . unCheck

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

42guardWith _ True = return ()

src/PureScript/TypeChecker/Types.hs+35−12

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

18 typeOf

19) where

21+import Debug.Trace

22+

21import Data.List

23import Data.List

22import Data.Function

24import Data.Function

@@ -43,10 +45,11 @@ newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Ro

43emptyTypeSolution :: TypeSolution

45emptyTypeSolution :: TypeSolution

44emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

46emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

46−typeOf :: Value -> Check Type

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

47−typeOf val = do

49+typeOf name val = do

50+ let me = 0

48− (cs, n, _) <- typeConstraints 0 M.empty val

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

49− solution <- solveTypeConstraints cs emptyTypeSolution

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

50 return $ varIfUnknown $ fst (runTypeSolution solution) n

53 return $ varIfUnknown $ fst (runTypeSolution solution) n

52varIfUnknown :: Type -> Type

55varIfUnknown :: Type -> Type

@@ -213,25 +216,44 @@ symBinOpConstraints ty left right result = [TypeConstraint left ty, TypeConstrai

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

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

214typeConstraintsForBinder n m val (VarBinder name) =

217typeConstraintsForBinder n m val (VarBinder name) =

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

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

216−typeConstraintsForBinder n m val (ConstructorBinder ctor binder) = do

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

220+ env <- get

221+ case M.lookup ctor (names env) of

222+ Just ret -> do

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

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

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

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

217 env <- get

227 env <- get

218 case M.lookup ctor (names env) of

228 case M.lookup ctor (names env) of

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

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

220 let obj = n

230 let obj = n

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

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

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

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

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

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

224− Just _ -> throwError $ ctor ++ " is not a constructor"

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

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

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

226−typeConstraintsForBinder n m val (ObjectBinder props) = do undefined

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)

241+ 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)

227

249

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

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

229typeConstraintsForBinders n _ _ _ [] = return ([], n)

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

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

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

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

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

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

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

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

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

234− return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3, max2)

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

235

257

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

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

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

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

@@ -291,7 +313,7 @@ typeConstraintsAll n m (t:ts) = do

291

313

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

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

293solveTypeConstraints [] s = return s

315solveTypeConstraints [] s = return s

294−solveTypeConstraints (TypeConstraint n t:cs) s = do

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

295 guardWith "Occurs check failed" $ not $ typeOccursCheck n t

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

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

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

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

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

@@ -343,8 +365,9 @@ replaceRowInRow n r (RCons name ty row) = RCons name (replaceRowInType n r ty) (

343replaceRowInRow _ _ other = other

365replaceRowInRow _ _ other = other

344

366

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

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

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

346unifyTypes (TUnknown u) t = do

369unifyTypes (TUnknown u) t = do

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

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

348 return [TypeConstraint u t]

371 return [TypeConstraint u t]

349unifyTypes t (TUnknown u) = do

372unifyTypes t (TUnknown u) = do

350 guardWith "Occurs check failed" $ not $ typeOccursCheck u t

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

src/PureScript/Values.hs+2−1

@@ -76,5 +76,6 @@ data Statement

77data Binder

78 = VarBinder String

79+ | NullaryBinder String

79− | ConstructorBinder String Binder

80+ | UnaryBinder String Binder

80 | ObjectBinder [(String, Binder)] deriving Show

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