{-# OPTIONS_GHC -fglasgow-exts #-} -- for "Non-type variables in constraint" -- -- Copyright (C) 2005 Stefan Wehr - http://www.stefanwehr.de -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- module Phrac.Symtab ( Symtab, buildSymtab, ST, liftIO, runST, getConfiguration, setConfiguration, modifyConfiguration, insertKind, kindOfTypeVarId, kindAssocs, findClass, findAssocTypeSig, findClassOfAssocType, findInstances, findTypeDef, findSuperClasses, findAllSuperClasses, findAllSuperConstraints, findDataConstructor, findMethodSig, getAssocIndexCount, isMethod, getMethods, getGlobalEqualities, addConcreteEqualities, deleteConcreteEqualities, instantiate, freshTypeVar, freshTyConstruct, freshValVar, setFreshVarsPrefix, replaceInstances, enterDictionaryExpression, getDictionaryExpressions, findDictionaryExpression ) where import qualified List import qualified Data.Set as Set import Maybe ( mapMaybe ) import Control.Exception import Control.Monad.State import Prelude hiding (catch) import qualified Phrac.UniqIdents as UniqIdents import qualified Phrac.Map as Map import Phrac.Pretty import Phrac.AbstractSyntax import Phrac.Error import Phrac.DependAnalysis import Phrac.Substitution import Phrac.Configuration -- Note: we don't have equality definitions for abstract associated -- type synonyms. This means we cannot define instances for such abstract -- associated type synonyms. data Symtab = Symtab { classMap :: Map.Map ClassId (ClassDec, [ClassInst]), assocTypeSigMap :: Map.Map AssocTypeId AssocTypeSig, typeVarKindMap :: Map.Map TypeVarId Kind, typeDefMap :: Map.Map TypeId TypeDef, nameSupply :: (UniqIdents.Version, -- next free version String, -- prefix for type variables String, -- prefix for type constructors String), -- prefix for value variables globalEqualities :: [EqualityDefinition],-- assoc type definitions concreteEqualities :: [EqualityDefinition],-- abstract assoc type definitions -- made concrete, e.g. for checking -- the body of an instance methods :: Set.Set ValId, -- which value ids are methods? dictExprs :: Map.Map (ClassId, [Type]) Exp, configuration :: Configuration } emptySymtab = Symtab { classMap = Map.empty, assocTypeSigMap = Map.empty, typeVarKindMap = Map.empty, typeDefMap = Map.empty, nameSupply = (UniqIdents.initialVersion - 1, "#v", "#c", "#d"), globalEqualities = [], concreteEqualities = [], methods = Set.empty, dictExprs = Map.empty, configuration = defaultConfiguration } type ST = StateT Symtab IO runST :: Symtab -> ST a -> IO a runST tab st = evalStateT st tab lookUp :: (Ord k, Pretty k) => (Symtab -> Map.Map k a) -> k -> ST a lookUp f k = do tab <- gets f case Map.lookup k tab of Just x -> return x Nothing -> phasefail ("Key `" ++ showPpr k ++ "' not found in symbol table") modifyConfiguration :: (Configuration -> Configuration) -> ST () modifyConfiguration f = modify (\s -> s { configuration = f (configuration s) }) setConfiguration :: Configuration -> ST () setConfiguration conf = modify (\s -> s { configuration = conf }) getConfiguration :: ST Configuration getConfiguration = gets configuration replaceInstances :: [ClassInst] -> ST () replaceInstances insts = do m <- gets classMap let emptyInsts = Map.map (\ (cdec,_) -> (cdec, [])) m m' = foldr insertInst emptyInsts insts modify (\s -> s { classMap = m' }) where insertInst :: ClassInst -> Map.Map ClassId (ClassDec, [ClassInst]) -> Map.Map ClassId (ClassDec, [ClassInst]) insertInst ci m = let cid = inst_class ci in case Map.lookup cid m of Nothing -> panic ("Class " ++ showPpr' cid ++ " not defined") Just (cdec, l) -> Map.insert cid (cdec, ci:l) m findInstances :: ClassId -> ST [ClassInst] findInstances cid = do (_, insts) <- lookUp classMap cid return insts findClass :: ClassId -> ST ClassDec findClass cid = do (cdec, _) <- lookUp classMap cid return cdec -- Returns the constraint for all superclasses with the parameters -- of the constraints reflecting the parameters of the class. findAllSuperConstraints :: ClassId -> ST [ClassConstraint] findAllSuperConstraints cid = do cdec <- findClass cid let constrs = class_constraints cdec l <- mapM handleConstraint constrs return $ concat l where handleConstraint cc@(ClassConstraint cid ts) = do cdec <- findClass cid let subst = substFromAssocs (zip (class_params cdec) ts) constrs <- findAllSuperConstraints cid let constrParams = applySubst subst (map cc_params constrs) supers = map (\ (cc, ps) -> cc { cc_params = ps }) (zip constrs constrParams) return $ cc : supers -- `findSuperClasses c' returns the _direct_ superclasses of c findSuperClasses :: ClassId -> ST [ClassId] findSuperClasses cid = do cdec <- findClass cid return (map cc_name (class_constraints cdec)) -- the transitive hull of `findSuperClasses' -- If class hierarchy is cyclic, this function loops findAllSuperClasses :: ClassId -> ST [ClassId] findAllSuperClasses cid = do direct <- findSuperClasses cid transitives <- mapM findSuperClasses direct return (direct ++ concat transitives) findAssocTypeSig :: AssocTypeId -> ST AssocTypeSig findAssocTypeSig = lookUp assocTypeSigMap -- returns the number of index parameter of an associated type synonym getAssocIndexCount :: AssocTypeId -> ST Int getAssocIndexCount id = do cdec <- findClassOfAssocType id return (length $ class_params cdec) findMethodSig :: ClassId -> ValId -> ST VSig findMethodSig cid i = do cdec <- findClass cid case List.find ((==) i . fst) (class_vsigs cdec) of Just vsig -> return vsig Nothing -> phasefail ("Method " ++ showPpr' i ++ " is not defined in " ++ "class " ++ showPpr cid) isMethod :: ValId -> ST Bool isMethod id = do set <- gets methods return (Set.member id set) getMethods :: ClassId -> ST [ValId] getMethods cid = do cdec <- findClass cid return (map fst (class_vsigs cdec)) findTypeDef :: TypeId -> ST TypeDef findTypeDef = lookUp typeDefMap findClassOfAssocType :: AssocTypeId -> ST ClassDec findClassOfAssocType id = do tab <- gets classMap case List.find definesAssocType (Map.elems tab) of Just (cd,_) -> return cd Nothing -> phasefail ("No class found which defines the associated " ++ "type synonym " ++ showPpr id) where definesAssocType (cd,_) = id `elem` map assocSig_name (class_tsigs cd) findDataConstructor :: DataId -> ST (TypeDef, DataConstructor) findDataConstructor id = do tab <- gets typeDefMap return $ find id (Map.elems tab) where find id [] = phasefail ("unknown data constructor: " ++ showPpr' id) find id (x:xs) = case List.find ((==) id . dconstr_name) (tydef_alts x) of Just dcons -> (x, dcons) Nothing -> find id xs getGlobalEqualities :: ST [EqualityDefinition] getGlobalEqualities = do glob <- gets globalEqualities concr <- gets concreteEqualities return $ concr ++ glob -- Add the concrete right-hand sides of the abstract type synonyms of the -- given instance to the global equality definitions addConcreteEqualities :: ClassInst -> ST () addConcreteEqualities ci = let -- add the assoc type definitions quants = freeTypeVarsList (inst_types ci) eqs = map mkEqConstraint (filter isAbstract $ inst_typeBinds ci) eqdefs = map (EqualityDefinition quants) eqs in do old <- gets concreteEqualities if not $ null old then panic ("INTERNAL ERROR: " ++ "cannot add concrete equalities for abstract associated "++ "type synonyms. Reaons: there are already some concrete "++ "equalities. This violates an invariant") else do modify (\s -> s { concreteEqualities = eqdefs }) debug ("added concrete equalities: " ++ showPpr eqdefs) -- Delete all concrete equality definitions resulting from abstract -- associated type synonyms deleteConcreteEqualities :: ST () deleteConcreteEqualities = do modify (\s -> s { concreteEqualities = [] }) enterDictionaryExpression :: (ClassId, [Type]) -> Exp -> ST () enterDictionaryExpression key exp = do modify (\s -> s { dictExprs = Map.insert key exp (dictExprs s) }) getDictionaryExpressions :: ST [((ClassId, [Type]), Exp)] getDictionaryExpressions = do m <- gets dictExprs return $ Map.toList m findDictionaryExpression :: ClassId -> [Type] -> ST (Maybe Exp) findDictionaryExpression cid ts = do m <- gets dictExprs return $ Map.lookup (cid, ts) m insertKind :: TypeVarId -> Kind -> ST () insertKind id k = do tab <- gets typeVarKindMap case Map.insertLookup id k tab of (Nothing, tab') -> modify (\s -> s { typeVarKindMap = tab' }) (Just k', _) | k /= k' -> phasefail ("Cannot insert kind (" ++ showPpr k ++ ") for type variable `" ++ showPpr id ++ "': type variable already defined with different " ++ "kind (" ++ showPpr k' ++ ")") _ -> return () kindOfTypeVarId :: TypeVarId -> ST Kind kindOfTypeVarId = lookUp typeVarKindMap kindAssocs :: ST [(TypeVarId, Kind)] kindAssocs = do tab <- gets typeVarKindMap return $ Map.assocs tab instantiate :: Substitution TypeVarId Type c => [TypeVarId] -> c -> ST (c, [TypeVarId], Subst TypeVarId Type) instantiate quants c = do kinds <- mapM kindOfTypeVarId quants freshs <- mapM freshTypeVar' kinds let subst = substFromAssocs (zip quants (map TyVar freshs)) return (applySubst subst c, freshs, subst) -- Sets the prefix used for generating fresh type and type constructor -- variables. The new prefixes have to be different from the old ones. -- Used to start name generation from scratch after prelude has been typed. -- This is a bit of a hack, I know, but otherwise tests break if we -- add something to the prelude :-) setFreshVarsPrefix :: String -> String -> String -> ST () setFreshVarsPrefix v c x = do (version, v', c', x') <- gets nameSupply if v == v' || c == c' || x == x' then panic ("new prefixes for type and constructor variables not " ++ "different from old prefixes!") else modify (\s -> s { nameSupply = (UniqIdents.initialVersion - 1, v, c, x) }) freshTypeVar' :: Kind -> ST TypeVarId freshTypeVar' k = do (cur, v, c, x) <- gets nameSupply modify (\s -> s { nameSupply = (cur - 1, v, c, x) }) let id = UniqIdents.mkTypeVar v cur insertKind id k return id freshTypeVar :: Kind -> ST Type freshTypeVar k = do id <- freshTypeVar' k return (TyVar id) freshTyConstruct :: Kind -> ST Type freshTyConstruct kind = do (cur, v, c, x) <- gets nameSupply modify (\s -> s { nameSupply = (cur - 1, v, c, x) }) let id = UniqIdents.mkTypeId c cur args <- freshArgs kind let tydef = TypeDef id args [] (emptyInfo { info_builtin = True }) insertTypeDef tydef return (TyConstruct id) where freshArgs KindStar = return [] freshArgs (KindFun k1 k2) = do v <- freshTypeVar' k1 restArgs <- freshArgs k2 return (v:restArgs) freshValVar :: ST ValId freshValVar = do (cur, v, c, x) <- gets nameSupply modify (\s -> s { nameSupply = (cur - 1, v, c, x) }) return $ UniqIdents.mkValId x cur ------------------------------------------------------------------------------ -- Building the symtab -- Please note: no kind information available when symbol table -- is built. buildSymtab :: Program -> IO Symtab buildSymtab (Program typeDefs classDecs classInsts binds) = runST emptySymtab build where build = do mapM insertTypeDef typeDefs let orderedClasses = orderClasses classDecs mapM insertClass orderedClasses mapM insertInstance classInsts get insertTypeDef :: TypeDef -> ST () insertTypeDef td = modify (\s -> s { typeDefMap = Map.insert (tydef_name td) td (typeDefMap s) }) orderClasses classDecs = let groups = getBindGroups classDecs class_name classDeps (cyclic, acyclic) = List.partition isCyclic groups in if not (null cyclic) then phasefail ("cyclic class hierarchy: " ++ show (map (ppr . class_name) (head cyclic))) else concat acyclic where classDeps cd = map cc_name $ class_constraints cd isCyclic group = length group >= 2 -- * inserts the class -- * inserts the signatures of the associated types insertClass :: ClassDec -> ST () insertClass cd = let eqs = mapMaybe toEq (class_tsigs cd) mids = Set.fromList (map fst (class_vsigs cd)) in modify (\s -> s { classMap = Map.insert (class_name cd) (cd, []) (classMap s), assocTypeSigMap = foldr insertAssocSig (assocTypeSigMap s) (class_tsigs cd), -- equalities for fixed associated type synonyms globalEqualities = eqs ++ (globalEqualities s), methods = mids `Set.union` (methods s) }) where insertAssocSig sig m = Map.insert (assocSig_name sig) sig m toEq (AssocTypeSig _ _ Nothing) = Nothing toEq (AssocTypeSig id l (Just right)) = let left = AssocType id (map TyVar l) in Just $ EqualityDefinition (take (length $ class_params cd) l) (EqConstraint left right) -- * registers the instances as a instance of its class -- * enters the associated type definitions in the equality environment insertInstance :: ClassInst -> ST () insertInstance ci = let -- add the assoc type definitions quants = freeTypeVarsList (inst_types ci) eqs = map mkEqConstraint (filter isConcrete $ inst_typeBinds ci) in modify $ addInstance (map (EqualityDefinition quants) eqs) where addInstance eqs s = let m = classMap s in case Map.lookup (inst_class ci) m of Nothing -> panic ("No such class: " ++ showPpr (inst_class ci)) Just (cdec, insts) -> s { classMap = Map.insert (inst_class ci) (cdec, ci:insts) m, globalEqualities = eqs ++ (globalEqualities s) } -- makes an equality constraint using the concrete rhs mkEqConstraint :: AssocTypeBind -> EqConstraint mkEqConstraint assoc = let left = AssocType (assocBind_name assoc) (assocBind_indices assoc ++ map TyVar (assocBind_params assoc)) right = assocBind_def assoc in EqConstraint left right insertTuple :: Ord k => (k, a) -> Map.Map k (k,a) -> Map.Map k (k,a) insertTuple t@(k,v) = Map.insert k t