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
, pathL
, localPathL
, exhaustPathL
, repeatPathL
, pathR
, pathT
, localPathR
, localPathT
, testPathT
) where
import Prelude hiding (id)
import Data.Maybe (isJust)
import Data.Monoid
import Data.DList (singleton, toList)
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif
import Control.Arrow
import Control.Category hiding ((.))
import Control.Monad
import Language.KURE.MonadCatch
import Language.KURE.Transform
import Language.KURE.Lens
import Language.KURE.Injection
import Language.KURE.Combinators
import Language.KURE.Path
class Walker c u where
allR :: MonadCatch m => Rewrite c m u -> Rewrite c m u
allT :: (MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
allT = unwrapAllT . allR . wrapAllT
oneT :: MonadCatch m => Transform c m u b -> Transform c m u b
oneT = unwrapOneT . allR . wrapOneT
anyR :: MonadCatch m => Rewrite c m u -> Rewrite c m u
anyR = unwrapAnyR . allR . wrapAnyR
oneR :: MonadCatch m => Rewrite c m u -> Rewrite c m u
oneR = unwrapOneR . allR . wrapOneR
childL :: (ReadPath c crumb, Eq crumb, MonadCatch m) => crumb -> Lens c m u u
childL = childL_default
childrenT :: (ReadPath c crumb, Walker c u, MonadCatch m) => Transform c m u [crumb]
childrenT = allT (lastCrumbT >>^ return)
childT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Transform c m u b -> Transform c m u b
childT n = focusT (childL n)
childR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Rewrite c m u -> Rewrite c m u
childR n = focusR (childL n)
foldtdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
foldtdT t = prefixFailMsg "foldtdT failed: " $
let go = t <> allT go
in go
foldbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
foldbuT t = prefixFailMsg "foldbuT failed: " $
let go = allT go <> t
in go
onetdT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b
onetdT t = setFailMsg "onetdT failed" $
let go = t <+ oneT go
in go
onebuT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b
onebuT t = setFailMsg "onebuT failed" $
let go = oneT go <+ t
in go
prunetdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
prunetdT t = setFailMsg "prunetdT failed" $
let go = t <+ allT go
in go
crushtdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
crushtdT t = foldtdT (mtryM t)
crushbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
crushbuT t = foldbuT (mtryM t)
collectT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]
collectT t = crushtdT (t >>^ singleton) >>^ toList
collectPruneT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]
collectPruneT t = prunetdT (t >>^ singleton) >>^ toList
alltdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
alltdR r = prefixFailMsg "alltdR failed: " $
let go = r >>> allR go
in go
allbuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
allbuR r = prefixFailMsg "allbuR failed: " $
let go = allR go >>> r
in go
allduR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
allduR r = prefixFailMsg "allduR failed: " $
let go = r >>> allR go >>> r
in go
anytdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anytdR r = setFailMsg "anytdR failed" $
let go = r >+> anyR go
in go
anybuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anybuR r = setFailMsg "anybuR failed" $
let go = anyR go >+> r
in go
anyduR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anyduR r = setFailMsg "anyduR failed" $
let go = r >+> anyR go >+> r
in go
onetdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
onetdR r = setFailMsg "onetdR failed" $
let go = r <+ oneR go
in go
onebuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
onebuR r = setFailMsg "onebuR failed" $
let go = oneR go <+ r
in go
prunetdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
prunetdR r = setFailMsg "prunetdR failed" $
let go = r <+ anyR go
in go
innermostR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
innermostR r = setFailMsg "innermostR failed" $
let go = anybuR (r >>> tryR go)
in go
tryL :: MonadCatch m => Lens c m u u -> Lens c m u u
tryL l = l `catchL` (\ _ -> id)
pathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
pathL = serialise . map childL
localPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Lens c m u u
localPathL = pathL . snocPathToPath
exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
exhaustPathL = foldr (\ n l -> tryL (childL n >>> l)) id
repeatPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
repeatPathL p = let go = tryL (pathL p >>> go)
in go
pathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Rewrite c m u -> Rewrite c m u
pathR = focusR . pathL
pathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u b -> Transform c m u b
pathT = focusT . pathL
localPathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Rewrite c m u -> Rewrite c m u
localPathR = focusR . localPathL
localPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Transform c m u b -> Transform c m u b
localPathT = focusT . localPathL
testPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u Bool
testPathT = testLensT . pathL
allLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
allLargestR p r = prefixFailMsg "allLargestR failed: " $
let go = ifM p r (allR go)
in go
anyLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
anyLargestR p r = setFailMsg "anyLargestR failed" $
let go = ifM p r (anyR go)
in go
oneLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
oneLargestR p r = setFailMsg "oneLargestR failed" $
let go = ifM p r (oneR go)
in go
allLargestT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u Bool -> Transform c m u b -> Transform c m u b
allLargestT p t = prefixFailMsg "allLargestT failed: " $
let go = ifM p t (allT go)
in go
oneLargestT :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Transform c m u b -> Transform c m u b
oneLargestT p t = setFailMsg "oneLargestT failed" $
let go = ifM p t (oneT go)
in go
summandIsTypeT :: forall c m a u. (MonadCatch m, Injection a u) => a -> Transform c m u Bool
summandIsTypeT _ = arr (isJust . (project :: (u -> 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) => Functor (AllT w m) where
fmap :: (a -> b) -> AllT w m a -> AllT w m b
fmap = liftM
instance (Monoid w, Monad m) => Applicative (AllT w m) where
pure :: a -> AllT w m a
pure = return
(<*>) :: AllT w m (a -> b) -> AllT w m a -> AllT w m b
(<*>) = ap
instance (Monoid w, Monad m) => Monad (AllT w m) where
return :: a -> AllT w m a
return a = AllT $ return (P a mempty)
fail :: String -> AllT w m a
fail = AllT . fail
(>>=) :: AllT w m a -> (a -> AllT w m d) -> AllT w m d
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 w m a -> (String -> AllT w m a) -> AllT w m a
catchM (AllT ma) f = AllT $ ma `catchM` (unAllT . f)
wrapAllT :: Monad m => Transform c m u b -> Rewrite c (AllT b m) u
wrapAllT t = readerT $ \ a -> resultT (AllT . liftM (P a)) t
unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) u -> Transform c m u 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 => Functor (OneT w m) where
fmap :: (a -> b) -> OneT w m a -> OneT w m b
fmap = liftM
instance Monad m => Applicative (OneT w m) where
pure :: a -> OneT w m a
pure = return
(<*>) :: OneT w m (a -> b) -> OneT w m a -> OneT w m b
(<*>) = ap
instance Monad m => Monad (OneT w m) where
return :: a -> OneT w m a
return a = OneT $ \ mw -> return (P a mw)
fail :: String -> OneT w m a
fail msg = OneT (\ _ -> fail msg)
(>>=) :: OneT w m a -> (a -> OneT w m d) -> OneT w m d
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 w m a -> (String -> OneT w m a) -> OneT w m a
catchM (OneT g) f = OneT $ \ mw -> g mw `catchM` (($ mw) . unOneT . f)
wrapOneT :: MonadCatch m => Transform c m u b -> Rewrite c (OneT b m) u
wrapOneT t = rewrite $ \ c a -> OneT $ \ mw -> case mw of
Just w -> return (P a (Just w))
Nothing -> ((P a . Just) `liftM` applyT t c a) <+ return (P a mw)
unwrapOneT :: Monad m => Rewrite c (OneT b m) u -> Transform c m u b
unwrapOneT = resultT (checkSuccessPMaybe "oneT failed" . liftM pSnd . ($ Nothing) . unOneT)
data GetChild c u a = GetChild (KureM a) (Maybe (c,u))
getChildSecond :: (Maybe (c,u) -> Maybe (c,u)) -> GetChild c u a -> GetChild c u a
getChildSecond f (GetChild ka mcu) = GetChild ka (f mcu)
instance Functor (GetChild c u) where
fmap :: (a -> b) -> GetChild c u a -> GetChild c u b
fmap = liftM
instance Applicative (GetChild c u) where
pure :: a -> GetChild c u a
pure = return
(<*>) :: GetChild c u (a -> b) -> GetChild c u a -> GetChild c u b
(<*>) = ap
instance Monad (GetChild c u) where
return :: a -> GetChild c u a
return a = GetChild (return a) Nothing
fail :: String -> GetChild c u a
fail msg = GetChild (fail msg) Nothing
(>>=) :: GetChild c u a -> (a -> GetChild c u b) -> GetChild c u b
(GetChild kma mcu) >>= k = runKureM (\ a -> getChildSecond (mplus mcu) (k a))
(\ msg -> GetChild (fail msg) mcu)
kma
instance MonadCatch (GetChild c u) where
catchM :: GetChild c u a -> (String -> GetChild c u a) -> GetChild c u a
uc@(GetChild kma mcu) `catchM` k = runKureM (\ _ -> uc)
(\ msg -> getChildSecond (mplus mcu) (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 u) u -> Transform c Maybe u (c,u)
unwrapGetChild = resultT (\ (GetChild _ mcu) -> mcu)
getChild :: (ReadPath c crumb, Eq crumb, Walker c u) => crumb -> Transform c Maybe u (c, u)
getChild = unwrapGetChild . allR . wrapGetChild
type SetChild = KureM
wrapSetChild :: (ReadPath c crumb, Eq crumb) => crumb -> u -> Rewrite c SetChild u
wrapSetChild cr u = do cr' <- lastCrumbT
if cr == cr' then return u else idR
unwrapSetChild :: Monad m => Rewrite c SetChild u -> Rewrite c m u
unwrapSetChild = resultT liftKureM
setChild :: (ReadPath c crumb, Eq crumb, Walker c u, Monad m) => crumb -> u -> Rewrite c m u
setChild cr = unwrapSetChild . allR . wrapSetChild cr
childL_default :: forall c crumb m u. (ReadPath c crumb, Eq crumb) => (Walker c u, MonadCatch m) => crumb -> Lens c m u u
childL_default cr = lens $ do cu <- getter
k <- setter
return (cu, k)
where
getter :: Transform c m u (c,u)
getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr)
setter :: Transform c m u (u -> m u)
setter = transform $ \ c a -> return (\ b -> applyR (setChild cr b) c a)