This module contains experimental stuff to complete the dictionary translation by translating class declarations to record types and instance declaration to record values. Doing this while staying within the source abstract syntax is a bit clumbsy, unfortunately.
The default methods in class declarations are placed in a "default instance", i.e. a record of the same type as an instance, from with the default methods are selected by the translation of instance declarations.
Apart from fields corresponding to methods, the record types also contain fields corresponding to superclasses. The context reduction function refers to these functions.
Most of this is not used at the moment.
module TiClassInst2({-tcClassDecl,tcInstDecl,-}tcInstOrClassDecl'') where
import List((\\))
--import HasBaseStruct(HasBaseStruct(..),hsTypeSig,hsClassDecl,hsInstDecl)
import HasBaseStruct
import BaseSyntax hiding (TI)
--import SrcLoc(SrcLoc,srcLoc)
import TI
import qualified TiKEnv(lookup)
import TiDkc(Dinst{-,Einst-})
import TiDinst(hsSimpleBind{-,hsSimpleBind',tcSelFns-})
import TiSolve(matches)
--import MUtils
import PrettyPrint
{-
tcClassDecl d src ctx cl fdeps ds =
do let (msigs,defaults) = splitMethodSigs ds
(ms,ds') <- tcClassDecl' src [cl] cl defaults
msigs':>:_ <- tcLocalDecls msigs -- kind check + type conversion
hsClassDecl2 d {-bs-} ms src ctx cl fdeps msigs' ds'
tcInstDecl src ictx inst ds =
do (ns,ds') <- tcInstDecl' src ictx inst ds
modmap <- getModule
let n = instName' modmap src
-- return $ hsInstDecl0 n ns src ictx inst ds'
hsInstDecl2 n ns src ictx inst ds'
-}
--------------------------------------------------------------------------------
{-
hsClassDecl2 ::
(Printable i,ValueId i,Eq i,TypeVar i,
HasBaseStruct d2 (Dinst i e2 p2 ds2),
HasBaseStruct e2 (Einst i e2 p2 ds2),HasId i e2,
DeclInfo i (Dinst i e2 p2 ds2),
HasId i p2,
HasDef ds2 d2,
--GetSigs i [Pred i] (Pred i) ds2,
HasAbstr i d2,AddDeclsType i ds2,
HasBaseStruct e1 (Einst i e1 p1 ds1),HasBaseStruct p1 (PI i p1),
HasDef ds1 d1,TypeCheckDecl i (Dinst i e1 p1 ds1) ds2
) =>
(Dinst i e1 p1 ds1) -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> HsFunDeps i ->
ds2 -> ds2 -> TI i ds2
hsClassDecl2 d1 {-bs-} mi@(ms,_,_) src ctx cl fdeps msigs ds =
do defaultInst <- hsDefaultMethods dn mi src ctx cl ds
--m <- getModule
let fields =
[HsRecDecl src cn
(supers++
[([i],unb (hsTyForall' vs (funT (c++[t]))))
| HsVar i:>:Forall vs (c:=>t)<-ms])]
dictdata <- return $ HsDataDecl src [] cl fields []
let dts = explicitlyTyped {-m-} [] dictdata
selfns <- extendts dts $ tcSelFns [d1] []{-bs-} fields
return $ addDeclsType ([],[HsVar dn:>:upscheme (funT [cl,cl])]) $
base dictdata
`consDef` defaultInst
`consDef` selfns
where
dn = defaultName cn
c@(HsCon cn) = definedType cl
supers = [([superName cn n],unb c)|(n,c)<-zip [1..] ctx]
unb = HsUnBangedType
hsTyForall' [] t = t
hsTyForall' vs t = hsTyForall vs t
hsDefaultMethods ::
(HasDef ds2 d2,HasBaseStruct d2 (Dinst i e p ds2),
HasId i e,HasId i p,Eq i,ValueId i,Printable i,
HasAbstr i d2,AddDeclsType i ds2,
HasBaseStruct e (Einst i e p ds2))
=> i -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> ds2 -> TI i d2
hsDefaultMethods dn (ms,ims,_) src ctx cl ds =
do darg <- dictName # fresh
return $ abstract [darg] $ hsSimpleBind' src dn (body [darg]) ds
where
c@(HsCon cn) = definedType cl
body dns = hsRecConstr cn (superDefs++methodDefs)
where
methodDefs = map methodDef ms
superDefs = [HsField n (noDefault n)|n<-take (length ctx) superns]
where superns = map (superName cn) [1..]
methodDef (i@(HsVar v):>:_) =
HsField v $ if i `elem` ims
then apps (ident i:map var dns)
else noDefault i
noDefault i = hsApp (var (prelVal "error"))
(hsLit$HsString$pp$src<>": no default for:"<+>i)
apps = foldl1 hsApp
-}
--------------------------------------------------------------------------------
type MethodInfo i = ([Assump i],[HsIdentI i],[i])
tcInstDecl' = tcInstOrClassDecl'' False
tcClassDecl' = tcInstOrClassDecl'' True
tcInstOrClassDecl'' ::
(TypeId i,Printable i,Fresh i,Printable dsin,
DefinedNames i dsin,HasBaseStruct din (Dinst i e p dsin),
HasDef dsin din,HasId i p,ValueId i,HasId i e,
TypeCheckDecls i dsin dsout,
HasDef dsout dout,HasBaseStruct dout (Dinst i e2 p2 dsout))
=> Bool -> SrcLoc -> [Pred i] -> Pred i -> dsin
-> TI i (MethodInfo i,dsout)
tcInstOrClassDecl'' isClass src ictx inst ds0 =
do let cname@(HsCon cn) = definedType inst
(k,Class super0 cvs0 fundeps0 ms0) <- env kenv cname
let cl0 = appT (ty cname:map tyvar (tdom cvs0))
(cl,ms,super) <- return (cl0,ms0,super0) -- names are already unique
--(cl,ms,super) <- allfresh (cl0,ms0,super0) --since `matches` requires disjoint vars
supdns <- if isClass then return []
--else map dictName # freshlist (length super)
else return $ map (superName cn) [1..length super]
let ds = toDefs (map superMethod supdns) `appendDef` ds0
ims = definedValueNames ds0 -- names of implemented methods
ns:>:_ = unzipTyped ms -- names of the methods of this class
supms = zipTyped (map HsVar supdns:>:map mono super)
case ims \\ ns of
badms@(_:_) ->
fail ("Extra bindings in "++dkind++" declaration: "++pp badms)
[] -> errorContext (pp$"In"<+>dkind<+>inst) $
do kenv <- getKEnv
s <- (inst `matches` cl) kenv
let mts = (map.fmap) (addctx kenv (apply s ictx))
(apply s (ms++supms))
ds' <-
--errmap (("Method signatures:\n"++pp mSigs++"\n")++) $
--errorContext ("Methods:\n"++pp ds) $
extendts [superVar:>:superType] $
tcInstDecls mts ds
return ((ms,ims,supdns),ds')
where
dkind = if isClass then "class" else "instance"
addctx kenv ictx (Forall vs' vs (ctx:=>t)) = Forall vs' (ivs++vs) ((ictx++ctx):=>t)
where
ivs0 = tv (ictx,ctx,t) \\ tdom vs
ivs = [v:>:kind v|v<-ivs0]
kind = maybe err fst . TiKEnv.lookup kenv . HsVar
err = error "Bug in TiClassInst2: missing kind for a type variable"
-- mSig m@(HsVar n) = do Forall vs (ctx:=>t) <- sch m
-- return $ hsTypeSig src [n] (ictx++ctx) t
superMethod n = hsSimpleBind src n (ident superVar)
superVar = HsVar (prelVal "super")
superType = forall' [av:>:kpred] ([a]:=>a)
where a = tyvar av
av = tvar 1
--------------------------------------------------------------------------------
{-
hsInstDecl2 ::
(Eq i,ValueId i,
HasDef ds2 d2,AddDeclsType i ds2,
HasId i e2,HasId i p2,HasAbstr i ds2,
HasBaseStruct e2 (Einst i e2 p2 ds2),
HasBaseStruct d2 (Dinst i e2 p2 ds2))
=> i -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> ds2 -> TI i ds2
hsInstDecl2 n (ms,ims,supsels) src ctx inst ds =
do self:dns <- map dictName # freshlist (1+length ctx)
let selfbody = body self dns
return $ abstract dns $
let ds' = addDeclsType ([],[HsVar self:>:mono inst]) $
consDef selfdef ds
selfdef = hsSimpleBind src self selfbody
in oneDef $ hsSimpleBind' src n (var self) ds'
where
c@(HsCon cn) = definedType inst
dn = defaultName cn
body self dns = hsRecConstr cn (superDefs++methodDefs)
where
methodDefs = map methodDef ms
superDefs = zipWith methodDef' superns (map HsVar supsels)
where superns = map (superName cn) [1..]
methodDef (i@(HsVar v):>:_) =
HsField v $ if i `elem` ims
then apps (ident i:map var dns)
else useDefault i
methodDef' v i = HsField v $ apps (ident i:map var dns)
useDefault i = ident i `hsApp` (var dn `hsApp` (var self))
apps = foldl1 hsApp
-}