{-# OPTIONS_GHC -fglasgow-exts #-} -- -- 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.Overloading ( resolveOverloading, Bind, installInstanceDictionaries, dumpDictExprs ) where import qualified Data.Map as Map import Control.Monad.State import Phrac.Symtab import Phrac.AbstractSyntax import Phrac.Error import Phrac.Unification ( matchConstraint ) import Phrac.Pretty import Phrac.Substitution import Phrac.Pretty {- The dictionary resolution algorithm is based on "John Peterson and Mark Jones. Implementing Type Classes. PLDI '93". -} data OVState = OVState { -- the current substitution ov_subst :: TypeSubst, -- context information for recursivly defined variables ov_recMap :: RecMap, -- mapping from class constraints to dictionary -- variables providing evidence for the constraint ov_dictEnv :: DictEnv } type OV = StateT OVState ST runOV :: TypeSubst -- current substitution -> RecMap -- context for recursivly defined variables -> [(ClassConstraint, ValId)] -- mapping from class constraints to -- dictionary variables for the binding -- being translated -> OV a -- OV computation to run -> ST a runOV subst map pairs ov = do env <- buildDictEnv pairs evalStateT ov (OVState subst map env) type RecMap = Map.Map ValId [ClassConstraint] emptyRecMap = Map.empty -- The dictionary environment. -- -- Maps class constraints to variable names holding the dictionaries -- for the constraints. If there is a mapping from `C a1 .. aN' to -- some variable, there must be mappings for all super classes of `C' -- to the same variable. Use the `buildDictEnv' function to maintain this -- invariant. type DictEnv = Map.Map ClassConstraint ValId emptyDictEnv = Map.empty buildDictEnv :: [(ClassConstraint, ValId)] -> ST DictEnv buildDictEnv pairs = foldM ins emptyDictEnv pairs where ins env (cc@(ClassConstraint c t), id) = do supers <- findAllSuperClasses c let constrs = cc : map (\c -> ClassConstraint c t) supers return (foldl (\m k -> Map.insert k id m) env constrs) installInstanceDictionaries :: [ClassInst] -> ST () installInstanceDictionaries insts = do replaceInstances insts -- replace the instances in the symtab let keys = map (\ci -> (inst_class ci, inst_types ci)) insts dictExps <- mapM buildInstanceDictionary insts mapM (uncurry enterDictionaryExpression) (zip keys dictExps) return () {- Returns an expression which yields a dictionary for the given instance when applied to the appropriate arguments. The arguments correspond to the constraints in the instance context. A dictionary is just a list containing the code of all methods of the instance (this includes the methods of all superclasses). See {tests/overloading-resolution/should_pass/004.phc, tests/overloading-resolution/should_pass/005.phc} for how dictionaries look like. -} buildInstanceDictionary :: ClassInst -> ST Exp buildInstanceDictionary ci = do let (cs,_) = splitConstraints (inst_constraints ci) ds <- mapM (\_ -> freshValVar) cs let instanceMapping = map (methodEntry ds) (inst_valBinds ci) -- construct dictionaries for super classes supers <- findAllSuperClasses (inst_class ci) let superConstrs = map (\c -> ClassConstraint c (inst_types ci)) supers superExps <- runOV nullSubst emptyRecMap (zip cs ds) $ mapM getDictionaryExp superConstrs superMapping <- mapM superEntries (zip supers superExps) return (Lam (map PVar ds) (Overloading $ Dictionary (instanceMapping ++ concat superMapping))) where methodEntry :: [ValId] -> ValBind -> (ValId, Method) methodEntry ctxParams bind = let n = length ctxParams mapping = zip ctxParams (map fromPVar (vbind_pats bind)) restParams = drop n (vbind_pats bind) in (vbind_name bind, Method mapping (Lam restParams $ vbind_exp bind)) where fromPVar (PVar i) = i fromPVar p = panic ("dictionary parameter cannot be a pattern: " ++ showPpr' p) superEntries :: (ClassId, Exp) -> ST [(ValId, Method)] superEntries (cid, e) = do mids <- getMethods cid return (map (\i -> (i, SuperMethod i e)) mids) -- Returns the instance declaration which fulfills the given constraint. -- Additionally, the class constraints in the instance context are returned, -- after applying the appropriate substitution. -- If there is no instance declaration fulfilling the constraint, -- `Nothing' is returned. This can happen with deferred constraints. getInstance :: ClassConstraint -> ST (Maybe (ClassInst, [ClassConstraint])) getInstance c@(ClassConstraint i _) = do insts <- findInstances i candidates <- sequence [tryInst it | it <- insts] case msum candidates of Nothing -> return Nothing Just (ci, goals) -> let (cs, _) = splitConstraints goals in return $ Just (ci, cs) where tryInst ci = do u <- matchConstraint (inst_class ci, inst_types ci) c case u of Nothing -> return Nothing Just u' -> return $ Just (ci, map (applySubst u') (inst_constraints ci)) {- Returns a expression evaluating to a dictionary which provides evidence for the given constraint. -} getDictionaryExp :: ClassConstraint -> OV Exp getDictionaryExp c = do env <- gets ov_dictEnv case Map.lookup c env of Just id -> return $ Var id Nothing -> do inst <- lift $ getInstance c case inst of Nothing -> return $ Overloading (Placeholder c) -- deferred constraint Just (ci, cs) -> do dicts <- mapM getDictionaryExp cs let instDict = DictionaryReference (inst_class ci) (inst_types ci) return $ foldl App (Overloading instDict) dicts resolveExp :: Exp -> OV Exp resolveExp (Overloading (Placeholder c)) = do s <- gets ov_subst getDictionaryExp (applySubst s c) resolveExp (Overloading (MethodPlaceholder cid mid ts)) = do s <- gets ov_subst let ts' = applySubst s ts dexp <- getDictionaryExp (ClassConstraint cid ts') return $ Overloading (DictionaryLookup mid dexp) resolveExp (Overloading o) = panic ("unexpected Overloading value during overloading resolution: " ++ show o) resolveExp (Var id) = do recMap <- gets ov_recMap case Map.lookup id recMap of Nothing -> return (Var id) Just [] -> do debug ("no overloading resolution necessary for recursivly " ++ "defined variable " ++ showPpr' id) return (Var id) Just cs -> do ds <- mapM getDictionaryExp cs let e = foldl App (Var id) ds debug ("resolving overloading for recursivly defined " ++ "variable " ++ showPpr' id ++ " by replacing it with " ++ showPpr' e) return e resolveExp e@(Const _) = return e resolveExp (Prim op es) = do es' <- mapM resolveExp es return $ Prim op es' resolveExp (Con id es) = do es' <- mapM resolveExp es return $ Con id es' resolveExp (App e1 e2) = do e1' <- resolveExp e1 e2' <- resolveExp e2 return $ App e1' e2' resolveExp (Lam vs e) = do e' <- resolveExp e return $ Lam vs e' resolveExp (If e1 e2 e3) = do e1' <- resolveExp e1 e2' <- resolveExp e2 e3' <- resolveExp e3 return $ If e1' e2' e3' resolveExp (Letrec vs e) = do e' <- resolveExp e return $ Letrec vs e' resolveExp (Case e alts) = do e' <- resolveExp e alts' <- mapM resolveAlt alts return $ Case e' alts' where resolveAlt a = do e' <- resolveExp (alt_exp a) return $ a { alt_exp = e' } resolveExp (Error s) = return (Error s) type Bind = ([Pat] {- arguments -} , Exp) resolveOverloading :: TypeSubst -- the current substitution -> RecMap -- constraints for recursivly defined vars -> Bind -- the binding to transform -> [ClassConstraint] -- class context of the binding -> ST Bind -- the transformed binding resolveOverloading subst recMap (pats, e) cs = do debug ("resolveOverloading called with recMap=" ++ show (dumpMap recMap) ++ ", cs=" ++ showCommaListed cs) ds <- mapM (\_ -> freshValVar) cs e' <- runOV subst recMap (zip cs ds) (resolveExp e) return (map PVar ds ++ pats, e') dumpDictExprs :: [((ClassId, [Type]), Exp)] -> Doc dumpDictExprs [] = empty dumpDictExprs (((cid, ts), e) : rest) = let restDoc = dumpDictExprs rest doc = text "dict-" <> ppr cid <> text "<" <> pprList ", " ts <> text ">:" $$ ppr e in doc $$ restDoc