purescript 0.2.13 → 0.2.13.1
raw patch · 4 files changed
+38/−26 lines, 4 files
Files
- purescript.cabal +1/−1
- src/Language/PureScript/TypeChecker.hs +13/−4
- src/Language/PureScript/TypeChecker/Monad.hs +1/−2
- src/Language/PureScript/TypeChecker/Types.hs +23/−19
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.13+version: 0.2.13.1 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript/TypeChecker.hs view
@@ -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'
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -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 =