1075979 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge polytype and type data types

1075979Phil Freeman13 years ago

src/Language/PureScript/CodeGen/Externs.hs+2−2

compare with golang

unifiedsplit

@@ -27,12 +27,12 @@ import Language.PureScript.Names

27externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

28externToPs indent path env (ValueDeclaration name _) = do

29 (ty, _) <- M.lookup (path, name) $ names env

30− return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintPolyType ty

30+ return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

31externToPs indent path env (DataDeclaration name _ _) = do

32 (kind, _) <- M.lookup (path, name) $ types env

33 return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

34externToPs indent path env (ExternMemberDeclaration member name ty) =

35− return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintPolyType ty

35+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

36externToPs indent path env (ExternDataDeclaration name kind) =

37 return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

38externToPs indent path env (TypeSynonymDeclaration name args ty) =

src/Language/PureScript/Parser/Types.hs+3−2

@@ -67,8 +67,9 @@ parseTypeAtom = indented *> P.choice (map P.try

67 , parens parseType ])

69parsePolyType :: P.Parsec String ParseState PolyType

70−parsePolyType = (PolyType <$> P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot)

70+parsePolyType = (ForAll <$> (P.try (reserved "forall") *> many (indented *> identifier) <* indented <* dot)

71− <*> parseType) P.<?> "polymorphic type"

71+ <*> parseType) <|>

72+ (ForAll [] <$> parseType)

73parseType :: P.Parsec String ParseState Type

74parseType :: P.Parsec String ParseState Type

74parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

75parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

src/Language/PureScript/Pretty/Types.hs+4−6

@@ -14,8 +14,7 @@

15module Language.PureScript.Pretty.Types (

16 prettyPrintType,

17− prettyPrintRow,

17+ prettyPrintRow

18− prettyPrintPolyType

19) where

18) where

21import Data.Maybe (fromMaybe)

20import Data.Maybe (fromMaybe)

@@ -43,7 +42,10 @@ typeLiterals = mkPattern match

43 match (TypeVar var) = Just var

42 match (TypeVar var) = Just var

44 match (TypeConstructor ctor) = Just $ show ctor

43 match (TypeConstructor ctor) = Just $ show ctor

45 match (TUnknown u) = Just $ 'u' : show u

44 match (TUnknown u) = Just $ 'u' : show u

45+ match (Skolem s) = Just $ 's' : show s

46 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

47+ match (ForAll idents ty) | not (null idents) = Just $ "forall " ++ unwords idents ++ ". " ++ prettyPrintType ty

48+ | otherwise = match ty

47 match _ = Nothing

49 match _ = Nothing

49prettyPrintRow :: Row -> String

51prettyPrintRow :: Row -> String

@@ -89,7 +91,3 @@ prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()

89 , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

91 , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

90 ]

92 ]

91 ]

93 ]

92−

93−prettyPrintPolyType :: PolyType -> String

94−prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty

95−prettyPrintPolyType (PolyType idents ty) = "forall " ++ unwords idents ++ ". " ++ prettyPrintType ty

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

@@ -54,7 +54,7 @@ typeCheckAll (DataDeclaration name args dctors : rest) = do

54 guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')

55 let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)

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

57− let polyType = PolyType args dctorTy

57+ let polyType = ForAll args dctorTy

58 putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }

59 typeCheckAll rest

60typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

@@ -94,7 +94,7 @@ typeCheckAll (ExternMemberDeclaration member name ty : rest) = do

94 case M.lookup (modulePath, name) (names env) of

95 Just _ -> throwError $ show name ++ " is already defined"

96 Nothing -> case ty of

97− (PolyType _ (Function [_] _)) -> do

97+ (ForAll _ (Function [_] _)) -> do

98 putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)

99 , members = M.insert (modulePath, name) member (members env) })

100 _ -> throwError "Foreign member declarations must have function types, with an single argument."

src/Language/PureScript/TypeChecker/Kinds.hs+6−4

@@ -59,10 +59,9 @@ newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }

59emptyKindSolution :: KindSolution

60emptyKindSolution = KindSolution KUnknown

62−kindOf :: PolyType -> Check Kind

62+kindOf :: Type -> Check Kind

63−kindOf (PolyType idents ty) = do

63+kindOf ty = do

64− ns <- replicateM (length idents) fresh

