module Ideas.Common.Strategy.Configuration
( StrategyCfg, byName, ConfigAction(..)
, configure, configureS
, remove, collapse, hide, multi
, isConfigId
) where
import Data.Char
import Ideas.Common.Classes
import Ideas.Common.CyclicTree hiding (label)
import Ideas.Common.Id
import Ideas.Common.Rule
import Ideas.Common.Strategy.Abstract
import Ideas.Common.Strategy.Choice
import Ideas.Common.Strategy.Derived (repeat1)
import Ideas.Common.Strategy.Process hiding (fold)
import Ideas.Common.Strategy.Sequence
import Ideas.Common.Strategy.StrategyTree
import Ideas.Common.Strategy.Symbol
import qualified Ideas.Common.CyclicTree as Tree
newtype StrategyCfg = Cfg [(ConfigLocation, ConfigAction)]
instance Show StrategyCfg where
show (Cfg xs) = show xs
instance Monoid StrategyCfg where
mempty = Cfg []
mconcat xs = Cfg [ y | Cfg ys <- xs, y <- ys ]
mappend (Cfg xs) (Cfg ys) = Cfg (xs ++ ys)
data ConfigLocation = ByName Id
instance Show ConfigLocation where
show (ByName a) = show a
data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal
deriving (Show, Eq)
instance Read ConfigAction where
readsPrec _ s =
let f = map toLower
in [ (x, "") | x <- concat actionGroups, f s == f (show x) ]
actionGroups :: [[ConfigAction]]
actionGroups = [[Remove, Reinsert], [Collapse, Expand], [Hide, Reveal]]
byName :: HasId a => ConfigAction -> a -> StrategyCfg
byName action a = Cfg [(ByName (getId a), action)]
configure :: StrategyCfg -> LabeledStrategy a -> LabeledStrategy a
configure cfg ls = label (getId ls) (configureS cfg (unlabel ls))
configureS :: StrategyCfg -> Strategy a -> Strategy a
configureS = onStrategyTree . configureStrategyTree
configureStrategyTree :: StrategyCfg -> StrategyTree a -> StrategyTree a
configureStrategyTree (Cfg pairs) tree = foldr handle tree pairs
where
handle (ByName l, action) =
case action of
Remove -> insertAtLabel l removeDecl
Reinsert -> removeAtLabel l removeDecl
Collapse -> insertAtLabel l collapseDecl
Expand -> removeAtLabel l collapseDecl
Hide -> insertAtLabel l hideDecl
Reveal -> removeAtLabel l hideDecl
insertAtLabel :: Id -> Decl Unary -> StrategyTree a -> StrategyTree a
insertAtLabel n comb = replaceLeaf f . replaceLabel g
where
f a | n == getId a = fromUnary (applyDecl comb) (leaf a)
| otherwise = leaf a
g l a | n == l = fromUnary (applyDecl comb) (Tree.label l a)
| otherwise = Tree.label l a
removeAtLabel :: Id -> Decl Unary -> StrategyTree a -> StrategyTree a
removeAtLabel n _decl = replaceNode $ \d xs ->
case map nextId xs of
[Just l] | n == l -> head xs
_ -> node d xs
nextId :: StrategyTree a -> Maybe Id
nextId = fold monoidAlg
{ fNode = \d xs -> if isConfigId d && length xs == 1
then head xs
else Nothing
, fLeaf = Just . getId
, fLabel = \l _ -> Just l
}
isConfigId :: HasId a => a -> Bool
isConfigId = (`elem` map getId configIds) . getId
remove, collapse, hide :: IsStrategy f => f a -> Strategy a
remove = decl1 removeDecl
collapse = decl1 collapseDecl
hide = decl1 hideDecl
multi :: (IsId l, IsStrategy f) => l -> f a -> Strategy a
multi l = collapse . label l . decl1 repeatDecl . toStrategy
repeatDecl :: Decl Unary
repeatDecl = "repeat1" .=. Unary repeat1
configIds :: [Id]
configIds = map getId [removeDecl, collapseDecl, hideDecl]
removeDecl :: Decl Unary
removeDecl = "removed" .=. Unary (const empty)
collapseDecl :: Decl Unary
collapseDecl = "collapsed" .=. Unary (\a ->
case firsts a of
[(r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r)
_ -> empty)
where
collapseWith l =
single . makeRule l . runProcess
hideDecl :: Decl Unary
hideDecl = "hidden" .=. Unary (fmap minor)