git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Qualify all names appearing in types when adding names to the environment.
commit521520d13c1d12bb3c111d8a50c4dcecb3983f3c authorPhil Freeman <paf31@cantab.net> dateSun 12 Jan 2014, 11:14 (13 years ago) parent8fe74d1
3 files changed+37−25
compare with golang
unifiedsplit
src/Language/PureScript/TypeChecker.hs+13−4 src/Language/PureScript/TypeChecker/Monad.hs+1−2 src/Language/PureScript/TypeChecker/Types.hs+23−19
src/Language/PureScript/TypeChecker.hs+13−4
@@ -24,6 +24,8 @@ import Language.PureScript.TypeChecker.Kinds as T
2424import Language.PureScript.TypeChecker.Types as T
2525import Language.PureScript.TypeChecker.Synonyms as T
2626
27+import Data.Data
28+import Data.Generics (mkT, everywhere)
2729import Data.Maybe
2830import qualified Data.Map as M
2931import Control.Monad.State
@@ -50,13 +52,13 @@ addDataConstructor moduleName name args dctor maybeTy = do
5052 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
5153 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
5254 let polyType = mkForAll args dctorTy
53− putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) }
55+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
5456
5557addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
5658addTypeSynonym moduleName name args ty kind = do
5759 env <- getEnv
5860 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
59− , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }
61+ , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }
6062
6163typeIsNotDefined :: ModuleName -> ProperName -> Check ()
6264typeIsNotDefined moduleName name = do
@@ -80,7 +82,7 @@ valueIsNotDefined moduleName name = do
8082addValue :: ModuleName -> Ident -> Type -> Check ()
8183addValue moduleName name ty = do
8284 env <- getEnv
83− putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })
85+ putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
8486
8587typeCheckAll :: ModuleName -> [Declaration] -> Check ()
8688typeCheckAll _ [] = return ()
@@ -132,7 +134,7 @@ typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
132134 guardWith "Expected kind *" $ kind == Star
133135 case M.lookup (moduleName, name) (names env) of
134136 Just _ -> throwError $ show name ++ " is already defined"
135− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })
137+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern) (names env) })
136138 typeCheckAll moduleName rest
137139typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
138140 typeCheckAll moduleName rest
@@ -184,3 +186,10 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
184186 constructs (TypeApp ty _) pn = ty `constructs` pn
185187 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
186188
189+qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
190+qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
191+ where
192+ go :: Qualified ProperName -> Qualified ProperName
193+ go qual = let (mn', pn') = canonicalizeType mn env qual
194+ in Qualified (Just mn') pn'
195+
src/Language/PureScript/TypeChecker/Monad.hs+1−2
@@ -51,11 +51,10 @@ data Environment = Environment
5151 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
5252 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
5353 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
54− , members :: M.Map (ModuleName, Ident) String
5554 } deriving (Show)
5655
5756emptyEnvironment :: Environment
58−emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
57+emptyEnvironment = Environment M.empty M.empty M.empty M.empty
5958
6059bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
6160bindNames newNames action = do
src/Language/PureScript/TypeChecker/Types.hs+23−19
@@ -20,8 +20,7 @@ module Language.PureScript.TypeChecker.Types (
2020) where
2121
2222import Data.List
23−import Data.Maybe (fromMaybe)
24−import Data.Either (lefts, rights)
23+import Data.Maybe (isNothing, isJust, fromMaybe)
2524import qualified Data.Data as D
2625import Data.Generics
2726 (mkT, something, everywhere, everywhereBut, mkQ)
@@ -146,31 +145,36 @@ typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
146145typesOf moduleName vals = do
147146 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do
148147 let es = map isTyped vals
149− typed = lefts es
150− untyped = rights es
151− typedDict = map (\(ident, ty, _) -> (ident, ty)) typed
148+ typed = filter (isJust . snd . snd) es
149+ untyped = filter (isNothing . snd . snd) es
150+ typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed
152151 untypedNames <- replicateM (length untyped) fresh
153152 let untypedDict = zip (map fst untyped) untypedNames
154153 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
155− tys <- forM es $ \e -> case e of
156− Left (_, ty, val) -> do
157− kind <- liftCheck $ kindOf moduleName ty
158− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
159− ty' <- replaceAllTypeSynonyms ty
160− bindNames dict $ check val ty'
161− return ty'
162− Right (ident, val) -> do
163− ty <- bindNames dict $ infer val
164− ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
165− return ty
154+ tys <- forM es $ \e -> do
155+ ty <- case e of
156+ (_, (val, Just ty)) -> do
157+ kind <- liftCheck $ kindOf moduleName ty
158+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
159+ ty' <- replaceAllTypeSynonyms ty
160+ bindNames dict $ check val ty'
161+ return ty'
162+ (ident, (val, Nothing)) -> do
163+ ty <- bindNames dict $ infer val
164+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
165+ return ty
166+ when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
167+ [eff, a] <- replicateM 2 fresh
168+ ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
169+ return ty
166170 return tys
167171 forM tys $ flip (escapeCheck checks) sub
168172 forM tys $ skolemEscapeCheck
169173 return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys
170174
171−isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)
172−isTyped (name, TypedValue value ty) = Left (name, ty, value)
173−isTyped (name, value) = Right (name, value)
175+isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))
176+isTyped (name, TypedValue value ty) = (name, (value, Just ty))
177+isTyped (name, value) = (name, (value, Nothing))
174178
175179escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
176180escapeCheck checks ty sub =