d7c524c · rowtype-yoga/purescript-native

examples/passing/DataImport.purs+2

compare with golang

unifiedsplit

@@ -8,3 +8,5 @@ import M1

8

9test :: Test -> M1.Test

10test t = t

11+

12+testCtor = Test

purescript.cabal+1−1

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.2.9.2

2+version: 0.2.9.3

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

src/Language/PureScript/CodeGen/JS.hs+5−2

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

23import Control.Arrow (second)

24import Control.Monad (replicateM, forM)

25

26−import Language.PureScript.TypeChecker (Environment, names)

26+import Language.PureScript.TypeChecker (Environment(..), NameKind(..))

27import Language.PureScript.Values

28import Language.PureScript.Names

29import Language.PureScript.Scope

@@ -32,7 +32,6 @@ import Language.PureScript.Pretty.Common

32import Language.PureScript.CodeGen.Monad

33import Language.PureScript.Options

34import Language.PureScript.CodeGen.JS.AST as AST

35−import Language.PureScript.TypeChecker.Monad (NameKind(..))

36import Language.PureScript.Types

35import Language.PureScript.Types

37

36

38moduleToJs :: Options -> Module -> Environment -> [JS]

37moduleToJs :: Options -> Module -> Environment -> [JS]

@@ -94,6 +93,10 @@ valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b

94valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

93valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

95valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

94valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

96valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

95valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

96+valueToJs _ m e (Constructor (Qualified Nothing name)) =

97+ case M.lookup (m, name) (dataConstructors e) of

98+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

99+ _ -> JSVar . Ident . runProperName $ name

97valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

100valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

98valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []

101valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []

99valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))

102valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))

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

@@ -50,7 +50,7 @@ addDataConstructor moduleName name args dctor maybeTy = do

50 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

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

52 let polyType = mkForAll args dctorTy

53− putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) }

53+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) }

54

55addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

56addTypeSynonym moduleName name args ty kind = do

@@ -183,16 +183,16 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

183 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

184 Just (k, _) -> do

185 modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

186− let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

186+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env

187 forM_ keys $ \dctor -> do

188 guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env

189 case (moduleName, dctor) `M.lookup` dataConstructors env of

190− Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })

190+ Just (ctorTy, _) -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })

191 Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

192 constructs (TypeConstructor (Qualified (Just mn) pn')) pn

193 = mn == moduleName && pn' == pn

194 constructs (ForAll _ ty) pn = ty `constructs` pn

195 constructs (Function _ ty) pn = ty `constructs` pn

196 constructs (TypeApp ty _) pn = ty `constructs` pn

197− constructs fn _ = error $ "Invalid arguments to construct" ++ show fn

197+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

198

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

@@ -36,7 +36,8 @@ data NameKind

36 = Value

37 | Extern

38 | Alias ModuleName Ident

39− | LocalVariable deriving Show

39+ | LocalVariable

40+ | DataConstructor deriving Show

40

41

41data TypeDeclarationKind

42data TypeDeclarationKind

42 = Data

43 = Data

@@ -48,7 +49,7 @@ data TypeDeclarationKind

48data Environment = Environment

49data Environment = Environment

49 { names :: M.Map (ModuleName, Ident) (Type, NameKind)

50 { names :: M.Map (ModuleName, Ident) (Type, NameKind)

50 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

51 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

51− , dataConstructors :: M.Map (ModuleName, ProperName) Type

52+ , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

52 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

53 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

53 , members :: M.Map (ModuleName, Ident) String

54 , members :: M.Map (ModuleName, Ident) String

54 } deriving (Show)

55 } deriving (Show)

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

@@ -337,7 +337,7 @@ infer' (Constructor c) = do

337 moduleName <- substCurrentModule `fmap` ask

338 case M.lookup (qualify moduleName c) (dataConstructors env) of

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

340− Just ty -> replaceAllTypeSynonyms ty

340+ Just (ty, _) -> replaceAllTypeSynonyms ty

341infer' (Case vals binders) = do

342 ts <- mapM infer vals

343 ret <- fresh

@@ -450,7 +450,7 @@ inferBinder val (NullaryBinder ctor) = do

450 env <- getEnv

451 moduleName <- substCurrentModule <$> ask

452 case M.lookup (qualify moduleName ctor) (dataConstructors env) of

453− Just ty -> do

453+ Just (ty, _) -> do

454 ty `subsumes` val

455 return M.empty

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

@@ -458,7 +458,7 @@ inferBinder val (UnaryBinder ctor binder) = do

458 env <- getEnv

459 moduleName <- substCurrentModule <$> ask

460 case M.lookup (qualify moduleName ctor) (dataConstructors env) of

461− Just ty -> do

461+ Just (ty, _) -> do

462 fn <- replaceAllVarsWithUnknowns ty

463 case fn of

464 Function [obj] ret -> do

@@ -649,7 +649,7 @@ check' (Constructor c) ty = do

649 moduleName <- substCurrentModule <$> ask

650 case M.lookup (qualify moduleName c) (dataConstructors env) of

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

652− Just ty1 -> do

652+ Just (ty1, _) -> do

653 repl <- replaceAllTypeSynonyms ty1

654 repl `subsumes` ty

655check' val (SaturatedTypeSynonym name args) = do