> {-# LANGUAGE TypeSynonymInstances #-}

> module HFusion.Internal.HyloFace(
>            CHylo(..)
>          , Algebra, Acomponent(..), Psi(..), Psii(..), Phii, OutF(..), InF(..), Etai(..), TupleTerm(..)
>          , Tau(..), TauTerm(..), TermWrapper(..), Sigma(..), PatternS(..), WrappedCA(..)
>          , ParaFunctor(..), EtaOp(..), HFunctor(..), HyloFunctor, Position, WrapTau(..)
>          , unwrapA, foldTWM, foldTau, foldPF, foldPFM, foldTW, getRecIndex, mapStructure, getVars
>          , getTerm, setTerm, getPosition, getPositions, rightCompose, leftCompose, compose
>          , composeEta, idEta, expanded, mapTau, mapTW, mapTWacc, wrapA, isRec
>          , runFusionState, FusionState, FusionError(..)
>          , mapTWaccM, expandPositions, remapPositions, isIdEta, tupleterm
>          , getTupletermsWithArgIndexes, makePosNR, OutFi(..)
>          , CoalgebraTerm(..), HasComponents(..), Coalgebra, TermWrappable(..)
>          , module HFusion.Internal.HsSyn
>          ) where
>
> import HFusion.Internal.HsSyn
> import HFusion.Internal.Utils
> import HFusion.Internal.HsPretty
> import HFusion.Internal.Parsing.HyloContext
> import Data.List(find)
> import HFusion.Internal.Messages
> import Control.Monad.Error
> import Control.Monad.State
> import Language.Haskell.Syntax(SrcLoc(..))

> -- | A class to construct and destruct hylos
>
> class CHylo hylo where
>
>   -- |  Derives an hylomorphism from a set of mutually recursive functions.
>   -- In the result, the i-th algebra, natural transformation, coalgebra and 
>   -- functor component are grouped together in a value of type @hylo Phii Psi@.
>   -- There is one such group for each provided mutually recursive function.
>   -- Additionally each group contains a specification called 'Context'
>   -- which tells for each input variable if it is considered recursive or not.
>   buildHylo :: [Variable]   -- ^ Names of the mutually recursive functions
>             -> [Term]       -- ^ The right hand sides of each mutually recursive definition
>             -> FusionState [hylo Phii Psi]  -- ^ The derived hylomorphism. 
>                                             -- It may return the same errors than the
>                                             -- derivation algorithm implemented in 'aA'.

>   -- | Returns the algebra of a grouping of a mutual hylo.
>   getAlgebra :: hylo a ca -> Algebra a

>   -- | Replaces the algebra in a grouping of a mutual hylo.
>   setAlgebra :: Algebra a -> hylo b ca -> hylo a ca

>   -- | Returns tha natural transformation in a grouping of a mutual hylo.
>   getEta :: hylo a ca -> Eta

>   -- | Replaces the natural transformation in a grouping of a mutual hylo.
>   setEta :: Eta -> hylo a ca -> hylo a ca

>   -- | Returns the coalgebra of a grouping of a mutual hylo.
>   getCoalgebra :: hylo a ca -> Coalgebra ca

>   -- | Replaces the coalgebra in a grouping of a mutual hylo.
>   setCoalgebra :: Coalgebra ca -> hylo a cb -> hylo a ca

>   -- | Returns the names of the constant arguments.
>   getContext :: hylo a ca -> Context

>   -- | Replaces the input variables of a grouping of a mutual hylo.
>   setContext :: Context -> hylo a ca -> hylo a ca

>   -- | Returns the name of the function from which the grouping of a mutual hylo was derived.
>   getName :: hylo a ca -> Variable

>   -- | Replaces the name of the function from which the grouping of a mutual hylo was derived.
>   setName :: Variable -> hylo a ca -> hylo a ca

>   -- | Returns the functor of the grouping of a mutual hylo was derived.
>   getFunctor :: hylo a ca -> HyloFunctor

>   -- | Replaces the functor in a grouping of a mutual hylo was derived.
>   setFunctor :: HyloFunctor -> hylo a ca -> hylo a ca

>   -- | Builds a grouping from an algebra, natural transformation, functor and 
>   -- coalgebra component. The resulting grouping has associated name /default/
>   -- and it doesn't have constant arguments.
>   consHylo :: Algebra a -> [Etai] -> HyloFunctor -> Coalgebra ca -> hylo a ca

> -- | A sum of product functors.
> type HyloFunctor = [HFunctor]

> --------------------------------------------------------------
> -- ** Types for representing algebras and coalgebras
> --------------------------------------------------------------

> -- | Algebras are a case of algebra components.
> type Algebra a = [Acomponent a]

> -- | Each algebra component has a list of input variables and a body,
> -- it is a sort of lambda abstraction with an input tuple: 
> -- @[| Acomp (vs,twa) |] = (\vs -> twa vs)@
> data Acomponent a = Acomp ([Boundvar],TermWrapper a)

> -- | Returns the algebra input variables.
> getVars :: Acomponent a -> [Boundvar]
> getVars (Acomp (vrs,_)) = vrs

> -- | Returns the body of the agebra component.
> unwrapA :: Acomponent a -> TermWrapper a
> unwrapA (Acomp (_,a)) = a

> -- |  Creates an algebra component.
> wrapA :: [Boundvar] -> TermWrapper a -> Acomponent a
> wrapA = curry Acomp

> -- | Bodies of algebra components in generic form.
> type Phii = Term

> -- | Bodies of algebra components for algebras in inF form.
> -- It has a constructor and a list of arguments, the list of arguments
> -- tells the arity and whether the argument is recursive in which case
> -- it would appear as a variable which is mentioned in the corresponding
> -- functor component.
> -- @[| InF (c,ts) |] = c@
> newtype InF = InF (Constructor,[Term])

> -- | Bodies of algebra components for algebras in the form Tau(alpha)
> -- where alpha can be any of Phii, InF or Tau
> data Tau = Tauphi (Tau' Phii)
>          | TauinF (Tau' InF)
>          | Tautau (Tau' Tau)

> type Tau' a = TermWrapper (TauTerm (Acomponent a))

> -- *** Injections into the 'Tau' type.

> class WrapTau a where
>  wrapTau :: Tau' a -> Tau
> instance WrapTau Term where
>  wrapTau = Tauphi
> instance WrapTau InF where
>  wrapTau = TauinF
> instance WrapTau Tau where
>  wrapTau = Tautau

> -- | A fold for 'Tau' values.
> foldTau ::  (Tau' Phii->b)->
>             (Tau' InF->b)->
>             (Tau' Tau->b)->Tau->b
> foldTau f1 _ _ (Tauphi t) = f1 t
> foldTau _ f2 _ (TauinF t) = f2 t
> foldTau _ _ f3 (Tautau t) = f3 t

> -- | A sort of /map/ for 'Tau' values. 
> mapTau :: (Tau' Phii->Tau' Phii)->(Tau' InF->Tau' InF)->(Tau' Tau->Tau' Tau)->Tau->Tau
> mapTau f1 f2 f3 = foldTau (Tauphi .f1) (TauinF .f2) (Tautau .f3)

> -- | A representation for a term with abstracted constructor applications.

> data TauTerm a = Taucons Constructor [TauTerm a] a Etai

>                 -- ^ @[| Taucons c ts phi eta |] = (phi.eta) [| ts |])@

>                | Tausimple Term

>                -- ^ @[| Tausimple t |] = t@
>                -- A term without abstracted constructor applications.

>                | Taupair Term (TauTerm a)

>                -- ^ @[| Taupair t tau |] = (t,[| tau |])@
>                -- This is mainly used for handling fusion of catamorphisms, which should keep
>                -- in the algebra both the term with abstracted constructors and the original
>                -- term.

>                | Taucata (Term->Term) (TauTerm a)

>                -- ^ @[| Taucata ft tau |] = (ft [| tau |])@
>                -- where @ft@ is supposed to contruct a term which applies a catamorphism 
>                -- to the argument 

> -- | A representation for natural transformations embeeded in an algebra terms.

> data TermWrapper a = TWcase Term [Pattern] [TermWrapper a]

>                    -- ^ @[| TWcase t0 ps ts |] = case t0 of ps[i] -> [| ts[i] |]@
>                    -- This constructor carries the invariant that no recursive variable could appear
>                    -- in t0, otherwise the case could not be considered to be movable to a natural transformation.

>                    | TWeta (TermWrapper a) Etai

>                    -- ^ @[| TWeta a eta |] = a.eta@

>                    | TWsimple a

>                    -- ^ @[| TWsimple a |] = [| a |]@

>                    | TWacomp (Acomponent a)

>                    -- ^ @[|  TWacomp a |] = [| a |]@

>                    | TWbottom

>                    -- ^ @[| TWbottom  |] = \_ -> _|_@

> -- | A fold for TermWrapper values.
> foldTW::(Term->[Pattern]->[b]->b)->(b->Etai->b)->(a->b)->(Acomponent a->b)->b->TermWrapper a->b
> foldTW f1 f2 f3 f4 f5 (TWcase t0 ps ts) = f1 t0 ps (map (foldTW f1 f2 f3 f4 f5) ts)
> foldTW f1 f2 f3 f4 f5 (TWeta a eta) = f2 (foldTW f1 f2 f3 f4 f5 a) eta
> foldTW _ _ f3 _ _ (TWsimple a) = f3 a
> foldTW _ _ _ f4 _ (TWacomp a) = f4 a
> foldTW _ _ _ _ f5 TWbottom = f5

> -- | A monadic fold for TermWrapper values.
> foldTWM :: Monad m => (Term->[Pattern]->[b]->m b)->(b->Etai->m b)->(a->m b)->(Acomponent a->m b)->m b->TermWrapper a->m b
> foldTWM f1 f2 f3 f4 f5 = foldTW (\t0 ps mbs->do bs<-sequence mbs; f1 t0 ps bs)
>                                 (\mb eta->do b<-mb; f2 b eta)
>                                 f3 f4 f5

> -- | A map for TermWrapper values.
> mapTW::(a->b)->TermWrapper a->TermWrapper b
> mapTW f = foldTW TWcase TWeta (TWsimple .f) (\a->TWacomp (wrapA (getVars a).mapTW f.unwrapA$ a)) TWbottom

> -- | A map with accumulator for TermWrapper values.
> mapTWacc:: [Boundvar] -> ([Boundvar]->a->(c,TermWrapper b))->([c]->c)->c->TermWrapper a->(c,TermWrapper b)
> mapTWacc bvs f1 f2 f3 = foldTW (\t0 ps ->(\(cs',ts')->(f2 cs',TWcase t0 ps ts')).unzip)
>                                (\(c,tw) e-> (c,TWeta tw e))
>                                (f1 bvs)
>                                (\a->(\(c,tw)-> (c,TWacomp (wrapA (getVars a) tw))).mapTWacc (getVars a) f1 f2 f3.unwrapA$ a)
>                                (f3,TWbottom)

> -- | A monadic map with accumulator for TermWrapper values.
> mapTWaccM::Monad m => [Boundvar] -> ([Boundvar] -> a->m (c,TermWrapper b))->([c]->c)->c->TermWrapper a->m (c,TermWrapper b)
> mapTWaccM bvs f1 f2 f3 = foldTWM (\t0 ps ->(\(cs',ts')->return (f2 cs',TWcase t0 ps ts')).unzip)
>                                  (\(c,tw) e-> return (c,TWeta tw e))
>                                  (f1 bvs)
>                                  (\a->do (c,tw)<-mapTWaccM (getVars a) f1 f2 f3.unwrapA$ a
>                                          return (c,TWacomp (wrapA (getVars a) tw)))
>                                  (return (f3,TWbottom))

> -- | Coalgebras are represented as a case inside a lambda abstraction.
> -- @[| (bs,ts,ca) |] = \bs -> case ts of [| ca |]@
> -- The alternatives of the case are reconstructed depending on the 
> -- component @ca@.

> type Coalgebra ca = ([Boundvar],[Term],ca)

> -- | A type to represent the union of all the coalgebras forms
> -- we could have.

> data WrappedCA = WCApsi (Coalgebra Psi)
>                | WCAoutF (Coalgebra OutF)
>                | WCAsigma (Coalgebra Sigma)

> -- | Common operations for all coalgebras.
> class HasComponents a where

>   -- | Tuples returned in all the alternatives of a colagebra.
>   getComponentTerms :: a -> [[TupleTerm]]

>   -- | Renames pattern variables with fresh names to avoid name captures during inlining.
>   renamePatternVars :: a -> VarGenState a

>   -- | Wraps a coalgebra to store it inside a coalgebra in sigma form.
>   wrapSigma :: Coalgebra a -> WrappedCA

> -- | Coalgebra alternatives for generic coalgebras.
> -- Each list element contains a tuple of patterns and
> -- a tuple of terms to be returned when the pattern matches.
> newtype Psi = Psi [Psii]
>   deriving Show
> newtype Psii = Psii PsiiRep
>   deriving Show
> type PsiiRep = ([Pattern],[TupleTerm])

> -- | Representation for alternatives of coalgebras in OutF form.
> -- Each list component represents the pattern and the term to return
> -- if the pattern matches.

> newtype OutF = OutF [OutFi]

> -- | Representation of an alternative of a coalgebra in OutF form.
> -- It contains a constructor to and the variables used as arguments
> -- in the pattern, and the tuple which is returned when the pattern matches.

> newtype OutFi = OutFc (Constructor,[Variable],[TupleTerm])

> -- ^ @[| OutFi (c,vs,ts) |] = (c,vs) -> ts@

> -- | Representation for alternatives of coalgegbras in sigma(beta_1,...,beta_n) form
> -- where beta_1,...,beta_n are coalgebras of mutual hylomorphism. Each coalgebra 
> -- component i is applied only to the i^th argument of the transfomer result.

> newtype Sigma = Sigma ([Int],[[TupleTerm]],[[PatternS]],[Maybe [(Int,[Acomponent InF],[Etai],WrappedCA,Int->Term->Term)]])

> -- ^ In Sigma (casemap,ts,[ps_1,...,ps_n],[psi_1,...,psi_n]), 
> --     * ts are the terms returned by sigma.
> --     * ps_i are the patterns corresponding to each alternative of the hylomorphism,
> --       the inner lists contain one pattern for each recursive argument.
> --     * psi_i is the coalgebra given as argument to sigma in position i.
> --       Each coalgebra psi_i is really a mutual hylomorphism, that's why
> --       it is a list. When inlining, the coalgebra and the natural transformations of this
> --       mutual hylo are extracted. Each component of the mutual hylo has an algebra, a 
> --       natural transformation, a coalgebra and a function fapp returning an application 
> --       of the hylo to its input term. The algebra is stored because it may contain part
> --       of the natural transformation, but it is also used during inlining to match cases
> --       of its hylo with patterns of sigma.
> -- 
> --       If no fusion happend on the ith parameter, psi_i is Nothing, otherwise it contains
> --       a list with the components of the mutual unfold. 
> --
> --     * casemap tells how the alternatives of sigma connects with the alternatives of the
> --       hylomorphism. Each sigma tuple must be replicated the amount specified in the
> --       corresponding position of casemap.

> -- | Representation for patterns of sigma. They have constructors abstracted away by
> -- using view patterns. During inlininig this is translated into case cascades

> data PatternS = PcaseS Variable Pattern PatternS

>            -- ^ @[| PcaseS v p t1 |] = case v of p -> [| t1 |]@

>            | PcaseSana Int Variable Pattern PatternS

>            -- ^ @[| PcaseSana ih v p t1 |] = case ana(beta) v of p -> [| t1 |]@
>            --         ih is the index of the coalgebra term to select from the mutual hylo.

>            | PcaseR Int Variable Constructor [Variable] [(PatternS,[Variable])]

>            -- ^ @[| PcaseR ih v c args [(t1,nrecs_1), ... ,(tn,nrecs_n)] |] =@ 
>            -- @case beta v of (c1,args)->[| t1 |]; ...;(cn,args)->[| tn |]@
>            --          ih is the index of the coalgebra term to select from the mutual hylo.
>            --          nrecs_i indicates for each occurrence of c which are considered non-recursive positions 
>            --          for the constructor c, they are always a subset of args. This is because c can appear 
>            --          in different tests with different recursive positions. 

>            | Ppattern Variable Pattern

>            -- ^       A place holder for patterns.

>            | Pdone

>            -- ^ @[| Pdone |] = (nothing)@ it is a marker that there are no more patterns.

>       deriving (Show,Eq)

> -- | Representation of natural transformations.
> -- Items in the list are interpreted as terms in a sum of natural transformations.

> type Eta = [Etai]

> -- | A natural transformation which is the composition of all the natural 
> -- transformations in both lists, though they are composed in different orders.
> -- @[|([h1,...,hm],[k1,...,kn])|] = [|h1|] . ... . [|hm|] . [|kn|] . ... . [|k1|]@
> newtype Etai = Etai ([EtaOp],[EtaOp])

> -- | Representation for the simplest natural transformations.

> data EtaOp = EOid

>             -- ^        @[| EOid |]=(\v->v)@

>             | EOgeneral [Boundvar] [Term]

>             -- ^        @[| EOgeneral vs ts |]=(\vs->ts)@

>             | EOsust [Variable] [Term] [Boundvar]

>             -- ^        @[| EOsust [v'_1,...,v'_r] [t_1,...,t_r] [v_1,...,v_n] |]@
>             --          @=(\ (v_1,...,v_n)->(v_1,...,v_n)[(t_1,...,t_r)/(v'_1,...,v'_r)])@

>             | EOlet [Term] [Pattern] [Variable] [Term]

>             -- ^        @[| EOlet t0s ps vs ts |]=(\vs->case t0s of Ptuple ps -> Ttuple ts)@

> -- | @forall op e. leftCompose op e == op . h@
> leftCompose :: EtaOp -> Etai -> Etai
> leftCompose op e@(Etai (l,r)) = if isId op then e else Etai (op:l,r)

> -- | @forall op e. rightCompose op e == e . op@
> rightCompose :: Etai -> EtaOp -> Etai
> rightCompose e@(Etai (l,r)) op = if isId op then e else Etai (l,op:r)

> -- | @forall e1 e2. compose e1 e2 == e1 . e2@
> compose :: Etai -> Etai -> Etai
> compose e1 (Etai ([],[])) = e1
> compose (Etai ([],[])) e2 = e2
> compose (Etai (l1,r1)) (Etai (l2,r2)) = Etai (l1++reverse r1,r2++reverse l2)

> -- | @[| composeEta a eta |] = a .eta@
> composeEta :: Acomponent a -> Etai -> TermWrapper a
> composeEta a eta | isIdEta eta = TWacomp a
>                  | otherwise = TWeta (TWacomp a) eta

> infixl 3  `rightCompose`
> infixr 3  `leftCompose`
> infixr 2  `compose`
> infixr 2  `composeEta`

> -- | @forall e. compose e idEta == compose idEta e == e@
> idEta :: Etai
> idEta = Etai ([],[])

> -- | @isIdEta e = True <=> e=isIdEta@
> isIdEta :: Etai -> Bool
> isIdEta (Etai ([],[])) = True
> isIdEta _ = False

> isId :: EtaOp -> Bool
> isId (EOsust [] _ _) = True
> isId (EOgeneral bv ts) = and (zipWith eq bv ts) && (length bv == length ts)
>         where eq (Bvar bv) (Tvar v) = bv==v
>               eq (Bvtuple _ bvs) (Ttuple _ ts) = and (zipWith eq bvs ts)
>               eq (Bvar bv) (Ttuple _ [Tvar v]) = bv==v
>               eq (Bvtuple _ [Bvar bv]) (Tvar v) = bv==v
>               eq _ _ = False
> isId (EOlet [] _ _ _) = True
> isId EOid = True
> isId _ = False

> -- | A class which provides common names for operations on coalgebras 
> -- of Psi and OutF form.

> class CoalgebraTerm ca where

>    -- | Given an alternative psi_i of a coalgebra where 
>    -- @[| psi_i |] = (p_i -> t_i)@
>    --  and t_i is a tuple of terms:
>    -- @getTerms psii = ti@
>    -- @[| setTerms ts psi_i |] = (p_i->ts)@
>    -- @getPattern psii = pi@

>    getTerms :: ca -> [TupleTerm]
>    setTerms :: [TupleTerm] -> ca -> ca
>    getPatterns :: ca -> [Pattern]

>    -- | Returns a list of positions in the output tuple which reference the given variable. 

>    getPos :: ca -> Variable -> [Position]
>    getPos ca v = map getPosition.filter (elem v.vars.getTerm).getTerms$ ca

> -- | Representation for terms inside tuples returned by coalgebras.
> -- Each term is accompanied by an identifier of its position inside a tuple (a generated variable, right now).

> data TupleTerm = Tterm Term Position
>  deriving (Eq,Show)
> type Position=Variable

> getPosition :: TupleTerm -> Position
> getPosition (Tterm _ p) = p

> getTerm :: TupleTerm -> Term
> getTerm (Tterm t _) = t

> setTerm :: Term -> TupleTerm -> TupleTerm
> setTerm t (Tterm  _ p) = Tterm t p

> -- | Creates a value of type 'TupleTerm' from its constituents.
> -- @getPosition (tupleterm p t) == p,  getTerm (tupleterm p t) == t@

> tupleterm :: Position -> Term -> TupleTerm
> tupleterm p t=Tterm t p

> -- | Positions in which the term references the given variable.

> getPositions :: [TupleTerm] -> Variable -> [Position]
> getPositions [] _ = []
> getPositions (tt:tts) v | elem v.vars.getTerm$ tt = getPosition tt:getPositions tts v
>                         | otherwise = getPositions tts v

> -- | Positions in which the term references the given variable, with acompanying argument 
> -- indexes where the variable appears.

> getTupletermsWithArgIndexes :: [TupleTerm] -> Variable -> [(TupleTerm,[Int])]
> getTupletermsWithArgIndexes [] _ = []
> getTupletermsWithArgIndexes (tt:tts) v =
>        let tsi = filter (elem v.vars.fst)$ zip (termToRecList (getTerm tt)) [0..]
>         in if null tsi then getTupletermsWithArgIndexes tts v
>              else (tt,map snd tsi):getTupletermsWithArgIndexes tts v
>      where termToRecList (Ttuple True ts) = ts
>            termToRecList t = [t]

> -- | HFunctor represents products of elemental functors (constant or Id functors).
> -- Each elemental functor is associated to a tuple element in a coalgebra.
> -- The order in which elemental functor descriptions appear is not the order in
> -- which they appear in the product. For getting the order, use the tuples returned
> -- by the coalgebra and retrieve the descriptions using the positions of the tuple elements.
> -- In:
> -- @HF [(p,mri,copies)]@
> --  * @p@ is a unique identifier for the position in the product.
> --  * @mri@ is the index of the mutual hylo component that is applied to this position.
> --     If the position is not recursive, most likely there is not an entry in the list.
> --     However there will be non-recursive positions if originally they were recursive 
> --     and then were made non-recursive as the result of a restructure.
> --  * @copies@ is a tree-like structures that tells how the recursive values are copied.
> --        It is used for fusion of paramorphisms.

> newtype HFunctor = HF [(Position,Int,ParaFunctor)]
>   deriving Show

> -- | Representation of sum terms of functors.

> data ParaFunctor = PFprod [ParaFunctor]
>                  | PFid Position
>                  | PFcnt Position
>  deriving Show

> -- | A fold for ParaFunctor values.

> foldPF :: (Variable->b)->(Variable->b)->([b]->b)->ParaFunctor->b
> foldPF f1 _ _ (PFid v) = f1 v
> foldPF _ f2 _ (PFcnt v) = f2 v
> foldPF f1 f2 f3 (PFprod bvs) = f3 (map (foldPF f1 f2 f3) bvs)

> -- | A monadic fold for ParaFunctor values.

> foldPFM :: Monad m => (Variable->m b)->(Variable->m b)->([b]->m b)->ParaFunctor->m b
> foldPFM f1 _ _ (PFid v) = f1 v
> foldPFM _ f2 _ (PFcnt v) = f2 v
> foldPFM f1 f2 f3 (PFprod bvs) = mapM (foldPFM f1 f2 f3) bvs >>= f3

> instance Vars ParaFunctor where
>  vars = foldPF (:[]) (:[]) concat

> -- | Makes a term of nested tuples which mimics the structure of the ParaFunctor value.
> -- Whenever a recursive position is found the first argument is copied, and whenever 
> -- a non-recursive position is found the second argument is copied.

> mapStructure :: Term -> Term -> ParaFunctor -> Term
> mapStructure f1 t2 = foldPF (const f1) (const t2) (Ttuple False)

> -- | Tells if a position can be considered recursive.

> isRec :: HFunctor -> Position -> Bool
> isRec (HF vrs) p = any isR vrs
>    where isR (p',_,bv) = p==p' && foldPF (const True) (const False) or bv || foldPF (==p) (const False) or bv

> -- | Returns the identifier of the projection in a recursive position.

> getRecIndex :: HFunctor -> Position -> Maybe Int
> getRecIndex (HF vrs) p = fmap (\(_,i,_)->i)$ find (findPos p)$ vrs
>    where findPos p (p',_,bv) = p==p' && foldPF (const True) (const False) or bv || foldPF (p==) (const False) or bv

> -- | Transforms the given positions from recursive to non-recursive.

> makePosNR :: [Position] -> HFunctor -> HFunctor
> makePosNR ps (HF vrs) = HF (mknr' ps vrs)
>    where mknr' ps vrs = if any (\(v,_,_)->elem v ps) vrs
>                           then map (\t@(v,i,bv)-> if elem v ps then (v,i,foldPF PFcnt PFcnt PFprod bv) else t) vrs
>                           else mknr ps vrs
>          mknr ps (h@(p,i,bv):vs) | any (flip elem ps) (vars bv) = (p,i,foldPF (mknrbv ps) PFcnt PFprod bv):vs
>                                  | otherwise = h:mknr ps vs
>          mknr _ [] = []
>          mknrbv ps p | elem p ps = PFcnt p
>                      | otherwise = PFid p

> -- | Expands each position with a new functor term. It can be though of as the substitution 
> -- operation for functor expressions.

> expandPositions :: [(ParaFunctor,Position)] -> HFunctor -> HFunctor
> expandPositions ps (HF vrs) = HF (map (exp ps)  vrs)
>    where exp ps (p,i,bv) = (p,i,foldPF (expbv ps) PFcnt PFprod bv)
>           where  expbv ps v = case find ((v==).snd) ps of
>                                Just (PFprod [],_) -> PFid v
>                                Just (pf,_) -> pf
>                                _ -> PFid v

> -- | Returns the functor term corresponding to a given position of a functor.

> expanded :: HFunctor -> Position -> ParaFunctor
> expanded fnc@(HF vrs) p = case find (\(p',_,_)->p'==p) vrs of
>                            Just (_,_,PFprod []) -> PFcnt p
>                            Just (_,_,bv) -> bv
>                            _ | isRec fnc p -> PFid p
>                              | otherwise -> PFcnt p

> -- | Replaces recursive indexes according to the given list.

> remapPositions :: [(Position,Int)] -> HFunctor -> HFunctor
> remapPositions idxs (HF vrs) = 
>                  HF$ map (\o@(a,_,b)->maybe o (\i'->(a,i',b))$ 
>                                       maybe (foldPF (flip lookup idxs) (const Nothing) findJust b) Just$
>                                       lookup a idxs) 
>                      vrs
>    where findJust (Just a:_) = Just a
>          findJust (_:as) = findJust as
>          findJust _ = Nothing

> -- | An error monad with 'FusionError' errors and a state
> -- monad carrying a generator of fresh variables. 
> type FusionState a = ErrorT FusionError VarGenState a

> -- | Runs a 'FusionState' computation using the given
> -- variable generator. The result is either
> -- the promised value or a 'FusionError'.
> runFusionState :: VarGen -> FusionState a -> Either FusionError a
> runFusionState vg m = evalState (runErrorT m) vg

> -- | Errors that the algorithms in "HFusion" can produce.
> data FusionError = 
>              NotSaturated Term -- ^ Thrown when hylomorphism derivation fails due to the existence of a non-saturated application of the recursive function in its definition.
>              | NotExpected Term -- ^ Thrown when hylomorphism derivation fails due to encountering a 'Term' like 'Thyloapp' which is not expected in the input. 
>              | NotInF -- ^ Thrown when fusion fails due to the inability of the implementation to derive an unfold from the definition at the right of the composition.
>              | NotOutF -- ^ Thrown when fusion fails due to the inability of the implementation to derive a fold from the definition at the left of the composition. 
>              | NotTau -- ^ Thrown when fusion fails due to the inability of the implementation to derive a /tau/ transformer from the algebra of the definition at the right of the composition.
>              | NotSigma -- ^ Thrown when fusion fails due to the inability of the implementation to derive a /sigma/ transformer from the coalgebra of the definition at the left of the composition. 
>              | NotFound String -- ^ When a definition which was requested to be fused is not found among the derived hylomorphisms.
>              | Msg String -- ^ A generic error message.
>              | ParserError SrcLoc String -- ^ Thrown when translation of a program to a 'Def' values fails.

> instance Error FusionError where
>  noMsg = Msg "Generic message"
>  strMsg = Msg

> instance Show FusionError where
>  show (NotSaturated t) = not_Satured t
>  show (NotExpected t) = not_Expected t
>  show NotInF = not_InF_Term
>  show NotOutF = not_OutF_Term
>  show NotTau = right_Hylo_Not_Tau_Form
>  show NotSigma = left_Hylo_Not_Sigma_Form
>  show (NotFound s) = not_Found s
>  show (Msg chrs) = error_Message chrs
>  show (ParserError loc s) = showLoc loc ++ s
>   where showLoc l = srcFilename l ++ "("++ show (srcLine l) ++ ","++ show (srcColumn l)++"): "

> class TermWrappable a where
>  wrapTerm :: Term -> a
> instance TermWrappable Phii where
>  wrapTerm = id
> instance TermWrappable InF where
>  wrapTerm t = InF (" ",[t])
> instance TermWrappable Tau where
>  wrapTerm t = wrapTau (TWsimple (Tausimple t::TauTerm (Acomponent Phii)))