module Language.KURE.Walker
(
Walker(..)
, childR
, childT
, alltdR
, allbuR
, allduR
, anytdR
, anybuR
, anyduR
, onetdR
, onebuR
, prunetdR
, innermostR
, allLargestR
, anyLargestR
, oneLargestR
, foldtdT
, foldbuT
, onetdT
, onebuT
, prunetdT
, crushtdT
, crushbuT
, collectT
, collectPruneT
, allLargestT
, oneLargestT
, numChildrenT
, hasChildT
, summandIsTypeT
, AbsolutePath
, rootAbsPath
, PathContext(..)
, absPathT
, Path
, rootPath
, rootPathT
, pathsToT
, onePathToT
, oneNonEmptyPathToT
, prunePathsToT
, uniquePathToT
, uniquePrunePathToT
, pathL
, exhaustPathL
, repeatPathL
, rootL
, pathR
, pathT
, testPathT
) where
import Prelude hiding (id)
import Data.Maybe (isJust)
import Data.Monoid
import Data.List
import Control.Monad
import Control.Arrow
import Control.Category hiding ((.))
import Language.KURE.MonadCatch
import Language.KURE.Translate
import Language.KURE.Lens
import Language.KURE.Injection
import Language.KURE.Combinators
class Walker c g where
allR :: MonadCatch m => Rewrite c m g -> Rewrite c m g
allT :: (MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
allT = unwrapAllT . allR . wrapAllT
oneT :: MonadCatch m => Translate c m g b -> Translate c m g b
oneT = unwrapOneT . allR . wrapOneT
anyR :: MonadCatch m => Rewrite c m g -> Rewrite c m g
anyR = unwrapAnyR . allR . wrapAnyR
oneR :: MonadCatch m => Rewrite c m g -> Rewrite c m g
oneR = unwrapOneR . allR . wrapOneR
childL :: MonadCatch m => Int -> Lens c m g g
childL = childL_default
numChildrenT :: (Walker c g, MonadCatch m) => Translate c m g Int
numChildrenT = getSum `liftM` allT (return $ Sum 1)
hasChildT :: (Walker c g, MonadCatch m) => Int -> Translate c m g Bool
hasChildT n = do c <- numChildrenT
return (n >= 0 && n < c)
childT :: (Walker c g, MonadCatch m) => Int -> Translate c m g b -> Translate c m g b
childT n = focusT (childL n)
childR :: (Walker c g, MonadCatch m) => Int -> Rewrite c m g -> Rewrite c m g
childR n = focusR (childL n)
foldtdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
foldtdT t = prefixFailMsg "foldtdT failed: " $
let go = t `mappend` allT go
in go
foldbuT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
foldbuT t = prefixFailMsg "foldbuT failed: " $
let go = allT go `mappend` t
in go
onetdT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g b
onetdT t = setFailMsg "onetdT failed" $
let go = t <+ oneT go
in go
onebuT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g b
onebuT t = setFailMsg "onebuT failed" $
let go = oneT go <+ t
in go
prunetdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
prunetdT t = setFailMsg "prunetdT failed" $
let go = t <+ allT go
in go
crushtdT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
crushtdT t = foldtdT (mtryM t)
crushbuT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g b -> Translate c m g b
crushbuT t = foldbuT (mtryM t)
collectT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b]
collectT t = crushtdT (t >>^ return)
collectPruneT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b]
collectPruneT t = prunetdT (t >>^ return)
alltdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
alltdR r = prefixFailMsg "alltdR failed: " $
let go = r >>> allR go
in go
allbuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
allbuR r = prefixFailMsg "allbuR failed: " $
let go = allR go >>> r
in go
allduR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
allduR r = prefixFailMsg "allduR failed: " $
let go = r >>> allR go >>> r
in go
anytdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
anytdR r = setFailMsg "anytdR failed" $
let go = r >+> anyR go
in go
anybuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
anybuR r = setFailMsg "anybuR failed" $
let go = anyR go >+> r
in go
anyduR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
anyduR r = setFailMsg "anyduR failed" $
let go = r >+> anyR go >+> r
in go
onetdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
onetdR r = setFailMsg "onetdR failed" $
let go = r <+ oneR go
in go
onebuR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
onebuR r = setFailMsg "onebuR failed" $
let go = oneR go <+ r
in go
prunetdR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
prunetdR r = setFailMsg "prunetdR failed" $
let go = r <+ anyR go
in go
innermostR :: (Walker c g, MonadCatch m) => Rewrite c m g -> Rewrite c m g
innermostR r = setFailMsg "innermostR failed" $
let go = anybuR (r >>> tryR go)
in go
newtype AbsolutePath = AbsolutePath [Int] deriving Eq
instance Show AbsolutePath where
show (AbsolutePath p) = show (reverse p)
rootAbsPath :: AbsolutePath
rootAbsPath = AbsolutePath []
class PathContext c where
absPath :: c -> AbsolutePath
(@@) :: c -> Int -> c
instance PathContext AbsolutePath where
absPath = id
(AbsolutePath ns) @@ n = AbsolutePath (n:ns)
absPathT :: (PathContext c, Monad m) => Translate c m a AbsolutePath
absPathT = absPath `liftM` contextT
type Path = [Int]
rootPath :: PathContext c => c -> Path
rootPath c = let AbsolutePath p = absPath c
in reverse p
rootPathT :: (PathContext c, Monad m) => Translate c m a Path
rootPathT = rootPath `liftM` contextT
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 g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path]
pathsToT q = collectT (acceptR q >>> absPathT) >>= mapM abs2pathT
onePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path
onePathToT q = setFailMsg "No matching nodes found." $
onetdT (acceptR q >>> absPathT) >>= abs2pathT
oneNonEmptyPathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path
oneNonEmptyPathToT q = setFailMsg "No matching nodes found." $
do start <- absPathT
onetdT (acceptR q >>> absPathT >>> acceptR (/= start)) >>= abs2pathT
prunePathsToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g [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 g, MonadCatch m) => (g -> Bool) -> Translate c m g Path
uniquePathToT q = pathsToT q >>> requireUniquePath
uniquePrunePathToT :: (PathContext c, Walker c g, MonadCatch m) => (g -> Bool) -> Translate c m g Path
uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath
tryL :: MonadCatch m => Lens c m g g -> Lens c m g g
tryL l = l `catchL` (\ _ -> id)
pathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g
pathL = serialise . map childL
exhaustPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g
exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id
repeatPathL :: (Walker c g, MonadCatch m) => Path -> Lens c m g g
repeatPathL p = let go = tryL (pathL p >>> go)
in go
rootL :: (Walker c g, MonadCatch m) => AbsolutePath -> Lens c m g g
rootL = pathL . rootPath
pathR :: (Walker c g, MonadCatch m) => Path -> Rewrite c m g -> Rewrite c m g
pathR = focusR . pathL
pathT :: (Walker c g, MonadCatch m) => Path -> Translate c m g b -> Translate c m g b
pathT = focusT . pathL
testPathT :: (Walker c g, MonadCatch m) => Path -> Translate c m g Bool
testPathT = testLensT . pathL
allLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g
allLargestR p r = prefixFailMsg "allLargestR failed: " $
let go = ifM p r (allR go)
in go
anyLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g
anyLargestR p r = setFailMsg "anyLargestR failed" $
let go = ifM p r (anyR go)
in go
oneLargestR :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Rewrite c m g -> Rewrite c m g
oneLargestR p r = setFailMsg "oneLargestR failed" $
let go = ifM p r (oneR go)
in go
allLargestT :: (Walker c g, MonadCatch m, Monoid b) => Translate c m g Bool -> Translate c m g b -> Translate c m g b
allLargestT p t = prefixFailMsg "allLargestT failed: " $
let go = ifM p t (allT go)
in go
oneLargestT :: (Walker c g, MonadCatch m) => Translate c m g Bool -> Translate c m g b -> Translate c m g b
oneLargestT p t = setFailMsg "oneLargestT failed" $
let go = ifM p t (oneT go)
in go
summandIsTypeT :: forall c m a g. (MonadCatch m, Injection a g) => a -> Translate c m g Bool
summandIsTypeT _ = arr (isJust . (project :: (g -> Maybe a)))
data P a b = P a b
pSnd :: P a b -> b
pSnd (P _ b) = b
checkSuccessPMaybe :: Monad m => String -> m (Maybe a) -> m a
checkSuccessPMaybe msg ma = ma >>= projectWithFailMsgM msg
newtype AllT w m a = AllT (m (P a w))
unAllT :: AllT w m a -> m (P a w)
unAllT (AllT mw) = mw
instance (Monoid w, Monad m) => Monad (AllT w m) where
return a = AllT $ return (P a mempty)
fail = AllT . fail
ma >>= f = AllT $ do P a w1 <- unAllT ma
P d w2 <- unAllT (f a)
return (P d (w1 <> w2))
instance (Monoid w, MonadCatch m) => MonadCatch (AllT w m) where
catchM (AllT ma) f = AllT $ ma `catchM` (unAllT . f)
wrapAllT :: Monad m => Translate c m g b -> Rewrite c (AllT b m) g
wrapAllT t = readerT $ \ a -> resultT (AllT . liftM (P a)) t
unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) g -> Translate c m g b
unwrapAllT = prefixFailMsg "allT failed:" . resultT (liftM pSnd . unAllT)
newtype OneT w m a = OneT (Maybe w -> m (P a (Maybe w)))
unOneT :: OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT (OneT f) = f
instance Monad m => Monad (OneT w m) where
return a = OneT $ \ mw -> return (P a mw)
fail msg = OneT (\ _ -> fail msg)
ma >>= f = OneT $ do \ mw1 -> do P a mw2 <- unOneT ma mw1
unOneT (f a) mw2
instance MonadCatch m => MonadCatch (OneT w m) where
catchM (OneT g) f = OneT $ \ mw -> g mw `catchM` (($ mw) . unOneT . f)
wrapOneT :: MonadCatch m => Translate c m g b -> Rewrite c (OneT b m) g
wrapOneT t = rewrite $ \ c a -> OneT $ \ mw -> case mw of
Just w -> return (P a (Just w))
Nothing -> ((P a . Just) `liftM` apply t c a) <+ return (P a mw)
unwrapOneT :: Monad m => Rewrite c (OneT b m) g -> Translate c m g b
unwrapOneT = resultT (checkSuccessPMaybe "oneT failed" . liftM pSnd . ($ Nothing) . unOneT)
data PInt a = PInt !Int a
secondPInt :: (a -> b) -> PInt a -> PInt b
secondPInt f = \ (PInt i a) -> PInt i (f a)
newtype GetChild c g a = GetChild (Int -> PInt (KureM a, Maybe (c,g)))
unGetChild :: GetChild c g a -> Int -> PInt (KureM a, Maybe (c,g))
unGetChild (GetChild f) = f
instance Monad (GetChild c g) where
return a = GetChild $ \ i -> PInt i (return a, Nothing)
fail msg = GetChild $ \ i -> PInt i (fail msg, Nothing)
ma >>= f = GetChild $ \ i0 -> let PInt i1 (kma, mcg) = unGetChild ma i0
in runKureM (\ a -> (secondPInt.second) (mplus mcg) $ unGetChild (f a) i1)
(\ msg -> PInt i1 (fail msg, mcg))
kma
instance MonadCatch (GetChild c g) where
ma `catchM` f = GetChild $ \ i0 -> let p@(PInt i1 (kma, mcg)) = unGetChild ma i0
in runKureM (\ _ -> p)
(\ msg -> (secondPInt.second) (mplus mcg) $ unGetChild (f msg) i1)
kma
wrapGetChild :: Int -> Rewrite c (GetChild c g) g
wrapGetChild n = rewrite $ \ c a -> GetChild $ \ m -> PInt (m + 1)
(return a, if n == m then Just (c, a) else Nothing)
unwrapGetChild :: Rewrite c (GetChild c g) g -> Translate c Maybe g (c,g)
unwrapGetChild r = translate $ \ c a -> let PInt _ (_,mcg) = unGetChild (apply r c a) 0
in mcg
getChild :: Walker c g => Int -> Translate c Maybe g (c, g)
getChild = unwrapGetChild . allR . wrapGetChild
newtype SetChild a = SetChild (Int -> PInt (KureM a))
unSetChild :: SetChild a -> Int -> PInt (KureM a)
unSetChild (SetChild f) = f
instance Monad SetChild where
return a = SetChild $ \ i -> PInt i (return a)
fail msg = SetChild $ \ i -> PInt i (fail msg)
ma >>= f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0
in runKureM (\ a -> unSetChild (f a) i1)
(\ msg -> PInt i1 (fail msg))
ka
instance MonadCatch SetChild where
ma `catchM` f = SetChild $ \ i0 -> let PInt i1 ka = unSetChild ma i0
in runKureM (\ _ -> PInt i1 ka)
(\ msg -> unSetChild (f msg) i1)
ka
wrapSetChild :: Int -> g -> Rewrite c SetChild g
wrapSetChild n g = contextfreeT $ \ a -> SetChild $ \ m -> PInt (m + 1)
(return $ if n == m then g else a)
unwrapSetChild :: Monad m => Rewrite c SetChild g -> Rewrite c m g
unwrapSetChild r = rewrite $ \ c a -> let PInt _ ka = unSetChild (apply r c a) 0
in runKureM return fail ka
setChild :: (Walker c g, Monad m) => Int -> g -> Rewrite c m g
setChild n = unwrapSetChild . allR . wrapSetChild n
childL_default :: forall c m g. (Walker c g, MonadCatch m) => Int -> Lens c m g g
childL_default n = lens $ do cg <- getter
k <- setter
return (cg, k)
where
getter :: Translate c m g (c,g)
getter = translate $ \ c a -> maybe (fail $ "there is no child number " ++ show n) return (apply (getChild n) c a)
setter :: Translate c m g (g -> m g)
setter = translate $ \ c a -> return (\ b -> apply (setChild n b) c a)