5d428e9 · rowtype-yoga/purescript-native

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

Separate polytypes into their own datatype, remove rank 2 types. Fix type synonym example.

commit5d428e9a0e35ce06d8072d1b1fa49b4d01cb4455 authorPhil Freeman <paf31@cantab.net> dateWed 9 Oct 2013, 16:40 (13 years ago) parentf96c9a1

14 files changed+76−86

compare with golang

unifiedsplit

examples/Rank2.ps−2 examples/TypeSynonyms.ps+11−9 src/PureScript/CodeGen/Externs.hs+5−9 src/PureScript/Declarations.hs+3−5 src/PureScript/Kinds.hs+1−3 src/PureScript/Parser/Declarations.hs+2−2 src/PureScript/Parser/Types.hs+5−5 src/PureScript/Parser/Values.hs+6−2 src/PureScript/TypeChecker.hs+5−5 src/PureScript/TypeChecker/Kinds.hs+4−6 src/PureScript/TypeChecker/Monad.hs+4−3 src/PureScript/TypeChecker/Types.hs+21−20 src/PureScript/Types.hs+7−6 src/PureScript/Values.hs+2−9

examples/Rank2.psdeleted−2

@@ -1,2 +0,0 @@

1−test :: (forall a. (a) -> a) -> Boolean

2−test = \f -> f(f(1) < f(2))

examples/TypeSynonyms.ps+11−9

@@ -1,12 +1,14 @@

1−type Monad m =

