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
, childrenT
, summandIsTypeT
, 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.DList (singleton, toList)
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
import Language.KURE.Path
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 :: (ReadPath c crumb, Eq crumb, MonadCatch m) => crumb -> Lens c m g g
childL = childL_default
childrenT :: (ReadPath c crumb, Walker c g, MonadCatch m) => Translate c m g [crumb]
childrenT = allT (lastCrumbT >>^ return)
childT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Translate c m g b -> Translate c m g b
childT n = focusT (childL n)
childR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> 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 >>^ singleton) >>^ toList
collectPruneT :: (Walker c g, MonadCatch m) => Translate c m g b -> Translate c m g [b]
collectPruneT t = prunetdT (t >>^ singleton) >>^ toList
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
applySnocPathT :: Translate (SnocPath crumb) m a b -> Translate c m a b
applySnocPathT t = contextfreeT (apply t mempty)
pathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]
pathsToT q = applySnocPathT pathsToT' >>^ map snocPathToPath
where
pathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]
pathsToT' = collectT (acceptR q >>> contextT)
prunePathsToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g [Path crumb]
prunePathsToT q = applySnocPathT prunePathsToT' >>^ map snocPathToPath
where
prunePathsToT' :: Translate (SnocPath crumb) m g [SnocPath crumb]
prunePathsToT' = collectPruneT (acceptR q >>> contextT)
onePathToT :: forall c crumb g m. (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)
onePathToT q = applySnocPathT onePathToT' >>^ snocPathToPath
where
onePathToT' :: (Walker (SnocPath crumb) g, MonadCatch m) => Translate (SnocPath crumb) m g (SnocPath crumb)
onePathToT' = setFailMsg "No matching nodes found." $
onetdT (acceptR q >>> contextT)
oneNonEmptyPathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)
oneNonEmptyPathToT q = applySnocPathT $ oneT (lastCrumbT &&& onePathToT q >>^ uncurry (:))
requireUniquePath :: Monad m => Translate c m [Path crumb] (Path crumb)
requireUniquePath = contextfreeT $ \ ps -> case ps of
[] -> fail "No matching nodes found."
[p] -> return p
_ -> fail $ "Ambiguous: " ++ show (length ps) ++ " matching nodes found."
uniquePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)
uniquePathToT q = pathsToT q >>> requireUniquePath
uniquePrunePathToT :: (Walker (SnocPath crumb) g, MonadCatch m) => (g -> Bool) -> Translate c m g (Path crumb)
uniquePrunePathToT q = prunePathsToT q >>> requireUniquePath
tryL :: MonadCatch m => Lens c m g g -> Lens c m g g
tryL l = l `catchL` (\ _ -> id)
pathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g
pathL = serialise . map childL
exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g
exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id
repeatPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Lens c m g g
repeatPathL p = let go = tryL (pathL p >>> go)
in go
rootL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => AbsolutePath crumb -> Lens c m g g
rootL = pathL . snocPathToPath
pathR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Rewrite c m g -> Rewrite c m g
pathR = focusR . pathL
pathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Translate c m g b -> Translate c m g b
pathT = focusT . pathL
testPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> 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 GetChild c g a = GetChild (KureM a) (Maybe (c,g))
getChildSecond :: (Maybe (c,g) -> Maybe (c,g)) -> GetChild c g a -> GetChild c g a
getChildSecond f (GetChild ka mcg) = GetChild ka (f mcg)
instance Monad (GetChild c g) where
return a = GetChild (return a) Nothing
fail msg = GetChild (fail msg) Nothing
(GetChild kma mcg) >>= k = runKureM (\ a -> getChildSecond (mplus mcg) (k a))
(\ msg -> GetChild (fail msg) mcg)
kma
instance MonadCatch (GetChild c g) where
gc@(GetChild kma mcg) `catchM` k = runKureM (\ _ -> gc)
(\ msg -> getChildSecond (mplus mcg) (k msg))
kma
wrapGetChild :: (ReadPath c crumb, Eq crumb) => crumb -> Rewrite c (GetChild c g) g
wrapGetChild cr = do cr' <- lastCrumbT
rewrite $ \ c a -> GetChild (return a) (if cr == cr' then Just (c, a) else Nothing)
unwrapGetChild :: Rewrite c (GetChild c g) g -> Translate c Maybe g (c,g)
unwrapGetChild = resultT (\ (GetChild _ mcg) -> mcg)
getChild :: (ReadPath c crumb, Eq crumb, Walker c g) => crumb -> Translate c Maybe g (c, g)
getChild = unwrapGetChild . allR . wrapGetChild
type SetChild = KureM
wrapSetChild :: (ReadPath c crumb, Eq crumb) => crumb -> g -> Rewrite c SetChild g
wrapSetChild cr g = do cr' <- lastCrumbT
if cr == cr' then return g else idR
unwrapSetChild :: Monad m => Rewrite c SetChild g -> Rewrite c m g
unwrapSetChild = resultT (runKureM return fail)
setChild :: (ReadPath c crumb, Eq crumb, Walker c g, Monad m) => crumb -> g -> Rewrite c m g
setChild cr = unwrapSetChild . allR . wrapSetChild cr
childL_default :: forall c crumb m g. (ReadPath c crumb, Eq crumb) => (Walker c g, MonadCatch m) => crumb -> Lens c m g g
childL_default cr = lens $ do cg <- getter
k <- setter
return (cg, k)
where
getter :: Translate c m g (c,g)
getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr)
setter :: Translate c m g (g -> m g)
setter = translate $ \ c a -> return (\ b -> apply (setChild cr b) c a)