ideas-0.6: src/Common/Navigator.hs
{-# OPTIONS -XExistentialQuantification #-}
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- This module defines a type class for navigating an expression.
--
-----------------------------------------------------------------------------
module Common.Navigator
( -- * Type classes for navigating expressions
IsNavigator(..), TypedNavigator(..)
-- * Types and constructors
, Navigator, Location
, navigator, noNavigator, viewNavigator
-- * Derived navigations
, leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo
, top, leafs, downFirst, downLast, left, right
) where
import Common.Uniplate
import Common.View hiding (left, right)
import Control.Monad
import Data.Maybe
import Data.Typeable
---------------------------------------------------------------
-- Type class for navigating expressions
type Location = [Int]
-- | For a minimal complete definition, provide an implemention for downs or
-- allDowns. All other functions need an implementation as well, except for
-- change. Note that a constructor (a -> f a) is not included in the type class
-- to allow additional type class constraints on type a.
class IsNavigator f where
-- navigation
up :: Monad m => f a -> m (f a)
down :: Monad m => Int -> f a -> m (f a)
allDowns :: f a -> [f a]
-- inspection
current :: Monad m => f a -> m a
location :: f a -> Location
-- adaption
change :: (a -> a) -> f a -> f a
changeM :: Monad m => (a -> m a) -> f a -> m (f a)
-- default definitions
down n a =
case drop n (allDowns a) of
[] -> fail ("down " ++ show n)
hd:_ -> return hd
allDowns a =
[ fa | i <- [0 .. arity a-1], fa <- down i a ]
change f a =
case changeM (Just . f) a of
Just new -> new
Nothing -> a
class IsNavigator f => TypedNavigator f where
changeT :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a)
currentT :: (Monad m, Typeable b) => f a -> m b
leaveT :: (Monad m, Typeable b) => f a -> m b
castT :: (Monad m, Typeable e) => View e b -> f a -> m (f b)
-- By default, fail
changeT _ _ = fail "changeT"
currentT _ = fail "currentT"
leaveT _ = fail "leaveT"
castT _ _ = fail "castT"
---------------------------------------------------------------
-- Derived navigations
leave :: (IsNavigator f, Monad m) => f a -> m a
leave a = maybe (current a) leave (up a)
replace :: IsNavigator f => a -> f a -> f a
replace = change . const
arity :: IsNavigator f => f a -> Int
arity = length . allDowns
isTop :: IsNavigator f => f a -> Bool
isTop = isNothing . up
isLeaf :: IsNavigator f => f a -> Bool
isLeaf = null . allDowns
ups :: (IsNavigator f, Monad m) => Int -> f a -> m (f a)
ups n a = foldM (const . up) a [1..n]
downs :: (IsNavigator f, Monad m) => [Int] -> f a -> m (f a)
downs is a = foldM (flip down) a is
navigateTo :: (IsNavigator f, Monad m) => Location -> f a -> m (f a)
navigateTo is a = ups (length js - n) a >>= downs (drop n is)
where
js = location a
n = length (takeWhile id (zipWith (==) is js))
top :: (IsNavigator f, Monad m) => f a -> m (f a)
top = navigateTo []
leafs :: IsNavigator f => f a -> [f a]
leafs a
| isLeaf a = [a]
| otherwise = concatMap leafs (allDowns a)
downFirst :: (IsNavigator f, Monad m) => f a -> m (f a)
downFirst = down 0
downLast :: (IsNavigator f, Monad m) => f a -> m (f a)
downLast a = down (arity a - 1) a
left :: (IsNavigator f, Monad m) => f a -> m (f a)
left a0 = rec a0
where
rec a
| isTop a = downFirst a0
| i == 0 = up a >>= rec
| otherwise = up a >>= down (i-1)
where
i = last (location a)
right :: (IsNavigator f, Monad m) => f a -> m (f a)
right a0 = rec a0
where
rec a
| isTop a = downLast a0
| otherwise = do
p <- up a
let n = arity p
if i >= n-1 then rec p else down (i+1) p
where
i = last (location a)
---------------------------------------------------------------
-- Instance based on Uniplate
-- The uniplate function is stored in the data type to get rid of the
-- Uniplate type class constraints in the member functions of the
-- Navigator type class.
data UniplateNav a = UN (UniplateType a) [(Int, a -> a)] a
type UniplateType a = a -> ([a], [a] -> a)
makeUN :: Uniplate a => a -> UniplateNav a
makeUN = UN uniplate []
instance Show a => Show (UniplateNav a) where
show = showNav
instance IsNavigator UniplateNav where
up (UN _ [] _) = fail "up"
up (UN uni ((_, f):xs) a) = return (UN uni xs (f a))
allDowns (UN uni xs a) = zipWith make [0..] cs
where
(cs, build) = uni a
make i = UN uni ((i, build . flip (update i) cs):xs)
update _ _ [] = []
update i x (y:ys)
| i == 0 = x:ys
| otherwise = y:update (i-1) x ys
location (UN _ xs _) = reverse (map fst xs)
changeM f (UN uni xs a) = liftM (UN uni xs) (f a)
current (UN _ _ a) = return a
showNav :: (IsNavigator f, Show a) => f a -> String
showNav a = maybe "???" show (leave a) ++ " { "
++ maybe "???" show (current a)
++ " @ " ++ show (location a) ++ " }"
---------------------------------------------------------------
-- Instance based on a View
data ViewNav a b = VN (View a b) (UniplateNav a)
instance Show a => Show (ViewNav a b) where
show (VN _ a) = show a
instance IsNavigator (ViewNav a) where
up (VN v a) = liftM (VN v) (up a)
allDowns (VN v a) = liftM (VN v) (allDowns a)
location (VN _ a) = location a
current (VN v a) = current a >>= matchM v
changeM f (VN v a) =
let g b = matchM v b >>= (liftM (build v) . f)
in liftM (VN v) (changeM g a)
instance Typeable a => TypedNavigator (ViewNav a) where
changeT f (VN v a) = do
new <- current a >>= castM >>= f >>= castM
return (VN v (replace new a))
currentT (VN _ a) =
current a >>= castM
leaveT (VN _ a) =
leave a >>= castM
castT v (VN v0 a)
| typeOf (getTp v) == typeOf (getTp v0) =
return (VN (makeView f g) a)
| otherwise =
fail "castT"
where
f e = castM e >>= matchM v
g = fromMaybe (error "castT") . cast . build v
getTp :: View a b -> a
getTp = error "castT"
castM :: (Monad m, Typeable a, Typeable b) => a -> m b
castM = maybe (fail "castM") return . cast
---------------------------------------------------------------
-- Uniform navigator type
instance Show a => Show (Navigator a) where
show = showNav
data Navigator a = forall f . TypedNavigator f => N (f a)
data Simple a = forall f . IsNavigator f => S (f a)
instance IsNavigator Navigator where
up (N a) = liftM N (up a)
allDowns (N a) = map N (allDowns a)
current (N a) = current a
location (N a) = location a
changeM f (N a) = liftM N (changeM f a)
instance TypedNavigator Navigator where
changeT f (N a) = liftM N (changeT f a)
currentT (N a) = currentT a
leaveT (N a) = leaveT a
castT v (N a) = liftM N (castT v a)
instance IsNavigator Simple where
up (S a) = liftM S (up a)
allDowns (S a) = map S (allDowns a)
current (S a) = current a
location (S a) = location a
changeM f (S a) = liftM S (changeM f a)
instance TypedNavigator Simple
---------------------------------------------------------------
-- Constructors
navigator :: Uniplate a => a -> Navigator a
navigator = N . S . makeUN
noNavigator :: a -> Navigator a
noNavigator = N . S . UN (\a -> ([], const a)) []
viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a
viewNavigator = N . VN identity . makeUN