Abstract.hs

{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- 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)
--
-----------------------------------------------------------------------------
module Common.Strategy.Abstract 
   ( Strategy, IsStrategy(..)
   , LabeledStrategy, label, unlabel
   , fullDerivationTree, derivationTree, rulesInStrategy
   , mapRules, mapRulesS, cleanUpStrategy
     -- Accessors to the underlying representation
   , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy
   , toLabeledStrategy
   , LabelInfo, processLabelInfo, changeInfo, makeInfo
   , removed, collapsed, hidden, IsLabeled(..)
   ) where

import Common.Id
import Common.Utils (commaList)
import Common.Strategy.Core
import Common.Classes
import Common.Rewriting (RewriteRule)
import Common.Transformation
import Common.Derivation
import Common.Uniplate hiding (rewriteM)
import Common.Strategy.Parsing

-----------------------------------------------------------
--- Strategy data-type

-- | Abstract data type for strategies
newtype Strategy a = S { toCore :: Core LabelInfo a }

instance Show (Strategy a) where
   show = show . toCore

instance Apply Strategy where
   applyAll = runCore . toCore

-----------------------------------------------------------
--- The information used as label in a strategy

data LabelInfo = Info 
   { labelId   :: Id 
   , removed   :: Bool
   , collapsed :: Bool
   , hidden    :: Bool
   }

instance Show LabelInfo where
   show info = 
      let ps = ["removed"   | removed   info] ++ 
               ["collapsed" | collapsed info] ++
               ["hidden"    | hidden    info]
          extra = " (" ++ commaList ps ++ ")"
      in showId info ++ if null ps then "" else extra

instance HasId LabelInfo where
   getId = labelId
   changeId f info = info { labelId = f (labelId info) }
   
makeInfo :: IsId a => a -> LabelInfo
makeInfo s = Info (newId s) False False False

-----------------------------------------------------------
--- Type class

-- | Type class to turn values into strategies
class IsStrategy f where
   toStrategy :: f a -> Strategy a

instance IsStrategy (Core LabelInfo) where
   toStrategy = S

instance IsStrategy Strategy where
   toStrategy = id

instance IsStrategy (LabeledStrategy) where
  toStrategy (LS info (S core)) = S (Label info core)

instance IsStrategy Rule where
   toStrategy r
      | isMajorRule r = toStrategy (toLabeled r)
      | otherwise     = S (Rule r)

instance IsStrategy RewriteRule where
   toStrategy r = 
      toStrategy (makeRule (getId r) (makeRewriteTrans r))

-----------------------------------------------------------
--- Labeled Strategy data-type

-- | A strategy which is labeled with a string
data LabeledStrategy a = LS 
   { labelInfo :: LabelInfo  -- ^ Returns information associated with this label
   , unlabel   :: Strategy a -- ^ Removes the label from a strategy
   }

makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a
makeLabeledStrategy info = LS info . toStrategy

toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a)
toLabeledStrategy s = 
   case toCore s of
      Label l c -> return (makeLabeledStrategy l (fromCore c))
      _         -> fail "Strategy without label"

instance Show (LabeledStrategy a) where
   show s = show (labelInfo s) ++ ": " ++ show (unlabel s)

instance Apply LabeledStrategy where
   applyAll = applyAll . toStrategy

instance HasId (LabeledStrategy a) where
   getId = getId . labelInfo
   changeId = changeInfo . changeId

class IsLabeled f where
   toLabeled :: f a -> LabeledStrategy a
   
instance IsLabeled LabeledStrategy where
   toLabeled = id

instance IsLabeled Rule where
   toLabeled r = LS (makeInfo (showId r)) (S (Rule r))

instance IsLabeled RewriteRule where
   toLabeled r = toLabeled (makeRule (showId r) (makeRewriteTrans r))

-- | Labels a strategy with a string
label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a
label l = LS (makeInfo l) . toStrategy

changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a
changeInfo f a = LS (f info) s
 where LS info s = toLabeled a

-----------------------------------------------------------
--- Process Label Information

processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a
processLabelInfo getInfo = rec emptyCoreEnv
 where
   rec env core = 
      case core of 
         Rec n a   -> Rec n (rec (insertCoreEnv n core env) a)
         Label l a -> forLabel env l (rec env a)
         _ -> descend (rec env) core
 
   forLabel env l c 
      | removed info   = Fail
      | collapsed info = Label l (Rule asRule) -- !!
      | otherwise      = new
    where 
      new | hidden info = mapRule minorRule (Label l c)
          | otherwise   = Label l c
      info   = getInfo l
      asRule = makeSimpleRuleList (showId info{- ++ " (collapsed)"-}) 
                  (runCoreWith env new)

-----------------------------------------------------------
--- Remaining functions

-- | Returns the derivation tree for a strategy and a term, including all
-- minor rules
fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a
fullDerivationTree = make . processLabelInfo id . toCore . toStrategy 
 where 
   make core = fmap value . parseDerivationTree . makeState core
 
-- | Returns the derivation tree for a strategy and a term with only major rules
derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a
derivationTree s = mergeMaybeSteps . mapSteps f . fullDerivationTree s
 where
   f (RuleStep r) | isMajorRule r = Just r
   f _ = Nothing
   
-- | Returns a list of all major rules that are part of a labeled strategy
rulesInStrategy :: IsStrategy f => f a -> [Rule a]
rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajorRule r ]
                    
-- | Apply a function to all the rules that make up a labeled strategy
mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b
mapRules f (LS n s) = LS n (mapRulesS f s)

mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b
mapRulesS f = S . mapRule f . toCore

-- | Use a function as do-after hook for all rules in a labeled strategy
cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
cleanUpStrategy f (LS n s) = mapRules g (LS n (S core))
 where
   core = Rule (doAfter f idRule) :*: toCore s
   g r | isMajorRule r = doAfter f r  
       | otherwise     = r
       
-----------------------------------------------------------
--- Functions to lift the core combinators

fromCore :: Core LabelInfo a -> Strategy a
fromCore = toStrategy

liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a
liftCore f = fromCore . f . toCore . toStrategy

liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a
liftCore2 f = liftCore . f . toCore . toStrategy