5d428e9 · rowtype-yoga/purescript-native

examples/Rank2.psdeleted−2

compare with golang

unifiedsplit

@@ -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 =

1+type Lens a b =

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

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

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

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

4 }

5

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

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

7−

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

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

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

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

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

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

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

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

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

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

13+ }

12 }

14 }

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

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

29import PureScript.TypeChecker.Monad

30import PureScript.CodeGen.Common

31

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

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

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

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

34

35typeLiterals :: Pattern Type String

36typeLiterals = Pattern $ A.Kleisli match

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

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

72 match _ = Nothing

73

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−

80typeToPs :: Type -> String

74typeToPs :: Type -> String

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

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

82 where

76 where

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

86 operators =

80 operators =

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

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

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

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

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

90 ]

83 ]

91

84

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 @@

14

15{-# LANGUAGE DeriveDataTypeable #-}

16

17−module PureScript.Declarations (

17+module PureScript.Declarations where

18− Declaration (..)

19−) where

20

18

21import PureScript.Values

19import PureScript.Values

22import PureScript.Types

20import PureScript.Types

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

26data Declaration

24data Declaration

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

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

28 | TypeSynonymDeclaration String [String] Type

26 | TypeSynonymDeclaration String [String] Type

29− | TypeDeclaration String Type

27+ | TypeDeclaration String PolyType

30 | ValueDeclaration String Value

28 | 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 @@

14

15{-# LANGUAGE DeriveDataTypeable #-}

16

17−module PureScript.Kinds (

17+module PureScript.Kinds where

18− Kind (..)

19−) where

20

18

21import Data.Data

19import Data.Data

22

20

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

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

42 return $ DataDeclaration name tyArgs ctors

43

44parseTypeDeclaration :: P.Parsec String () Declaration

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

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

46

47parseTypeSynonymDeclaration :: P.Parsec String () Declaration

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

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

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

52

53parseExternDeclaration :: 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)

55

56parseDeclaration :: P.Parsec String () Declaration

57parseDeclaration = P.choice $ map P.try

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

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

14

15module PureScript.Parser.Types (

16 parseType,

17+ parsePolyType,

17 parseRow

18 parseRow

18) where

19) where

19

20

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

51parseTypeConstructor :: P.Parsec String () Type

52parseTypeConstructor :: P.Parsec String () Type

52parseTypeConstructor = TypeConstructor <$> properName

53parseTypeConstructor = TypeConstructor <$> properName

53

54

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

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

56− <*> (dot *> parseType)

57−

58parseTypeAtom :: P.Parsec String () Type

55parseTypeAtom :: P.Parsec String () Type

59parseTypeAtom = P.choice $ map P.try

56parseTypeAtom = P.choice $ map P.try

60 [ parseNumber

57 [ parseNumber

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

63 , parseArray

60 , parseArray

64 , parseObject

61 , parseObject

65 , parseFunction

62 , parseFunction

66− , parseForAllType

67 , parseTypeVariable

63 , parseTypeVariable

68 , parseTypeConstructor

64 , parseTypeConstructor

69 , parens parseType ]

65 , parens parseType ]

70

66

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

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

69+ <*> parseType

70+

71parseType :: P.Parsec String () Type

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

73

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

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

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

66

67parseVar :: 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

69

72

70parseCase :: P.Parsec String () Value

73parseCase :: P.Parsec String () Value

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

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

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

86 , parseObjectLiteral

89 , parseObjectLiteral

87 , parseAbs

90 , parseAbs

88 , parseVar

91 , parseVar

92+ , parseConstructor

89 , parseBlock

93 , parseBlock

90 , parseCase

94 , parseCase

91 , C.parens parseValue ]

95 , C.parens parseValue ]

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

95 where

99 where

96 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

100 typedValue = C.augment parseValueAtom parseTypeAnnotation TypedValue

97 funArgs = C.parens $ C.commaSep parseValue

101 funArgs = C.parens $ C.commaSep parseValue

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

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

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

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

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

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

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

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

src/PureScript/TypeChecker.hs+5−5

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

42

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

44typeCheckAll [] = return ()

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

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

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

47 env <- getEnv

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

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

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

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

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

53 env' <- getEnv

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

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

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

57− let quantified = ForAll args dctorTy

57+ let polyType = PolyType args dctorTy

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

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

59 typeCheckAll rest

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

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

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

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

47emptyKindSolution :: KindSolution

48emptyKindSolution = KindSolution KUnknown

49

50−kindOf :: Type -> Check Kind

50+kindOf :: PolyType -> Check Kind

51−kindOf ty = do

51+kindOf (PolyType idents ty) = do

52+ ns <- replicateM (length idents) fresh

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

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

53 solution <- solveKindConstraints cs emptyKindSolution

54 solution <- solveKindConstraints cs emptyKindSolution

54 return $ starIfUnknown $ runKindSolution solution n

55 return $ starIfUnknown $ runKindSolution solution n

55

56

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

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

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

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

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

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

109 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

112kindConstraints m _ = do

110kindConstraints m _ = do

113 me <- fresh

111 me <- fresh

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

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

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

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

27

28import qualified Data.Map as M

29

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

30+data NameKind = Value | Extern deriving Show

31

32data TypeDeclarationKind = Data | TypeSynonym deriving Show

33

34data Environment = Environment

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

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

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

