ideas-0.6: src/Common/Strategy/Core.hs
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- The core strategy combinators. This module defines the interal data
-- structure of a strategy, and some utility functions that operate
-- directly on it.
--
-----------------------------------------------------------------------------
module Common.Strategy.Core
( Core(..)
, strategyTree, runTree --, makeTree
, mapRule, coreVars, noLabels, mapCore, mapCoreM --, catMaybeLabel --, ,
, mapLabel, Translation, ForLabel(..) --, simpleTranslation
) where
import qualified Common.Strategy.Grammar as Grammar
import Common.Strategy.Grammar (Grammar, (<*>), (<|>), symbol)
import Common.Apply
import Common.Derivation
import Common.Transformation
import Common.Uniplate
import Control.Monad.Identity
-----------------------------------------------------------------
-- Strategy (internal) data structure, containing a selection
-- of combinators
infixr 3 :|:, :|>:
infixr 5 :*:
-- Some rules receive label (but not all)
data Core l a
= Core l a :*: Core l a
| Core l a :|: Core l a
| Core l a :|>: Core l a
| Many (Core l a)
| Repeat (Core l a)
| Not (Core () a) -- proves that there are no labels inside
| Label l (Core l a)
| Succeed
| Fail
| Rule (Maybe l) (Rule a)
| Var Int
| Rec Int (Core l a)
deriving Show
-----------------------------------------------------------------
-- Useful instances
instance Apply (Core l) where
applyAll core = results . makeTree core
instance Uniplate (Core l a) where
uniplate core =
case core of
a :*: b -> ([a,b], \[x,y] -> x :*: y)
a :|: b -> ([a,b], \[x,y] -> x :|: y)
a :|>: b -> ([a,b], \[x,y] -> x :|>: y)
Many a -> ([a], \[x] -> Many x)
Repeat a -> ([a], \[x] -> Repeat x)
Label l a -> ([a], \[x] -> Label l x)
Rec n a -> ([a], \[x] -> Rec n x)
Not a -> ([noLabels a], \[x] -> Not (noLabels x))
_ -> ([], \_ -> core)
-----------------------------------------------------------------
-- The strategy tree (static, no term)
strategyTree :: Translation l a b -> Core l a -> DerivationTree b ()
strategyTree t = grammarTree . toGrammar t
grammarTree :: Grammar a -> DerivationTree a ()
grammarTree gr = addBranches list node
where
node = singleNode () (Grammar.empty gr)
list = [ (f, grammarTree rest) | (f, rest) <- Grammar.firsts gr ]
-----------------------------------------------------------------
-- Running a strategy
makeTree :: Core l a -> a -> DerivationTree (Rule a) a
makeTree c = changeLabel fst . runTree (strategyTree simpleTranslation c)
runTree :: Apply f => DerivationTree (f a) info -> a -> DerivationTree (f a, info) a
runTree t a = addBranches list (singleNode a (endpoint t))
where
list = concatMap make (branches t)
make (f, st) = [ ((f, root st), runTree st b) | b <- applyAll f a ]
-----------------------------------------------------------------
-- Translation to Grammar data type
type Translation l a b = (l -> ForLabel b, Rule a -> b)
data ForLabel a = Skip | Before a | After a | Around a a
simpleTranslation :: Translation l a (Rule a)
simpleTranslation = (const Skip, id)
toGrammar :: Translation l a b -> Core l a -> Grammar b
toGrammar (f, g) = rec
where
rec core =
case core of
a :*: b -> rec a <*> rec b
a :|: b -> rec a <|> rec b
a :|>: b -> rec (a :|: (Not (noLabels a) :*: b))
Many a -> Grammar.many (rec a)
Repeat a -> rec (Many a :*: Not (noLabels a))
Succeed -> Grammar.succeed
Fail -> Grammar.fail
Label l a -> forLabel l (rec a)
Rule ml r -> (maybe id forLabel ml) (symbol (g r))
Var n -> Grammar.var n
Rec n a -> Grammar.rec n (rec a)
Not a -> symbol (g (notRule a))
forLabel l g =
case f l of
Skip -> g
Before s -> symbol s <*> g
After t -> g <*> symbol t
Around s t -> symbol s <*> g <*> symbol t
notRule :: Apply f => f a -> Rule a
notRule f = checkRule (not . applicable f)
-----------------------------------------------------------------
-- Utility functions
mapLabel :: (l -> m) -> Core l a -> Core m a
mapLabel f = mapCore (Label . f) (Rule . fmap f)
mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b
mapRule f = mapCore Label (\ml -> Rule ml . f)
noLabels :: Core l a -> Core m a
noLabels = mapCore (const id) (const (Rule Nothing))
-- catMaybeLabel :: Core (Maybe l) a -> Core l a
-- catMaybeLabel = mapCore (maybe id Label) (Rule . join)
mapCore :: (l -> Core m b -> Core m b) -> (Maybe l -> Rule a -> Core m b)
-> Core l a -> Core m b
mapCore f g =
let fm l = return . f l . runIdentity
gm l = return . g l
in runIdentity . mapCoreM fm gm
-- The most primitive function that applies functions to the label and
-- rule alternatives. Monadic version.
mapCoreM :: Monad m => (k -> m (Core l b) -> m (Core l b))
-> (Maybe k -> Rule a -> m (Core l b))
-> Core k a -> m (Core l b)
mapCoreM f g = rec
where
rec core =
case core of
a :*: b -> liftM2 (:*:) (rec a) (rec b)
a :|: b -> liftM2 (:|:) (rec a) (rec b)
a :|>: b -> liftM2 (:|>:) (rec a) (rec b)
Many a -> liftM Many (rec a)
Repeat a -> liftM Repeat (rec a)
Succeed -> return Succeed
Fail -> return Fail
Label l a -> f l (rec a)
Rule ml r -> g ml r
Var n -> return (Var n)
Rec n a -> liftM (Rec n) (rec a)
Not a -> do
let recNot h = mapCoreM (const id) (const h)
b <- recNot (g Nothing) a
c <- recNot (return . Rule Nothing) b
return (Not c)
coreVars :: Core l a -> [Int]
coreVars s = [ n | Rec n _ <- universe s ] ++ [ n | Var n <- universe s ]