diff --git a/purescript.cabal b/purescript.cabal --- 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 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -166,41 +166,51 @@ 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@(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 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -33,6 +33,7 @@ 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 @@ 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 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -196,17 +196,22 @@ (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 @@ 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 --- a/src/Language/PureScript/Values.hs +++ b/src/Language/PureScript/Values.hs @@ -75,11 +75,16 @@ | 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