module Type.Ctx( buildCtx, buildDefaults, ctxsReduce, ctxsSimplify, initCtxs) where import List(sort) import NT import IntState import Info import Id import Type.Subst import Util.Extra import qualified Data.Map as Map import Syntax import Type.Data import State import Maybe initCtxs :: [TypeDict] initCtxs = [] removeTSyn :: IntState -> NT -> NT removeTSyn state nt@(NTstrict nt') = removeTSyn state nt' removeTSyn state nt@(NTcons c _ nts) = case lookupIS state c of Just (InfoData u tid exp (NewType free [] _ [nt]) (DataTypeSynonym uboxed depth)) -> -- No context in type synonyms removeTSyn state (substNT (zip free nts) nt) _ -> -- It must be an InfoData here, or we have an internal error nt removeTSyn state tvar = tvar -- Is c a superclass of cstart? scof :: IntState -> Id -- ^ would-be superclass -> Id -- ^ would-be subclass -> Bool scof state c cstart = case lookupIS state cstart of Just info -> let sc = superclassesI info in any (c==) sc || any (scof state c) sc -- ctxsReduce only works on NTvar and NTexist ctxsReduce :: IntState -> [(Id,NT)] -> [(Id,NT)] ctxsReduce state ctxs = case foldr (ctxReduce state) [] ctxs of ctxs -> foldr (ctxReduce state) [] (reverse ctxs) -- Not very nice but... ctxReduce :: IntState -> (Id,NT) -> [(Id,NT)] -> [(Id,NT)] ctxReduce state ctx@(c,nt) ctxs = let v = stripNT nt in if ctx `elem` ctxs then ctxs else let sametvar = filter ((v==) . stripNT . snd) ctxs in if (any (scof state c) . map fst) sametvar then ctxs else ctx: ctxs ctxsSimplify :: [Pos] -> IntState -> [((Id,Id),([Id],[(Id,Id)]))] -> TypeDict -> [(Id,NT)] ctxsSimplify poss state given cls_nt = ctxsSimplify' poss state given cls_nt [] -- Only NTvar and NTexist in result ctxsSimplify' :: [Pos] -> IntState -> [((Id,Id),([Id],[(Id,Id)]))] -> TypeDict -> [(Id,NT)] -> [(Id,NT)] ctxsSimplify' _ state given (TypeDict cls (NTany v) ipos) r = (cls,mkNTvar v):r ctxsSimplify' _ state given (TypeDict cls (NTvar v k) ipos) r = (cls,NTvar v k):r ctxsSimplify' _ state given (TypeDict cls (NTexist v k) ipos) r = (cls,NTexist v k):r ctxsSimplify' poss state given (TypeDict cls (NTstrict nt) ipos) r = -- Don't keep strictness information in ctx? ctxsSimplify' poss state given (TypeDict cls nt ipos) r ctxsSimplify' poss state given (TypeDict cls nt ipos) r = case removeTSyn state nt of (NTvar v k) -> (cls,NTvar v k):r (NTany v) -> (cls,mkNTvar v):r (NTexist v k) -> (cls,NTexist v k):r (NTstrict nt) -> -- Don't keep strictness information in ctx? ctxsSimplify' poss state given (TypeDict cls nt ipos) r (NTcons con _ nts) -> case lookup (cls,con) given of Just (tvs,ctxs) -> -- A derived instance foldr (ctxsSimplify' poss state given) r (pair2ctxs ipos tvs nts ctxs) Nothing -> case lookupIS state cls of Nothing -> error ("Internal: CtxsSimplify couldn't find the class " ++ show cls) Just info -> case Map.lookup con (instancesI info) of Just (_,tvs,ctxs) -> foldr (ctxsSimplify' poss state given) r (pair2ctxs ipos tvs nts ctxs) Nothing -> error ("The class " ++ strIS state cls ++ " has no instance for the type " ++ strIS state con ++ ".\nPossible sources for the problem are: " ++ mixCommaAnd (map (strPos . snd) ipos) ++ "\nWhen type checking declarations at: " ++ mixCommaAnd (map strPos poss) ++ "\n") -- (NTapp (NTvar v k) nt2) -> -- (cls,NTapp (NTvar v k) nt2):r -- (NTapp (NTany v) nt2) -> -- (cls,NTapp (mkNTvar v) nt2):r (NTapp nt1 nt2) -> error ("Couldn't simplify the context (" ++ strIS state cls ++ " (" ++ strNT (strIS state) strTVar nt1 ++ " " ++ strNT (strIS state) strTVar nt2 ++ ")).\nPossible sources for the problem are: " ++ mixCommaAnd (map (strPos . snd) ipos)) ent -> error ("Internal: CtxsSimplify expanded the type synonym " ++ show nt ++ " to " ++ show ent ++ "\nInternal: expected a type constructor") pair2ctxs :: Eq a => [(Id,Pos)] -> [a] -> [NT] -> [(Id,a)] -> [TypeDict] pair2ctxs ipos tvs nts ctxs = let al = zip tvs nts in map ( \ (c,v) -> TypeDict c (fromJust (lookup v al)) ipos) ctxs --- =================================== isVar :: NT -> Bool isVar (NTvar v _) = True isVar (NTexist v _) = True isVar _ = False buildCtx :: IntState -> Pos -> [((Id, NT), Id)] -> TypeDict -> Exp Id buildCtx state pos given (TypeDict cls (NTany tvar) ipos)= buildCtx state pos given (TypeDict cls (mkNTvar tvar) ipos) buildCtx state pos given (TypeDict cls nt ipos) | isVar nt = case lookup (cls,nt) given of Just i -> ExpVar pos i Nothing -> let lpis = ( sort . map ( \ ((p,i):_) -> (length p,p,i) ) . filter (not.null) . map ( \ ((c,ntv),i) -> ( map ( \ (c,p) -> (c:p,i) ) . filter ((cls==).fst) . allSCof state ) c) . filter ((nt==).snd.fst) ) (given::[((Id,NT),Id)]) in case lpis of ((_,p,i):_) -> mkPath state pos (ExpVar pos i) (reverse p) [] -> -- Error message generated elsewhere, probably when deriving need (PatWildcard pos) buildCtx state pos given (TypeDict cls nt ipos) = case removeTSyn state nt of nt@(NTcons con _ nts) -> case lookupIS state cls of Just info -> case Map.lookup con (instancesI info) of Just (_,tvs,[]) -> mkRealCon pos state cls con Just (_,tvs,ctxs) -> ExpApplication pos (mkRealCon pos state cls con : map (buildCtx state pos given) (pair2ctxs ipos tvs nts ctxs)) Nothing -> -- Error message generated elsewhere, -- probably when deriving need (PatWildcard pos) nt -> buildCtx state pos given (TypeDict cls nt ipos) mkRealCon :: Pos -> a -> Id -> Id -> Exp Id mkRealCon pos state cls con = Exp2 pos cls con {- Not used since March'96 version of Haskell 1.3 case lookupIS state con of Just conInfo -> if isRealData conInfo then Exp2 pos cls con else mkRealCon state cls (getIndDataIS state conInfo) -} mkPath :: a -> Pos -> Exp b -> [b] -> Exp b mkPath state pos ea (f:t:r) = -- superclass from class mkPath state pos (ExpApplication pos [Exp2 pos f t,ea]) (t:r) mkPath state pos ea _ = ea -- | get all super classes of c (including c itself!) in width first order allSCof :: IntState -> Id -> [(Id,[Id])] allSCof state c = allSCof' state [(c,[])] allSCof' :: IntState -> [(Id,[Id])] -> [(Id,[Id])] allSCof' state [] = [] allSCof' state (cp@(c,p):cs) = case lookupIS state c of Just info -> let sc = (map ( \ s -> (s,c:p)) . superclassesI) info in cp : allSCof' state (cs++sc) -- Default does not work if it creates new dependencies, -- this brutal hack cannot handle arguments either! findDefault :: [Map.Map Id (b,[c],[d])] -> [Id] -> Maybe Id findDefault insts [] = Nothing findDefault insts (d:ds) = if all (\inst-> case Map.lookup d inst of Just (_,[],[])-> True; _-> False) insts then Just d else findDefault insts ds -- oneDefault :: (Int,[(Int,Int)]) -> (Pos,Exp Int,[Int]) -- -> IntState -> ([Decl Int],IntState) oneDefault :: Show a => (a,[(Id,Id)]) -> (Pos,b,[Id]) -> IntState -> ([Decl Id],IntState) oneDefault (tvar,cis) (pos,trueExp,defaults) state = case findDefault (map (instancesI . fromJust . lookupIS state . fst) cis) defaults of Just con -> (map (\(cls,i)-> (DeclFun noPos i [Fun [] (Unguarded (mkRealCon pos state cls con)) (DeclsScc [])])) cis ,state) Nothing -> ([] ,addError state ("No default for " ++ concatMap ((' ':).strIS state . fst) cis ++ " at " ++ strPos pos ++ "." ++ "(" ++ show tvar ++ "," ++ show cis++")")) buildDefaults :: Pos -> [((Id,NT),Id)] -> a -> [Id] -> IntState -> ([Decl Id],IntState) buildDefaults pos defaultCtxsi trueExp defaults state = let setup = Map.toList (foldr (\((c,nt),i) t -> Map.insertWith (++) (stripNT nt) [(c,i)] t) Map.empty defaultCtxsi) (defaultDecls,state') = mapS oneDefault setup (pos,trueExp,defaults) state in (concat defaultDecls,state')