1075979 · rowtype-yoga/purescript-native

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

Merge polytype and type data types

commit10759791c6e243ea27bd888400c8c37d7315709a authorPhil Freeman <paf31@cantab.net> dateSun 17 Nov 2013, 18:15 (13 years ago) parente354866

8 files changed+50−34

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+2−2 src/Language/PureScript/Parser/Types.hs+3−2 src/Language/PureScript/Pretty/Types.hs+4−6 src/Language/PureScript/TypeChecker.hs+2−2 src/Language/PureScript/TypeChecker/Kinds.hs+6−4 src/Language/PureScript/TypeChecker/Monad.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+27−11 src/Language/PureScript/Types.hs+4−5

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

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

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

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

2929 (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

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

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

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

3434externToPs 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

3636externToPs indent path env (ExternDataDeclaration name kind) =

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

3838externToPs 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

6767 , parens parseType ])

6868

6969parsePolyType :: P.Parsec String ParseState PolyType

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

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

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

71+ <*> parseType) <|>

72+ (ForAll [] <$> parseType)

7273

7374parseType :: P.Parsec String ParseState Type

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

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

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

1414

1515module Language.PureScript.Pretty.Types (

1616 prettyPrintType,

17− prettyPrintRow,

18− prettyPrintPolyType

17+ prettyPrintRow

1918) where

2019

2120import Data.Maybe (fromMaybe)

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

4342 match (TypeVar var) = Just var

4443 match (TypeConstructor ctor) = Just $ show ctor

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

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

4646 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

4749 match _ = Nothing

4850

4951prettyPrintRow :: Row -> String

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

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

9092 ]

9193 ]

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

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

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

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

57− let polyType = PolyType args dctorTy

57+ let polyType = ForAll args dctorTy

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

5959 typeCheckAll rest

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

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

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

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

9696 Nothing -> case ty of

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

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

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

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

100100 _ -> 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 }

5959emptyKindSolution :: KindSolution

6060emptyKindSolution = KindSolution KUnknown

6161

62−kindOf :: PolyType -> Check Kind

63−kindOf (PolyType idents ty) = do

64− ns <- replicateM (length idents) fresh

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

62+kindOf :: Type -> Check Kind

63+kindOf ty = do

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

6665 solution <- solveKindConstraints cs emptyKindSolution

6766 return $ starIfUnknown $ runKindSolution solution n

6867

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

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

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

126125 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

127129kindConstraints _ m t = do

128130 me <- fresh

129131 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

3333data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

3434

3535data Environment = Environment

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

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

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

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

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

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

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

4141 } deriving (Show)

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

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

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

7777allConstraints _ val = typeConstraints M.empty val

7878

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

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

8080typeOf name val = do

8181 (cs, n) <- allConstraints name val

8282 desugared <- replaceAllTypeSynonyms cs

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

129129 f (RUnknown n) = [n]

130130 f _ = []

131131

132−varIfUnknown :: Type -> PolyType

132+varIfUnknown :: Type -> Type

133133varIfUnknown ty =

134134 let

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

136136 in

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

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

138138 where

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

140140 f (TUnknown n) = do

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

321321 modulePath <- checkModulePath `fmap` get

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

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

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

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

325325 me <- fresh

326326 replaced <- replaceVarsWithUnknowns idents ty

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

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

335335 modulePath <- checkModulePath `fmap` get

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

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

338− Just (PolyType idents ty) -> do

338+ Just (ForAll idents ty) -> do

339339 me <- fresh

340340 replaced <- replaceVarsWithUnknowns idents ty

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

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

349349 (cs2, n2) <- typeConstraints m th

350350 (cs3, n3) <- typeConstraints m el

351351 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

353− kind <- kindOf poly

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

353+ kind <- kindOf ty

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

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

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

355+ typeCheck m val ty

356+ me <- fresh

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

358+

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

360+typeCheck _ _ _ = return ()

357361

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

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

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

403407 env <- getEnv

404408 modulePath <- checkModulePath `fmap` get

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

406− Just (PolyType args ret) -> do

410+ Just (ForAll args ret) -> do

407411 ret' <- replaceVarsWithUnknowns args ret

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

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

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

411415 env <- getEnv

412416 modulePath <- checkModulePath `fmap` get

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

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

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

415419 obj <- fresh

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

417421 (cs, m1) <- typeConstraintsForBinder obj binder

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

590594 unifyTypes o replaced ty

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

592596unifyTypes 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

593601unifyTypes _ Number Number = return []

594602unifyTypes _ String String = return []

595603unifyTypes _ Boolean Boolean = return []

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

609617 cs1 <- unifyTypes o t1 t3

610618 cs2 <- unifyTypes o t2 t4

611619 return $ cs1 ++ cs2

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

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

613622

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

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

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

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

640649 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

3030 | TypeVar String

3131 | TypeConstructor (Qualified ProperName)

3232 | 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)

3436

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

37+type PolyType = Type

3638

3739data Row

3840 = RUnknown Int

3941 | RowVar String

4042 | REmpty

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

42−

43−monoType :: Type -> PolyType

44−monoType = PolyType []