2− { ret :: forall a. (a) -> m a

3− ; bind :: forall a b. (m a) -> ((a) -> m b) -> m b

1+type Lens a b =

2+ { get :: (a) -> b

3+ ; set :: (a) -> (b) -> b

44 }

6−data List a = Nil | Cons { head :: a; tail :: List a }

7−

8−replicateM :: forall m a. ((Number, Monad m, m a) -> m (List a))

9−replicateM = \n, m, x -> case n of

10− { 0 -> (m.ret)(Nil)

11− ; n -> (m.bind)(x)(\a -> (m.bind)(replicateM(n - 1, m, x))(\as -> (m.ret)(Cons({ head: a, tail: as }))))

6+composeLenses :: forall a b c. (Lens a b) -> (Lens b c) -> Lens a c

7+composeLenses = \l1 -> \l2 ->

8+ { get: \a -> (l2.get)((l1.get)(a))

9+ , set: \a -> \c -> {

10+ var b = (l1.get)(a);

11+ var b1 = (l2.set)(b)(c);

12+ return (l1.set)(a)(b1);

13+ }

1214 }

src/PureScript/CodeGen/Externs.hs+5−9

@@ -29,8 +29,8 @@ import PureScript.Declarations

2929import PureScript.TypeChecker.Monad

3030import PureScript.CodeGen.Common

3131

32−externToPs :: String -> (Type, NameKind) -> String

33−externToPs name (ty, _) = "extern " ++ name ++ " :: " ++ typeToPs ty

32+externToPs :: String -> (PolyType, NameKind) -> String

33+externToPs name (ty, _) = "extern " ++ name ++ " :: " ++ polyTypeToPs ty

3434

3535typeLiterals :: Pattern Type String

3636typeLiterals = Pattern $ A.Kleisli match

@@ -71,12 +71,6 @@ function = Pattern $ A.Kleisli match

7171 match (Function args ret) = Just (args, ret)

7272 match _ = Nothing

7373

74−forAll :: Pattern Type ([String], Type)

75−forAll = Pattern $ A.Kleisli match

76− where

77− match (ForAll args t) = Just (args, t)

78− match _ = Nothing

79−

8074typeToPs :: Type -> String

8175typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType

8276 where

@@ -86,6 +80,8 @@ typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType

8680 operators =

8781 OperatorTable $ [ AssocL typeApp $ \f x -> f ++ " " ++ x

8882 , Split function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ typeToPs ret

89− , Wrap forAll $ \args t -> "forall " ++ intercalate " " args ++ ". " ++ t

9083 ]

9184

85+polyTypeToPs :: PolyType -> String

86+polyTypeToPs (PolyType [] ty) = typeToPs ty

87+polyTypeToPs (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ typeToPs ty

src/PureScript/Declarations.hs+3−5

@@ -14,9 +14,7 @@

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616

17−module PureScript.Declarations (

18− Declaration (..)

19−) where

17+module PureScript.Declarations where

2018

2119import PureScript.Values

2220import PureScript.Types

@@ -26,6 +24,6 @@ import Data.Data

2624data Declaration

2725 = DataDeclaration String [String] [(String, Maybe Type)]

2826 | TypeSynonymDeclaration String [String] Type

29− | TypeDeclaration String Type

27+ | TypeDeclaration String PolyType

3028 | ValueDeclaration String Value

31− | ExternDeclaration String Type deriving (Show, Data, Typeable)

29+ | ExternDeclaration String PolyType deriving (Show, Data, Typeable)

src/PureScript/Kinds.hs+1−3

@@ -14,9 +14,7 @@

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616

17−module PureScript.Kinds (

18− Kind (..)

19−) where

17+module PureScript.Kinds where

2018

2119import Data.Data

2220

src/PureScript/Parser/Declarations.hs+2−2

@@ -42,7 +42,7 @@ parseDataDeclaration = do

4242 return $ DataDeclaration name tyArgs ctors

4343

4444parseTypeDeclaration :: P.Parsec String () Declaration

45−parseTypeDeclaration = TypeDeclaration <$> identifier <*> (lexeme (P.string "::") *> parseType)

45+parseTypeDeclaration = TypeDeclaration <$> identifier <*> (lexeme (P.string "::") *> parsePolyType)

4646

4747parseTypeSynonymDeclaration :: P.Parsec String () Declaration

4848parseTypeSynonymDeclaration = TypeSynonymDeclaration <$> (reserved "type" *> properName) <*> many identifier <*> (lexeme (P.char '=') *> parseType)

@@ -51,7 +51,7 @@ parseValueDeclaration :: P.Parsec String () Declaration

5151parseValueDeclaration = ValueDeclaration <$> identifier <*> (lexeme (P.char '=') *> parseValue)

5252

5353parseExternDeclaration :: P.Parsec String () Declaration

54−parseExternDeclaration = ExternDeclaration <$> (reserved "extern" *> (identifier <|> properName)) <*> (lexeme (P.string "::") *> parseType)

54+parseExternDeclaration = ExternDeclaration <$> (reserved "extern" *> (identifier <|> properName)) <*> (lexeme (P.string "::") *> parsePolyType)

5555

5656parseDeclaration :: P.Parsec String () Declaration

5757parseDeclaration = P.choice $ map P.try

src/PureScript/Parser/Types.hs+5−5

@@ -14,6 +14,7 @@

1414

1515module PureScript.Parser.Types (

1616 parseType,

17+ parsePolyType,

1718 parseRow

1819) where

1920

@@ -51,10 +52,6 @@ parseTypeVariable = TypeVar <$> identifier

5152parseTypeConstructor :: P.Parsec String () Type

5253parseTypeConstructor = TypeConstructor <$> properName

5354

54−parseForAllType :: P.Parsec String () Type

55−parseForAllType = ForAll <$> (reserved "forall" *> many identifier)

56− <*> (dot *> parseType)

57−

5855parseTypeAtom :: P.Parsec String () Type

5956parseTypeAtom = P.choice $ map P.try

6057 [ parseNumber

@@ -63,11 +60,14 @@ parseTypeAtom = P.choice $ map P.try

6360 , parseArray

6461 , parseObject

6562 , parseFunction

66− , parseForAllType

6763 , parseTypeVariable

6864 , parseTypeConstructor

6965 , parens parseType ]

7066

67+parsePolyType :: P.Parsec String () PolyType

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

69+ <*> parseType

70+

7171parseType :: P.Parsec String () Type

7272parseType = fold (lexeme parseTypeAtom) (lexeme parseTypeAtom) TypeApp

7373

src/PureScript/Parser/Values.hs+6−2

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

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

6666

6767parseVar :: P.Parsec String () Value

68−parseVar = Var <$> (C.identifier <|> C.properName)

68+parseVar = Var <$> C.identifier

69+

70+parseConstructor :: P.Parsec String () Value

71+parseConstructor = Constructor <$> C.properName

6972

7073parseCase :: P.Parsec String () Value

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

@@ -86,6 +89,7 @@ parseValueAtom = P.choice $ map P.try

8689 , parseObjectLiteral

8790 , parseAbs

8891 , parseVar

92+ , parseConstructor

8993 , parseBlock

9094 , parseCase

9195 , C.parens parseValue ]

@@ -95,7 +99,7 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

9599 where

96100 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

97101 funArgs = C.parens $ C.commaSep parseValue

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

102+ parseTypeAnnotation = C.lexeme (P.string "::") *> parsePolyType

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

100104 , Postfix $ Indexer <$> C.squares parseValue ]

101105 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)

src/PureScript/TypeChecker.hs+5−5

@@ -42,20 +42,20 @@ import qualified Data.Map as M

4242

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

4444typeCheckAll [] = return ()

45−typeCheckAll (DataDeclaration name args ctors : rest) = do

