hfusion-0.0.6: HFusion/Internal/HyloFace.lhs
-- Please, see the file LICENSE for copyright and license information.
> {-# LANGUAGE TypeSynonymInstances #-}
% -----------------------------------------------------------------------------
% Interfaces for manipulating hylomorphisms and its components.
% -----------------------------------------------------------------------------
> 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 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))
Tipo para representar una coalgebra. Se da la variable de entrada el termino sobre el
case que divide en alternativas y las alternativas.
> -- | 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
===========================================================
Auxiliary definitions for fusion algorithms
===========================================================
> -- | 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)))