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

--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.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. All definitions are
-- generalised versions of those in "Data.Comp.Generic".
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.Generic where

import Control.Monad
import Data.Comp.Multi.HFoldable
import Data.Comp.Multi.HFunctor
import Data.Comp.Multi.HTraversable
import Data.Comp.Multi.Sum
import Data.Comp.Multi.Term
import GHC.Exts
import Prelude

import Data.Maybe

-- | This function returns a list of all subterms of the given
-- term. This function is similar to Uniplate's @universe@ function.
subterms :: forall h f a. HFoldable f => Cxt h f a  :=> [E (Cxt h f a)]
subterms :: forall h (f :: (* -> *) -> * -> *) (a :: * -> *).
HFoldable f =>
Cxt h f a :=> [E (Cxt h f a)]
subterms Cxt h f a i
t = (forall b. (E (Cxt h f a) -> b -> b) -> b -> b) -> [E (Cxt h f a)]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build (Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
forall i b. Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
f Cxt h f a i
t)
    where f :: forall i b. Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
          f :: forall i b. Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
f (Term f (Cxt h f a) i
t) E (Cxt h f a) -> b -> b
cons b
nil = Cxt h f a i -> E (Cxt h f a)
forall (f :: * -> *) i. f i -> E f
E (f (Cxt h f a) i -> Cxt h f a i
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) i.
f (Cxt h f a) i -> Cxt h f a i
Term f (Cxt h f a) i
t) E (Cxt h f a) -> b -> b
`cons` (b -> Cxt h f a :=> b) -> b -> f (Cxt h f a) :=> b
forall b (a :: * -> *). (b -> a :=> b) -> b -> f a :=> b
forall (h :: (* -> *) -> * -> *) b (a :: * -> *).
HFoldable h =>
(b -> a :=> b) -> b -> h a :=> b
hfoldl (\b
u Cxt h f a i
s -> Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
forall i b. Cxt h f a i -> (E (Cxt h f a) -> b -> b) -> b -> b
f Cxt h f a i
s E (Cxt h f a) -> b -> b
cons b
u) b
nil f (Cxt h f a) i
t
          f (Hole a i
h) E (Cxt h f a) -> b -> b
cons b
nil = Cxt h f a i -> E (Cxt h f a)
forall (f :: * -> *) i. f i -> E f
E (a i -> Cxt Hole f a i
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole a i
h) E (Cxt h f a) -> b -> b
`cons` b
nil

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

allHoles :: (HFoldable f) => Context f a l -> [E a]
allHoles :: forall (f :: (* -> *) -> * -> *) (a :: * -> *) l.
HFoldable f =>
Context f a l -> [E a]
allHoles Context f a l
t = [a i -> E a
forall (f :: * -> *) i. f i -> E f
E a i
h | E (Hole a i
h) <- Context f a l -> [E (Cxt Hole f a)]
Cxt Hole f a :=> [E (Cxt Hole f a)]
forall h (f :: (* -> *) -> * -> *) (a :: * -> *).
HFoldable f =>
Cxt h f a :=> [E (Cxt h f a)]
subterms Context f a l
t]

-- |
-- @
-- transform :: (forall i. Term fs i -> Term fs i) -> Term f l -> Term f l
-- @
--
-- If @f :: Term fs i -> Term fs i@ rewrites a single node, then @transform f t@
-- is the result of running @f@ on all nodes within @t@ in a bottom-up fashion.
transform :: forall f . (HFunctor f) => (HFix f :-> HFix f) -> HFix f :-> HFix f
transform :: forall (f :: (* -> *) -> * -> *).
HFunctor f =>
(HFix f :-> HFix f) -> HFix f :-> HFix f
transform HFix f :-> HFix f
f = HFix f i -> HFix f i
HFix f :-> HFix f
run
    where run :: HFix f :-> HFix f
          run :: HFix f :-> HFix f
