c584c40 · rowtype-yoga/purescript-native

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

Fix a kind checking error, add support for 'extern data'

commitc584c40d09fecf88b01103f4aa443a05fddf938b authorPhil Freeman <paf31@cantab.net> dateTue 29 Oct 2013, 16:09 (13 years ago) parent73a773e

8 files changed+73−8

compare with golang

unifiedsplit

PureScript.cabal+4−3 examples/ExternData.ps+13 src/PureScript/Declarations.hs+2 src/PureScript/Parser/Declarations.hs+6−3 src/PureScript/Parser/Kinds.hs+41 src/PureScript/TypeChecker.hs+5 src/PureScript/TypeChecker/Kinds.hs+1−1 src/PureScript/TypeChecker/Monad.hs+1−1

PureScript.cabal+4−3

@@ -30,7 +30,8 @@ library

3030 exposed: True

3131 buildable: True

3232 hs-source-dirs: src

33− other-modules: PureScript.CodeGen.Pretty.Kinds

33+ other-modules: PureScript.Parser.Kinds

34+ PureScript.CodeGen.Pretty.Kinds

3435

3536executable psc

3637 build-depends: base -any, cmdtheline -any, containers -any,

@@ -38,6 +39,6 @@ executable psc

3839 main-is: Main.hs

3940 buildable: True

4041 hs-source-dirs: src

41− other-modules: PureScript.CodeGen.Pretty.Kinds

42− PureScript.CodeGen.Pretty.Types

42+ other-modules: PureScript.Parser.Kinds

43+ PureScript.CodeGen.Pretty.Kinds PureScript.CodeGen.Pretty.Types

4344

examples/ExternData.psnew file+13

@@ -0,0 +1,13 @@

1+extern data IO :: * -> *

3+extern fmap :: forall a b. IO a -> (a -> b) -> IO b

5+extern ret :: forall a. a -> IO a

7+extern bind :: forall a b. IO a -> (a -> IO b) -> IO b

9+extern showMessage :: String -> IO { }

10+

11+extern prompt :: IO String

12+

13+main = prompt `bind` \s -> showMessage s

src/PureScript/Declarations.hs+2

@@ -19,6 +19,7 @@ module PureScript.Declarations where

1919import PureScript.Values

2020import PureScript.Types

2121import PureScript.Names

22+import PureScript.Kinds

2223

2324import qualified Data.Data as D

2425

@@ -34,4 +35,5 @@ data Declaration

3435 | TypeDeclaration Ident PolyType

3536 | ValueDeclaration Ident Value

3637 | ExternDeclaration Ident PolyType

38+ | ExternDataDeclaration String Kind

3739 | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)

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

@@ -35,6 +35,7 @@ import PureScript.Parser.Common

3535import PureScript.Declarations

3636import PureScript.Parser.Values

3737import PureScript.Parser.Types

38+import PureScript.Parser.Kinds

3839

3940parseDataDeclaration :: P.Parsec String ParseState Declaration

4041parseDataDeclaration = do

@@ -62,9 +63,11 @@ parseValueDeclaration =

6263 <*> (lexeme (indented *> P.char '=') *> parseValue)

6364

6465parseExternDeclaration :: P.Parsec String ParseState Declaration

65−parseExternDeclaration =

66− ExternDeclaration <$> (reserved "extern" *> indented *> parseIdent)

67− <*> (lexeme (indented *> P.string "::") *> parsePolyType)

66+parseExternDeclaration = reserved "extern" *> indented *>

67+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)

68+ <*> (lexeme (indented *> P.string "::") *> parseKind)

69+ <|> ExternDeclaration <$> parseIdent

70+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))

6871

6972parseAssociativity :: P.Parsec String ParseState Associativity

7073parseAssociativity =

src/PureScript/Parser/Kinds.hsnew file+41

@@ -0,0 +1,41 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.Kinds (

16+ parseKind

17+) where

18+

19+import PureScript.Kinds

20+import PureScript.Parser.State

21+import PureScript.Parser.Common

22+import Control.Applicative

23+import qualified Text.Parsec as P

24+import qualified Text.Parsec.Expr as P

25+

26+parseStar :: P.Parsec String ParseState Kind

27+parseStar = const Star <$> lexeme (P.char '*')

28+

29+parseRow :: P.Parsec String ParseState Kind

30+parseRow = const Row <$> lexeme (P.char 'ρ')

31+

32+parseTypeAtom :: P.Parsec String ParseState Kind

33+parseTypeAtom = indented *> P.choice (map P.try

34+ [ parseStar

35+ , parseRow

36+ , parens parseKind ])

37+

38+parseKind :: P.Parsec String ParseState Kind

39+parseKind = P.buildExpressionParser operators $ parseTypeAtom

40+ where

41+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]

src/PureScript/TypeChecker.hs+5

@@ -79,6 +79,11 @@ typeCheckAll (ValueDeclaration name val : rest) = do

7979 ty <- typeOf name val

8080 putEnv (env { names = M.insert name (ty, Value) (names env) })

8181 typeCheckAll rest

82+typeCheckAll (ExternDataDeclaration name kind : rest) = do

83+ env <- getEnv

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

85+ putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }

86+ typeCheckAll rest

8287typeCheckAll (ExternDeclaration name ty : rest) = do

8388 rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do

8489 env <- getEnv

src/PureScript/TypeChecker/Kinds.hs+1−1

@@ -89,7 +89,7 @@ kindConstraints m (Function args ret) = do

8989 me <- fresh

9090 (cs, ns, m') <- kindConstraintsAll m args

9191 (cs', retN, m'') <- kindConstraints m' ret

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

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

9393kindConstraints m (TypeVar v) = do

9494 case M.lookup v m of

9595 Just u -> return ([], u, m)

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

@@ -30,7 +30,7 @@ import qualified Data.Map as M

3030

3131data NameKind = Value | Extern deriving Show

3232

33−data TypeDeclarationKind = Data | TypeSynonym deriving Show

33+data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

3434

3535data Environment = Environment

3636 { names :: M.Map Ident (PolyType, NameKind)