65− (cs, n, m) <- kindConstraints Nothing (M.fromList (zip idents ns)) ty

64+ (cs, n, m) <- kindConstraints Nothing M.empty ty

66 solution <- solveKindConstraints cs emptyKindSolution

65 solution <- solveKindConstraints cs emptyKindSolution

67 return $ starIfUnknown $ runKindSolution solution n

66 return $ starIfUnknown $ runKindSolution solution n

@@ -124,6 +123,9 @@ kindConstraints name m a@(TypeApp t1 t2) = do

124 (cs1, n1, m1) <- kindConstraints name m t1

123 (cs1, n1, m1) <- kindConstraints name m t1

125 (cs2, n2, m2) <- kindConstraints name m1 t2

124 (cs2, n2, m2) <- kindConstraints name m1 t2

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

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

126+kindConstraints name m (ForAll idents ty) = do

127+ ns <- replicateM (length idents) fresh

128+ kindConstraints name (M.fromList (zip idents ns) `M.union` m) ty

127kindConstraints _ m t = do

129kindConstraints _ m t = do

128 me <- fresh

130 me <- fresh

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

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

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

@@ -33,9 +33,9 @@ data NameKind = Value | Extern | Alias ModulePath Ident deriving Show

33data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

35data Environment = Environment

36− { names :: M.Map (ModulePath, Ident) (PolyType, NameKind)

36+ { names :: M.Map (ModulePath, Ident) (Type, NameKind)

37 , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)

38− , dataConstructors :: M.Map (ModulePath, ProperName) PolyType

38+ , dataConstructors :: M.Map (ModulePath, ProperName) Type

39 , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)

40 , members :: M.Map (ModulePath, Ident) String

41 } deriving (Show)

src/Language/PureScript/TypeChecker/Types.hs+27−11

@@ -76,7 +76,7 @@ allConstraints name val | isFunction val = do

76 return (TypeConstraint me (TUnknown n) (ValueOrigin val): cs, n)

77allConstraints _ val = typeConstraints M.empty val

79−typeOf :: Ident -> Value -> Check PolyType

79+typeOf :: Ident -> Value -> Check Type

80typeOf name val = do

81 (cs, n) <- allConstraints name val

82 desugared <- replaceAllTypeSynonyms cs

@@ -129,12 +129,12 @@ findUnknownRows = everything (++) (mkQ [] f)

129 f (RUnknown n) = [n]

130 f _ = []

131

132−varIfUnknown :: Type -> PolyType

132+varIfUnknown :: Type -> Type

133varIfUnknown ty =

134 let

135 (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty

136 in

137− PolyType (sort $ nub $ M.elems m ++ findTypeVars ty) ty'

137+ ForAll (sort $ nub $ M.elems m ++ findTypeVars ty) ty'

138 where

139 f :: Type -> State (M.Map Int String) Type

140 f (TUnknown n) = do

@@ -321,7 +321,7 @@ typeConstraints m v@(Var var@(Qualified mp name)) = do

321 modulePath <- checkModulePath `fmap` get

322 case M.lookup (qualify modulePath var) (names env) of

323 Nothing -> throwError $ show var ++ " is undefined"

324− Just (PolyType idents ty, _) -> do

324+ Just (ForAll idents ty, _) -> do

325 me <- fresh

326 replaced <- replaceVarsWithUnknowns idents ty

327 return ([TypeConstraint me replaced (ValueOrigin v)], me)

@@ -335,7 +335,7 @@ typeConstraints m v@(Constructor c) = do

335 modulePath <- checkModulePath `fmap` get

336 case M.lookup (qualify modulePath c) (dataConstructors env) of

337 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

338− Just (PolyType idents ty) -> do

338+ Just (ForAll idents ty) -> do

339 me <- fresh

340 replaced <- replaceVarsWithUnknowns idents ty

341 return ([TypeConstraint me replaced (ValueOrigin v)], me)

@@ -349,11 +349,15 @@ typeConstraints m v@(IfThenElse cond th el) = do

349 (cs2, n2) <- typeConstraints m th

350 (cs3, n3) <- typeConstraints m el

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

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

352+typeConstraints m v@(TypedValue val ty) = do

353− kind <- kindOf poly

353+ kind <- kindOf ty

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

355− (cs, n1) <- typeConstraints m val

355+ typeCheck m val ty

356+ me <- fresh

356− return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1)