run = HFix f i -> HFix f i
HFix f :-> HFix f
f (HFix f i -> HFix f i)
-> (HFix f i -> HFix f i) -> HFix f i -> HFix f i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (HFix f) i -> HFix f i
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) i.
f (Cxt h f a) i -> Cxt h f a i
Term (f (HFix f) i -> HFix f i)
-> (HFix f i -> f (HFix f) i) -> HFix f i -> HFix f i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HFix f :-> HFix f) -> f (HFix f) :-> f (HFix f)
forall (f :: * -> *) (g :: * -> *). (f :-> g) -> f f :-> f g
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *).
HFunctor h =>
(f :-> g) -> h f :-> h g
hfmap HFix f i -> HFix f i
HFix f :-> HFix f
run (f (HFix f) i -> f (HFix f) i)
-> (HFix f i -> f (HFix f) i) -> HFix f i -> f (HFix f) i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HFix f i -> f (HFix f) i
forall (f :: (* -> *) -> * -> *) t. HFix f t -> f (HFix f) t
unTerm


-- | Monadic version of 'transform'.
transformM :: forall f m . (HTraversable f, Monad m) =>
             NatM m (HFix f) (HFix f) -> NatM m (HFix f) (HFix f)
transformM :: forall (f :: (* -> *) -> * -> *) (m :: * -> *).
(HTraversable f, Monad m) =>
NatM m (HFix f) (HFix f) -> NatM m (HFix f) (HFix f)
transformM  NatM m (HFix f) (HFix f)
f = HFix f i -> m (HFix f i)
NatM m (HFix f) (HFix f)
run
    where run :: NatM m (HFix f) (HFix f)
          run :: NatM m (HFix f) (HFix f)
run HFix f i
t = HFix f i -> m (HFix f i)
NatM m (HFix f) (HFix f)
f (HFix f i -> m (HFix f i)) -> m (HFix f i) -> m (HFix f i)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (f (HFix f) i -> HFix f i) -> m (f (HFix f) i) -> m (HFix f i)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM f (HFix f) i -> HFix f i
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) i.
f (Cxt h f a) i -> Cxt h f a i
Term (NatM m (HFix f) (HFix f) -> NatM m (f (HFix f)) (f (HFix f))
forall (m :: * -> *) (a :: * -> *) (b :: * -> *).
Monad m =>
NatM m a b -> NatM m (f a) (f b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) (a :: * -> *)
       (b :: * -> *).
(HTraversable t, Monad m) =>
NatM m a b -> NatM m (t a) (t b)
hmapM HFix f i -> m (HFix f i)
NatM m (HFix f) (HFix f)
run (f (HFix f) i -> m (f (HFix f) i))
-> f (HFix f) i -> m (f (HFix f) i)
forall a b. (a -> b) -> a -> b
$ HFix f i -> f (HFix f) i
forall (f :: (* -> *) -> * -> *) t. HFix f t -> f (HFix f) t
unTerm HFix f i
t)

-- |
-- @
-- query :: (forall i. Term fs i -> r) -> (r -> r -> r) -> Term fs l -> r
-- @
--
-- Example usage: let @getConsts :: (IntConst :-<: fs) => Term fs l -> [Int]@ be
-- a function where @getConsts (iIntConst n) = [n]@, and @getConsts t = []@
-- for everything that is not an @IntConst@. Then
--
-- @
-- query getConsts (++) term
-- @
--
-- returns a list of all integer constants in @term@.
query :: HFoldable f => (Cxt h f a :=>  r) -> (r -> r -> r) -> Cxt h f a :=> r
-- query q c = run
--     where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t
query :: forall (f :: (* -> *) -> * -> *) h (a :: * -> *) r.
HFoldable f =>
(Cxt h f a :=> r) -> (r -> r -> r) -> Cxt h f a :=> r
query Cxt h f a :=> r
q r -> r -> r
c i :: Cxt h f a i
i@(Term f (Cxt h f a) i
t) = (r -> Cxt h f a :=> r) -> r -> f (Cxt h f a) :=> r
forall b (a :: * -> *). (b -> a :=> b) -> b -> f a :=> b
forall (h :: (* -> *) -> * -> *) b (a :: * -> *).
HFoldable h =>
(b -> a :=> b) -> b -> h a :=> b
hfoldl (\r
s Cxt h f a i
x -> r
s r -> r -> r
`c` (Cxt h f a :=> r) -> (r -> r -> r) -> Cxt h f a :=> r
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) r.
HFoldable f =>
(Cxt h f a :=> r) -> (r -> r -> r) -> Cxt h f a :=> r
query Cxt h f a i -> r
Cxt h f a :=> r
q r -> r -> r
c Cxt h f a i
x) (Cxt h f a i -> r
Cxt h f a :=> r
q Cxt h f a i
i) f (Cxt h f a) i
t
query Cxt h f a :=> r
q r -> r -> r
c i :: Cxt h f a i
i@(Hole a i
_) = Cxt h f a i -> r
Cxt h f a :=> r
q Cxt h f a i
i

