diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.2.13 +version: 0.2.13.1 cabal-version: >=1.8 build-type: Simple license: MIT diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -24,6 +24,8 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Synonyms as T +import Data.Data +import Data.Generics (mkT, everywhere) import Data.Maybe import qualified Data.Map as M import Control.Monad.State @@ -50,13 +52,13 @@ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy let polyType = mkForAll args dctorTy - putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) } + putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) } addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do env <- getEnv putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) - , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) } + , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) } typeIsNotDefined :: ModuleName -> ProperName -> Check () typeIsNotDefined moduleName name = do @@ -80,7 +82,7 @@ addValue :: ModuleName -> Ident -> Type -> Check () addValue moduleName name ty = do env <- getEnv - putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) }) + putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) }) typeCheckAll :: ModuleName -> [Declaration] -> Check () typeCheckAll _ [] = return () @@ -132,7 +134,7 @@ guardWith "Expected kind *" $ kind == Star case M.lookup (moduleName, name) (names env) of Just _ -> throwError $ show name ++ " is already defined" - Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) }) + Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern) (names env) }) typeCheckAll moduleName rest typeCheckAll moduleName (FixityDeclaration _ name : rest) = do typeCheckAll moduleName rest @@ -183,4 +185,11 @@ constructs (Function _ ty) pn = ty `constructs` pn constructs (TypeApp ty _) pn = ty `constructs` pn constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn + +qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d +qualifyAllUnqualifiedNames mn env = everywhere (mkT go) + where + go :: Qualified ProperName -> Qualified ProperName + go qual = let (mn', pn') = canonicalizeType mn env qual + in Qualified (Just mn') pn' diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -51,11 +51,10 @@ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind) , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type) - , members :: M.Map (ModuleName, Ident) String } deriving (Show) emptyEnvironment :: Environment -emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty +emptyEnvironment = Environment M.empty M.empty M.empty M.empty bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a bindNames newNames action = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -20,8 +20,7 @@ ) where import Data.List -import Data.Maybe (fromMaybe) -import Data.Either (lefts, rights) +import Data.Maybe (isNothing, isJust, fromMaybe) import qualified Data.Data as D import Data.Generics (mkT, something, everywhere, everywhereBut, mkQ) @@ -146,31 +145,36 @@ typesOf moduleName vals = do (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do let es = map isTyped vals - typed = lefts es - untyped = rights es - typedDict = map (\(ident, ty, _) -> (ident, ty)) typed + typed = filter (isJust . snd . snd) es + untyped = filter (isNothing . snd . snd) es + typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed untypedNames <- replicateM (length untyped) fresh let untypedDict = zip (map fst untyped) untypedNames dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict) - tys <- forM es $ \e -> case e of - Left (_, ty, val) -> do - kind <- liftCheck $ kindOf moduleName ty - guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star - ty' <- replaceAllTypeSynonyms ty - bindNames dict $ check val ty' - return ty' - Right (ident, val) -> do - ty <- bindNames dict $ infer val - ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict) - return ty + tys <- forM es $ \e -> do + ty <- case e of + (_, (val, Just ty)) -> do + kind <- liftCheck $ kindOf moduleName ty + guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star + ty' <- replaceAllTypeSynonyms ty + bindNames dict $ check val ty' + return ty' + (ident, (val, Nothing)) -> do + ty <- bindNames dict $ infer val + ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict) + return ty + when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do + [eff, a] <- replicateM 2 fresh + ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a + return ty return tys forM tys $ flip (escapeCheck checks) sub forM tys $ skolemEscapeCheck return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys -isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value) -isTyped (name, TypedValue value ty) = Left (name, ty, value) -isTyped (name, value) = Right (name, value) +isTyped :: (Ident, Value) -> (Ident, (Value, Maybe Type)) +isTyped (name, TypedValue value ty) = (name, (value, Just ty)) +isTyped (name, value) = (name, (value, Nothing)) escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check () escapeCheck checks ty sub =