521520d · rowtype-yoga/purescript-native

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

on golang help sign in

Qualify all names appearing in types when adding names to the environment.

521520dPhil Freeman13 years ago

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

compare with golang

unifiedsplit

@@ -24,6 +24,8 @@ import Language.PureScript.TypeChecker.Kinds as T

24import Language.PureScript.TypeChecker.Types as T

25import Language.PureScript.TypeChecker.Synonyms as T

27+import Data.Data

28+import Data.Generics (mkT, everywhere)

27import Data.Maybe

29import Data.Maybe

28import qualified Data.Map as M

30import qualified Data.Map as M

29import Control.Monad.State

31import Control.Monad.State

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

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

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

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

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

52 let polyType = mkForAll args dctorTy

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

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

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

56addTypeSynonym moduleName name args ty kind = do

58addTypeSynonym moduleName name args ty kind = do

57 env <- getEnv

59 env <- getEnv

58 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)

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

61typeIsNotDefined :: ModuleName -> ProperName -> Check ()

63typeIsNotDefined :: ModuleName -> ProperName -> Check ()

62typeIsNotDefined moduleName name = do

64typeIsNotDefined moduleName name = do

@@ -80,7 +82,7 @@ valueIsNotDefined moduleName name = do

80addValue :: ModuleName -> Ident -> Type -> Check ()

82addValue :: ModuleName -> Ident -> Type -> Check ()

81addValue moduleName name ty = do

83addValue moduleName name ty = do

82 env <- getEnv

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

85typeCheckAll :: ModuleName -> [Declaration] -> Check ()

87typeCheckAll :: ModuleName -> [Declaration] -> Check ()

86typeCheckAll _ [] = return ()

88typeCheckAll _ [] = return ()

@@ -132,7 +134,7 @@ typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do

132 guardWith "Expected kind *" $ kind == Star

134 guardWith "Expected kind *" $ kind == Star

133 case M.lookup (moduleName, name) (names env) of

135 case M.lookup (moduleName, name) (names env) of

134 Just _ -> throwError $ show name ++ " is already defined"

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

136 typeCheckAll moduleName rest

138 typeCheckAll moduleName rest

137typeCheckAll moduleName (FixityDeclaration _ name : rest) = do

139typeCheckAll moduleName (FixityDeclaration _ name : rest) = do

138 typeCheckAll moduleName rest

140 typeCheckAll moduleName rest

@@ -184,3 +186,10 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do

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

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

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

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

186

188

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

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

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

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

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

55 } deriving (Show)

54 } deriving (Show)

57emptyEnvironment :: Environment

56emptyEnvironment :: 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

60bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

59bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

61bindNames newNames action = do

60bindNames newNames action = do

src/Language/PureScript/TypeChecker/Types.hs+23−19

@@ -20,8 +20,7 @@ module Language.PureScript.TypeChecker.Types (

20) where

22import Data.List

23−import Data.Maybe (fromMaybe)

23+import Data.Maybe (isNothing, isJust, fromMaybe)

24−import Data.Either (lefts, rights)

25import qualified Data.Data as D

24import qualified Data.Data as D

26import Data.Generics

25import Data.Generics

27 (mkT, something, everywhere, everywhereBut, mkQ)

26 (mkT, something, everywhere, everywhereBut, mkQ)

@@ -146,31 +145,36 @@ typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]

146typesOf moduleName vals = do

145typesOf moduleName vals = do

147 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do

146 (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do

148 let es = map isTyped vals

147 let es = map isTyped vals

149− typed = lefts es

148+ typed = filter (isJust . snd . snd) es

150− untyped = rights es

149+ untyped = filter (isNothing . snd . snd) es

151− typedDict = map (\(ident, ty, _) -> (ident, ty)) typed

150+ typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed

152 untypedNames <- replicateM (length untyped) fresh

151 untypedNames <- replicateM (length untyped) fresh

153 let untypedDict = zip (map fst untyped) untypedNames

152 let untypedDict = zip (map fst untyped) untypedNames

154 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

153 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)

155− tys <- forM es $ \e -> case e of

154+ tys <- forM es $ \e -> do

156− Left (_, ty, val) -> do

155+ ty <- case e of

156+ (_, (val, Just ty)) -> do

157− kind <- liftCheck $ kindOf moduleName ty

157+ kind <- liftCheck $ kindOf moduleName ty

158− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

158+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

159− ty' <- replaceAllTypeSynonyms ty

159+ ty' <- replaceAllTypeSynonyms ty

160− bindNames dict $ check val ty'

160+ bindNames dict $ check val ty'

161− return ty'

161+ return ty'

162− Right (ident, val) -> do

162+ (ident, (val, Nothing)) -> do

163− ty <- bindNames dict $ infer val

163+ ty <- bindNames dict $ infer val

164− ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

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

165− return ty

169+ return ty

166 return tys

170 return tys

167 forM tys $ flip (escapeCheck checks) sub

171 forM tys $ flip (escapeCheck checks) sub

168 forM tys $ skolemEscapeCheck

172 forM tys $ skolemEscapeCheck

169 return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys

173 return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys

170

174

171−isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)

175+isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type))

172−isTyped (name, TypedValue value ty) = Left (name, ty, value)

176+isTyped (name, TypedValue value ty) = (name, (value, Just ty))

173−isTyped (name, value) = Right (name, value)

177+isTyped (name, value) = (name, (value, Nothing))

174

178

175escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()

179escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()

176escapeCheck checks ty sub =

180escapeCheck checks ty sub =