subs :: HFoldable f => Cxt h f a  :=> [E (Cxt h f a)]
subs :: forall (f :: (* -> *) -> * -> *) h (a :: * -> *).
HFoldable f =>
Cxt h f a :=> [E (Cxt h f a)]
subs = (Cxt h f a :=> [E (Cxt h f a)])
-> ([E (Cxt h f a)] -> [E (Cxt h f a)] -> [E (Cxt h f a)])
-> Cxt h f a :=> [E (Cxt h f a)]
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) r.
HFoldable f =>
(Cxt h f a :=> r) -> (r -> r -> r) -> Cxt h f a :=> r
query (\Cxt h f a i
x-> [Cxt h f a i -> E (Cxt h f a)
forall (f :: * -> *) i. f i -> E f
E Cxt h f a i
x]) [E (Cxt h f a)] -> [E (Cxt h f a)] -> [E (Cxt h f a)]
forall a. [a] -> [a] -> [a]
(++)

subs' :: (HFoldable f, g :<: f) => Cxt h f a :=> [E (g (Cxt h f a))]
subs' :: forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) h
       (a :: * -> *).
(HFoldable f, g :<: f) =>
Cxt h f a :=> [E (g (Cxt h f a))]
subs' = (E (Cxt h f a) -> Maybe (E (g (Cxt h f a))))
-> [E (Cxt h f a)] -> [E (g (Cxt h f a))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe E (Cxt h f a) -> Maybe (E (g (Cxt h f a)))
forall {g :: (* -> *) -> * -> *} {f :: (* -> *) -> * -> *} {h}
       {a :: * -> *}.
(g :<: f) =>
E (Cxt h f a) -> Maybe (E (g (Cxt h f a)))
pr ([E (Cxt h f a)] -> [E (g (Cxt h f a))])
-> (Cxt h f a i -> [E (Cxt h f a)])
-> Cxt h f a i
-> [E (g (Cxt h f a))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cxt h f a i -> [E (Cxt h f a)]
Cxt h f a :=> [E (Cxt h f a)]
forall (f :: (* -> *) -> * -> *) h (a :: * -> *).
HFoldable f =>
Cxt h f a :=> [E (Cxt h f a)]
subs
        where pr :: E (Cxt h f a) -> Maybe (E (g (Cxt h f a)))
pr (E Cxt h f a i
v) = (g (Cxt h f a) i -> E (g (Cxt h f a)))
-> Maybe (g (Cxt h f a) i) -> Maybe (E (g (Cxt h f a)))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g (Cxt h f a) i -> E (g (Cxt h f a))
forall (f :: * -> *) i. f i -> E f
E (Cxt h f a i -> Maybe (g (Cxt h f a) i)
NatM Maybe (Cxt h f a) (g (Cxt h f a))
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *) h
       (a :: * -> *).
(g :<: f) =>
NatM Maybe (Cxt h f a) (g (Cxt h f a))
project Cxt h f a i
v)

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

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