XPath.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Transform.Rules.XPath
-- Copyright   :  (c) 2010 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Pointless Rewrite:
-- automatic transformation system for point-free programs
-- 
-- Generic strategy for the rewriting of point-free functions.
--
-----------------------------------------------------------------------------

module Transform.Rules.XPath where

import Transform.Rewriting
import Transform.Rules.SYB.TU
import Transform.Rules.PF.Lists
import Transform.Rules.PF.Monoids
import Transform.Rules.PF.Rec
import Transform.Rules.PF.Products
import Transform.Rules.PF.Combinators
import Transform.Rules.PF
import Data.Type
import Data.Pf
import Data.Equal
import Transform.Rules.PF.Sums

import Control.Monad
import Data.Char

child_def :: Rule
child_def _ CHILD = success "child-Def" $ GMAPQ SELF
child_def _ _ = mzero

attribute_def :: Rule
attribute_def _ ATTRIBUTE = success "attribute-Def" $ GMAPQ ATT
attribute_def _ _ = mzero

descendant_def :: Rule
descendant_def _ DESCENDANT = success "descendant-Def" $ EVERYTHING CHILD
descendant_def _ _ = mzero

descself_def :: Rule
descself_def _ DESCSELF = success "descself-Def" $ EVERYTHING SELF
descself_def _ _ = mzero

self_applyQ :: Rule
self_applyQ _ (APPLYQ Dynamic SELF) = mzero
self_applyQ _ (APPLYQ a SELF) | not (isAtt a) = success "self-ApplyQ" $ COMP Dynamic WRAP (MKDYN a)
                              | otherwise = success "self-ApplyQ" ZERO
self_applyQ _ _ = mzero

att_applyQ :: Rule
att_applyQ _ (APPLYQ Dynamic ATT) = mzero
att_applyQ _ (APPLYQ a ATT) | isAtt a = success "att-ApplyQ" $ COMP Dynamic WRAP (MKDYN a)
                            | otherwise = success "att-ApplyQ" ZERO
att_applyQ _ _ = mzero

name_applyQ :: Rule
name_applyQ _ (APPLYQ Dynamic (NAME n)) = mzero
name_applyQ _ (APPLYQ a@(dataName -> Just name) (NAME n)) | sameName name n = success "name-ApplyQ" $ APPLYQ a SELF
name_applyQ _ (APPLYQ a@(dataName -> Just name) (NAME n)) | sameName name ("@"++n) = success "name-ApplyQ" $ APPLYQ a ATT
name_applyQ _ (APPLYQ a (NAME n)) = success "name-ApplyQ" ZERO 
name_applyQ _ _ = mzero

slash_applyQ :: Rule
slash_applyQ (Fun _ r) (APPLYQ a (f :/: g)) =
    success "comp-ApplyQ" $ COMP (List r) FOLD $ COMP (List Dynamic) (MAP $ APPLYQ Dynamic g) $ APPLYQ a f
slash_applyQ _ _ = mzero

seqQ_applyQ :: Rule
seqQ_applyQ (Fun _ s) (APPLYQ a (SEQQ (q::Pf (Q r)) f)) = let r=typeof::Type r in success "seqQ-ApplyQ" $ COMP r f $ APPLYQ a q
seqQ_applyQ _ _ = mzero

dyn_applyQ, dyn_applyQ' :: Rule
dyn_applyQ = comp dyn_applyQ'
dyn_applyQ' _ (COMP _ (APPLYQ Dynamic f) (MKDYN a)) = success "dyn-ApplyQ" $ APPLYQ a f
dyn_applyQ' _ _ = mzero

optimise_xpath :: Rule
optimise_xpath = outermost rules >>> try ((once fuse1 ||| once fuse2 ||| once sum_sfusion) >>> optimise_xpath)
    where rules, fuse1, fuse2 :: Rule
          rules = primitives ||| xpath ||| tu ||| monoids ||| lists ||| prods ||| sums ||| bangs ||| convs ||| recs
          fuse1 = top prod_fusion ||| top sum_fusion
          fuse2 = top para_cata ||| top cata_fusion ||| top para_fusion ||| top ana_fusion ||| top cata_zero

xpath = top child_def ||| top attribute_def ||| top descendant_def ||| top descself_def
    ||| top self_applyQ ||| top att_applyQ ||| top name_applyQ
    ||| top slash_applyQ ||| top seqQ_applyQ ||| top dyn_applyQ