357+ return ([TypeConstraint me ty (ValueOrigin v)], me)

358+

359+typeCheck :: M.Map Ident Int -> Value -> Type -> Check ()

360+typeCheck _ _ _ = return ()

357

361

358unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]

362unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]

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

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

@@ -403,7 +407,7 @@ typeConstraintsForBinder val b@(NullaryBinder ctor) = do

403 env <- getEnv

407 env <- getEnv

404 modulePath <- checkModulePath `fmap` get

408 modulePath <- checkModulePath `fmap` get

405 case M.lookup (qualify modulePath ctor) (dataConstructors env) of

409 case M.lookup (qualify modulePath ctor) (dataConstructors env) of

406− Just (PolyType args ret) -> do

410+ Just (ForAll args ret) -> do

407 ret' <- replaceVarsWithUnknowns args ret

411 ret' <- replaceVarsWithUnknowns args ret

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

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

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

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

@@ -411,7 +415,7 @@ typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do

411 env <- getEnv

415 env <- getEnv

412 modulePath <- checkModulePath `fmap` get

416 modulePath <- checkModulePath `fmap` get

413 case M.lookup (qualify modulePath ctor) (dataConstructors env) of

417 case M.lookup (qualify modulePath ctor) (dataConstructors env) of

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

418+ Just (ForAll idents f@(Function [_] _)) -> do

415 obj <- fresh

419 obj <- fresh

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

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

417 (cs, m1) <- typeConstraintsForBinder obj binder

421 (cs, m1) <- typeConstraintsForBinder obj binder

@@ -590,6 +594,10 @@ unifyTypes o (SaturatedTypeSynonym name args) ty = do

590 unifyTypes o replaced ty

594 unifyTypes o replaced ty

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

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

592unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty

596unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty

597+unifyTypes o (ForAll idents ty1) ty2 =do

598+ sk <- skolemize idents ty1

599+ unifyTypes o sk ty2

600+unifyTypes o ty f@(ForAll _ _) = unifyTypes o f ty

593unifyTypes _ Number Number = return []

601unifyTypes _ Number Number = return []

594unifyTypes _ String String = return []

602unifyTypes _ String String = return []

595unifyTypes _ Boolean Boolean = return []

603unifyTypes _ Boolean Boolean = return []

@@ -609,6 +617,7 @@ unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do

609 cs1 <- unifyTypes o t1 t3

617 cs1 <- unifyTypes o t1 t3

610 cs2 <- unifyTypes o t2 t4

618 cs2 <- unifyTypes o t2 t4

611 return $ cs1 ++ cs2

619 return $ cs1 ++ cs2

620+unifyTypes _ (Skolem s1) (Skolem s2) | s1 == s2 = return []

612unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."

621unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."

613

622

614unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

623unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

@@ -638,3 +647,10 @@ unifyRows o r1 r2 =

638 unifyRows' _ [] REmpty [] REmpty = return []

647 unifyRows' _ [] REmpty [] REmpty = return []

639 unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return []

648 unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return []

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

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

650+

651+skolemize :: [String] -> Type -> Check Type

652+skolemize idents ty = do

653+ sks <- replicateM (length idents) fresh

654+ let m = M.fromList (zip idents (map Skolem sks))

655+ return $ replaceTypeVars m ty

656+

src/Language/PureScript/Types.hs+4−5

@@ -30,15 +30,14 @@ data Type

30 | TypeVar String

31 | TypeConstructor (Qualified ProperName)

32 | TypeApp Type Type

33− | SaturatedTypeSynonym (Qualified ProperName) [Type] deriving (Show, Eq, Data, Typeable)

33+ | SaturatedTypeSynonym (Qualified ProperName) [Type]

34+ | ForAll [String] Type

35+ | Skolem Int deriving (Show, Eq, Data, Typeable)

35−data PolyType = PolyType [String] Type deriving (Show, Eq, Data, Typeable)

37+type PolyType = Type

37data Row

39data Row

38 = RUnknown Int

40 = RUnknown Int

39 | RowVar String

41 | RowVar String

40 | REmpty

42 | REmpty

41 | RCons String Type Row deriving (Show, Eq, Data, Typeable)

43 | RCons String Type Row deriving (Show, Eq, Data, Typeable)

42−

43−monoType :: Type -> PolyType

44−monoType = PolyType []