-- 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, getArgIndexes, 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] > newtype Psii = Psii PsiiRep > 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, > -- it contains 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. > -- * 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,mais,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. > -- * @mais@ are the indices of the hylomorphism arguments involved in the construction of > -- the recursive argument. They are used for fusion of hylomorphims of multiple > -- arguments. > -- * @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,[[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 > -- | Returns indexes of the arguments involved in constructing the term for a given position. > getArgIndexes :: HFunctor -> Position -> [[Int]] > getArgIndexes (HF vrs) p = maybe [] (\(_,_,iss,_)->iss)$ 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,iss,bv)-> if elem v ps then (v,i,iss,foldPF PFcnt PFcnt PFprod bv) else t) vrs > else mknr ps vrs > mknr ps (h@(p,i,iss,bv):vs) | any (flip elem ps) (vars bv) = (p,i,iss,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,iss,bv) = (p,i,iss,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,_,iss,b)->maybe o (\i'->(a,i',iss,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)))