summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-18 02:37:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-18 02:37:00 (GMT)
commitae84a9b7fe354e04c5d3904d0b096959538f563f (patch)
tree179a7dfa15d61fdc881ec90d4484e920f732a3b0
parent55f9857d0a04f52fb4ba67b329e98495d9f38118 (diff)
version 0.3.00.3.0
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/TypeChecker.hs79
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs18
-rw-r--r--src/Language/PureScript/Values.hs7
5 files changed, 73 insertions, 44 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 72db876..fdc9f7d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.15.2
+version: 0.3.0
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 07953ea..0e4409b 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -166,41 +166,51 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
Just idents' -> do
shadowIdents (lefts idents') env
shadowTypes (rights idents') env
+ shadowTypeClassInstances env
ds <- typeCheckAll currentModule rest
return $ d : ds
- where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
- filterModule = filter ((== moduleName) . fst) . M.keys
- moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
- shadowIdents idents' env =
- forM_ idents' $ \ident -> do
- case (moduleName, ident) `M.lookup` names env of
- Just (_, Alias _ _) -> return ()
- Just (pt, _) -> do
- guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
- modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
- Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
- shadowTypes pns env =
- forM_ pns $ \pn -> do
- case (moduleName, pn) `M.lookup` types env of
- Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
- Just (_, DataAlias _ _) -> return ()
- Just (k, _) -> do
- guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
- modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
- let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
- forM_ keys $ \dctor -> do
- case (moduleName, dctor) `M.lookup` dataConstructors env of
- Just (_, Alias _ _) -> return ()
- Just (ctorTy, _) -> do
- guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
- modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
- Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
- constructs (TypeConstructor (Qualified (Just mn) pn')) pn
- = mn == moduleName && pn' == pn
- constructs (ForAll _ ty) pn = ty `constructs` pn
- constructs (Function _ ty) pn = ty `constructs` pn
- constructs (TypeApp ty _) pn = ty `constructs` pn
- constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
+ where
+ errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
+ filterModule = filter ((== moduleName) . fst) . M.keys
+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
+ shadowIdents idents' env =
+ forM_ idents' $ \ident -> do
+ case (moduleName, ident) `M.lookup` names env of
+ Just (_, Alias _ _) -> return ()
+ Just (pt, _) -> do
+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
+ modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
+ shadowTypes pns env =
+ forM_ pns $ \pn -> do
+ case (moduleName, pn) `M.lookup` types env of
+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
+ Just (_, DataAlias _ _) -> return ()
+ Just (k, _) -> do
+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
+ forM_ keys $ \dctor -> do
+ case (moduleName, dctor) `M.lookup` dataConstructors env of
+ Just (_, Alias _ _) -> return ()
+ Just (ctorTy, _) -> do
+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
+ shadowTypeClassInstances env = do
+ let instances = filter (\tcd ->
+ let Qualified (Just mn) _ = tcdName tcd in
+ moduleName == mn && tcdType tcd == TCDRegular
+ ) (typeClassDictionaries env)
+ forM_ instances $ \tcd -> do
+ let (Qualified _ ident) = tcdName tcd
+ addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn
+ = mn == moduleName && pn' == pn
+ constructs (ForAll _ ty) pn = ty `constructs` pn
+ constructs (Function _ ty) pn = ty `constructs` pn
+ constructs (TypeApp ty _) pn = ty `constructs` pn
+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
env <- getEnv
ds <- typeCheckAll moduleName rest
@@ -208,6 +218,7 @@ typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
env <- getEnv
dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
- addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env [TypeClassDictionaryInScope dictName className ty (Just deps)])
+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
+ [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
ds <- typeCheckAll moduleName rest
return $ qualifyAllUnqualifiedNames moduleName env d : ds
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index bb3f0bb..1ab2ea0 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -33,6 +33,7 @@ import Control.Applicative
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Reader
+import Control.Arrow ((***))
import qualified Data.Map as M
@@ -241,6 +242,10 @@ fresh = unknown . Unknown <$> fresh'
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'
+ go :: Type -> Type
+ go (TypeConstructor nm) = TypeConstructor $ qualify' nm
+ go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
+ go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty
+ go other = other
+ qualify' qual = let (mn', pn') = canonicalizeType mn env qual
+ in Qualified (Just mn') pn'
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index ea48dbf..15ae118 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -196,17 +196,22 @@ entails moduleName context goal@(className, ty) = do
(dict : _) -> return dict
where
go env (className', ty') =
- [ mkDictionary (tcdName tcd) args
+ [ mkDictionary (canonicalizeDictionary tcd) args
| tcd <- context
- , qualify moduleName className' == qualify moduleName (tcdClassName tcd)
+ , filterModule tcd
+ , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
, subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
, args <- solveSubgoals env subst (tcdDependencies tcd) ]
solveSubgoals _ _ Nothing = return Nothing
solveSubgoals env subst (Just subgoals) = do
dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
return $ Just dict
- mkDictionary fnName Nothing = Var (Qualified Nothing fnName)
- mkDictionary fnName (Just args) = App (Var (Qualified Nothing fnName)) args
+ mkDictionary fnName args = maybe id (flip App) args $ (Var fnName)
+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
+ filterModule _ = False
+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
typeHeadsAreEqual _ _ String String = Just []
@@ -647,7 +652,10 @@ check' val (ConstrainedType constraints ty) = do
dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
- val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty
+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
+ (qualifyAllUnqualifiedNames moduleName env constraints)) $
+ check val ty
return $ Abs dictNames val'
check' val u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index c57cfa6..0051003 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -75,11 +75,16 @@ data Value
| Do [DoNotationElement]
| TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
+data TypeClassDictionaryType
+ = TCDRegular
+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
+
data TypeClassDictionaryInScope
- = TypeClassDictionaryInScope { tcdName :: Ident
+ = TypeClassDictionaryInScope { tcdName :: Qualified Ident
, tcdClassName :: Qualified ProperName
, tcdInstanceType :: Type
, tcdDependencies :: Maybe [(Qualified ProperName, Type)]
+ , tcdType :: TypeClassDictionaryType
} deriving (Show, Data, Typeable)
data DoNotationElement