45+typeCheckAll (DataDeclaration name args dctors : rest) = do

4646 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

4747 env <- getEnv

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

49− ctorKind <- kindsOf (Just name) args (catMaybes $ map snd ctors)

49+ ctorKind <- kindsOf (Just name) args (catMaybes $ map snd dctors)

5050 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }

51− flip mapM_ ctors $ \(dctor, maybeTy) ->

51+ flip mapM_ dctors $ \(dctor, maybeTy) ->

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

5353 env' <- getEnv

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

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

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

57− let quantified = ForAll args dctorTy

58− putEnv $ env' { names = M.insert dctor (quantified, DataConstructor) (names env') }

57+ let polyType = PolyType args dctorTy

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

5959 typeCheckAll rest

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

6161 rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do

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

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

4747emptyKindSolution :: KindSolution

4848emptyKindSolution = KindSolution KUnknown

4949

50−kindOf :: Type -> Check Kind

51−kindOf ty = do

52− (cs, n, m) <- kindConstraints M.empty ty

50+kindOf :: PolyType -> Check Kind

51+kindOf (PolyType idents ty) = do

52+ ns <- replicateM (length idents) fresh

53+ (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty

5354 solution <- solveKindConstraints cs emptyKindSolution

5455 return $ starIfUnknown $ runKindSolution solution n

5556

@@ -106,9 +107,6 @@ kindConstraints m (TypeApp t1 t2) = do

106107 (cs1, n1, m1) <- kindConstraints m t1

107108 (cs2, n2, m2) <- kindConstraints m1 t2

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

109−kindConstraints m (ForAll idents ty) = do

110− ns <- replicateM (length idents) fresh

111− kindConstraints (m `M.union` M.fromList (zip idents ns)) ty

112110kindConstraints m _ = do

113111 me <- fresh

114112 return ([KindConstraint me Star], me, m)

src/PureScript/TypeChecker/Monad.hs+4−3

@@ -27,18 +27,19 @@ import Control.Arrow ((***))

2727

2828import qualified Data.Map as M

2929

30−data NameKind = Value | DataConstructor | Extern deriving Show

30+data NameKind = Value | Extern deriving Show

3131

3232data TypeDeclarationKind = Data | TypeSynonym deriving Show

3333

3434data Environment = Environment

35− { names :: M.Map String (Type, NameKind)

35+ { names :: M.Map String (PolyType, NameKind)

3636 , types :: M.Map String (Kind, TypeDeclarationKind)

37+ , dataConstructors :: M.Map String PolyType

3738 , typeSynonyms :: M.Map String ([String], Type)

3839 }

3940

4041emptyEnvironment :: Environment

41−emptyEnvironment = Environment M.empty M.empty M.empty

42+emptyEnvironment = Environment M.empty M.empty M.empty M.empty

4243

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

4445

src/PureScript/TypeChecker/Types.hs+21−20

@@ -48,19 +48,20 @@ newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Ro

4848emptyTypeSolution :: TypeSolution

4949emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

5050

51−typeOf :: String -> Value -> Check Type

51+typeOf :: String -> Value -> Check PolyType

5252typeOf name val = do

5353 me <- fresh

5454 (cs, n) <- typeConstraints (M.singleton name me) val

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

5656 return $ varIfUnknown $ fst (runTypeSolution solution) n

5757

58−varIfUnknown :: Type -> Type

58+varIfUnknown :: Type -> PolyType

5959varIfUnknown ty =

6060 let

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

62+ -- TODO : check no nested unknowns

6263 in

63− ForAll (sort $ nub $ M.elems m) ty'

64+ PolyType (sort $ nub $ M.elems m) ty'

6465 where

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

6667 f (TUnknown n) = do

@@ -196,9 +197,10 @@ typeConstraints m (Var var) =

196197 env <- getEnv

197198 case M.lookup var (names env) of

198199 Nothing -> throwError $ var ++ " is undefined"

199− Just (ty, _) -> do

200+ Just (PolyType idents ty, _) -> do

200201 me <- fresh

201− return ([TypeConstraint me ty], me)

202+ replaced <- replaceVarsWithUnknowns idents ty

203+ return ([TypeConstraint me replaced], me)

202204 Just u -> do

203205 me <- fresh

204206 return ([TypeConstraint u (TUnknown me)], me)

@@ -209,22 +211,23 @@ typeConstraints m (Block ss) = do

209211 return (cs, ret)

210212typeConstraints m (Constructor c) = do

211213 env <- getEnv

212− case M.lookup c (names env) of

213− Nothing -> throwError $ c ++ " is undefined"

214− Just (ty, _) -> do

214+ case M.lookup c (dataConstructors env) of

215+ Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"

216+ Just (PolyType idents ty) -> do

215217 me <- fresh

216− return ([TypeConstraint me ty], me)

218+ replaced <- replaceVarsWithUnknowns idents ty

219+ return ([TypeConstraint me replaced], me)

217220typeConstraints m (Case val binders) = do

218221 (cs1, n1) <- typeConstraints m val

219222 ret <- fresh

220223 cs2 <- typeConstraintsForBinders m n1 ret binders

221224 return (cs1 ++ cs2, ret)

222−typeConstraints m (TypedValue val ty) = do

223− kind <- kindOf ty

225+typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do

226+ kind <- kindOf poly

224227 guardWith ("Expected type of kind *, was " ++ show kind) $ kind == Star

225− ty' <- replaceAllTypeSynonyms ty

228+ desugared <- replaceAllTypeSynonyms ty

226229 (cs, n1) <- typeConstraints m val

227− return (TypeConstraint n1 ty' : cs, n1)

230+ return (TypeConstraint n1 desugared : cs, n1)

228231

229232replaceAllTypeSynonyms :: Type -> Check Type

230233replaceAllTypeSynonyms ty = do

@@ -281,17 +284,17 @@ typeConstraintsForBinder val (VarBinder name) = do

281284 return ([TypeConstraint me (TUnknown val)], M.singleton name me)

282285typeConstraintsForBinder val (NullaryBinder ctor) = do

283286 env <- getEnv

284− case M.lookup ctor (names env) of

285− Just (ForAll args ret, DataConstructor) -> do

287+ case M.lookup ctor (dataConstructors env) of

288+ Just (PolyType args ret) -> do

286289 ret' <- replaceVarsWithUnknowns args ret

287290 return ([TypeConstraint val ret'], M.empty)

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

289292typeConstraintsForBinder val (UnaryBinder ctor binder) = do

290293 env <- getEnv

291− case M.lookup ctor (names env) of

292− Just (ForAll args f@(Function [_] _), DataConstructor) -> do

294+ case M.lookup ctor (dataConstructors env) of

295+ Just (PolyType idents f@(Function [_] _)) -> do

293296 obj <- fresh

294− (Function [ty] ret) <- replaceVarsWithUnknowns args f

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

295298 (cs, m1) <- typeConstraintsForBinder obj binder

296299 return ((TypeConstraint val ret) : (TypeConstraint obj ty) : cs, m1)

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

@@ -432,8 +435,6 @@ unifyTypes (TUnknown u) t = do

432435unifyTypes t (TUnknown u) = do

433436 typeOccursCheck u t

434437 return [TypeConstraint u t]

435−unifyTypes (ForAll idents t1) t2 = join $ flip unifyTypes t2 <$> replaceVarsWithUnknowns idents t1

436−unifyTypes t1 (ForAll idents t2) = join $ unifyTypes t1 <$> replaceVarsWithUnknowns idents t2

437438unifyTypes Number Number = return []

438439unifyTypes String String = return []

439440unifyTypes Boolean Boolean = return []

src/PureScript/Types.hs+7−6

@@ -14,10 +14,7 @@

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616

17−module PureScript.Types (

18− Type (..),

19− Row(..)

20−) where

17+module PureScript.Types where

2118

2219import Data.Data

2320

@@ -31,11 +28,15 @@ data Type

3128 | Function [Type] Type

3229 | TypeVar String

3330 | TypeConstructor String

34− | TypeApp Type Type

35− | ForAll [String] Type deriving (Show, Data, Typeable)

31+ | TypeApp Type Type deriving (Show, Data, Typeable)

32+

33+data PolyType = PolyType [String] Type deriving (Show, Data, Typeable)

3634

3735data Row

3836 = RUnknown Int

3937 | RowVar String

4038 | REmpty

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

40+

41+monoType :: Type -> PolyType

42+monoType = PolyType []

src/PureScript/Values.hs+2−9

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

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

1616

17−module PureScript.Values (

18− UnaryOperator (..),

19− BinaryOperator (..),

20− Value (..),

21− Statement (..),

22− Binder (..),

23− AssignmentTarget (..)

24−) where

17+module PureScript.Values where

2518

2619import PureScript.Types

2720

@@ -70,7 +63,7 @@ data Value

7063 | Block [Statement]

7164 | Constructor String

7265 | Case Value [(Binder, Value)]

73− | TypedValue Value Type deriving (Show, Data, Typeable)

66+ | TypedValue Value PolyType deriving (Show, Data, Typeable)

7467

7568data Statement

7669 = VariableIntroduction String Value