-- $Id: HsDeclMaps.hs,v 1.20 2004/01/22 21:21:46 hallgren Exp $ {- 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>#