summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-12 19:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-12 19:15:00 (GMT)
commitb36b1714f1293ffabcdc3ddf51329bfc9ce761d8 (patch)
tree5ba2e9f6360bccc75a9ceccca7b266d4f57f4ec4
parent5f54395c85ed2f8bc3d3f5d04021a94f37c4a385 (diff)
version 0.2.13.10.2.13.1
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/TypeChecker.hs17
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs3
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs42
4 files changed, 38 insertions, 26 deletions
diff --git a/purescript.cabal b/purescript.cabal
index df2621a..eaf3a3d 100644
--- 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
index d13d69c..da68ef9 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -24,6 +24,8 @@ import Language.PureScript.TypeChecker.Kinds as T
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 @@ addDataConstructor moduleName name args dctor maybeTy = do
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 @@ valueIsNotDefined moduleName name = do
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 @@ typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
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
@@ -184,3 +186,10 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
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
index 0afabc9..70c9215 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -51,11 +51,10 @@ data Environment = Environment
, 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
index a69247c..db99611 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -20,8 +20,7 @@ module Language.PureScript.TypeChecker.Types (
) 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 -> [(Ident, Value)] -> Check [Type]
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 =