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)
import Control.Monad
import Control.Applicative
import Control.Arrow
import Control.Category hiding ((.))
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 g where
allR :: MonadCatch m => Rewrite c m g -> Rewrite c m g
allT :: (MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b
allT = unwrapAllT . allR . wrapAllT
oneT :: MonadCatch m => Transform c m g b -> Transform 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) => Transform c m g [crumb]
childrenT = allT (lastCrumbT >>^ return)
childT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => crumb -> Transform c m g b -> Transform 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) => Transform c m g b -> Transform c m g b
foldtdT t = prefixFailMsg "foldtdT failed: " $
let go = t <> allT go
in go
foldbuT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b
foldbuT t = prefixFailMsg "foldbuT failed: " $
let go = allT go <> t
in go
onetdT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g b
onetdT t = setFailMsg "onetdT failed" $
let go = t <+ oneT go
in go
onebuT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g b
onebuT t = setFailMsg "onebuT failed" $
let go = oneT go <+ t
in go
prunetdT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b
prunetdT t = setFailMsg "prunetdT failed" $
let go = t <+ allT go
in go
crushtdT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b
crushtdT t = foldtdT (mtryM t)
crushbuT :: (Walker c g, MonadCatch m, Monoid b) => Transform c m g b -> Transform c m g b
crushbuT t = foldbuT (mtryM t)
collectT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform c m g [b]
collectT t = crushtdT (t >>^ singleton) >>^ toList
collectPruneT :: (Walker c g, MonadCatch m) => Transform c m g b -> Transform 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
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
localPathL :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Lens c m g g
localPathL = pathL . snocPathToPath
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
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 -> Transform c m g b -> Transform c m g b
pathT = focusT . pathL
localPathR :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Rewrite c m g -> Rewrite c m g
localPathR = focusR . localPathL
localPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => LocalPath crumb -> Transform c m g b -> Transform c m g b
localPathT = focusT . localPathL
testPathT :: (ReadPath c crumb, Eq crumb, Walker c g, MonadCatch m) => Path crumb -> Transform c m g Bool
testPathT = testLensT . pathL
allLargestR :: (Walker c g, MonadCatch m) => Transform 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) => Transform 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) => Transform 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) => Transform c m g Bool -> Transform c m g b -> Transform 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) => Transform c m g Bool -> Transform c m g b -> Transform 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 -> Transform 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) => 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 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 -> Transform 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 (Monoid w, Monad m) => Functor (OneT w m) where
fmap :: (a -> b) -> OneT w m a -> OneT w m b
fmap = liftM
instance (Monoid w, 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 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` applyT t c a) <+ return (P a mw)
unwrapOneT :: Monad m => Rewrite c (OneT b m) g -> Transform 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 Functor (GetChild c g) where
fmap :: (a -> b) -> GetChild c g a -> GetChild c g b
fmap = liftM
instance Applicative (GetChild c g) where
pure :: a -> GetChild c g a
pure = return
(<*>) :: GetChild c g (a -> b) -> GetChild c g a -> GetChild c g b
(<*>) = ap
instance Monad (GetChild c g) where
return :: a -> GetChild c g a
return a = GetChild (return a) Nothing
fail :: String -> GetChild c g a
fail msg = GetChild (fail msg) Nothing
(>>=) :: GetChild c g a -> (a -> GetChild c g b) -> GetChild c g b
(GetChild kma mcg) >>= k = runKureM (\ a -> getChildSecond (mplus mcg) (k a))
(\ msg -> GetChild (fail msg) mcg)
kma
instance MonadCatch (GetChild c g) where
catchM :: GetChild c g a -> (String -> GetChild c g a) -> GetChild c g a
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 -> Transform c Maybe g (c,g)
unwrapGetChild = resultT (\ (GetChild _ mcg) -> mcg)
getChild :: (ReadPath c crumb, Eq crumb, Walker c g) => crumb -> Transform 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 liftKureM
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 :: Transform c m g (c,g)
getter = resultT (projectWithFailMsgM "there is no child matching the crumb.") (getChild cr)
setter :: Transform c m g (g -> m g)
setter = transform $ \ c a -> return (\ b -> applyR (setChild cr b) c a)