eeb5c85 · rowtype-yoga/purescript-native

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

Don't need to carry NameKind for dcons anymore

commiteeb5c85b6358b41791f0c705f0effb2812bb6439 authorGary Burgess <gary.burgess@gmail.com> dateThu 27 Feb 2014, 12:04 (13 years ago) parent42dba3e

5 files changed+17−18

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+2−2 src/Language/PureScript/Sugar/Names.hs+5−5 src/Language/PureScript/TypeChecker.hs+4−5 src/Language/PureScript/TypeChecker/Monad.hs+2−2 src/Language/PureScript/TypeChecker/Types.hs+4−4

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

@@ -308,10 +308,10 @@ binderToJs m e varName done (NamedBinder ident binder) = do

308308--

309309isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool

310310isOnlyConstructor m e ctor =

311− let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e

311+ let ty = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e

312312 in numConstructors ty == 1

313313 where

314− numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e

314+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.elems $ dataConstructors e

315315 typeConstructor (TypeConstructor qual) = qualify m qual

316316 typeConstructor (ForAll _ ty _) = typeConstructor ty

317317 typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty

src/Language/PureScript/Sugar/Names.hs+5−5

@@ -90,7 +90,7 @@ findExports = foldl addModule nullEnv

9090 where

9191 addModule env (Module mn ds) = foldl (addDecl mn) env ds

9292 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

93− addDecl mn env (DataDeclaration tcn _ dcs) = foldl (flip addDataConstructor mn) env (map fst dcs)

93+ addDecl mn env (DataDeclaration tcn _ dcs) = foldl (`addDataConstructor` mn) env (map fst dcs)

9494 addDecl _ env _ = env

9595

9696findImports :: [Declaration] -> [ModuleName]

@@ -102,12 +102,12 @@ resolveImports env (Module currentModule decls) = do

102102 typeClasses <- resolve exportedTypeClasses

103103 return $ ImportEnvironment dataConstructors typeClasses

104104 where

105− scope = (currentModule : findImports decls)

105+ scope = currentModule : findImports decls

106106 resolve get = foldM resolveDefs M.empty (M.toList $ get env)

107107 resolveDefs result (mn, names) | mn `elem` scope = foldM (resolveDef mn) result (S.toList names)

108108 resolveDefs result _ = return result

109109 resolveDef mn result name = case M.lookup name result of

110110 Nothing -> return $ M.insert name (Qualified (Just mn) name) result

111− Just x@(Qualified (Just mn') _) -> if mn' == currentModule

112− then Left $ "Module '" ++ show currentModule ++ "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

113− else Left $ "Module '" ++ show currentModule ++ "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

111+ Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++ if mn' == currentModule

112+ then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

113+ else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

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

@@ -53,7 +53,7 @@ addDataConstructor moduleName name args dctor tys = do

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

5454 let dctorTy = foldr function retTy tys

5555 let polyType = mkForAll args dctorTy

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

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

5757

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

5959addTypeSynonym moduleName name args ty kind = do

@@ -221,13 +221,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

221221 Just (k, _) -> do

222222 guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

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

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

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

225225 forM_ keys $ \dctor ->

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

227− Just (_, Alias _ _) -> return ()

228− Just (ctorTy, _) -> do

227+ Just ctorTy -> do

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

230− modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })

229+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })

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

232231 shadowTypeClassInstances env = do

233232 let instances = filter (\tcd ->

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

@@ -101,7 +101,7 @@ data Environment = Environment {

101101 -- |

102102 -- Data constructors currently in scope, along with their associated data type constructors

103103 --

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

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

105105 -- |

106106 -- Type synonyms currently in scope

107107 --

@@ -315,7 +315,7 @@ liftUnify unify = do

315315 return (a, unifyCurrentSubstitution ust)

316316

317317-- |

318−-- Replace any unqualified names in a type wit their qualified versionss

318+-- Replace any unqualified names in a type with their qualified versions

319319--

320320qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

321321qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

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

@@ -547,8 +547,8 @@ infer' v@(Constructor c) = do

547547 Just moduleName <- checkCurrentModule <$> get

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

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

550− Just (ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

551− return $ TypedValue True v ty'

550+ Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

551+ return $ TypedValue True v ty'

552552infer' (Case vals binders) = do

553553 ts <- mapM infer vals

554554 ret <- fresh

@@ -597,7 +597,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

597597 env <- getEnv

598598 Just moduleName <- checkCurrentModule <$> get

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

600− Just (ty, _) -> do

600+ Just ty -> do

601601 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

602602 go binders fn

603603 where

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

808808 Just moduleName <- checkCurrentModule <$> get

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

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

811− Just (ty1, _) -> do

811+ Just ty1 -> do

812812 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

813813 _ <- subsumes Nothing repl ty

814814 return $ TypedValue True (Constructor c) ty