module Language.KURE.Walker
(
Node(..)
, numChildrenT
, hasChild
, hasChildT
, Walker(..)
, childR
, alltdR
, allbuR
, allduR
, anytdR
, anybuR
, anyduR
, onetdR
, onebuR
, prunetdR
, innermostR
, childT
, foldtdT
, foldbuT
, onetdT
, onebuT
, prunetdT
, crushtdT
, crushbuT
, collectT
, collectPruneT
, AbsolutePath
, rootAbsPath
, extendAbsPath
, PathContext(..)
, absPathT
, Path
, rootPath
, pathsToT
, onePathToT
, oneNonEmptyPathToT
, prunePathsToT
, uniquePathToT
, uniquePrunePathToT
, pathL
, exhaustPathL
, repeatPathL
, rootL
, pathR
, pathT
, testPathT
) where
import Prelude hiding (id)
import Data.Monoid
import Data.List
import Control.Monad
import Control.Arrow
import Control.Category hiding ((.))
import Language.KURE.Combinators
import Language.KURE.Translate
import Language.KURE.Injection
class (Injection a (Generic a), Generic a ~ Generic (Generic a)) => Node a where
type Generic a :: *
numChildren :: a -> Int
numChildrenT :: (Monad m, Node a) => Translate c m a Int
numChildrenT = arr numChildren
hasChild :: Node a => Int -> a -> Bool
hasChild n a = (0 <= n) && (n < numChildren a)
hasChildT :: (Monad m, Node a) => Int -> Translate c m a Bool
hasChildT = arr . hasChild
class (MonadCatch m, Node a) => Walker c m a where
childL :: Int -> Lens c m a (Generic a)
allT :: Monoid b => Translate c m (Generic a) b -> Translate c m a b
allT t = modFailMsg ("allT failed: " ++) $
do n <- numChildrenT
mconcat (childrenT n (const t))
oneT :: Translate c m (Generic a) b -> Translate c m a b
oneT t = setFailMsg "oneT failed" $
do n <- numChildrenT
catchesT (childrenT n (const t))
allR :: Rewrite c m (Generic a) -> Rewrite c m a
allR r = modFailMsg ("allR failed: " ++) $
do n <- numChildrenT
andR (childrenR n (const r))
anyR :: Rewrite c m (Generic a) -> Rewrite c m a
anyR r = setFailMsg "anyR failed" $
do n <- numChildrenT
orR (childrenR n (const r))
oneR :: Rewrite c m (Generic a) -> Rewrite c m a
oneR r = setFailMsg "oneR failed" $
do n <- numChildrenT
catchesT (childrenR n (const r))
childT :: Walker c m a => Int -> Translate c m (Generic a) b -> Translate c m a b
childT n = focusT (childL n)
childR :: Walker c m a => Int -> Rewrite c m (Generic a) -> Rewrite c m a
childR n = focusR (childL n)
childrenT :: Walker c m a => Int -> (Int -> Translate c m (Generic a) b) -> [Translate c m a b]
childrenT n ts = [ childT i (ts i) | i <- [0..(n1)] ]
childrenR :: Walker c m a => Int -> (Int -> Rewrite c m (Generic a)) -> [Rewrite c m a]
childrenR n rs = [ childR i (rs i) | i <- [0..(n1)] ]
foldtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
foldtdT t = modFailMsg ("foldtdT failed: " ++) $
let go = t `mappend` allT go
in go
foldbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
foldbuT t = modFailMsg ("foldbuT failed: " ++) $
let go = allT go `mappend` t
in go
onetdT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
onetdT t = setFailMsg "onetdT failed" $
let go = t <+ oneT go
in go
onebuT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
onebuT t = setFailMsg "onetdT failed" $
let go = oneT go <+ t
in go
prunetdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
prunetdT t = setFailMsg "prunetdT failed" $
let go = t <+ allT go
in go
crushtdT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
crushtdT t = foldtdT (mtryM t)
crushbuT :: (Walker c m a, Monoid b, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) b
crushbuT t = foldbuT (mtryM t)
collectT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]
collectT t = crushtdT (t >>^ (: []))
collectPruneT :: (Walker c m a, a ~ Generic a) => Translate c m (Generic a) b -> Translate c m (Generic a) [b]
collectPruneT t = prunetdT (t >>^ (: []))
alltdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
alltdR r = modFailMsg ("alltdR failed: " ++) $
let go = r >>> allR go
in go
allbuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
allbuR r = modFailMsg ("allbuR failed: " ++) $
let go = allR go >>> r
in go
allduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
allduR r = modFailMsg ("allduR failed: " ++) $
let go = r >>> allR go >>> r
in go
anytdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
anytdR r = setFailMsg "anytdR failed" $
let go = r >+> anyR go
in go
anybuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
anybuR r = setFailMsg "anybuR failed" $
let go = anyR go >+> r
in go
anyduR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
anyduR r = setFailMsg "anyduR failed" $
let go = r >+> anyR go >+> r
in go
onetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
onetdR r = setFailMsg "onetdR failed" $
let go = r <+ oneR go
in go
onebuR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
onebuR r = setFailMsg "onetdR failed" $
let go = oneR go <+ r
in go
prunetdR :: (Walker c m a, a ~ Generic a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
prunetdR r = setFailMsg "prunetdR failed" $
let go = r <+ anyR go
in go
innermostR :: (Walker c m a, Generic a ~ a) => Rewrite c m (Generic a) -> Rewrite c m (Generic a)
innermostR r = setFailMsg "innermostR failed" $
let go = anybuR (r >>> tryR go)
in go
newtype AbsolutePath = AbsolutePath [Int]
instance Show AbsolutePath where
show (AbsolutePath p) = show (reverse p)
rootAbsPath :: AbsolutePath
rootAbsPath = AbsolutePath []
extendAbsPath :: Int -> AbsolutePath -> AbsolutePath
extendAbsPath n (AbsolutePath ns) = AbsolutePath (n:ns)
class PathContext c where
contextPath :: c -> AbsolutePath
instance PathContext AbsolutePath where
contextPath p = p
absPathT :: (PathContext c, Monad m) => Translate c m a AbsolutePath
absPathT = contextT >>^ contextPath
type Path = [Int]
rootPath :: AbsolutePath -> Path
rootPath (AbsolutePath p) = reverse p
rmPathPrefix :: AbsolutePath -> AbsolutePath -> Maybe Path
rmPathPrefix (AbsolutePath p1) (AbsolutePath p2) = do guard (p1 `isSuffixOf` p2)
return (drop (length p1) (reverse p2))
abs2pathT :: (PathContext c, Monad m) => AbsolutePath -> Translate c m a Path
abs2pathT there = do here <- absPathT
maybe (fail "Absolute path does not pass through current node.") return (rmPathPrefix here there)
pathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]
pathsToT q = collectT (acceptR q >>> absPathT) >>= mapM abs2pathT
onePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path
onePathToT q = setFailMsg "No matching nodes found." $
onetdT (acceptR q >>> absPathT) >>= abs2pathT
oneNonEmptyPathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path
oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $
do n <- numChildrenT
catchesT $ childrenT n (\ i -> onePathToT q >>^ (i:))
prunePathsToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) [Path]
prunePathsToT q = collectPruneT (acceptR q >>> absPathT) >>= mapM abs2pathT
requireUniquePath :: Monad m => Translate c m [Path] Path
requireUniquePath = contextfreeT $ \ ps -> case ps of
[] -> fail "No matching nodes found."
[p] -> return p
_ -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."
uniquePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path
uniquePathToT q = pathsToT q >>> requireUniquePath
uniquePrunePathToT :: (PathContext c, Walker c m a, a ~ Generic a) => (Generic a -> Bool) -> Translate c m (Generic a) Path
uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath
pathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)
pathL = andR . map childL
exhaustPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)
exhaustPathL = foldr (\ n l -> tryR (childL n >>> l)) id
repeatPathL :: (Walker c m a, a ~ Generic a) => Path -> Lens c m (Generic a) (Generic a)
repeatPathL p = tryR (pathL p >>> repeatPathL p)
rootL :: (Walker c m a, a ~ Generic a) => AbsolutePath -> Lens c m (Generic a) (Generic a)
rootL = pathL . rootPath
pathR :: (Walker c m a, a ~ Generic a) => Path -> Rewrite c m (Generic a) -> Rewrite c m (Generic a)
pathR = focusR . pathL
pathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m (Generic a) b -> Translate c m (Generic a) b
pathT = focusT . pathL
testPathT :: (Walker c m a, a ~ Generic a) => Path -> Translate c m a Bool
testPathT = testLensT . pathL