{-
Maps for the D functor.
-}
module HsDeclMaps where
import HsDeclStruct
--import HsGuardsStruct
import HsGuardsMaps(mapRhs, accRhs, seqRhs)
import AccList(accList)
import HsIdent
import MUtils
mapDI idf = mapDI2 idf idf
mapDI2 :: (i1 -> i2) -> -- variable identifier recursion function
(i1 -> i2) -> -- constructor identifier recursion function
(e1 -> e2) -> -- expression recursion function
(p1 -> p2) -> -- pattern recursion function
(d1 -> d2) -> -- declaration recursion function
(t1 -> t2) -> -- type recursion function
(c1 -> c2) -> -- context recursion function
(tp1 -> tp2) -> -- type pattern recursion function
DI i1 e1 p1 d1 t1 c1 tp1 -> -- old declaration structure
DI i2 e2 p2 d2 t2 c2 tp2 -- new declaration structure
mapDI2 vf cf ef pf df tf ctxf tpf decl =
case decl of
HsTypeDecl s tp t -> HsTypeDecl s (tpf tp) (tf t)
HsNewTypeDecl s cntxt tp cd ns -> HsNewTypeDecl s (ctxf cntxt) (tpf tp)
(mapConDeclI2 vf cf tf ctxf cd) (map cf ns)
HsDataDecl s cntxt tp cds ns -> HsDataDecl s (ctxf cntxt) (tpf tp)
(map (mapConDeclI2 vf cf tf ctxf) cds) (map cf ns)
HsClassDecl s c tp fundeps ds -> HsClassDecl s (ctxf c) (tpf tp)
(mapFunDeps vf fundeps) (df ds)
HsInstDecl s optn c tp ds -> HsInstDecl s (fmap vf optn) (ctxf c)
(tf tp) (df ds)
HsDefaultDecl s t -> HsDefaultDecl s (map tf t)
HsTypeSig s nms c tp -> HsTypeSig s (map vf nms) (ctxf c) (tf tp)
HsFunBind s ms -> HsFunBind s
(map (mapMatchI vf ef pf df) ms)
HsPatBind s p rhs ds -> HsPatBind s (pf p) (mapRhs ef rhs)
(df ds)
HsInfixDecl s fixity names -> HsInfixDecl s fixity (map (mapHsIdent2 vf cf) names)
-- Hugs compatibility
HsPrimitiveTypeDecl s cntxt tp -> HsPrimitiveTypeDecl s (ctxf cntxt) (tpf tp)
HsPrimitiveBind s nm tp -> HsPrimitiveBind s (vf nm) (tf tp)
mapMatch = mapMatchI id
mapMatchI vf ef pf df (HsMatch s nm ps rhs ds)
= HsMatch s (vf nm) (map pf ps) (mapRhs ef rhs) (df ds)
mapConDecl = mapConDeclI id
mapConDeclI idf = mapConDeclI2 idf idf
mapConDeclI2 vf cf tf ctxf (HsConDecl s is c nm bangts)
= HsConDecl s (map vf is) (ctxf c) (cf nm) (map (mapBangType tf) bangts)
mapConDeclI2 vf cf tf ctxf (HsRecDecl s is c nm nmbangts)
= HsRecDecl s (map vf is) (ctxf c) (cf nm) (map f nmbangts)
where
f (n,bt) = (map vf n, mapBangType tf bt)
mapBangType tf (HsBangedType x) = HsBangedType (tf x)
mapBangType tf (HsUnBangedType x) = HsUnBangedType (tf x)
{-
Accumulator for the D functor.
-}
accDI ::(i -> b -> b) -> -- identifier recursion operator
(e -> b -> b) -> -- expression recursion operator
(p -> b -> b) -> -- pattern recursion operator
(d -> b -> b) -> -- declaration recursion operator
(t -> b -> b) -> -- type recursion operator
(c -> b -> b) -> -- context recursion operator
(tp -> b -> b) -> -- type pattern recursion operator
DI i e p d t c tp -> -- declaration structure
b -> -- base case
b
accDI idf ef pf df tf cf tpf decl =
case decl of
HsTypeDecl s tp t -> tpf tp . tf t
HsNewTypeDecl s cntxt tp cd names -> cf cntxt . tpf tp
. accConDeclI idf tf cf cd
HsDataDecl s cntxt tp cds names -> cf cntxt . tpf tp
. accList (accConDeclI idf tf cf) cds
HsClassDecl s c tp fundeps ds -> cf c . tpf tp
. accFunDeps idf fundeps . df ds
HsInstDecl s optn c tp ds -> maybe id idf optn . cf c . tf tp . df ds
HsDefaultDecl s t -> accList tf t
HsTypeSig s nms c tp -> accList idf nms . cf c . tf tp
HsFunBind s ms -> accList (accMatchI idf ef pf df) ms
HsPatBind s p rhs ds -> pf p . accRhs ef rhs . df ds
HsInfixDecl s fixity ns -> accList (accHsIdent idf) ns
-- Hugs compatibility
HsPrimitiveTypeDecl s cntxt tp -> cf cntxt . tpf tp
HsPrimitiveBind s nm tp -> idf nm . tf tp
accD = accDI (curry snd)
accMatch = accMatchI (const id)
accMatchI idf ef pf df (HsMatch s nm ps rhs ds)
= idf nm . accList pf ps . accRhs ef rhs . df ds
accConDecl = accConDeclI (const id)
accConDeclI idf tf ctxf (HsConDecl s is c nm bangts)
= idf nm . accList idf is . ctxf c . accList (accBangType tf) bangts
accConDeclI idf tf ctxf (HsRecDecl s is c nm nmbangts)
= idf nm . accList idf is . ctxf c . accList f nmbangts
where
f (n,bt) = accList idf n . accBangType tf bt
accBangType tf (HsBangedType x) ans = tf x ans
accBangType tf (HsUnBangedType x) ans = tf x ans
--- in preparation for the D functor monadic trifecta
seqDI :: (Functor m,Monad m) =>
-- declaration structure containing computations:
DI(m i)
(m e) -- ... delivering expression recursion
(m p) -- ... delivering pattern recursion
(m d) -- ... delivering declaration recursion
(m t) -- ... delivering type recursion
(m c) -- ... delivering context recursion
(m tp) -> -- ... delivering type pattern recursion
m (DI i e p d t c tp) -- computation delivering declaration structure
seqDI decl =
case decl of
HsTypeDecl s tp t -> HsTypeDecl s # tp <# t
HsNewTypeDecl s c tp cd nms ->
HsNewTypeDecl s # c <# tp <# seqConDecl cd <# sequence nms
HsDataDecl s c tp cds nms ->
HsDataDecl s # c <# tp <# mapM seqConDecl cds <# sequence nms
HsClassDecl s c tp fundeps ds -> HsClassDecl s # c <# tp <# seqFunDeps fundeps <# ds
HsInstDecl s optn c tp ds -> HsInstDecl s # seqMaybe optn <# c <# tp <# ds
HsDefaultDecl s t -> HsDefaultDecl s # sequence t
HsTypeSig s nms c tp -> HsTypeSig s # sequence nms <# c <# tp
HsFunBind s ms -> HsFunBind s # mapM seqMatch ms
HsPatBind s p rhs ds -> HsPatBind s # p <# seqRhs rhs <# ds
HsInfixDecl s fixity names -> HsInfixDecl s fixity # mapM seqHsIdent names
HsPrimitiveTypeDecl s c tp -> HsPrimitiveTypeDecl s # c <# tp
HsPrimitiveBind s nm tp -> HsPrimitiveBind s # nm <# tp
seqConDecl (HsConDecl sloc is c name bangtypes) =
HsConDecl sloc # sequence is <# c <# name <# mapM seqBangType bangtypes
seqConDecl (HsRecDecl sloc is c name fields) =
HsRecDecl sloc # sequence is <# c <# name <# mapM (sequence >#< seqBangType) fields
--mapSndM seqBangType fields
seqBangType (HsBangedType t) = HsBangedType # t
seqBangType (HsUnBangedType t) = HsUnBangedType # t
seqMatch (HsMatch sloc name bs rhs c) =
HsMatch sloc # name <# sequence bs <# seqRhs rhs <# c
mapFunDeps = map . mapFunDep
mapFunDep = apBoth . map
accFunDeps = accList . accFunDep
accFunDep tf (ts1,ts2) = accList tf ts1 . accList tf ts2
seqFunDeps fs = mapM seqFunDep fs
seqFunDep fd = sequence>#<sequence $ fd