d7c524c · rowtype-yoga/purescript-native

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

Fix bug in which data constructors were being incorrectly accessed across modules

commitd7c524c7f11690beec962071da338403db293602 authorPhil Freeman <paf31@cantab.net> dateFri 10 Jan 2014, 12:17 (13 years ago) parent5248e03

6 files changed+19−13

compare with golang

unifiedsplit

examples/passing/DataImport.purs+2 purescript.cabal+1−1 src/Language/PureScript/CodeGen/JS.hs+5−2 src/Language/PureScript/TypeChecker.hs+4−4 src/Language/PureScript/TypeChecker/Monad.hs+3−2 src/Language/PureScript/TypeChecker/Types.hs+4−4

examples/passing/DataImport.purs+2

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

99test :: Test -> M1.Test

1010test t = t

11+

12+testCtor = Test

purescript.cabal+1−1

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

11name: purescript

2−version: 0.2.9.2

2+version: 0.2.9.3

33cabal-version: >=1.8

44build-type: Simple

55license: MIT

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

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

2323import Control.Arrow (second)

2424import Control.Monad (replicateM, forM)

2525

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

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

2727import Language.PureScript.Values

2828import Language.PureScript.Names

2929import Language.PureScript.Scope

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

3232import Language.PureScript.CodeGen.Monad

3333import Language.PureScript.Options

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

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

3635import Language.PureScript.Types

3736

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

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

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

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

9695valueToJs 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

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

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

99102valueToJs 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

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

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

5252 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) }

5454

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

5656addTypeSynonym moduleName name args ty kind = do

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

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

184184 Just (k, _) -> do

185185 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

187187 forM_ keys $ \dctor -> do

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

189189 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) })

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

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

193193 = mn == moduleName && pn' == pn

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

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

196196 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

198198

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

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

3636 = Value

3737 | Extern

3838 | Alias ModuleName Ident

39− | LocalVariable deriving Show

39+ | LocalVariable

40+ | DataConstructor deriving Show

4041

4142data TypeDeclarationKind

4243 = Data

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

4849data Environment = Environment

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

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

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

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

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

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

5455 } deriving (Show)

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

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

337337 moduleName <- substCurrentModule `fmap` ask

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

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

340− Just ty -> replaceAllTypeSynonyms ty

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

341341infer' (Case vals binders) = do

342342 ts <- mapM infer vals

343343 ret <- fresh

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

450450 env <- getEnv

451451 moduleName <- substCurrentModule <$> ask

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

453− Just ty -> do

453+ Just (ty, _) -> do

454454 ty `subsumes` val

455455 return M.empty

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

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

458458 env <- getEnv

459459 moduleName <- substCurrentModule <$> ask

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

461− Just ty -> do

461+ Just (ty, _) -> do

462462 fn <- replaceAllVarsWithUnknowns ty

463463 case fn of

464464 Function [obj] ret -> do

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

649649 moduleName <- substCurrentModule <$> ask

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

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

652− Just ty1 -> do

652+ Just (ty1, _) -> do

653653 repl <- replaceAllTypeSynonyms ty1

654654 repl `subsumes` ty

655655check' val (SaturatedTypeSynonym name args) = do