purescript 0.2.15.2 → 0.3.0
raw patch · 5 files changed
+73/−44 lines, 5 files
Files
- purescript.cabal +1/−1
- src/Language/PureScript/TypeChecker.hs +45/−34
- src/Language/PureScript/TypeChecker/Monad.hs +8/−3
- src/Language/PureScript/TypeChecker/Types.hs +13/−5
- src/Language/PureScript/Values.hs +6/−1
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.15.2+version: 0.3.0 cabal-version: >=1.8 build-type: Simple license: MIT
src/Language/PureScript/TypeChecker.hs view
@@ -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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -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'
src/Language/PureScript/TypeChecker/Types.hs view
@@ -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
src/Language/PureScript/Values.hs view
@@ -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