37+ , dataConstructors :: M.Map String PolyType

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

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

38 }

39 }

39

40

40emptyEnvironment :: Environment

41emptyEnvironment :: Environment

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

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

42

43

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

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

44

45

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

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

48emptyTypeSolution :: TypeSolution

49emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

50

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

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

52typeOf name val = do

53 me <- fresh

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

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

56 return $ varIfUnknown $ fst (runTypeSolution solution) n

57

58−varIfUnknown :: Type -> Type

58+varIfUnknown :: Type -> PolyType

59varIfUnknown ty =

60 let

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

62+ -- TODO : check no nested unknowns

62 in

63 in

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

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

64 where

65 where

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

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

66 f (TUnknown n) = do

67 f (TUnknown n) = do

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

196 env <- getEnv

197 env <- getEnv

197 case M.lookup var (names env) of

198 case M.lookup var (names env) of

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

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

199− Just (ty, _) -> do

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

200 me <- fresh

201 me <- fresh

202+ replaced <- replaceVarsWithUnknowns idents ty

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

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

202 Just u -> do

204 Just u -> do

203 me <- fresh

205 me <- fresh

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

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

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

209 return (cs, ret)

211 return (cs, ret)

210typeConstraints m (Constructor c) = do

212typeConstraints m (Constructor c) = do

211 env <- getEnv

213 env <- getEnv

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

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

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

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

214− Just (ty, _) -> do

216+ Just (PolyType idents ty) -> do

215 me <- fresh

217 me <- fresh

218+ replaced <- replaceVarsWithUnknowns idents ty

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

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

217typeConstraints m (Case val binders) = do

220typeConstraints m (Case val binders) = do

218 (cs1, n1) <- typeConstraints m val

221 (cs1, n1) <- typeConstraints m val

219 ret <- fresh

222 ret <- fresh

220 cs2 <- typeConstraintsForBinders m n1 ret binders

223 cs2 <- typeConstraintsForBinders m n1 ret binders

221 return (cs1 ++ cs2, ret)

224 return (cs1 ++ cs2, ret)

222−typeConstraints m (TypedValue val ty) = do

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

223− kind <- kindOf ty

226+ kind <- kindOf poly

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

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

225− ty' <- replaceAllTypeSynonyms ty

228+ desugared <- replaceAllTypeSynonyms ty

226 (cs, n1) <- typeConstraints m val

229 (cs, n1) <- typeConstraints m val

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

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

228

231

229replaceAllTypeSynonyms :: Type -> Check Type

232replaceAllTypeSynonyms :: Type -> Check Type

230replaceAllTypeSynonyms ty = do

233replaceAllTypeSynonyms ty = do

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

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

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

282typeConstraintsForBinder val (NullaryBinder ctor) = do

285typeConstraintsForBinder val (NullaryBinder ctor) = do

283 env <- getEnv

286 env <- getEnv

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

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

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

288+ Just (PolyType args ret) -> do

286 ret' <- replaceVarsWithUnknowns args ret

289 ret' <- replaceVarsWithUnknowns args ret

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

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

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

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

289typeConstraintsForBinder val (UnaryBinder ctor binder) = do

292typeConstraintsForBinder val (UnaryBinder ctor binder) = do

290 env <- getEnv

293 env <- getEnv

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

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

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

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

293 obj <- fresh

296 obj <- fresh

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

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

295 (cs, m1) <- typeConstraintsForBinder obj binder

298 (cs, m1) <- typeConstraintsForBinder obj binder

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

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

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

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

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

432unifyTypes t (TUnknown u) = do

435unifyTypes t (TUnknown u) = do

433 typeOccursCheck u t

436 typeOccursCheck u t

434 return [TypeConstraint u t]

437 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

437unifyTypes Number Number = return []

438unifyTypes Number Number = return []

438unifyTypes String String = return []

439unifyTypes String String = return []

439unifyTypes Boolean Boolean = return []

440unifyTypes Boolean Boolean = return []

src/PureScript/Types.hs+7−6

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

14

15{-# LANGUAGE DeriveDataTypeable #-}

16

17−module PureScript.Types (

17+module PureScript.Types where

18− Type (..),

19− Row(..)

20−) where

21

18

22import Data.Data

19import Data.Data

23

20

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

31 | Function [Type] Type

28 | Function [Type] Type

32 | TypeVar String

29 | TypeVar String

33 | TypeConstructor String

30 | TypeConstructor String

34− | TypeApp Type Type

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

32+

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

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

36

34

37data Row

35data Row

38 = RUnknown Int

36 = RUnknown Int

39 | RowVar String

37 | RowVar String

40 | REmpty

38 | REmpty

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

39 | 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 @@

14

15{-# LANGUAGE DeriveDataTypeable #-}

16

17−module PureScript.Values (

17+module PureScript.Values where

18− UnaryOperator (..),

19− BinaryOperator (..),

20− Value (..),

21− Statement (..),

22− Binder (..),

23− AssignmentTarget (..)

24−) where

25

18

26import PureScript.Types

19import PureScript.Types

27

20

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

70 | Block [Statement]

63 | Block [Statement]

71 | Constructor String

64 | Constructor String

72 | Case Value [(Binder, Value)]

65 | Case Value [(Binder, Value)]

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

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

74

67

75data Statement

68data Statement

76 = VariableIntroduction String Value

69 = VariableIntroduction String Value