module Language.Grammars.AspectAG (
Att, Fam(..), Chi, Rule,
emptyRule,
instdef, locdef,
inhdef, syndef,
inhmod, synmod,
At(..), lhs, loc, def,
instdefM, locdefM,
inhdefM, syndefM,
inhmodM, synmodM,
ext, adapt, rename, fixCst, graft,
Prd, (.+.),
sem_Lit, knit,
SemType(),
copy, use, chain,
inhAspect, synAspect, chnAspect,
attAspect, defAspect,
ListNT(..),
module Data.HList
) where
import Data.HList hiding ((.+.), hUpdateAtLabel)
import Data.HList.FakePrelude
import Control.Monad.Reader
type Att att val = LVPair att val
data Fam l ho c p = Fam l ho c p
type Chi ch atts = LVPair ch atts
type Rule lf hof sc ip l ho ic sp l' ho' ic' sp'
= Fam lf hof sc ip -> Fam l ho ic sp -> Fam l' ho' ic' sp'
emptyRule :: Rule lf hof sc ip l ho ic sp l ho ic sp
emptyRule = const id
instdef :: HExtend (Att att val) ho ho'
=> att -> val -> (Fam l ho ic sp -> Fam l ho' ic sp)
instdef att val (Fam l ho ic sp) = Fam l (att .=. val .*. ho) ic sp
locdef :: HExtend (Att att val) l l'
=> att -> val -> (Fam l ho ic sp -> Fam l' ho ic sp)
locdef att val (Fam l ho ic sp) = Fam (att .=. val .*. l) ho ic sp
syndef :: HExtend (Att att val) sp sp'
=> att -> val -> (Fam l ho ic sp -> Fam l ho ic sp')
syndef att val (Fam l ho ic sp) = Fam l ho ic (att .=. val .*. sp)
synmod :: HUpdateAtLabel att val sp sp'
=> att -> val -> Fam l ho ic sp -> Fam l ho ic sp'
synmod att v (Fam l ho ic sp) = Fam l ho ic (hUpdateAtLabel att v sp)
inhdef :: Defs att nts vals ic ic'
=> att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
inhdef att nts vals (Fam l ho ic sp) =
Fam l ho (defs att nts vals ic) sp
class Defs att nts vals ic ic' | vals ic -> ic' where
defs :: att -> nts -> vals -> ic -> ic'
instance Defs att nts (Record HNil) ic ic where
defs _ _ _ ic = ic
instance ( Defs att nts (Record vs) ic ic'
, HasLabel (Proxy (lch,t)) ic' mch
, HMember (Proxy t) nts mnts
, SingleDef mch mnts att
(Chi (Proxy (lch,t)) vch)
ic' ic'' )
=> Defs att nts
(Record (HCons (Chi (Proxy (lch,t)) vch) vs))
ic ic''
where
defs att nts ~(Record (HCons pch vs)) ic =
singledef mch mnts att pch ic'
where ic' = defs att nts (Record vs) ic
lch = labelLVPair pch
mch = hasLabel lch ic'
mnts = hMember (sndProxy lch) nts
class SingleDef mch mnts att pv ic ic'
| mch mnts pv ic -> ic'
where singledef :: mch -> mnts -> att -> pv -> ic -> ic'
data IncorrectDef l lch err
data UndefNT t
data UndefProd t
data UndefAtt t
instance Fail (IncorrectDef l lch (UndefNT t))
=> SingleDef HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
singledef = undefined
instance Fail (IncorrectDef l lch (UndefProd (lch,t)))
=> SingleDef HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
singledef = undefined
instance ( HasField lch ic och
, HExtend (Att att vch) och och'
, HUpdateAtLabel lch och' ic ic')
=> SingleDef HTrue HTrue att (Chi lch vch) ic ic'
where singledef _ _ att pch ic =
hUpdateAtLabel lch (att .=. vch .*. och) ic
where lch = labelLVPair pch
vch = valueLVPair pch
och = hLookupByLabel lch ic
inhmod :: Mods att nts vals ic ic'
=> att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
inhmod att nts vals (Fam l ho ic sp) =
Fam l ho (mods att nts vals ic) sp
class Mods att nts vals ic ic' | vals ic -> ic' where
mods :: att -> nts -> vals -> ic -> ic'
instance Mods att nts (Record HNil) ic ic where
mods _ _ _ ic = ic
instance ( Mods att nts (Record vs) ic ic'
, HasLabel (Proxy (lch,t)) ic' mch
, HMember (Proxy t) nts mnts
, SingleMod mch mnts att
(Chi (Proxy (lch,t)) vch)
ic' ic'' )
=> Mods att nts
(Record (HCons (Chi (Proxy (lch,t)) vch) vs))
ic ic''
where
mods att nts ~(Record (HCons pch vs)) ic =
singlemod mch mnts att pch ic'
where ic' = mods att nts (Record vs) ic
lch = labelLVPair pch
mch = hasLabel lch ic'
mnts = hMember (sndProxy lch) nts
class SingleMod mch mnts att pv ic ic'
| mch mnts pv ic -> ic'
where singlemod :: mch -> mnts -> att -> pv -> ic -> ic'
data IncorrectMod l lch err
instance Fail (IncorrectMod l lch (UndefNT t))
=> SingleMod HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
singlemod = undefined
instance Fail (IncorrectMod l lch (UndefProd (lch,t)))
=> SingleMod HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
singlemod = undefined
instance ( HasField lch ic och
, HUpdateAtLabel att vch och och'
, HUpdateAtLabel lch och' ic ic')
=> SingleMod HTrue HTrue att (Chi lch vch) ic ic'
where singlemod _ _ att pch ic =
hUpdateAtLabel lch (hUpdateAtLabel att vch och) ic
where lch = labelLVPair pch
vch = valueLVPair pch
och = hLookupByLabel lch ic
ext :: Rule lf hof sc ip l' ho' ic' sp' l'' ho'' ic'' sp''
-> Rule lf hof sc ip l ho ic sp l' ho' ic' sp'
-> Rule lf hof sc ip l ho ic sp l'' ho'' ic'' sp''
ext f g input = f input . g input
adapt :: Rule lf hof sc ip li hoi ici spi lo hoo ico spo
-> (sc' -> sc) -> (ici' -> ici) -> (ico -> ico')
-> Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
adapt rule fsc fici fico (Fam lf hof sc ip) (Fam li hoi ici spi) =
let (Fam lo hoo ico spo) = rule (Fam lf hof (fsc sc) ip) (Fam li hoi (fici ici) spi)
in (Fam lo hoo (fico ico) spo)
rename :: (RenRL s sc' sc, RenRL s ici' ici, RenLR s ico ico')
=> Rule lf hof sc ip li hoi ici spi lo hoo ico spo
-> s
-> Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
rename asp s = adapt asp (renRL s) (renRL s) (renLR s)
class RenLR s r r' | s r -> r' where
renLR :: s -> r -> r'
instance RenLR HNil r r where
renLR _ r = r
instance ( RenLR s (Record r') (Record r'')
, HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
=> RenLR (HCons (LVPair lr lr') s)
(Record r)
(Record (HCons (LVPair lr' v) r''))
where
renLR (HCons lp s) r = hExtend (newLVPair lr' v) r''
where
lr = labelLVPair lp
lr' = valueLVPair lp
v = hLookupByLabel lr r
r' = hDeleteAtLabel lr r
r'' = renLR s r'
class RenRL s r r' | s r -> r' where
renRL :: s -> r -> r'
instance RenRL HNil r r where
renRL _ r = r
instance ( RenRL s (Record r') (Record r'')
, HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
=> RenRL (HCons (LVPair lr' lr) s)
(Record r)
(Record (HCons (LVPair lr' v) r''))
where
renRL (HCons lp s) r = hExtend (newLVPair lr' v) r''
where
lr' = labelLVPair lp
lr = valueLVPair lp
v = hLookupByLabel lr r
r' = hDeleteAtLabel lr r
r'' = renRL s r'
fixCst
:: (RecordLabels r ls,
HRLabelSet (HCons (LVPair l (Record HNil)) r),
HExtend (LVPair l v) t2 l',
HRearrange ls r1 r',
HLabelSet ls,
H2ProjectByLabels (HCons l HNil) t10 t11 r1) =>
(Fam t t1 l' t3
-> Fam t4 t5 (Record (HCons (LVPair l (Record HNil)) r)) t6
-> Fam t7 t8 (Record t10) t9)
-> l
-> v
-> Fam t t1 t2 t3
-> Fam t4 t5 (Record r) t6
-> Fam t7 t8 (Record r') t9
fixCst rule lch cst (Fam lf hof sc ip) (Fam li hoi ici spi) =
let (Fam lo hoo ico spo) = rule (Fam lf hof (lch .=. cst .*. sc) ip) (Fam li hoi (lch .=. emptyRecord .*. ici) spi)
ls = recordLabels ici
ico' = hRearrange ls (hDeleteAtLabel lch ico)
in (Fam lo hoo ico' spo)
graft
:: (RecordLabels r ls,
RecordValues r1 vs,
HRLabelSet t2,
HRLabelSet t1,
H2ProjectByLabels vs r t1 t2,
HRLabelSet (HCons (LVPair l (Record HNil)) t2),
HRLabelSet t21,
HRLabelSet t11,
H2ProjectByLabels vs t t11 t21,
HasField l t6 ip1,
RenLR r1 ico1 t4,
RenRL r1 (Record t1) ici1,
RenRL r1 (Record t11) sc1,
HRLabelSet (HCons (LVPair l t5) t21),
RenLR l' ico (Record t6),
RenRL
l' (Record (HCons (LVPair l (Record HNil)) t2)) ici,
RenRL
l' (Record (HCons (LVPair l t5) t21)) sc,
HExtend (LVPair l l) l1 l',
HLeftUnion t4 (Record t23) (Record r2),
H2ProjectByLabels (HCons l HNil) t6 t13 t23,
HRearrange ls r2 r',
HLabelSet ls) =>
Rule lf hof sc ip li hoi ici spi li1 hoi1 ico t12
-> l1
-> l
-> Rule lf hof sc1 ip1 li1 hoi1 ici1 (Record HNil) t22 t3 ico1 t5
-> r1
-> Fam lf hof (Record t) ip
-> Fam li hoi (Record r) spi
-> Fam t22 t3 (Record r') t12
graft rule1 chs1 lch rule2 chs2 (Fam lf hof sc ip) (Fam l ho ici spi) =
let spi1 = spi
spi2 = emptyRecord
ls2 = recordValues (Record chs2)
(ici2,ici1') = hProjectByLabels2 ls2 ici
ici1 = lch .=. emptyRecord .*. ici1'
(sc2,sc1') = hProjectByLabels2 ls2 sc
sc1 = lch .=. spo2 .*. sc1'
ip1 = ip
ip2 = ico1 # lch
(Fam l1 ho1 ico1 spo1) = (rename rule1 (lch .=. lch .*. chs1)) (Fam lf hof sc1 ip1) (Fam l ho ici1 spi1)
(Fam l2 ho2 ico2 spo2) = (rename rule2 chs2) (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
ls = recordLabels ici
ico = hRearrange ls $ hLeftUnion ico2 (hDeleteAtLabel lch ico1)
spo = spo1
in (Fam l2 ho2 ico spo)
data Lhs
lhs :: Proxy Lhs
lhs = proxy
data Loc
loc :: Proxy Loc
loc = proxy
class At l m v | l -> v where
at :: l -> m v
instance (HasField (Proxy (lch,nt)) chi v, MonadReader (Fam l ho chi par) m)
=> At (Proxy (lch,nt)) m v where
at lbl = liftM (\(Fam _ _ chi _) -> chi # lbl) ask
instance MonadReader (Fam l ho chi par) m
=> At (Proxy Lhs) m par where
at _ = liftM (\(Fam _ _ _ par) -> par) ask
instance MonadReader (Fam l ho chi par) m
=> At (Proxy Loc) m l where
at _ = liftM (\(Fam l _ _ _) -> l) ask
def :: Reader (Fam l ho chi par) a -> ((Fam l ho chi par) -> a)
def = runReader
instdefM :: (HExtend (Att att a) ho ho')
=> att -> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic sp l ho' ic sp
instdefM att d inp = instdef att (def d inp)
locdefM :: (HExtend (Att att a) l l')
=> att -> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic sp l' ho ic sp
locdefM att d inp = locdef att (def d inp)
inhdefM :: (Defs att nts a ic ic')
=> att-> nts-> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic sp l ho ic' sp
inhdefM att nts d inp = inhdef att nts (def d inp)
syndefM :: (HExtend (Att att a) sp sp')
=> att-> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic sp l ho ic sp'
syndefM att d inp = syndef att (def d inp)
inhmodM :: (Mods att nts a ic ic')
=> att -> nts -> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic sp l ho ic' sp
inhmodM att nts d inp = inhmod att nts (def d inp)
synmodM :: (HUpdateAtHNat n (Att att a) sp sp',HFind att ls n,RecordLabels sp ls)
=> att-> Reader (Fam lf hof sc ip) a
-> Rule lf hof sc ip l ho ic (Record sp) l ho ic (Record sp')
synmodM att d inp = synmod att (def d inp)
type Prd prd rule = LVPair prd rule
class Com r r' r'' | r r' -> r''
where (.+.) :: r -> r' -> r''
instance Com r (Record HNil) r
where r .+. _ = r
instance ( HasLabel lprd r b
, ComSingle b (Prd lprd rprd) r r'''
, Com r''' (Record r') r'')
=> Com r (Record (HCons (Prd lprd rprd) r')) r''
where
r .+. (Record (HCons prd r')) = r''
where b = hasLabel (labelLVPair prd) r
r''' = comsingle b prd r
r'' = r''' .+. (Record r')
class ComSingle b f r r' | b f r -> r'
where comsingle :: b -> f -> r -> r'
instance ( HasField lprd r (Rule lf hof sc ip l' ho' ic' sp' l'' ho'' ic'' sp'')
, HUpdateAtLabel lprd (Rule lf hof sc ip
l ho ic sp
l'' ho'' ic'' sp'')
r r')
=> ComSingle HTrue (Prd lprd (Rule lf hof sc ip l ho ic sp l' ho' ic' sp'))
r r'
where
comsingle _ f r = hUpdateAtLabel n ((r # n) `ext` v) r
where n = labelLVPair f
v = valueLVPair f
instance ComSingle HFalse f (Record r) (Record (HCons f r))
where comsingle _ f (Record r) = Record (HCons f r)
sem_Lit :: a -> Record HNil -> a
sem_Lit e (Record HNil) = e
knit :: (HLeftUnion ho fc fc', Kn fc' ic sc, Empties fc' ec)
=> Rule l ho sc ip (Record HNil) (Record HNil) ec (Record HNil) l ho ic sp
-> fc -> ip -> sp
knit rule fc ip =
let fc' = hLeftUnion ho fc
ec = empties fc'
(Fam l ho ic sp) = rule (Fam l ho sc ip)
(Fam emptyRecord emptyRecord ec emptyRecord)
sc = kn fc' ic
in sp
class Kn fc ic sc | fc -> ic sc where
kn :: fc -> ic -> sc
instance Kn fc ic sc
=> Kn (Record fc) (Record ic) (Record sc) where
kn (Record fc) (Record ic) = Record $ kn fc ic
instance Kn HNil HNil HNil where
kn _ _ = hNil
instance Kn fcr icr scr
=> Kn (HCons (Chi lch (ich->sch)) fcr)
(HCons (Chi lch ich) icr)
(HCons (Chi lch sch) scr)
where
kn ~(HCons pfch fcr) ~(HCons pich icr) =
let scr = kn fcr icr
lch = labelLVPair pfch
fch = valueLVPair pfch
ich = valueLVPair pich
in HCons (newLVPair lch (fch ich)) scr
class Empties fc ec | fc -> ec where
empties :: fc -> ec
instance Empties fc ec => Empties (Record fc) (Record ec)
where empties (Record fc) = Record $ empties fc
instance Empties fcr ecr
=> Empties (HCons (Chi lch fch) fcr)
(HCons (Chi lch (Record HNil)) ecr)
where
empties ~(HCons pch fcr) =
let ecr = empties fcr
lch = labelLVPair pch
in HCons (newLVPair lch emptyRecord) ecr
instance Empties HNil HNil where
empties _ = hNil
class SemType t nt | t -> nt
class ListNT nt tHd tTl where
ch_hd :: Proxy (tHd, nt)
ch_tl :: Proxy (tTl, [nt])
ch_hd = proxy
ch_tl = proxy
copy :: (Copy att nts vp ic ic', HasField att ip vp)
=> att -> nts -> Rule lf hof sc ip l ho ic sp l ho ic' sp
copy att nts (Fam _ _ _ ip) = defcp att nts (ip # att)
defcp :: Copy att nts vp ic ic'
=> att -> nts -> vp -> (Fam l ho ic sp -> Fam l ho ic' sp)
defcp att nts vp (Fam l ho ic sp) =
Fam l ho (cpychi att nts vp ic) sp
class Copy att nts vp ic ic' | ic -> ic' where
cpychi :: att -> nts -> vp -> ic -> ic'
instance Copy att nts vp (Record HNil) (Record HNil) where
cpychi _ _ _ _ = emptyRecord
instance ( Copy att nts vp (Record ics) ics'
, HMember (Proxy t) nts mnts
, HasLabel att vch mvch
, Copy' mnts mvch att vp
(Chi (Proxy (lch, t)) vch)
pch
, HExtend pch ics' ic)
=> Copy att nts vp
(Record (HCons (Chi (Proxy (lch, t)) vch) ics))
ic
where
cpychi att nts vp (Record (HCons pch ics)) =
cpychi' mnts mvch att vp pch .*. ics'
where ics' = cpychi att nts vp (Record ics)
lch = sndProxy (labelLVPair pch)
vch = valueLVPair pch
mnts = hMember lch nts
mvch = hasLabel att vch
class Copy' mnts mvch att vp pch pch' | mnts mvch pch -> pch'
where
cpychi' :: mnts -> mvch -> att -> vp -> pch -> pch'
instance Copy' HFalse mvch att vp pch pch where
cpychi' _ _ _ _ pch = pch
instance Copy' HTrue HTrue att vp pch pch where
cpychi' _ _ _ _ pch = pch
instance HExtend (Att att vp) vch vch'
=> Copy' HTrue HFalse att vp (Chi lch vch)
(Chi lch vch') where
cpychi' _ _ att vp pch = lch .=. (att .=. vp .*. vch)
where lch = labelLVPair pch
vch = valueLVPair pch
use :: (Use att nts a sc, HExtend (Att att a) sp sp')
=> att -> nts -> (a -> a -> a) -> a
-> Rule lf hof sc ip l ho ic sp l ho ic sp'
use att nts oper unit (Fam _ _ sc _) = syndef att val
where val = case usechi att nts oper sc of
Just r -> r
Nothing -> unit
class Use att nts a sc where
usechi :: att -> nts -> (a -> a -> a) -> sc -> Maybe a
instance Use att nts a sc => Use att nts a (Record sc) where
usechi att nts oper (Record sc) = usechi att nts oper sc
instance Use l nt a HNil where
usechi _ _ _ _ = Nothing
instance ( HMember (Proxy t) nts mnts
, Use' mnts att nts a (HCons (LVPair (Proxy (lch, t)) vch) scr))
=> Use att nts a (HCons (LVPair (Proxy (lch, t)) vch) scr) where
usechi att nts oper ~sc@(HCons fa _) = usechi' mnts att nts oper sc
where mnts = hMember (sndProxy $ labelLVPair fa) nts
class Use' mnts att nts a sc where
usechi' :: mnts -> att -> nts -> (a -> a -> a) -> sc -> Maybe a
instance (HasField att (Record vch) a, Use att nts a scr) =>
Use' HTrue att nts a (HCons (LVPair lch (Record vch)) scr) where
usechi' _ att nts oper ~(HCons fa scr) = Just $ case usechi att nts oper scr of
Just r -> oper a r
Nothing -> a
where a = valueLVPair fa # att
instance (Use att nts a scr) =>
Use' HFalse att nts a (HCons (LVPair lch b) scr) where
usechi' _ att nts oper ~(HCons _ scr) = usechi att nts oper scr
chain :: ( Chain att nts val sc l ho ic sp ic' sp'
, HasField att ip val )
=> att -> nts -> Rule lf hof sc ip l ho ic sp l ho ic' sp'
chain att nts (Fam _ _ sc ip) = defchn att nts (ip # att) sc
class Chain att nts val sc l ho ic sp ic' sp' | sc ic sp -> ic' sp' where
defchn :: att -> nts -> val -> sc -> (Fam l ho ic sp -> Fam l ho ic' sp')
instance ( Chain' msp att nts val sc l ho ic sp ic' sp'
, HasLabel att sp msp )
=> Chain att nts val sc l ho ic sp ic' sp'
where
defchn att nts val sc inp@(Fam _ _ _ sp) = defchn' msp att nts val sc inp
where msp = hasLabel att sp
class Chain' msp att nts val sc l ho ic sp ic' sp' | msp sc ic sp -> ic' sp' where
defchn' :: msp -> att -> nts -> val -> sc -> Fam l ho ic sp -> Fam l ho ic' sp'
instance ( ChnChi att nts val sc ic ic'
, HExtend (Att att val) sp sp' )
=> Chain' HFalse att nts val sc l ho ic sp ic' sp'
where
defchn' _ att nts val sc (Fam l ho ic sp) =
let (val',ic') = chnchi att nts val sc ic
in Fam l ho ic' (att .=. val' .*. sp)
instance ( ChnChi att nts val sc ic ic' )
=> Chain' HTrue att nts val sc l ho ic sp ic' sp
where
defchn' _ att nts val sc (Fam l ho ic sp) =
let (_,ic') = chnchi att nts val sc ic
in Fam l ho ic' sp
class ChnChi att nts val sc ic ic' | sc ic -> ic' where
chnchi :: att -> nts -> val -> sc -> ic -> (val,ic')
instance ChnChi att nts val (Record HNil) (Record HNil) (Record HNil) where
chnchi _ _ val _ _ = (val, emptyRecord)
instance ( ChnChi att nts val (Record scs) (Record ics) ics'
, HMember (Proxy t) nts mnts
, ChnChi' mnts att val
(Chi (Proxy (lch, t)) sch)
(Chi (Proxy (lch, t)) ich)
pch
, HExtend pch ics' ic)
=> ChnChi att nts val
(Record (HCons (Chi (Proxy (lch, t)) sch) scs))
(Record (HCons (Chi (Proxy (lch, t)) ich) ics))
ic
where
chnchi att nts val (Record (HCons psch scs)) (Record (HCons pich ics)) =
let (val'',ics') = chnchi att nts val' (Record scs) (Record ics)
in (val'',ich'.*. ics')
where (val',ich') = chnchi' mnts att val psch pich
lch = sndProxy (labelLVPair psch)
mnts = hMember lch nts
class ChnChi' mnts att val sch ich ich' | mnts sch ich -> ich'
where
chnchi' :: mnts -> att -> val -> sch -> ich -> (val,ich')
instance ChnChi' HFalse att val sch ich ich where
chnchi' _ _ val _ ich = (val,ich)
instance ( HasLabel att sch msch
, HasLabel att ich mich
, ChnChi'' msch mich att val
(Chi (Proxy (lch, t)) sch)
(Chi (Proxy (lch, t)) ich)
pch )
=> ChnChi' HTrue att val
(Chi (Proxy (lch, t)) sch)
(Chi (Proxy (lch, t)) ich)
pch
where
chnchi' _ att val psch pich = chnchi'' msch mich att val psch pich
where sch = valueLVPair psch
ich = valueLVPair pich
msch = hasLabel att sch
mich = hasLabel att ich
class ChnChi'' msch mich att val sch ich ich' | msch mich sch ich -> ich'
where
chnchi'' :: msch -> mich -> att -> val -> sch -> ich -> (val,ich')
instance Fail (IncorrectDef att lch (UndefAtt att))
=> ChnChi'' HFalse HTrue att val sch (Chi lch ich) ich' where
chnchi'' _ _ _ _ _ _ = undefined
instance Fail (IncorrectDef att lch (UndefAtt att))
=> ChnChi'' HFalse HFalse att val sch (Chi lch ich) ich' where
chnchi'' _ _ _ _ _ _ = undefined
instance HasField att sch val
=> ChnChi'' HTrue HTrue att val (Chi lch sch) ich ich where
chnchi'' _ _ att _ psch ich = (sch # att,ich)
where sch = valueLVPair psch
instance ( HasField att sch val
, HExtend (Att att val) ich ich' )
=> ChnChi'' HTrue HFalse att val (Chi lch sch) (Chi lch ich) (Chi lch ich') where
chnchi'' _ _ att val psch pich = (sch # att, lch .=. (att .=. val .*. ich))
where lch = labelLVPair psch
sch = valueLVPair psch
ich = valueLVPair pich
inhAspect :: ( AttAspect (FnInh att nts) defs defasp
, DefAspect (FnCpy att nts) cpys cpyasp
, Com cpyasp defasp inhasp)
=> att -> nts -> cpys -> defs -> inhasp
inhAspect att nts cpys defs
= (defAspect (FnCpy att nts) cpys)
.+. (attAspect (FnInh att nts) defs)
synAspect :: ( AttAspect (FnSyn att) defs defasp
, DefAspect (FnUse att nts op unit) uses useasp
, Com useasp defasp synasp)
=> att -> nts -> op -> unit -> uses -> defs -> synasp
synAspect att nts op unit uses defs
= (defAspect (FnUse att nts op unit) uses)
.+. (attAspect (FnSyn att) defs)
chnAspect :: ( DefAspect (FnChn att nts) chns chnasp
, AttAspect (FnInh att nts) inhdefs inhasp
, Com chnasp inhasp asp
, AttAspect (FnSyn att) syndefs synasp
, Com asp synasp asp')
=> att -> nts -> chns -> inhdefs -> syndefs -> asp'
chnAspect att nts chns inhdefs syndefs
= (defAspect (FnChn att nts) chns)
.+. (attAspect (FnInh att nts) inhdefs)
.+. (attAspect (FnSyn att) syndefs)
class AttAspect rdef defs rules | rdef defs -> rules
where attAspect :: rdef -> defs -> rules
instance ( AttAspect rdef (Record defs) rules
, Apply rdef def rule
, HExtend (Prd lprd rule) rules rules' )
=> AttAspect rdef
(Record (HCons (Prd lprd def)
defs))
rules'
where
attAspect rdef (Record (HCons def defs)) =
let lprd = (labelLVPair def)
in lprd .=. apply rdef (valueLVPair def)
.*. attAspect rdef (Record defs)
instance AttAspect rdef (Record HNil) (Record HNil)
where attAspect _ _ = emptyRecord
data FnSyn att = FnSyn att
instance HExtend (LVPair att val) sp sp'
=> Apply (FnSyn att) (Fam lf hof sc ip -> val)
(Rule lf hof sc ip l ho ic sp l ho ic sp') where
apply (FnSyn att) f = syndef att . f
data FnInh att nt = FnInh att nt
instance Defs att nts vals ic ic'
=> Apply (FnInh att nts) (Fam lf hof sc ip -> vals)
(Rule lf hof sc ip l ho ic sp l ho ic' sp) where
apply (FnInh att nts) f = inhdef att nts . f
class DefAspect deff prds rules | deff prds -> rules
where defAspect :: deff -> prds -> rules
instance DefAspect deff HNil (Record HNil) where
defAspect _ _ = emptyRecord
instance ( Poly deff deff'
, DefAspect deff prds rules
, HExtend (Prd prd deff') rules rules' )
=> DefAspect deff (HCons prd prds) rules' where
defAspect deff (HCons prd prds) =
prd .=. poly deff .*. defAspect deff prds
class Poly a b where
poly :: a -> b
data FnCpy att nts = FnCpy att nts
instance ( Copy att nts vp ic ic'
, HasField att ip vp
, TypeCast (Rule lf hof sc ip l ho ic sp l ho ic' sp) r)
=> Poly (FnCpy att nts) r where
poly (FnCpy att nts) = typeCast $ copy att nts
data FnUse att nt op unit = FnUse att nt op unit
instance ( Use att nts a sc
, HExtend (LVPair att a) sp sp'
, TypeCast (Rule lf hof sc ip l ho ic sp l ho ic sp') r)
=> Poly (FnUse att nts (a -> a -> a) a) r where
poly (FnUse att nts op unit) = typeCast $ use att nts op unit
data FnChn att nt = FnChn att nt
instance ( Chain att nts val sc l ho ic sp ic' sp'
, HasLabel att sp msp
, Chain' msp att nts val sc l ho ic sp ic' sp'
, HasField att ip val
, TypeCast (Rule lf hof sc ip l ho ic sp l ho ic' sp') r)
=> Poly (FnChn att nts) r where
poly (FnChn att nts) = typeCast $ chain att nts
class HBool b => HasLabel l r b | l r -> b
instance HasLabel l r b => HasLabel l (Record r) b
instance (HEq l lp b, HasLabel l r b', HOr b b' b'')
=> HasLabel l (HCons (LVPair lp vp) r) b''
instance HasLabel l HNil HFalse
hasLabel :: HasLabel l r b => l -> r -> b
hasLabel = undefined
class HUpdateAtLabel l v r r' | l v r -> r' where
hUpdateAtLabel :: l -> v -> r -> r'
instance ( RecordLabels r ls, HFind l ls n
, HUpdateAtHNat n (LVPair l v) r r')
=> HUpdateAtLabel l v (Record r) (Record r')
where
hUpdateAtLabel l v rec@(Record r) = Record r'
where
n = hFind l (recordLabels rec)
r' = hUpdateAtHNat n (newLVPair l v) r
sndProxy :: Proxy (a,b) -> Proxy b
sndProxy _ = undefined