{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Generic
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- This module defines type generic functions and recursive schemes
-- along the lines of the Uniplate library.
--
--------------------------------------------------------------------------------

module Data.Comp.Generic where

import Control.Monad hiding (mapM)
import Data.Comp.Algebra
import Data.Comp.Sum
import Data.Comp.Term
import Data.Foldable
import Data.Maybe
import Data.Traversable
import GHC.Exts (build)
import Prelude hiding (foldl, mapM)


-- | This function returns the subterm of a given term at the position
-- specified by the given path or @Nothing@ if the input term has no
-- such subterm

getSubterm :: (Functor g, Foldable g) => [Int] -> Term g -> Maybe (Term g)
getSubterm :: forall (g :: * -> *).
(Functor g, Foldable g) =>
[Int] -> Term g -> Maybe (Term g)
getSubterm [Int]
path Term g
t = forall (f :: * -> *) a. Functor f => Alg f a -> Term f -> a
cata forall (g :: * -> *) h a.
(Functor g, Foldable g) =>
Alg g ([Int] -> Maybe (Cxt h g a))
alg Term g
t [Int]
path where
    alg :: (Functor g, Foldable g) => Alg g ([Int] -> Maybe (Cxt h g a))
    alg :: forall (g :: * -> *) h a.
(Functor g, Foldable g) =>
Alg g ([Int] -> Maybe (Cxt h g a))
alg g ([Int] -> Maybe (Cxt h g a))
t [] = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. HasCallStack => Maybe a -> a
fromJust) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ [])) g ([Int] -> Maybe (Cxt h g a))
t
    alg g ([Int] -> Maybe (Cxt h g a))
t (Int
i:[Int]
is) = case forall a. Int -> [a] -> [a]
drop Int
i (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList g ([Int] -> Maybe (Cxt h g a))
t) of
                     [] -> forall a. Maybe a
Nothing
                     [Int] -> Maybe (Cxt h g a)
x : [[Int] -> Maybe (Cxt h g a)]
_ -> [Int] -> Maybe (Cxt h g a)
x [Int]
is

-- | This function returns a list of all subterms of the given
-- term. This function is similar to Uniplate's @universe@ function.
subterms :: forall f . Foldable f => Term f -> [Term f]
subterms :: forall (f :: * -> *). Foldable f => Term f -> [Term f]
subterms Term f
t = forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (forall b. Term f -> (Term f -> b -> b) -> b -> b
f Term f
t)
    where f :: Term f -> (Term f -> b -> b) -> b -> b
          f :: forall b. Term f -> (Term f -> b -> b) -> b -> b
f Term f
t Term f -> b -> b
cons b
nil = Term f
t Term f -> b -> b
`cons` forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\b
u Term f
s -> forall b. Term f -> (Term f -> b -> b) -> b -> b
f Term f
s Term f -> b -> b
cons b
u) b
nil (forall (f :: * -> *) a. Cxt NoHole f a -> f (Cxt NoHole f a)
unTerm Term f
t)
-- universe t = t : foldl (\u s -> u ++ universe s) [] (unTerm t)


-- | This function returns a list of all subterms of the given term
-- that are constructed from a particular functor.
subterms' :: forall f g . (Foldable f, g :<: f) => Term f -> [g (Term f)]
subterms' :: forall (f :: * -> *) (g :: * -> *).
(Foldable f, g :<: f) =>
Term f -> [g (Term f)]
subterms' (Term f (Cxt NoHole f ())
t) = forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (forall b.
f (Cxt NoHole f ()) -> (g (Cxt NoHole f ()) -> b -> b) -> b -> b
f f (Cxt NoHole f ())
t)
    where f :: f (Term f) -> (g (Term f) -> b -> b) -> b -> b
          f :: forall b.
f (Cxt NoHole f ()) -> (g (Cxt NoHole f ()) -> b -> b) -> b -> b
f f (Cxt NoHole f ())
t g (Cxt NoHole f ()) -> b -> b
cons b
nil = let rest :: b
rest = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\b
u (Term f (Cxt NoHole f ())
s) -> forall b.
f (Cxt NoHole f ()) -> (g (Cxt NoHole f ()) -> b -> b) -> b -> b
f f (Cxt NoHole f ())
s g (Cxt NoHole f ()) -> b -> b
cons b
u) b
nil f (Cxt NoHole f ())
t
                         in case forall (f :: * -> *) (g :: * -> *) a.
(f :<: g) =>
g a -> Maybe (f a)
proj f (Cxt NoHole f ())
t of
                              Just g (Cxt NoHole f ())
t' -> g (Cxt NoHole f ())
t'g (Cxt NoHole f ()) -> b -> b
`cons` b
rest
                              Maybe (g (Cxt NoHole f ()))
Nothing -> b
rest

-- | This function transforms every subterm according to the given
-- function in a bottom-up manner. This function is similar to
-- Uniplate's @transform@ function.
transform :: (Functor f) => (Term f -> Term f) -> Term f -> Term f
transform :: forall (f :: * -> *).
Functor f =>
(Term f -> Term f) -> Term f -> Term f
transform Term f -> Term f
f = Term f -> Term f
run
    where run :: Term f -> Term f
run = Term f -> Term f
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term f -> Term f
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Cxt NoHole f a -> f (Cxt NoHole f a)
unTerm
-- transform f  = f . Term . fmap (transform f) . unTerm

transform' :: (Functor f) => (Term f -> Maybe (Term f)) -> Term f -> Term f
transform' :: forall (f :: * -> *).
Functor f =>
(Term f -> Maybe (Term f)) -> Term f -> Term f
transform' Term f -> Maybe (Term f)
f = forall (f :: * -> *).
Functor f =>
(Term f -> Term f) -> Term f -> Term f
transform Term f -> Term f
f' where
    f' :: Term f -> Term f
f' Term f
t = forall a. a -> Maybe a -> a
fromMaybe Term f
t (Term f -> Maybe (Term f)
f Term f
t)


-- | Monadic version of 'transform'.
transformM :: (Traversable f, Monad m) =>
             (Term f -> m (Term f)) -> Term f -> m (Term f)
transformM :: forall (f :: * -> *) (m :: * -> *).
(Traversable f, Monad m) =>
(Term f -> m (Term f)) -> Term f -> m (Term f)
transformM  Term f -> m (Term f)
f = Term f -> m (Term f)
run
    where run :: Term f -> m (Term f)
run Term f
t = Term f -> m (Term f)
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term f -> m (Term f)
run forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Cxt NoHole f a -> f (Cxt NoHole f a)
unTerm Term f
t)

query :: Foldable f => (Term f -> r) -> (r -> r -> r) -> Term f -> r
query :: forall (f :: * -> *) r.
Foldable f =>
(Term f -> r) -> (r -> r -> r) -> Term f -> r
query Term f -> r
q r -> r -> r
c = Term f -> r
run
    where run :: Term f -> r
run i :: Term f
i@(Term f (Term f)
t) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\r
s Term f
x -> r
s r -> r -> r
`c` Term f -> r
run Term f
x) (Term f -> r
q Term f
i) f (Term f)
t
-- query q c i@(Term t) = foldl (\s x -> s `c` query q c x) (q i) t

gsize :: Foldable f => Term f -> Int
gsize :: forall (f :: * -> *). Foldable f => Term f -> Int
gsize = forall (f :: * -> *) r.
Foldable f =>
(Term f -> r) -> (r -> r -> r) -> Term f -> r
query (forall a b. a -> b -> a
const Int
1) forall a. Num a => a -> a -> a
(+)

-- | This function computes the generic size of the given term,
-- i.e. the its number of subterm occurrences.
size :: Foldable f => Cxt h f a -> Int
size :: forall (f :: * -> *) h a. Foldable f => Cxt h f a -> Int
size (Hole {}) = Int
0
size (Term f (Cxt h f a)
t) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
s Cxt h f a
x -> Int
s forall a. Num a => a -> a -> a
+ forall (f :: * -> *) h a. Foldable f => Cxt h f a -> Int
size Cxt h f a
x) Int
1 f (Cxt h f a)
t

-- | This function computes the generic height of the given term.
height :: Foldable f => Cxt h f a -> Int
height :: forall (f :: * -> *) h a. Foldable f => Cxt h f a -> Int
height (Hole {}) = Int
0
height (Term f (Cxt h f a)
t) = Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
s Cxt h f a
x -> Int
s forall a. Ord a => a -> a -> a
`max` forall (f :: * -> *) h a. Foldable f => Cxt h f a -> Int
height Cxt h f a
x) Int
0 f (Cxt h f a)
t