hfusion (empty) → 0.0.1
raw patch · 20 files changed
+5601/−0 lines, 20 filesdep +basedep +containersdep +haskell-srcsetup-changed
Dependencies added: base, containers, haskell-src, haskell98, mtl, pretty
Files
- HFusion/HFusion.hs +84/−0
- HFusion/Internal/FsDeriv.lhs +291/−0
- HFusion/Internal/FunctorRep.lhs +768/−0
- HFusion/Internal/FuseEnvironment.lhs +78/−0
- HFusion/Internal/FuseFace.lhs +281/−0
- HFusion/Internal/HsPrec.hs +38/−0
- HFusion/Internal/HsPretty.hs +456/−0
- HFusion/Internal/HsSyn.hs +262/−0
- HFusion/Internal/HyloFace.lhs +666/−0
- HFusion/Internal/HyloRep.lhs +223/−0
- HFusion/Internal/Inline.lhs +841/−0
- HFusion/Internal/Messages.lhs +167/−0
- HFusion/Internal/Parsing/HyloContext.lhs +129/−0
- HFusion/Internal/Parsing/HyloParser.lhs +271/−0
- HFusion/Internal/Parsing/Translator.lhs +306/−0
- HFusion/Internal/RenVars.lhs +248/−0
- HFusion/Internal/Utils.lhs +399/−0
- LICENSE +41/−0
- Setup.hs +2/−0
- hfusion.cabal +50/−0
+ HFusion/HFusion.hs view
@@ -0,0 +1,84 @@+-- Please, see the file LICENSE for copyright and license information.++-- | Functions exported by this module can be used to fuse programs as follows:+--+-- > import HFusion.HFusion+-- > import Control.Monad.Trans(lift)+-- > import Language.Haskell.Parser(parseModule)+-- >+-- > fuseProgram :: String -> Either FusionError String+-- > fuseProgram sourceCode = runFusionState newVarGen$+-- > -- Parse input with a Haskell parser.+-- > parseResult2FusionState (Language.Haskell.Parser.parseModule sourceCode) +-- > -- Convert the haskell AST to the AST used by HFusion.+-- > >>= hsModule2HsSyn +-- > -- Derive hylomorphisms for the definitions in the program.+-- > >>= lift . fmap snd . deriveHylos +-- > -- Fuse functions "zip" and "filter" composing "filter" on the second+-- > -- argument of "zip" and name "h" the resulting recursive definition.+-- > >>= fuse "zip" 2 "filter" ["zf"]+-- > -- Translate the result from HFusion AST to Haskell source code.+-- > >>= return . hsSyn2HsSourceCode+-- >+-- > main = do cs <- readFile "examples.hs"+-- > putStr$ either (("There was an error: "++) . show) id$ fuseProgram cs+--+-- For more information on HFusion please visit <http://www.fing.edu.uy/inco/proyectos/fusion>.+module HFusion.HFusion (+ hsModule2HsSyn -- :: HsModule -> FusionState [Def]+ ,deriveHylos -- :: [Def] -> IntState (([Def],FusionError),[HyloT])+ ,fuse -- :: [HyloT] -> String -> Int -> String -> String -> FusionState [Def]+ ,fuse' -- :: String -> Int -> String -> [String] -> [HyloT] -> FusionState ([Def],String)+ ,hsSyn2HsSourceCode -- :: [Def] -> String+ -- * Auxiliary definitions + ,runFusionState -- :: VarGen -> FusionState a -> Either FusionError a+ ,FusionError(..)+ ,FusionState(..)+ ,VarGen,newVarGen+ ,parseResult2FusionState -- :: ParseResult HsModule -> FusionState HsModule+ -- * Abstract syntax tree+ ,Def(..),Term(..),Pattern(..),Variable(..),Constructor(..),Literal(..),Boundvar(..)+ ) where++import HFusion.Internal.HsSyn hiding (Vars,VarsB,AlphaConvertible)+import HFusion.Internal.Parsing.Translator+import HFusion.Internal.Parsing.HyloParser+import HFusion.Internal.FuseEnvironment+import HFusion.Internal.FuseFace+import HFusion.Internal.HyloFace+import HFusion.Internal.Utils+import Control.Monad.Trans(lift)+import Control.Arrow(first,(&&&))+import Control.Applicative(liftA2)++-- | Transforms a composition of two recursive functions into an equivalent +-- recursive function.+--+-- @fuse "f" 1 "g" [h_1 .. h_n] dfs@ yields a recursive function equivalent to @f . g@ and calls +-- the resulting (possibly mutually) recursive definitions @h_1 .. h_n@. Functions @f@ and @g@+-- must be hylomorphisms defined in @dfs@.+--+-- @fuse "f" 2 "g" [h_1 .. h_n] dfs@ yields a recursive function equivalent to @\x y -> f x (g y)@,+-- @fuse "f" 3 "g" [h_1 .. h_n] dfs@ yields a recursive function equivalent to @\x y z -> f x y (g z)@,+-- and so on ...+fuse :: String -> Int -> String -> [String] -> [HyloT] -> FusionState [Def]+fuse nombre1 inArg nombre2 resultNames hylos = env2FusionState fuseHylos >>= lift . inline >>= return . map polishDef+ where fuseHylos :: Env HyloT+ fuseHylos = do mapM_ insertFuseEnv hylos+ fuseFuseEnv (map str2var resultNames) (str2var nombre1) inArg (str2var nombre2)++-- | Works like 'fuse' but returns also a string resembling the hylomorphism which represents+-- the result of fusion.+fuse' :: String -> Int -> String -> [String] -> [HyloT] -> FusionState ([Def],String)+fuse' nombre1 inArg nombre2 resultNames hylos = + env2FusionState fuseHylos >>= uncurry (liftA2 (,)) . (lift . inline &&& lift . showHT)+ >>= return . first (map polishDef)+ where fuseHylos :: Env HyloT+ fuseHylos = do mapM_ insertFuseEnv hylos+ fuseFuseEnv (map str2var resultNames) (str2var nombre1) inArg (str2var nombre2)++-- | Pretty prints a set of definitions into Haskell source code. +hsSyn2HsSourceCode :: [Def] -> String+hsSyn2HsSourceCode = unlines . map ((++"\n").show)++
+ HFusion/Internal/FsDeriv.lhs view
@@ -0,0 +1,291 @@+-- Please, see the file LICENSE for copyright and license information.++> {-# LANGUAGE PatternGuards #-}++% -----------------------------------------------------------------------------+% $Id: FsDeriv.lhs,v 1.37 2005/08/26 20:59:55 fdomin Exp $+%+% Los algoritmos que crean y modifican hilomorfismos.+% Tomados del artículo de Onoue, Hu, Iwasaki y Takeichi.+%+% -----------------------------------------------------------------------------++>module HFusion.Internal.FsDeriv(+> aA, -- derivation algorithm+> ) where+>+> import List hiding (intersperse)+> import HFusion.Internal.Utils+> import HFusion.Internal.HsSyn+> import HFusion.Internal.RenVars+> import HFusion.Internal.HyloFace+> import Control.Monad.Error(throwError)+> import Control.Monad.Trans(lift)+> import Maybe(catMaybes)++ import Debug.Trace++ sss l v = trace (l++": "++show v) v++Error codes used here are defined in Utils.++=====================================================================++Algorithm for replacing with fresh variables the recursive calls+of a function. Used for deriving hylomorphisms.+Restrictions:+ *Every occurrence of the function name must appear in a saturated+ application.++=====================================================================+++Algorithm aD takes the number of arguments over which recursion is performed, +a term t1, two sets of variables vsis and+c1, and variables which identify functions fs expected to be called+recursively in term t1, together with their respective amount of arguments to check saturation.+vsis is expected to contain the constant parameters of the function f.+Values returned in the following triplet ++> type DReturnType = ([(Variable,Variable)], [(Variable, Int,[[Int]], [Term])], Term)++ are:+ * A set of free variables in t1 appearing in c1. These variables go paired with fresh variables.+ * A set of triplets (fresh variable,recursive function index,+ indexes of the arguments used to build the recursive argument,+ recursive arguments of the function appearing in t1).+ * A term constructed by substituting in t1 the recursive calls for+ the corresponding fresh variables.++This algorithm expects to be invoked as+ aD (vars pi) fs t+where vars pi are the variables bound by pattern pi. And pattern pi+is the pattern of the case in the body of the function over which the+derivation algorithm is applied.++ Errors:++ NotSaturated t: Thrown when a non-saturated recursive function application+ appears. This may be thrown also if the recursive arguments+ are not the last ones, or if non-recursive paramenters are+ not invariant from call to call.+ t is the term being processed when the error appeared.+ NotExpected t: Thrown when the algorithm is not defined for the given term.+ This happens if a term like Thylo appears.+ t is the unexpected term.+++> aD :: [(Int,[Variable])] -> [Variable] -> [(Variable,Int)] -> Term -> FusionState DReturnType++> aD pvss c1 fs t =+> let d = aD pvss c1 fs+> except ex t =+> -- I want to eliminate variables of vsis when examining+> -- expressions in a let or lambda scope.+> -- If the intersections of variables to eliminate and+> -- vsis is non-empty, then if recursive calls appear in the+> -- the term they are not saturated and so I must throw NotSaturated.+> let vs = vars ex in+> aD pvss (c1 \\ vs) fs t+> in+> case t of+> Tvar v -> if elem v c1 then do u<-lift$ getFreshVar (varPrefix v); return ([(v,u)],[],Tvar u)+> else return ([],[],t)+> Tlit _ -> return ([],[],t)+> Ttuple b ts -> do res<- mapM d ts+> let (vs,ps,ts') = unzip3 res+> return (foldr (++) [] vs, concat ps, Ttuple b ts')+> Tlamb bv t -> do (c,p,t') <- except bv t+> return (c,p,Tlamb bv t')+> Tlet v t1 t0 -> do (s0,c0,t0') <- except v t0+> (s1,c1,t1') <- except v t1+> return (s0++s1, c0++c1, Tlet v t1' t0')+> Tcase t0 ps ts -> let aux pi t = do (vs2,ps2,t') <- except pi t+> return (vs2,ps2,t')+> in+> do res <- sequence$ zipWith aux ps ts+> let (vs,pos,ts') = unzip3 res+> (v0,p0,t0') <- d t0+> return ((v0++).foldr (++) []$ vs,+> p0++concat pos, Tcase t0' ps ts')+> Tfapp v ts -> +> do res <- mapM d ts+> let (vs,ps,ts') = unzip3 res+> (v0,p0,_) <- d (Tvar v)+> let retres = ((v0++).foldr (++) []$ vs, p0++concat ps, Tfapp v ts')+> if any (not.null) ps then return retres+> else case findIndex ((v==).fst) fs of+> Just idx | Just nargs<-lookup v fs ->+> -- All application parameters must be equal to the+> -- variables in vsis, except the last arguments that+> -- are the recursive ones.+> if length ts==nargs then+> do let tvs=vars ts+> u<-lift$ getFreshVar (if null tvs then "v" else varPrefix (head tvs))+> return ([],[(u,idx,map (findArgumentIndexes pvss) ts,ts)],Tvar u)+> else throwError (NotSaturated t)+> _ -> return retres+>+> Tcapp cons ts -> do res <- mapM d ts+> let (vs,ps,ts') = unzip3 res+> return (foldr (++) [] vs,+> concat ps, Tcapp cons ts')+>+> Tapp t1 t2 -> do (vs1,ps1,t1') <- d t1+> (vs2,ps2,t2') <- d t2+> return (vs1++vs2, ps1++ps2, Tapp t1' t2')+> _ -> throwError (NotExpected t)+> where findArgumentIndexes pvss t = map fst . filter (not . null . intersect (vars t) . snd)$ pvss++++=====================================================================++Algorithm for deriving hylomorphisms.+Restrictions:+ *Every ocurrence of the name for the recursive function must appear+ in a saturated application (comes from the restriction in algorithm aD).++=====================================================================++The algorithm aA takes terms ts and variables that identify+ functions $f_i$. The variables are the functions defined by each term+in ts.++> type InputLine = ([Pattern],DReturnType)+> aA :: [Variable] -> [Term] -> FusionState [([Boundvar],[Term],[InputLine])]++The returned value is a representation of each function as hilomorphism.++ Errors:++ Errors of algorithm aD belong to this algorithm.+ In addition, the following error is also thrown:++ NotExpected t: Thrown when any of the terms in ts is not a recursive lambda expresión.+ t is the term being processed when the error occurred.++----------- La implementación ------------++Function aA calls aA', which collecs parameters+from lambda expresions.++> aA fs ts = sequence . zipWith (aA' id (zip fs (map countArgs ts))) fs$ ts+> where countArgs (Tlamb _ t) = 1 + countArgs t+> countArgs t = 0++Having found the last lambda expression, function aA'' is called++> aA' :: ([Boundvar]->[Boundvar]) -> [(Variable,Int)] -> Variable -> Term -> FusionState ([Boundvar],[Term],[InputLine])+> aA' fvars fs f (Tlamb bv t) =+> do res<-aA' (fvars.(bv:)) fs f t+> return res+>+> aA' vsis fs f (Tcase t0 ps ts) =+> aA'' fs f (vsis []) t0 ps ts++It is supposed that a case comes after all the lambda expressions,+but if not we improvise a dummy case:+ case () of ()->t+to apply the algorithm anyway. This works for functions like repeat, which+have no recursive argument++> aA' vsis fs f t =+> do res<-aA'' fs f (vsis []) (Ttuple False []) [pany] [t]+> return res++Being this the invocation of to function aA+ aA f (\vs1 \vs2 .. \vsm -> case t0 of alternatives)+call to function aA'' looks like++> aA'' :: [(Variable,Int)] -> Variable -> [Boundvar] -> Term ->+> [Pattern] -> [Term] -> FusionState ([Boundvar],[Term],[InputLine])+> aA'' fs f recs'' t' ps' ts' =+> do (recs,t,ps,ts) <- lift$ removePas recs'' t' ps' ts'+> let recs' = splitVars t0s (\bv t -> not$ null$ intersect (vars t)$ vars$ bv) recs t0s -- variables to insert in the case+> t0s = termToList t+> t0s' = adaptTerms recs' t0s+> ps' = map (adaptPattern recs' t0s) ps+> if not (matchOrder recs t0s') +> then throwError$+> Msg$ show f++": Order or ammount of recursive arguments "+> ++"does not match with the main case."++show recs++" "++show t0s'+> else do lines <- sequence (zipWith (appD recs) +> ps'+> ts)+> return (recs,t0s',lines)+> where matchOrder (Bvar bv:bvs) (Tvar v:ts) = bv==v && matchOrder bvs ts+> matchOrder (_:bvs) (_:ts) = matchOrder bvs ts+> matchOrder [] [] = True+> matchOrder _ _ = False+> -- calls aD. pis are the argument indexes for+> -- each t0, recs are the recursive arguments,+> -- pi is the pattern in a case alternative and ti the corresponding term.+> appD recs pi ti =+> let ps = patternToList pi+> in do r<-aD [(i,vars r++vars p) | (i,Bvar r,p)<-zip3 [0..] recs ps]+> (union (vars recs) (vars ps)) fs ti+> return (ps,r)+> adaptPattern recs [] p = ptuple$ map (toPat (vars p))$ concat$ recs+> adaptPattern recs t0s p = +> ptuple$ intersperse (map (map (toPat (vars p))) recs) (patternToList p)+> toPat vps (Bvtuple _ bvs) = Ptuple (map (toPat vps) bvs)+> toPat vps (Bvar v) | elem v vps = pany+> | otherwise = Pvar v+> adaptTerms recs t0s = intersperse (map (map bv2term) recs) t0s+> eqTermBv (Tvar v) (Bvar v') = v==v'+> eqTermBv (Ttuple _ bvs) (Bvtuple _ ts) = and . zipWith eqTermBv bvs$ ts+> eqTermBv _ _ = False+> splitVars :: [b] -> (a->b->Bool) -> [a] -> [b] -> [[a]]+> splitVars bst p [] bs = []+> splitVars bst p as [] = [as]+> splitVars bst p as bs = let (as',ass) = break (flip any bst . p) as+> (bs',bss) = break (p (head ass)) bs+> tail' [] = []+> tail' ls = tail ls+> in if null ass then [as']+> else as' : map (const []) bs' ++ splitVars bst p (tail' ass) (tail' bss)++> intersperse :: [[a]] -> [a] -> [a]+> intersperse (as:ass) (b:bs) = as ++ b : intersperse ass bs+> intersperse ass [] = concat ass+> intersperse [] bs = bs+++Removes @-patterns from top level patterns in the main case.+\(v1,v2) -> case (v1,v2) of+ a@[] [] -> t1+ b@(x:xs) _ -> t2+is converted to+\(u,v2) -> case (u,v2) of+ [] [] -> t1[u/a]+ (x:xs) _ -> t2[u/b]++> removePas :: [Boundvar] -> Term -> [Pattern] -> [Term] -> VarGenState ([Boundvar],Term,[Pattern],[Term])+> removePas bvs t0 ps ts =+> do removeus <- sequence (zipWith removable t0s pss)+> let catremoveus = catMaybes removeus+> if null catremoveus then return (bvs,t0,ps,ts)+> else let (pss',sustss)=unzip$ zipWith removePas' removeus pss+> in return (map (alphaConvert [] catremoveus) bvs+> ,substitution (map (\(v,u)->(v,Tvar u)) catremoveus) t0+> ,map ptuple$ transpose pss'+> ,zipWith substitution (map catMaybes$ transpose sustss) ts)+> where t0s = termToList t0+> pss = transpose$ map patternToList ps+> removePas' (Just (_,u)) ps = (map remPas ps,map (getPas (Tvar u)) ps)+> removePas' _ ps = (ps,[])+> removable :: Term -> [Pattern] -> VarGenState (Maybe (Variable,Variable))+> removable (Tvar v) ps = if any isPas ps then getFreshVar "t" >>= \u->return (Just (v,u)) else return Nothing+> removable _ _ = return Nothing+> remPas (Pas _ p) = p+> remPas p = p+> getPas u (Pas v _) = Just (v,u)+> getPas u _ = Nothing+> isPas (Pas _ _) = True+> isPas _ = False++> termToList (Ttuple _ t0s) = t0s+> termToList t = [t]+> patternToList (Ptuple ps) = ps+> patternToList p = [p]
+ HFusion/Internal/FunctorRep.lhs view
@@ -0,0 +1,768 @@+-- Please, see the file LICENSE for copyright and license information.++> {-# LANGUAGE PatternGuards #-}++% ===============================================================================================+% $Id: FunctorRep.lhs,v 1.75 2006/06/21 17:04:41 fdomin Exp $ +% Este archivo contiene las funciones que extraen la información de algebras y coalgebras+% necesaria para realizar fusión.+%+% ===============================================================================================++>module HFusion.Internal.FunctorRep where++> import HFusion.Internal.HyloRep+> import HFusion.Internal.Parsing.HyloContext+> import HFusion.Internal.HyloFace+> import List+> import Maybe(catMaybes)+> import HFusion.Internal.Utils+> import HFusion.Internal.RenVars+> import Control.Monad.Error(throwError)+> import Control.Monad.State(runState,get,put,State)+> import Control.Monad.Trans(lift)+> import Control.Monad(zipWithM)+> import qualified Data.Map as M(lookup,adjust,insert)++> import HFusion.Internal.Messages++ import Debug.Trace++> import HFusion.Internal.Inline+> import HFusion.Internal.HsPretty++ sss t = trace (show t)+++> cargs h1 h2 = setContext (combineContexts (getContext h1) (getContext h2))++> remap :: CHylo h => [[(Position,Int)]] -> h a b -> h a b +> remap idxs h = setFunctor (zipWith remapPositions idxs (getFunctor h)) h++This functions tries to derive outF for a hilomorfism. It calls basicCAR (see below for an explanation)+and rearrange patterns if possible. Patterns must be non nested aplications of constructors to variables,+if this is not the case, nested positions are replaced by a variable an the pattern is move to a natural +transformation (the position is made non recursive if necessary).++> getCata :: CHylo h => [h a Psi] -> h a Psi -> FusionState (h a OutF)+> getCata hs h' =let (vsm,t0,Psi psis)=getCoalgebra h in+> if length t0 /= 1 || length vsm /= 1 then throwError NotOutF+> else if repitePatron (map (head . getPatterns) psis)|| distinct (head vsm) (head t0) +> then throwError NotOutF+> else do res<-sequence$ zipWith3 analizePsii (getFunctor h) (getEta h) psis+> let (etas,outF,fncs)=unzip3 res+> return$ setEta etas.setFunctor fncs.setCoalgebra (vsm,t0,OutF outF)$ h+> where+> h=basicCAR hs h'+> analizePsii fnc etai psii =+> let analizePattern (Pvar v) = return (Right v,[])+> analizePattern p = do u<-lift$ getFreshVar "p"+> return (Left (u,p),vars p)+> ts = getTerms psii+> in case (head . getPatterns) psii of+> Pcons c ps -> do res<-mapM analizePattern ps+> let (ps',vs)=unzip res+> (change,nchange)=partition (flip elem (concat vs).t2v.getTerm) ts+> vss = map getPosition change+> (vt0s,pi)=unzip$ getvt0pi ps'+> t0s=zipWith tupleterm vt0s (map Tvar vt0s)+> inputs=map (either fst id) ps'+> applyH p = maybe id (\i->applyHyloWithCtxCntArgs (getContext h) (hs!!i))$ getRecIndex fnc p+> para p = mapStructure (applyH p (Tvar p)) (Tvar p)$ expanded fnc p+> return$ (etai `rightCompose` EOsust vss (map para vss) (map (Bvar .getPosition) ts)+> `rightCompose` EOlet (map getTerm t0s) pi (vt0s++map getPosition nchange) +> (map (getTermLet change) ts),+> OutFc (c,inputs,t0s++nchange),+> makePosNR vss fnc)+> _ -> throwError NotOutF+> getvt0pi (Left p:ps) = p:getvt0pi ps+> getvt0pi (_:ps) = getvt0pi ps+> getvt0pi [] = []+> getTermLet change tt = if elem tt change then getTerm tt else Tvar (getPosition tt)+> distinct (Bvar v) (Tvar v') = v/=v'+> distinct _ _ = True+> repitePatron (Pcons c _:ps) = any (has c) ps || repitePatron ps+> repitePatron [] = False+> repitePatron _ = True+> has c (Pcons c' _) = c==c'+> has c _ = True+> tt2v ts v = filter ((v==).t2v.getTerm) ts+> t2v (Tvar v) = v+> t2v _ = error$ coalgebra_Should_Not_Return_Terms_Diffrent_From_Vars+++Coalgebra positions which are not variables and are recursive must be converted to none+recursive positions in order to call outF to the coalgebra.+We also check that each recursion of multiple functions is made over different arguments,+if this is not the case we make non recursive all but one of the conflicting calls.++> basicCAR :: CHylo h => [h a b] -> h a Psi -> h a Psi+> basicCAR hs h = let (etas,psis',fncs)=unzip3$ zipWith3 analizePsii (getFunctor h) (getEta h) psis+> in setEta etas.setFunctor fncs.setCoalgebra (vsm,t0s,Psi psis')$ h+> where+> (vsm,t0s,Psi psis)=getCoalgebra h+> analizePsii fnc etai psii =+> let isNonVarRec tt = case getTerm tt of+> Tvar v -> False+> Ttuple _ ts | all isVar ts && length ts==length t0s -> False+> t -> isRec fnc$ getPosition tt+> isVar (Tvar _) = True+> isVar _ = False+> ts = getTerms psii+> (change,nchange)=partition isNonVarRec ts+> pos=map getPosition change++posToNR+> posToNR = let ts1 = filter (maybe False (const True).fst) $ map (\t->(getRecIndex fnc (getPosition t),t)) (ts\\change)+> ts2 = nubBy (\(i1,t1) (i2,t2)-> (i1/=i2) && (getTerm t1==getTerm t2)) ts1+> in map (getPosition.snd) (ts1\\ts2)+> nuevas = nub.concat.map (filter (flip elem (vars$ (head . getPatterns) psii)).vars.getTerm)$ change+> para tt = let p=getPosition tt +> t = if elem tt change then getTerm tt else Tvar p+> applyH = maybe id (\i->applyHyloWithCtxCntArgs (getContext h) (hs!!i))$ getRecIndex fnc p+> in if elem p pos then mapStructure (applyH t) t$ expanded fnc p+> else t+> nuevastts = zipWith tupleterm nuevas (map Tvar nuevas)+> in (etai `rightCompose` if null pos then EOid else EOgeneral (map Bvar$ nuevas++map getPosition nchange) (map para ts),+> setTerms (nuevastts++nchange) psii,+> makePosNR pos fnc)+++> getAna :: CHylo h => [h Phii ca] -> h Phii ca -> FusionState (h InF ca)+> getAna hs h = let phis = getAlgebra h in+> do res<-sequence$ zipWith (\phii fnc->analizePhii (getVars phii) fnc (unwrapA phii)) phis (getFunctor h)+> let (inF,fncs)=unzip res+> return$ setFunctor fncs.setAlgebra (zipWith (wrapA.getVars) phis inF)$ h+> where+> analizePhii :: [Boundvar] -> HFunctor -> TermWrapper Phii -> FusionState (TermWrapper InF,HFunctor)+> analizePhii inputs fnc t = do (vs,inF)<-mapTWaccM inputs (analizePhii' fnc) concat [] t+> return (inF,makePosNR vs fnc)+> analizePhii' fnc inputs t =+> let analizeTerm (Tvar _) = []+> analizeTerm t = foldl (\r (v,m)->maybe r (\i->(v,i):r) m) []$ map (\v->(v,getRecIndex fnc v))$ vars t+> in case t of+> Tcapp c ts -> let pvs=concat$ map analizeTerm ts +> vs = map fst pvs+> eta=(EOgeneral inputs ts) `leftCompose` +> EOsust vs (map (\ (v,i)->applyHyloWithCtxCntArgs (getContext h) (hs!!i) (Tvar v)) pvs) inputs `leftCompose` idEta+> in return (vs,(if isIdEta eta then id else flip TWeta eta) (TWsimple$ InF (c,ts)))+> Tcase t0 ps ts -> do res<-mapM (analizePhii' fnc inputs)$ ts +> let (vs,inFs)=unzip res+> return$ ((concat vs++).filter (isRec fnc).vars$ t0,TWcase t0 ps inFs)+> t -> let pvs = analizeTerm t+> vs = map fst pvs+> eta=EOgeneral inputs [t] `leftCompose` +> EOsust vs (map (\ (v,i)->applyHyloWithCtxCntArgs (getContext h) (hs!!i) (Tvar v)) pvs) inputs `leftCompose` idEta+> in do u<-case t of Tvar v -> return v; _ -> lift$ getFreshVar "v"+> return (vs,(if isIdEta eta then id else flip TWeta eta) (TWsimple$ InF ("_",[Tvar u])))+++A function used for debugging purposes++ showRawTW :: TermWrapper a -> Doc+ showRawTW (TWcase t0 ps tw) = (text "case"<+>showDoc t0<+> text "of")+ $$ vcat (zipWith (\p t -> showDoc p<+>text "->"<+>showRawTW t) ps tw) <+> text "EndCase" -- $$+ showRawTW (TWeta tw e) = showRawTW tw <+>text "."<+>showDoc e+ showRawTW (TWsimple a) = text "TWsimple a"+ showRawTW (TWacomp a) = text "TWacomp "<+>text (show (getVars a))<+>showRawTW (unwrapA a)<+> text "EndTWacomp"+ showRawTW TWbottom = text "TWbottom"++++Builds a natural transformation for a paramorphism wich makes copies of recursive variables,+it can apply some function over the copies.++> etaPara :: (Term -> Term) -> HFunctor -> [Boundvar] -> (TupleTerm -> Term) -> [TupleTerm] -> EtaOp+> etaPara h fnc input sel output = EOgeneral input (map applyh output)+> where applyh tt = let seltt=sel tt+> in if any (isRec fnc).t2positions$ tt+> then mapStructure seltt (h seltt) (expanded fnc (getPosition tt))+> else mapStructure seltt seltt (expanded fnc (getPosition tt))+> t2positions tt = +> case getTerm tt of+> Tvar vt -> getPositions output vt+> Ttuple _ ts | all isVar ts -> concat . map (getPositions output) . nub . vars $ ts+> t -> error ("FunctorRep: etaPara: unexpected tuple term: "++show t)+> isVar (Tvar _) = True+> isVar _ = False++> fst3 (a,_,_)=a+> snd3 (_,a,_)=a+> thrd3 (_,_,a)=a+++buildParaStructure applies function calls over non-recursive uses of recursive variables in+a hylomorfism. This works for cata-ana fusion for the algebra side of the fusion result.++> buildParaStructure :: (Int->Term -> Term) -> HFunctor -> [(Variable,(Int,ParaFunctor))] +> -> [Variable] -> [TupleTerm] -> EtaOp+> buildParaStructure h fnc mvs input output = EOgeneral (map buildInput input) (map buildOutput output)+> where buildInput v = maybe (Bvar v) (buildBv v .snd)$ lookup v mvs+> buildOutput tt = let pf = case expanded fnc (getPosition tt) of+> p@(PFcnt _) -> maybe p (maybe (PFcnt vt) id . getInnermostNonRecVar . snd)$ lookup vt mvs+> pf' -> pf'+> t@(Tvar vt)=getTerm tt+> in maybe (foldPF (const t) (const t) (Ttuple False) pf) (\(i,_)->foldPF Tvar (h i.Tvar) (Ttuple False) pf)$ lookup vt mvs+> buildBv v (PFprod []) = Bvar v+> buildBv _ pf = foldPF Bvar Bvar (Bvtuple False) pf+> getInnermostNonRecVar (PFprod pfl) | all (not . isPFprod) pfl = find isPFcnt pfl+> | otherwise = case catMaybes (map getInnermostNonRecVar pfl) of+> p:_ -> Just p+> [] -> Nothing+> getInnermostNonRecVar _ = Nothing+> isPFcnt (PFcnt _) = True+> isPFcnt _ = False+> isPFprod (PFprod _) = True+> isPFprod _ = False++paraMKNR applies function calls over positiones that are beign made non recursive in+a hylomorfism. This works for cata-ana fusion for the algebra side of the fusion result.++> paraMKNR :: (Int->Term->Term) -> HFunctor -> [Position] -> [Boundvar] -> EtaOp+> paraMKNR applyHList fnc pos inputs = +> let applyH p = maybe (Tvar p) (flip applyHList (Tvar p))$ getRecIndex fnc p+> genInputs bv@(Bvar v) | isRec fnc v = foldPF Bvar Bvar (Bvtuple False) (expanded fnc v)+> | otherwise = bv+> genInputs (Bvtuple b bvs) = Bvtuple b (map genInputs bvs)+> susts p = foldPF (:[]) (const []) concat (expanded fnc p)+> pos' = concat$ map susts pos+> in EOsust pos' (map applyH pos') (map genInputs inputs)++> applyHyloList hs h i i' | i==i' = applyHyloWithCtxCntArgs (getContext h) h+> | otherwise = applyHyloWithCtxCntArgs (getContext h) (hs!!i')++> applyHyloListCtx hs h ctx i i' | i==i' = applyHyloWithCtxCntArgs ctx h+> | otherwise = applyHyloWithCtxCntArgs ctx (hs!!i')++> applyHyloWithCtxCntArgs ctx h t = applyHyloWithCntArgs h (map Tvar (getConstantArgs ctx)) (getCntArgPos ctx) t+++> fusionarSimple :: (CHylo hylo,Vars a, AlphaConvertible a, Vars ca, AlphaConvertible ca, VarsB ca,VarsB a,TermWrappable a,HasComponents ca) => +> [hylo a OutF] -> Int -> [hylo InF ca] -> Int -> FusionState (Int,[hylo a ca])+> fusionarSimple hs1 i1 hs2 i2 = fusionarSimpleAcc [((i1,i2),0)] [(i1,i2)]+> where +> fusionarSimpleAcc accfi@((_,acci):_) is = +> do res<-mapM (\(i1,i2)->do (h1,h2)<-lift$ renameVariables (hs1!!i1) (hs2!!i2) [];fusionarSimple' h1 i1 h2 i2) is+> let (ws,hs,hused) = unzip3 res+> nused = nub [ p | ll<-hused, l<-ll, (_,p)<-l, all ((/=p).fst) accfi]+> lnused = length nused+acci+> accfi'= zip nused [acci+1..lnused]++accfi+> recmaps = map (map (map (\(v,p)->maybe (error "fusionarSimple: recmaps") (\i->(v,i))$ lookup p accfi'))) hused+> hs'=zipWith remap recmaps hs+> in if null nused then return (sum ws,hs') +> else do (w,hss)<-fusionarSimpleAcc accfi' nused+> return (w+sum ws,hs'++hss)+> fusionarSimpleAcc [] is = error$ "fusionarSimpleAcc: unexpected empty request list"+> fusionarSimple' :: (CHylo hylo,HasComponents ca,TermWrappable a) => hylo a OutF -> Int -> hylo InF ca -> Int +> -> FusionState (Int,hylo a ca,[[(Position,(Int,Int))]])+> fusionarSimple' h1 i1 h2 i2 = +> do res<-zipWithM (fusionar lines) inF fncs2+> let (acc,phis,hused)=unzip3 res+> (matches,fncs2')=unzip acc+> return (sum matches,cargs h1 h2.setAlgebra phis.setFunctor fncs2'$ h2,hused)+> where+> inF=getAlgebra h2+> fncs2 = getFunctor h2+> (_,_,OutF outF)=getCoalgebra h1+> lines= zip4 (getAlgebra h1) (getEta h1) (getFunctor h1) outF+> fusionar :: TermWrappable a => [(Acomponent a,Etai,HFunctor,OutFi)]->Acomponent InF->HFunctor+> -> FusionState ((Int,HFunctor),Acomponent a,[(Position,(Int,Int))])+> fusionar lines1 inf fnc2 = +> do let accumCase acc = let (is,ls,hused)=unzip3 acc+> in (sum is,concat ls,concat hused)+> ((i,mvs,hused),tw)<-mapTWaccM (getVars inf) (buildAlg lines1 fnc2) accumCase (0,[],[]) (unwrapA inf)+> return ((i,expandPositions mvs$ fnc2),wrapA (getVars inf) tw,hused)+> buildAlg :: TermWrappable a => [(Acomponent a,Etai,HFunctor,OutFi)]->HFunctor->[Boundvar]->InF+> -> FusionState ((Int,[(ParaFunctor,Position)],[(Position,(Int,Int))]),TermWrapper a)+> buildAlg lines1 fnc2 input2 (InF ("_",[t@(Tvar v)])) +> | Just i2<-getRecIndex fnc2 v = return ((1,[],[(v,(i1,i2))]),TWacomp$ wrapA [Bvar v] (TWsimple (wrapTerm t)))+> | otherwise = return ((0,[],[]),TWacomp$ wrapA [Bvar v] (TWsimple (wrapTerm (applyHyloList hs1 h1 i1 i1 t))))+> buildAlg lines1 fnc2 input2 (InF (c,inFoutput))=+> case find (fbranch c) lines1 of+> Just (phi1,eta1,fnc1,OutFc (_,input1,outFoutput))->+> do res<-zipWithM (match fnc1 fnc2 outFoutput) input1 inFoutput+> let (matches,mvs,izqs,hused)=unzip4 res +> cizqs=concat izqs+> cmvs=concat mvs+> cmvs'=map (\(a,_,i,(pf,_))->(a,(i,pf))) cmvs+> toVar (Tvar v)=v+> toVar t = error$ "buildAlg: toVar: unexpected term: "++show t +> mkNRh1= paraMKNR (applyHyloList hs1 h1 i1) fnc1 cizqs (map (Bvar .getPosition) outFoutput)+> epara= buildParaStructure (applyHyloList hs2 h2 i2) (makePosNR cizqs fnc1) cmvs' input1 outFoutput+> return ((sum matches,map (\(_,_,_,a)->a) cmvs,concat hused),+> phi1 `composeEta` eta1 `rightCompose` mkNRh1 `rightCompose` epara)+> _ -> return ((0,[],[]),TWbottom)+> fbranch cn (_,_,_,OutFc (cn',_,_)) = cn'==cn+> match :: HFunctor -> HFunctor -> [TupleTerm] -> Variable->Term->+> FusionState (Int,[(Variable,[Position],Int,(ParaFunctor,Position))],[Position],[(Position,(Int,Int))])+> match fnc1 fnc2 out v t =+> let posv=getPositions out v+> in case t of+> Tvar vt | Just i2<-getRecIndex fnc2 vt ->+> let hused= map (\i->(vt,(i,i2))) $ catMaybes$ map (getRecIndex fnc1) posv+> freshConstVar (PFcnt _) = getFreshVar "v" >>= return . PFcnt+> freshConstVar pf = return pf+> in do expds<-lift$ mapM freshConstVar$ map (expanded fnc1) posv+> return (length (filter (isRec fnc1) posv),[(v,posv,i2,(mkpf' expds,vt))],[],hused)+> _ -> return (0,[],posv,[])+> mkpf' [bv] = bv+> mkpf' bvs = PFprod bvs+++> fusionarTau :: (CHylo h,WrapTau a,HasComponents cb,VarsB cb,AlphaConvertible cb,Vars cb,VarsB a,AlphaConvertible a,Vars a) =>+> [h a OutF] -> Int -> [h Phii cb] -> Int -> VarGenState (Int,[h Tau cb])+> fusionarTau hs1 i1 hs2 i2 = fusionarTauAcc [((i1,i2),0)] [(i1,i2)]+> where +> fusionarTauAcc accfi@((_,acci):_) is = +> do res<-mapM fusionarTau' is+> let (ws,hs,hused) = unzip3 res+> nused = nub$ map snd$ concat$ map (concat . map (filter (\(_,pair)->all ((/=pair).fst) accfi))) hused+> lnused = length nused+acci+> accfi'= zip nused [acci+1..lnused]++accfi+> recmaps = map (map (map (\(v,p)->maybe (error "fusionarTau: recmaps") (\i->(v,i))$ lookup p accfi'))) hused+> hs'=zipWith remap recmaps hs+> if null nused then return (sum ws,hs') +> else fusionarTauAcc accfi' nused >>= (\(w,hss)->return (w+sum ws,hs'++hss))+> fusionarTauAcc [] is = error$ "fusionarTauAcc: unexpected empty request list"+> fusionarTau' (i1,i2) =+> do (h1,h2')<-renameVariables (hs1!!i1) (hs2!!i2) []+> h2<-toPara hs2 h2' i2+> let psitts=getComponentTerms.(\(_,_,a)->a).getCoalgebra$ h2+> lines h1=let (_,_,OutF outF)=getCoalgebra h1 in zip4 (getAlgebra h1) (getEta h1) (getFunctor h1) outF+> linesh=map lines hs1+> phis=getAlgebra h2+> gt eta2 fnc2 phii psitts= +> do ((matches,ders,hused),tau)<-getTau linesh i1 fnc2 phii+> let mkNRh2=paraMKNR (applyHyloList hs2 h2 i2) fnc2 ders$ map (Bvar .getPosition) psitts+> return (matches,tau,eta2 `rightCompose` mkNRh2,+> makePosNR ders fnc2,hused)+> res<-sequence$ zipWith4 gt (getEta h2) (getFunctor h2) phis psitts+> let (matches,taus,etas,fncs,hused)=unzip5 res+> st<-get+> return (sum matches,cargs (head hs1) h2.setAlgebra (zipWith (\p t->wrapA (getVars p) (TWsimple .wrapTau$ t)) phis taus).+> setEta etas.setFunctor fncs$ h2, hused)+> getTau :: [[(a,Etai,HFunctor,OutFi)]]->Int->HFunctor->Acomponent Phii+> ->VarGenState ((Int,[Position], [(Position,(Int,Int))]),TermWrapper (TauTerm a))+> getTau psis ih1 fnc2 phi =+> mapTWvars (getVars' phi) (buildTW psis ih1 fnc2)+> ((\ (ms,ps,hused)->(sum ms,concat ps,concat hused)).unzip3) (0,[],[]) (unwrapA phi)+> getVars' phi = concat (map two (getVars phi))+> two (Bvtuple False [Bvar a,Bvar b]) = [(a,b)]+> two _ = []+> h1 = hs1 !! i1+> fapp i1 t =Ttuple False [t,applyHyloWithCtxCntArgs (getContext h1) h1 t]+> pi2 t = case t of Taupair _ t2 -> t2+> Taucata ft tau -> Taucata (pi2'.ft) tau+> _ -> error "fusionarTau: pi2: No se esperaba el termino."+> pi2' t= case t of Ttuple _ [t1,t2] -> t2;_ -> error "fusionarTau: pi2': No se esperaba el termino."+> buildTW psis ih1 fnc2 pairs t =+> case t of+> Tcase t0 ps ts -> do res<-mapM (buildTW psis ih1 fnc2 pairs) ts+> let (acc,taus)=unzip res+> (matches,ders,hused)=unzip3 acc+> return ((sum matches,concat ders,concat hused),TWcase t0 ps taus)+> _ -> do (acc,tau)<-buildTauTerm psis ih1 fnc2 pairs t; return (acc,TWsimple (pi2 tau))+> buildTauTerm psis ih1 fnc2 pairs t =+> case t of+> Tcapp c ts -> +> case find (fbranch c) (psis!!ih1) of+> Just (phii,etai,fnc1,ca@(OutFc (_,input,output))) -> +> do res<-sequence$ zipWith (match fnc1 fnc2 output) input ts+> let (acc,taus)=unzip res+> (matches,ders,hused)=unzip3 acc+> inFapply = Tcapp c (map getCnt taus)+> epara<-etaParaTau fnc1 input output+> return ((sum matches,concat ders,concat hused),+> (Taupair inFapply (Taucons c taus phii (etai `rightCompose` epara)+> )))+> Nothing -> return ((0,[],[]),Taupair Tbottom (Tausimple Tbottom))+> Tvar v -> return$ maybe ((0,[],[]),Taucata (fapp ih1) (Tausimple t))+> (\ih2->((1,[],[(v,(ih1,ih2))]),Taupair (Tvar$ replv v) (Tausimple t)))+> $ getRecIndex fnc2 v +> _ -> return ((0,filter (isRec fnc2)$ vars t,[]),Taucata (fapp ih1) (Tausimple t))+> where+> replv v = maybe (error (fuse_Tau_Operation_Label ++ ":" ++ {-show pairs++show v++-} var_Rec_Not_Binded)) +> fst (find ((v==).snd) pairs)+> fbranch cn (_,_,_,OutFc (cn',_,_)) = cn'==cn+> match fnc1 fnc2 out v t =+> case find (maybe False (const True))$ map (getRecIndex fnc1) (getPositions out v) of+> Just (Just ih1') -> buildTauTerm psis ih1' fnc2 pairs t+> _ -> return ((0,filter (isRec fnc2)$ vars t,[]),Tausimple t)+++> getCnt (Tausimple t) = t+> getCnt (Taupair t _) = t+> getCnt (Taucata _ t) = getCnt t+> getCnt _ = error (fuse_Tau_Operation_Label ++ ":" ++ unexpected_Constructed_Pair)++> etaParaTau :: HFunctor -> [Variable] -> [TupleTerm] -> VarGenState EtaOp+> etaParaTau fnc input output = +> do ps<-parear fnc output input+> let selectV (Tvar x) = Tvar .maybe x id.flip lookup ps$ x+> selectV t = error$ "selectV: unexpected term: "++show t+> return$ etaPara selectV fnc (map (buildInput ps) input) getTerm output+> where -- find which positions must be duplicated, they are paired with fresh variables.+> parear fnc output lst = +> let parear' v | any (isRec fnc) (getPositions output v) = do u<-getFreshVar (varPrefix v); return [(v,u)]+> | otherwise = return []+> in do l<-mapM parear' input+> return (concat l)+> buildInput ps v = maybe (Bvar v) (Bvtuple False .(:[Bvar v]).Bvar) .flip lookup ps$ v+++> mapTWvars:: [(Variable,Variable)]->([(Variable,Variable)]->a->VarGenState (c,TermWrapper b))->([c]->c)+> ->c->TermWrapper a->VarGenState (c,TermWrapper b)+> mapTWvars lst 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 lst)+> (\a->do (c,tw)<-mapTWvars (getPairs$ getVars a) f1 f2 f3.unwrapA$ a+> return (c,TWacomp (wrapA (getVars a) tw)))+> (return (f3,TWbottom))+> where getPairs = concat.map getPair+> getPair (Bvtuple _ [Bvar v1,Bvar v2]) = [(v1,v2)]+> getPair bv = []++ This function is apropriate for converting a hilomorfism into a paramorfism when it is+about to beign fused with another hilomorfism on the left using cata-paragen law.++> toPara :: (CHylo h,HasComponents ca) => [h a ca] -> h a ca -> Int -> VarGenState (h a ca)+> toPara hs h ih = +> do let (_,_,cas)=getCoalgebra h+> res <- sequence$ zipWith4 splitRecPos (getAlgebra h) (getEta h) (getFunctor h) (getComponentTerms cas)+> let (alg,etas,fncs)=unzip3 res+> return. setAlgebra alg . setEta etas. setFunctor fncs$ h+> where splitRecPos a eta fnc tts = +> do (_,TWacomp a',ps)<-handleAcomp a+> let changeVars = map ((\(PFprod (PFcnt v:_))->v).fst) ps+> fnc'=expandPositions ps fnc+> e = EOsust changeVars (zipWith applyMutualHylo (map snd ps) changeVars) (inputList fnc')+> return (a',eta `rightCompose` e,fnc')+> where inputList fnc' = map (foldPF Bvar Bvar (Bvtuple False) . expanded fnc') (map getPosition tts)+> inside :: TermWrapper a -> VarGenState (Bool,TermWrapper a,[(ParaFunctor,Position)])+> inside = foldTWM handleCase (\(b,tw,ps) e->return (b,TWeta tw e,ps)) (\a->return (False,TWsimple a,[]))+> handleAcomp (return (True,TWbottom,[]))+> handleCase t0 ps bs = let (bools,tws,pairs)=unzip3 bs+> in return (and bools,TWcase t0 ps tws,concat pairs)+> handleAcomp :: Acomponent a -> VarGenState (Bool,TermWrapper a,[(ParaFunctor,Position)])+> handleAcomp a = +> do (b,tw,ps)<-inside (unwrapA a)+> if b then return (b,TWacomp (wrapA (getVars a) tw),ps)+> else do res<-mapM pair (getVars a)+> let (bvs,pairs)=unzip res+> return (True,TWacomp (wrapA bvs tw),concat pairs++ps)+> pair bv@(Bvar v) +> | isRec fnc v = do u<-getFreshVar (varPrefix v)+> return (Bvtuple False [Bvar u,bv],[(PFprod [PFcnt u,PFid v],v)])+> | otherwise = return (Bvar v,[])+> pair _ = error (fuse_Tau_Operation_Label ++ ":" ++ " toPara: " ++ unexpected_Non_Variables)+> applyMutualHylo p v = maybe (Tvar v) (\i->applyHyloList hs h ih i (Tvar v))$ getRecIndex fnc p++++This function removes nested patterns by introducing cascade cases on the coalgebra, it also abstracts calls+to outF.++> data STfl = STfl {ivar::VarGen,matches::Int}++> deriveSigmaPatterns :: Int -> Int -> [(PatternS,[TupleTerm],HFunctor)] +> -> [[(Acomponent InF,HFunctor)]] -> VarGenState (Int,[PatternS],[[((Position,Int),(Int,Int))]])+> deriveSigmaPatterns ih2 ia pts inF = +> do i<-get +> let (pshused,STfl i' matches) = runState (mapM (derivePattern' inF)$ pts) (STfl i 0)+> let (ps,hused) = unzip pshused+> put i'+> return (matches,ps,concat hused)+> where getFreshVar pr = do k<-get+> case M.lookup pr (ivar k) of+> Just i -> put (k {ivar=M.adjust (+1) "v" (ivar k)}) >> return (Vgen pr i)+> _ -> put (k {ivar=M.insert "v" 1 (ivar k)}) >> return (Vgen pr 0)+> derivePattern' inF (Ppattern v p,tts,fnc1) = derivePattern ih2 v inF p tts fnc1 Pdone+> derivePattern' inF (p,_,_) = error$ "deriveSigmaPatterns: derivePattern': unexpected pattern: "++show p+> derivePattern :: Int -> Variable -> [[(Acomponent InF,HFunctor)]] -> Pattern -> [TupleTerm]+> -> HFunctor -> PatternS -> State STfl (PatternS,[[((Position,Int),(Int,Int))]])+> derivePattern ih2 t0 inF (Pcons c ps) tts fnc1 t = +> do let cocs = collectC c (inF!!ih2)+> args<-mapM generateVars ps+> let ps' = map removePas ps+> ts<- mapM (buildAlt (zip args ps')) cocs+> let (ts',hused)=unzip (concat ts)+> return (PcaseR ih2 t0 c args ts',concat hused)+> where +> generateVars (Pvar v) | not (isPany v) = getFreshVar (varPrefix v)+> generateVars (Pas v _) | not (isPany v) = getFreshVar (varPrefix v)+> generateVars _ = getFreshVar "v"+> isPany (Vuserdef "_") = True+> isPany _ = False+> removePas (Pas _ p) = p+> removePas p = p+> buildAlt args (inFs,fnc2) = mapM (checkArg args fnc2) $ inFs+> checkArg args fnc2 (InF (c,ts)) = +> do (t,izqs,hused)<-foldrM (buildCase2 fnc2) (t,[],[[]]) (zip args ts)+> return ((t,izqs),hused)+> getr fnc2 t = case t of (Tvar vt) -> getRecIndex fnc2 vt; _ -> Nothing+> getrecindex fnc2 (Tvar vt) = getRecIndex fnc2 vt+> getrecindex _ t = error$ "getrecindex: unexpected term: "++show t+> buildCase2 :: HFunctor -> ((Variable,Pattern),Term) ->+> (PatternS,[Variable],[[((Position,Int),(Int,Int))]]) -> +> State STfl (PatternS,[Variable],[[((Position,Int),(Int,Int))]]) +> buildCase2 fnc2 ((u,p),t) (sigOk,nrec,hused0) =+> let vp = vars p in+> maybe (return (PcaseS u p sigOk, u:nrec, hused0))+> (\i2-> do (t',hused1)<-derivePattern i2 u inF p tts fnc1 sigOk+> return (t',nrec, [ l1++l2 | l1<-hused0, l2<-hused1]))+> $ getr fnc2 t+> derivePattern ih2 t0 inF p@(Pvar vp) tts fnc1 t =+> let pos = getTupletermsWithArgIndexes tts vp+> ipos = [ (i,ppos) | ppos@(tt,_)<-pos, Just i<-[getRecIndex fnc1 (getPosition tt)], isValidRecArg fnc1 vp tt ]+> in if null ipos then return (PcaseSana ih2 t0 p t,[[]])+> else do k<-get+> put (k {matches=matches k+length ipos})+> return (PcaseS t0 p t,[[ ((getPosition tt,i1),(ia,ih2)) | (i1,(tt,ias))<-ipos, ia<-ias ]]) +> derivePattern ih2 t0 inF p _ _ t = return (PcaseSana ih2 t0 p t,[[]])+> isValidRecArg fnc1 vp tt = all (isValidInPos vp)$ (termToList (getTerm tt))+> isValidInPos vp (Tvar _) = True+> isValidInPos vp t = notElem vp (vars t)+> termToList (Ttuple _ ts) = ts+> termToList t = [t]+++> collectC :: Constructor -> [(Acomponent InF,HFunctor)] -> [([InF],HFunctor)]+> collectC c inFs = map collect' inFs+> where collect' :: (Acomponent InF,HFunctor) -> ([InF],HFunctor)+> collect' (inF,fnc2) = (collect'' inF,fnc2)+> collect'' :: Acomponent InF -> [InF]+> collect'' = foldTW (\_ _ is->concat is) const isC collect'' [] . unwrapA+> isC i@(InF (c',_)) | c==c' = [i]+> | otherwise = []++Returns for a given pattern the amount of cases it spawns.++> countCases :: PatternS -> Int+> countCases p =+> case p of+> Pdone -> 1+> PcaseS t0 p t -> countCases t+> PcaseSana i t0 p t -> countCases t+> PcaseR i t0 c vrs ps -> sum$ map (countCases . fst) ps+> _ -> error$ "FunctorRep: countCases: " ++ (unexpected_Pattern p)++La siguiente función construye sigma, retorna las ramas del hilomorfismo correpondiente.++> getSigma :: (CHylo h, HasComponents b, TermWrappable a ) => [h a ca] -> [[(Acomponent InF,HFunctor)]] -> +> h a Sigma -> Int -> Int -> [h InF b] -> h InF b -> Int -> [(Acomponent a,Etai,HFunctor)] ->+> FusionState (Int,Coalgebra Sigma,[(Acomponent a,Etai,HFunctor)],[[((Position,Int),(Int,Int))]])+> getSigma hs1 inF h1 ih1 ia hs2 h2 ih2 as = +> do +> let etas2 h2=zipWith3 applypara (getEta h2) (getFunctor h2).getComponentTerms.(\(_,_,ca)->ca).getCoalgebra$ h2+> applypara etai2 fnc2 tts = +> let para2 p = mapStructure (Tvar p) (Tvar p)$ expanded fnc2 p+> pos=map getPosition tts+> in etai2 `rightCompose` EOgeneral (map Bvar pos) (map para2 pos)+> v0s'' <-lift$ mapM regenVars v0s'+> (pss,tts',fcn1s',as',casemap)<-addInFNoConstructorCase (pss'!!ia) pss' tts (getFunctor h1) as casemap' h2+> (matches,sps,hused)<-lift$ deriveSigmaPatterns ih2 ia (zip3 (pss!!ia) tts' fcn1s') inF+> let t0t = bv2term (recbvtuple v0s'')+> caseCounts = map countCases$ sps+> joined = replicateList (replicateList casemap caseCounts) (zip as' (replicateList casemap (zip (transpose pss) tts')))+> (psb',psa') = splitAt ia pss+> (hsb',hsa') = splitAt ia hss+> return$ (matches,(v0b++recbvtuple v0s'':tail v0a,t0b++t0t:tail t0a,Sigma (zipWith (*) casemap caseCounts,tts',+> transpose (psb'++sps:(tail psa')),+> hsb'++ +> Just (ih2,getAlgebra h2,etas2 h2,wrapSigma (getCoalgebra h2), applyHyloWithCtxCntArgs (getContext h2).(hs2!!)) +> : tail hsa'+> )),+> map fst joined, hused)+> where (v0,t0s,Sigma (casemap',tts,pss'',hss))=getCoalgebra h1+> (v0b,v0a) = break ((head t0a==) . bv2term) v0+> (t0b,t0a) = splitAt ia t0s+> (v0s',_,_) = getCoalgebra h2+> pss' = transpose pss''+> regenVars (Bvar v) = getFreshVar (varPrefix v) >>= return . Bvar+> regenVars (Bvtuple b bvs) = mapM regenVars bvs >>= return . Bvtuple b+> recbvtuple [bv] = bv+> recbvtuple bvs = Bvtuple True bvs+> addInFNoConstructorCase ps@(Ppattern u0 _:_) pss tts fcn1s as casemap h2 | not (null inFs) =+> if all noNestedCons ps then+> do us<-lift$ zipWithM getPpatternVar t0s pss+> u1<-lift$ getFreshVar (varPrefix u0)+> let acomp = wrapA [Bvar u1] (TWsimple (wrapTerm (Tvar u1)))+> fnc = HF [(u1,ih1,map (:[]) [0..length us-1],PFid u1)]+> eqPRow (Ppattern _ (Pcons _ _),_,prow,_,_,_) (Ppattern _ (Pcons _ _),_,prow',_,_,_) = +> and$ zipWith matchPattern (take ia prow) (take ia prow')+> eqPRow _ _ = False+> matchPattern p0 p1 = nullPatternS p0 == nullPatternS p1+> to5 (_,a,b,c,d,e) = (a,b,c,d,e)+> ignorePattern (Ppattern _ _) u = Ppattern u (Pvar u)+> ignorePattern _ u = PcaseS u (Pvar u) Pdone+> addInFCons ls@((Ppattern _ (Pcons _ _),_,psrow,_,_,_):_) = +> map to5 ls ++ [((acomp,Etai ([],[]),fnc),+> take ia psrow++ Ppattern u0 (Pcons "_" [Pvar u1]) : drop (ia+1) (zipWith ignorePattern psrow us),+> [tupleterm u1 (Ttuple True$ zipWith (\i u->Tvar (if i==ia then u1 else u)) [0..] us)],+> fnc,1)]+> addInFCons ls = map to5 ls+> (as',pss',tts',fcn1s',casemap') = unzip5$ concat$ map addInFCons$ +> groupBy eqPRow (zip6 (pss!!ia) as (transpose pss) tts fcn1s casemap)+> return (transpose pss',tts',fcn1s',as',casemap')+> else throwError NotInF+> where inFs = filter (not.null.fst)$ collectC "_" (zip (getAlgebra h2) (getFunctor h2))+> noNestedCons (Ppattern _ (Pcons _ ps)) = all isVar ps+> noNestedCons (Ppattern _ (Pvar _)) = True+> noNestedCons (Ppattern _ p) = False+> noNestedCons _ = False+> isVar (Pvar _) = True+> isVar _ = False+> getPpatternVar (Tvar v) _ = return v+> getPpatternVar _ (Ppattern v _:_) = return v+> getPpatternVar _ (PcaseR _ v _ _ _:_) = return v+> getPpatternVar _ (PcaseS v _ _:_) = return v+> getPpatternVar _ (PcaseSana _ v _ _:_) = return v+> getPpatternVar _ _ = getFreshVar "v"+> addInFNoConstructorCase ps pss tts fnc1s as casemap _ = return (pss,tts,fnc1s,as,casemap)++> replicateList :: [Int] -> [a] -> [a]+> replicateList is = concat . zipWith replicate is++> nullPatternS :: PatternS -> PatternS+> nullPatternS (Ppattern _ p) = Ppattern (Vuserdef "") (nullPVariables p)+> nullPatternS (PcaseR _ _ c _ alts) = PcaseR 0 (Vuserdef "") c [] (map (\(p,_)->(nullPatternS p,[])) alts)+> nullPatternS (PcaseS _ p pts) = PcaseS (Vuserdef "") (nullPVariables p) (nullPatternS pts)+> nullPatternS (PcaseSana _ _ p pts) = PcaseSana 0 (Vuserdef "") (nullPVariables p) (nullPatternS pts)+> nullPatternS Pdone = Pdone++> nullPVariables (Pvar _) = Pvar (Vuserdef "")+> nullPVariables p@(Plit _) = p+> nullPVariables (Pcons c ps) = Pcons c (map nullPVariables ps)+> nullPVariables (Ptuple ps) = Ptuple (map nullPVariables ps)+> nullPVariables (Pas _ p) = Pas (Vuserdef "") (nullPVariables p)++Builds a natural transformation for a paramorphism wich applies a given function in +copies of recursive positions. ++> etaParaSigma :: [Variable] -> [Boundvar] -> Int -> Int -> [(Position,Int)] -> (Int -> Term -> Term) -> +> HFunctor -> HFunctor -> [TupleTerm] -> VarGenState EtaOp+> etaParaSigma bs v0s ia defaultIndex vis h fncOld fnc tts = +> do vts' <- if nr>1 then mapM (expandHyloMutipleArgs fncOld fnc . getPosition) tts+> else return$ map (Bvar . getPosition) tts+> -- variables which are recursive with respect to the ia argument+> let rs = (vars (v0s!!ia) \\ bs) ++ (concat$ map (recvars ia) tts)+> return$ EOgeneral vts' (zipWith (applyh rs) vts' tts)+> where nr = length v0s+> recvars ia tt = vars$ map (\(i,_)->filter isVar [termToList (getTerm tt)!!i])$ filter (elem ia.snd)$ zip [0..]$+> getArgIndexes fnc (getPosition tt) +> applyh :: [Variable] -> Boundvar -> TupleTerm -> Term+> applyh recs bv tt = +> let seltt = bv2term bv+> ih = maybe defaultIndex snd$ find (recPosFor tt) vis+> in if (not . null . intersect recs . vars . getTerm$ tt)+> then mapStructureBv bv2term (buildHyloApp (h ih) recs (getTerm tt)) bv$ expanded fnc (getPosition tt)+> else mapStructure seltt seltt (expanded fnc (getPosition tt))+> isVar (Tvar _) = True+> isVar _ = False+> expandHyloMutipleArgs fncOld fnc1 v +> | isRec fncOld v = let expArgs v = do bvs<-sequence$ replicate nr (getFreshVar (varPrefix v)) +> return$ bvtuple (map Bvar bvs)+> in foldPFM (return.Bvar) expArgs (return.Bvtuple False)$ expanded fnc1 v+> | otherwise = return$ Bvar v+> buildHyloApp h recs (Tvar v) (Bvar bv) | elem v recs = h (Tvar bv)+> buildHyloApp h recs (Ttuple b ts) (Bvtuple _ bvs) = Ttuple b (zipWith (buildHyloApp h recs) ts bvs)+> buildHyloApp h recs _ bv = bv2term bv+> termToList (Ttuple _ ts) = ts+> termToList t = [t]+> recPosFor tt (v,_) = any (elem v) (map (getPositions tts) (vars (getTerm tt)))+> mapStructureBv :: (Boundvar->Term) -> (Boundvar->Term) -> Boundvar -> ParaFunctor -> Term+> mapStructureBv fid fconst bv (PFcnt _) = fconst bv+> mapStructureBv fid fconst bv (PFid _) = fid bv+> mapStructureBv fid fconst (Bvtuple b bvs) (PFprod pfs) = Ttuple b$ zipWith (mapStructureBv fid fconst) bvs pfs+> mapStructureBv fid fconst bv pf = error$ "etaParaSigma: internal structures do not match: "++show bv++" "++show pf+++> psiToSigma :: CHylo hylo => [hylo a Psi] -> FusionState [hylo a Sigma]+> psiToSigma hs = mapM (psiToSigma' hs) hs+> where psiToSigma' hs1 h1 =+> let (v0s,t0s,Psi psis)=getCoalgebra h1+> pss = map getPatterns psis+> tts = map getTerms psis+> in do pss'<-zipWithM pattern2Ppattern t0s (transpose pss)+> return$ setCoalgebra (v0s,t0s,Sigma (map (const 1) tts,tts,transpose pss',map (const Nothing) v0s)) h1+> pattern2Ppattern (Tvar t0) ps = mapM (return . Ppattern t0) ps+> pattern2Ppattern _ ps = lift (getFreshVar "v") >>= \u-> mapM (return . Ppattern u) ps++> fusionarSigma :: (CHylo hylo,HasComponents ca,VarsB ca, AlphaConvertible ca, Vars ca,Vars a,TermWrappable a, VarsB a,AlphaConvertible a) => +> [hylo a Sigma] -> Int -> Int -> [hylo InF ca] -> Int -> FusionState (Int,[hylo a Sigma])+> fusionarSigma hs1 i1 ia' hs2 i2 = fusionarSigmaAcc [((i1,[(ia,i2)]),0)] [(i1,[(ia,i2)])]+> where+> (v0s',t0s',_)=getCoalgebra (hs1!!i1)+> ia = max 0 (min (length v0s'-1) ia')+> fusionarSigmaAcc accfi@((_,acci):_) is = +> do res<-mapM fusionarSigma' is+> let (ws,hs,hused) = unzip3 res+> hused' :: [[[(Position,(Int,[(Int,Int)]))]]]+> hused' = map (map joinHylos) hused +> nused = nub$ map snd$ concat$ map (concat . map (filter (\(_,pair)->all ((/=pair).fst) accfi))) hused'+> lnused = length nused+acci+> accfi'= zip nused [acci+1..lnused]++accfi+> recmaps = map (map (map (\(v,p)->maybe (error "fusionarSigma: recmaps") (\i->(v,i))$ lookup p accfi'))) hused'+> hs'=zipWith remap recmaps hs+> if null nused then return (sum ws,hs')+> else fusionarSigmaAcc accfi' nused >>= (\(w,hss)->return (w+sum ws,hs'++hss))+> fusionarSigmaAcc [] is = error$ "fusionarSigmaAcc: unexpected empty request list"+> -- join requests for fusion of the same hylo with different arguments+> joinHylos us@(((v,ih1),_):_) = (v,(ih1,sort$ map snd us')) : joinHylos uss+> where (us',uss) = partition ((==v).fst.fst) us+> joinHylos [] = []+> fusionarSigma' (i1,is) = +> do (s,h,hused) <- foldrM (fusionarSigma'' i1) (0,hs1!!i1,repeat []) is+> h' <- lift$ updateHylo h hused+> return (s,cargs h' (head hs2) h',hused)+> where updateHylo h hused = let (v0,_,Sigma (casemap,tts,pss,_)) = getCoalgebra h+> reptts = replicateList casemap tts+> (etas1,fncs) = unzip$ zipWith3 (paraMKNRSigma hs1 (hs1!!i1) (getContext h) i1)+> (map (nub.map (fst.fst)) hused)+> (getFunctor h) reptts+> updPara :: [HFunctor] -> (Int,Int) -> [[EtaOp]] -> VarGenState [[EtaOp]]+> updPara fncs (ia,ih2) etas = +> do etas'<-mapM (upd ia ih2 v0)$ zip5 (getFunctor h) fncs +> (map (nub . map (\((a,_),(_,d))->(a,d))) hused)+> (replicateList casemap pss)+> reptts+> return$ zipWith (:) etas' etas+> in do etas2<-foldrM (updPara fncs) (replicate (length fncs) []) is+> return$ setEta (zipWith3 composeEtas (getEta h) etas1 etas2)$ setFunctor fncs h+> upd ia ih2 v0 (fnc1,fnc1',indexes,ps,tts) = +> etaParaSigma (vars ps) v0 ia ih2 indexes (applyHyloList hs2 (hs2!!ih2) ih2) fnc1 fnc1' tts+> composeEtas eta e1 es2 = foldl rightCompose (eta `rightCompose` e1) es2+> paraMKNRSigma :: CHylo h => [h a ca] -> h a ca -> Context -> Int -> [Position] -> HFunctor -> [TupleTerm] -> (EtaOp,HFunctor)+> paraMKNRSigma hs1 h1 ctx ih1 recs fnc1 tts = +> let vts = map getPosition tts+> izqs = nub (vts\\recs)+> in (paraMKNR (applyHyloListCtx hs1 h1 ctx ih1) fnc1 izqs (map Bvar vts), makePosNR izqs fnc1)+> fusionarSigma'' i1 (ia',i2) (s,h1'',oldhused) = +> do let h2'' = hs2!!i2+> (h1,h2')<-lift$ renameVariables h1'' (setContext emptyContext h2'') (getConstantArgs (getContext h2''))+> let h2 = setContext (getContext h2'') h2'+> ia = max 0 (min (length v0s-1) ia')+> --h1=basicCARSigma hs1 ia h1'+> (v0s,t0s,Sigma (_,_,pss,_))=getCoalgebra h1+> fncs1=getFunctor h1+> etas1=getEta h1+> alg1=getAlgebra h1+> lines1=zip3 alg1 etas1 fncs1+> iabv = v0s!!ia+> if all (\(t,i)-> i/=ia && null (intersect (vars iabv) (vars t)) +> || i==ia && bv2term iabv==t0s!!ia) (zip t0s [0..])+> && all (isPpattern . (!!ia)) pss then+> do (matches,caS,branches,hused)<-getSigma hs1 inF h1 i1 ia hs2 h2 i2 lines1+> let (alg1',etai1',fncs1')=unzip3 branches+> return$ (matches+s,setContext (getContext h1)$ consHylo alg1' etai1' fncs1' caS,+> zipWith (++) hused oldhused)+> else throwError NotSigma+> inF=map (\h2->zip (getAlgebra h2) (getFunctor h2)) hs2+> isPpattern (Ppattern _ _) = True+> isPpattern _ = False++> instance Vars PatternS where+> vars (PcaseS t0 pat termS) = vars termS ++ vars pat+> vars (PcaseSana _ t0 pat termS) = t0 : vars termS ++ vars pat+> vars (PcaseR _ t0 _ vrs ts) = t0 : vrs ++ concat (map (vars.fst) ts)+> vars (Ppattern v p) = vars p+> vars Pdone = []+
+ HFusion/Internal/FuseEnvironment.lhs view
@@ -0,0 +1,78 @@+-- Please, see the file LICENSE for copyright and license information.++A monad to keep an environment with hylomorphism definitions and throwing errors.++>module HFusion.Internal.FuseEnvironment(+> clearFuseEnv,+> insertFuseEnv,+> deleteFuseEnv,+> lookupFuseEnv,+> fuseFuseEnv,+> renameFuseEnv,+> toListFuseEnv,+> runEnv,+> env2FusionState,+> Binds,+> emptyBinds,+> Env) where++> import HFusion.Internal.HsSyn(Variable(..))+> import HFusion.Internal.Utils(newVarGen)+> import Control.Monad.State(State,StateT(..),get,put,evalStateT)+> import Control.Monad.Error(throwError,ErrorT)+> import Control.Monad.Trans(lift)+> import Data.Map(empty,Map,insert,lookup,delete,toList)+> import HFusion.Internal.Utils(VarGen)+> import HFusion.Internal.HyloFace+> import List(elemIndex)+> import HFusion.Internal.FuseFace(fusionar,HyloT,getNames,renameHT)+> import Prelude(maybe,Int,Monad(..),(.),error,id,($),+> show,fst,Either(..),either,foldr,flip)++ data Key a = SingleKey a | KeyList [a]++> type Binds = (Map [Variable] HyloT,Map Variable [Variable])+> type Env a = StateT Binds (ErrorT FusionError (State VarGen)) a++> emptyBinds :: Binds+> emptyBinds = (empty,empty)++> env2FusionState :: Env a -> FusionState a+> env2FusionState m = evalStateT m emptyBinds++> runEnv :: Env a -> Either FusionError a+> runEnv = runFusionState newVarGen . env2FusionState++> clearFuseEnv :: Env ()+> clearFuseEnv = put emptyBinds++> insertFuseEnv :: HyloT -> Env ()+> insertFuseEnv h = do (mh,mv)<-get;put (insert names h mh,foldr (flip insert names) mv names)+> where names = getNames h++> deleteFuseEnv :: Variable -> Env ()+> deleteFuseEnv v = do (mh,mv)<-get+> maybe (return ()) (\ns -> put (delete ns mh,foldr delete mv ns)) (Data.Map.lookup v mv)++> lookupFuseEnv :: Variable -> Env HyloT+> lookupFuseEnv v = do (mh,mv)<-get +> maybe err (maybe err return . flip Data.Map.lookup mh) (Data.Map.lookup v mv)+> where err = throwError (NotFound (show v))++> fuseFuseEnv :: [Variable] -> Variable -> Int -> Variable -> Env HyloT+> fuseFuseEnv names v1 ia v2 = +> do h1<-lookupFuseEnv v1+> h2<-lookupFuseEnv v2+> let getIndex v h = maybe (error "fuseFuseEnv: this should not happen.") id $ elemIndex v (getNames h)+> (_,h3)<-lift (fusionar names h1 (getIndex v1 h1) ia h2 (getIndex v2 h2))+> insertFuseEnv h3+> return h3++> renameFuseEnv :: Variable -> Variable -> Env (HyloT,HyloT)+> renameFuseEnv v1 v2 = do h1<-lookupFuseEnv v1+> h2<-lookupFuseEnv v2+> let getIndex v h = maybe (error "fuseFuseEnv: this should not happen.") id $ elemIndex v (getNames h)+> lift (renameHT h1 h2)++> toListFuseEnv :: Env [([Variable],HyloT)]+> toListFuseEnv = get >>= return . toList . fst
+ HFusion/Internal/FuseFace.lhs view
@@ -0,0 +1,281 @@+-- Please, see the file LICENSE for copyright and license information.++% -----------------------------------------------------------------------------+% $Id: FuseFace.lhs,v 1.32 2006/06/21 17:04:41 fdomin Exp $+%+% Se presenta aqui la interfaz del tipo HyloT que representa hilomorfimos de+% cualquier tipo.+%+% -----------------------------------------------------------------------------++> module HFusion.Internal.FuseFace(+> fusionar, +> fusionarTau, +> fusionarSigma, +> getCata, +> getAna, +> HyloT,+> showHT, +> deriveHylo,+> inline,+> getConstantArgCount,+> getNames,+> renameHT,+> WrapHT(..),WrapHA(..)+> )+> where++> import HFusion.Internal.HyloRep+> import HFusion.Internal.Parsing.HyloContext+> import qualified HFusion.Internal.FunctorRep as F+> import qualified HFusion.Internal.Inline as I+> import Control.Monad.Error(throwError,catchError)+> import Control.Monad.Trans(lift)+> import Control.Monad.State(get)+> import List((\\))++> import HFusion.Internal.RenVars+> import HFusion.Internal.Utils+> import HFusion.Internal.Messages++ import Debug.Trace++ sss s v = trace (s++": "++show v) v++> data HyloT = HTp (HA Phii)+> | HTi (HA InF)+> | HTt (HA Tau)++> showHT :: HyloT -> VarGenState String+> showHT h = do i<-get;return$ foldHT (show' i False) (show' i False) (show' i True) h+> where show' i t h=foldHA (show'' i t) (show'' i t) (show'' i t) h+> show'' i t hss@(h:hs) = (names ++)$ concat $ (I.showHylo t i h :) $ +> map ("\n------------------------------\n"++)$ map (I.showHylo t i) hs+> where names=tuple (map getName hss)+> tuple [] = "()"+> tuple (n:ns) = '(': show n ++ concat (map ((',':).show) ns) ++ ") =\n"+> show'' _ t _ = ""++> data HA a = HAp [Hylo a Psi]+> | HAs [Hylo a Sigma]+> | HAo [Hylo a OutF]++> foldHT :: (HA Phii->b)->(HA InF->b)->(HA Tau->b)->HyloT->b+> foldHT f1 f2 f3 (HTp a) = f1 a+> foldHT f1 f2 f3 (HTi a) = f2 a+> foldHT f1 f2 f3 (HTt a) = f3 a++> foldHA :: ([Hylo a Psi]->b)->([Hylo a OutF]->b)->([Hylo a Sigma]->b)->HA a->b+> foldHA f1 f2 f3 (HAp a) = f1 a+> foldHA f1 f2 f3 (HAo a) = f2 a+> foldHA f1 f2 f3 (HAs a) = f3 a++> class WrapHA ca where+> wrapHA :: [Hylo a ca] -> HA a+> instance WrapHA Psi where+> wrapHA h = HAp h+> instance WrapHA OutF where+> wrapHA h = HAo h+> instance WrapHA Sigma where+> wrapHA h = HAs h+> class WrapHT a where+> wrapHT :: HA a -> HyloT+> instance WrapHT Term where+> wrapHT = HTp+> instance WrapHT InF where+> wrapHT = HTi+> instance WrapHT Tau where+> wrapHT = HTt+++> getNames :: HyloT -> [Variable]+> getNames = foldHT gn gn gn+> where gn = foldHA (map getName) (map getName) (map getName)++> getConstantArgCount :: HyloT -> Int+> getConstantArgCount = length . foldHT gn gn gn+> where gn = head . foldHA (map (getConstantArgs.getContext)) (map (getConstantArgs.getContext)) (map (getConstantArgs.getContext))++> getRecArgCount :: HyloT -> Int -> Int+> getRecArgCount h i = foldHT gn gn gn h+> where gn = (!!i) . foldHA (map getRecArgs) (map getRecArgs) (map getRecArgs)+> getRecArgs = (\(bvs,_,_)->length bvs) . getCoalgebra++> getConstantArgPos :: HyloT -> Maybe [Int]+> getConstantArgPos = foldHT gn gn gn+> where gn = head . foldHA (map (getCntArgPos.getContext)) (map (getCntArgPos.getContext)) (map (getCntArgPos.getContext))+++> renameHT :: HyloT -> HyloT -> FusionState (HyloT,HyloT)+> renameHT h1 h2 = foldHT (renh1 h2) (renh1 h2) (renh1 h2) h1+> where renh1 h2 h1 = foldHA (ren h2) (ren h2) (ren h2) h1+> ren h2 h1 = foldHT (renh2 h1) (renh2 h1) (renh2 h1) h2+> renh2 h1 h2 = foldHA (ren' h1) (ren' h1) (ren' h1) h2+> ren' [h1] [h2] = do (h1',h2')<-lift (renameVariables h1 h2 [])+> return (wrapHT.wrapHA$ [h1'],wrapHT.wrapHA$ [h2'])+> ren' _ _ = error "Mutual recursion not handled."++> deriveHylo :: [Def] -> FusionState HyloT+> deriveHylo dfs = let (ctxs,vs,ts)=unzip3$ map (\(ctx,Defvalue v t)-> (ctx,v,t))$ extractContext$ dfs+> in buildHylo vs ts >>= (return.wrapHT.wrapHA.zipWith setContext ctxs)+++> fusionar :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionar names h1 ih1 ia' h2 ih2 = +> -- catchError (fusionar' names h1 ih1 (ia h1 ih1) h2 ih2)$ const$+> do h1' <- lift (inline h1) >>= deriveHylo+> h2' <- lift (inline h2) >>= deriveHylo+> fusionar' names h1' ih1 (ia h1' ih1) h2' ih2 +> where ia'' = maybe (ia'-getConstantArgCount h1) (length.([0..ia'-1]\\))$ getConstantArgPos h1+> ia h1 ih1 = max 0 (min (getRecArgCount h1 ih1-1) ia'')++> fusionar' :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionar' names h1 ih1 ia h2 ih2 = foldHT (fuseh1 h2) (fuseh1 h2) (fuseh1 h2) h1+> where+> fuseh1 h2 h1 = foldHA (fusePsi h2) (fuseCata h2) (fuseSigma h2) h1+> errorTau _ = throwError NotTau+> fuseCata h2 h1 = foldHT (fuseCataHylo h1) (fuseCataAna h1) errorTau h2+> fusePsi h2 h1 = foldHT (fusePsiPhii h1) (fuseHyloAna h1) errorTau h2+> fuseSigma h2 h1 = foldHT (fuseSigmaPhii h1) (fuseSigmaAna h1) errorTau h2+> fuseCataHylo h1 h2 = let f h2 i2 = fusionarOutF names h1 ih1 h2 i2+> in foldHA f f f h2 ih2+> fuseCataAna h1 h2 = let f h2 i2 = F.fusionarSimple h1 ih1 h2 i2 >>= wrapHylos+> in foldHA f f f h2 ih2+> fusePsiPhii h1 h2 = let f h1=fusionarAmbos names h1 ih1 ia+> in foldHA (f h1) (f h1) (f h1) h2 ih2+> fuseHyloAna h1 h2 = let f h1=fusionarInF names h1 ih1 ia+> in foldHA (f h1) (f h1) (f h1) h2 ih2+> fuseSigmaAna h1 h2 = let f h1 h2=F.fusionarSigma h1 ih1 ia h2 ih2 >>= wrapHylos+> in foldHA (f h1) (f h1) (f h1) h2+> fuseSigmaPhii h1 h2 = let f h1 h2 = do h2' <- mapM (F.getAna h2) h2+> F.fusionarSigma h1 ih1 ia h2' ih2>>=wrapHylos+> in foldHA (f h1) (f h1) (f h1) h2 +> wrapHylos (m,h) = do vs<-sequence $ replicate (length h-length names) (lift (getFreshVar "v"))+> return (m,wrapHT.wrapHA.zipWith setName (names++vs)$ h)++> fusionarTau :: [Variable] -> HyloT -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionarTau names h1 ih1 h2 ih2 = foldHT (fuseh1 h2) (fuseh1 h2) (fuseh1 h2) h1+> where+> fuseh1 h2 h1 = foldHA errorh1 (fuseCata h2) errorh1 h1+> errorh1 _ = throwError (Msg first_Hylo_Not_OutF_Form)+> errorh2 _ = throwError (Msg second_Hylo_Not_Phi_Form)+> fuseCata h2 h1 = foldHT (fuseCataHylo h1) errorh2 errorh2 h2+> fuseCataHylo h1 h2 = let f h1 h2=do res<-lift$ F.fusionarTau h1 ih1 h2 ih2;wrapHylos res+> in foldHA (f h1) (f h1) (f h1) h2+> wrapHylos (m,h) = do vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")+> return (m,wrapHT.wrapHA.zipWith setName (names++vs)$ h)++> fusionarSigma :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionarSigma names h1 ih1 ia h2 ih2 = foldHT (fuseh1 h2) (fuseh1 h2) (fuseh1 h2) h1+> where+> fuseh1 h2 h1 = foldHA (fuseAna h2) errorh1 (fuseSigma h2) h1+> errorh1 _ = throwError (Msg first_Hylo_Not_Psi_Form)+> errorh2 _ = throwError (Msg second_Hylo_Not_InF_Form)+> fuseAna h2 h1 = foldHT errorh2 (fuseHyloAna h1) errorh2 h2+> fuseSigma h2 h1 = foldHT errorh2 (fuseSigmaAna h1) errorh2 h2+> fuseSigmaAna h1 h2 = let f h1 = F.fusionarSigma h1 ih1 ia+> in wrapHylos$ foldHA (f h1) (f h1) (f h1) h2 ih2+> fuseHyloAna h1 h2 = let f h1 h2 ih2 = do h1'<-F.psiToSigma h1+> F.fusionarSigma h1' ih1 ia h2 ih2+> in wrapHylos$ foldHA (f h1) (f h1) (f h1) h2 ih2+> wrapHylos res = do (m,h)<-res+> vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")+> return (m,wrapHT.wrapHA.zipWith setName (names++vs)$ h)+++> getCata :: HyloT -> FusionState HyloT+> getCata h = foldHT f f f h+> where f h=foldHA f' (return.wrapHT.wrapHA) (\_->throwError NotInF) h+> f' h = do h'<-mapM (F.getCata h) h+> return.wrapHT.wrapHA$ h'++> getAna :: HyloT -> FusionState HyloT+> getAna h = foldHT f (return.wrapHT) (\_->throwError NotInF) h+> where f h=foldHA f' f' f' h+> f' h = do h'<-mapM (F.getAna h) h+> return.wrapHT.wrapHA$ h'++> wrapHylos :: (WrapHT a,WrapHA b) => [Variable] -> Int -> [Hylo a b] -> FusionState (Int,HyloT)+> wrapHylos names m h = do vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")+> return (m,wrapHT.wrapHA.zipWith setName (names++vs)$ h)++ fusionarAmbos :: (WrapHT a,WrapHA b,HasComponents b,WrapTau a,Vars a, AlphaConvertible a,VarsB b, AlphaConvertible b, Vars b) =>+ [Variable] -> [Hylo a Psi] -> Int -> Int -> [Hylo Phii b] -> Int -> FusionState (Int,HyloT)++> fusionarAmbos names h1 ih1 ia h2 ih2 = catchError (mapM (F.getCata h1) h1 >>= okCata) badCata+> where+> okCata h1' = catchError (mapM (F.getAna h2) h2 >>= okcataana h1') (okCataBadAna h1')+> badCata _ = catchError (mapM (F.getAna h2) h2 >>= badCataOkAna ) badCataBadAna +> okcataana h1' h2'= catchError (do h1''<-F.psiToSigma h1+> res<-F.fusionarSigma h1'' ih1 ia h2' ih2+> oksigma h1' h2' res)+> (badsigma h1' h2')+> oksigma h1' h2' (m3,hh3) =+> do (m1,hh1)<-F.fusionarSimple h1' ih1 h2' ih2+> (m2,hh2)<-lift$ F.fusionarTau h1' ih1 h2 ih2+> if m1>=m2+> then if m1>=m3 then wrapHylos names m1 hh1+> else wrapHylos names m3 hh3+> else if m2>=m3 then wrapHylos names m2 hh2+> else wrapHylos names m3 hh3+> okCataBadAna h1' _ = do (m2,hh2)<-lift (F.fusionarTau h1' ih1 h2 ih2); wrapHylos names m2 hh2+> badCataOkAna h2' = do h1''<-F.psiToSigma h1+> (m3,hh3)<-F.fusionarSigma h1'' ih1 ia h2' ih2; wrapHylos names m3 hh3+> badCataBadAna _ = throwError (Msg couldnt_Fuse_Hylos)+> badsigma h1' h2' _ = do (m1,hh1)<-F.fusionarSimple h1' ih1 h2' ih2+> (m2,hh2)<-lift$ F.fusionarTau h1' ih1 h2 ih2+> if m1>=m2+> then wrapHylos names m1 hh1+> else wrapHylos names m2 hh2+++> fusionarOutF :: (WrapHT a,WrapHA b,HasComponents b,TermWrappable a, WrapTau a,Vars b, AlphaConvertible b, VarsB b,VarsB a,Vars a, AlphaConvertible a) =>+> [Variable] -> [Hylo a OutF] -> Int -> [Hylo Phii b] -> Int -> FusionState (Int,HyloT)+> fusionarOutF names h1 ih1 h2 ih2 = catchError (mapM (F.getAna h2) h2 >>= okcataana) okCataBadAna+> where+> okcataana h2'= do (m1,hh1)<-F.fusionarSimple h1 ih1 h2' ih2+> (m2,hh2)<-lift$ F.fusionarTau h1 ih1 h2 ih2+> if m1>=m2+> then wrapHylos names m1 hh1+> else wrapHylos names m2 hh2+> okCataBadAna _ = do (m2,hh2)<-lift$ F.fusionarTau h1 ih1 h2 ih2; wrapHylos names m2 hh2++ fusionarInF :: (WrapHT a,WrapHA b,HasComponents b,WrapTau a,AlphaConvertible a, Vars a,Vars b, AlphaConvertible b, VarsB b) =>+ [Variable] -> [Hylo a Psi] -> Int -> Int -> [Hylo InF b] -> Int -> FusionState (Int,HyloT)++> fusionarInF names h1 ih1 ia h2 ih2 = catchError (mapM (F.getCata h1) h1 >>= okCata) badCata+> where+> okCata h1' = catchError (do h1''<-F.psiToSigma h1+> res<-F.fusionarSigma h1'' ih1 ia h2 ih2+> oksigma h1' res)+> (badsigma h1')+> oksigma h1' (m2,hh2)=+> do (m1,hh1)<-F.fusionarSimple h1' ih1 h2 ih2+> if m1>=m2+> then wrapHylos names m1 hh1+> else wrapHylos names m2 hh2+> badCata _ = catchError (do h1''<- F.psiToSigma h1+> (m3,hh3)<-F.fusionarSigma h1'' ih1 ia h2 ih2+> wrapHylos names m3 hh3)+> error+> badsigma h1' _ = do (m3,hh3)<-F.fusionarSimple h1' ih1 h2 ih2; wrapHylos names m3 hh3+> error _ = throwError (Msg couldnt_Fuse_Hylos)+++===================================================================================================================================+inline+===================================================================================================================================++> inline :: HyloT -> VarGenState [Def]+> inline hylo =+> foldHT f f f hylo+> where f h = foldHA g g g h+> g h = do dfs<-mapM (I.inline h) h+> return (mergeContext (zip (map getContext h) dfs))++ inline :: HyloT -> VarGenState [Def]+ inline hylo =+ foldHT (trace "phi" f) (trace "inf" f) (trace "tau" f) hylo+ where f h = foldHA (trace "psi" g) (trace "outF" g) (trace "sigma" g) h+ g h = do dfs<-mapM (I.inline h) h+ return (mergeContext (zip (map getContext h) dfs))
+ HFusion/Internal/HsPrec.hs view
@@ -0,0 +1,38 @@+-- Please, see the file LICENSE for copyright and license information.++module HFusion.Internal.HsPrec(+ Precedence,+ LeftParam,+ hpar, -- :: Bool -> Doc -> Doc+ parentizar, -- ::Precedence -> LeftParam -> Precedence -> Bool+ Asoc(LeftAsoc,RightAsoc,None)+) where++import Text.PrettyPrint++type Precedence = (PrecValue,Asoc) -- Caracteriza un operador.+type LeftParam = Bool -- Se utiliza para determinar de que lado de+ -- un operador infijo está un subtérmino.++type PrecValue = Int+data Asoc = LeftAsoc | RightAsoc | None+ deriving (Eq,Show)++-- Inserta paréntesis o no, de acuerdo al valor del primer parámetro,+-- utilizando <> delante y detrás de la expresión en el segundo +-- parámetro.+hpar:: Bool -> Doc -> Doc+hpar paren d = if paren then char '(' <> d <> char ')'+ else d++-- Decide si una expresión E2, cuyo operador O2 más externo tiene la +-- precedencia dada en el tercer parámetro, necesita ser parentizada,+-- siendo el primer parámetro la precedencia del operador O1 del cuál E2+-- es subexpresión, y el segundo parámetro indica si E2 se halla a la +-- izquierda de O1.+-- parentizar (1,LeftAsoc) False (1,_) -> True+parentizar::Precedence -> LeftParam -> Precedence -> Bool+parentizar (p0,a0) left (p1,_) = (p0>p1)||+ (p0==p1)&&(if left then (a0==RightAsoc)+ else (a0==LeftAsoc)) +
+ HFusion/Internal/HsPretty.hs view
@@ -0,0 +1,456 @@+-- Please, see the file LICENSE for copyright and license information.++{-# LANGUAGE PatternGuards #-}++{-% -----------------------------------------------------------------------------+% $Id: HsPretty.lhs,v 1.39 2006/05/30 23:13:31 fdomin Exp $+%+% Operaciones para imprimir los programas parseados.+%+% -----------------------------------------------------------------------------}++module HFusion.Internal.HsPretty(+ show, -- :: Prog -> String+ ShowDoc(..),+ mapSeparator,+ mapDocSeparator,+ mishowList,+ showTuple, -- :: ShowDoc a => [a]->Doc+ ttupleprec,tlambprec,tletprec,tcaseprec,tfappprec,thyloprec,tcappprec,tappprec,tsumprec,+ mergeCasePatterns,+ module Text.PrettyPrint,+ sss+ -- :: Term -> String+) where++import HFusion.Internal.HsSyn+import Text.PrettyPrint+import HFusion.Internal.HsPrec+import HFusion.Internal.Utils++import Control.Monad(mplus,msum)+import List((\\),transpose)+import Debug.Trace(trace)++import HFusion.Internal.Messages+++instance Show Prog where + show (Prog defs) = render.vcat.mapDocSeparator (text ""$$) $ defs+ {- o : show (Prog defs) = fullRender PageMode 100 1.5 string_txt "" (showDoc defs)+ string_txt (Chr c) s = c:s+ string_txt (Str s1) s2 = s1 ++ s2+ string_txt (PStr s1) s2 = s1 ++ s2+ -}++instance Show Def where+ show = render . showDoc++instance Show Term where + show t = render.showDoc$ t++-- Esta clase agrupa los tipos de los cuales es posible construir+-- un documento de la librería Pretty.+class ShowDoc a where+ showDoc::a->Doc+ showDocPrec:: Precedence -> LeftParam -> a -> Doc++ showDoc = showDocPrec (0,None) False+ showDocPrec _ _ = showDoc -- Usa dos parámetros uno para el valor de+ -- precedencia, y la asociatividad, estos+ -- permiten determinar la necesidad de paréntesis.+++-- =================================================+-- FUNCIONES AUXILIARES +-- =================================================+++-- Coloca un separador entre la representación de strings de elementos de+-- una lista.+-- miShowList ";" [1,2,3,4] -> "1;2;3;4"+mishowList:: Show a => String->[a]->String+mishowList _ [] = ""+mishowList separador elems = foldr1 ((++).(++separador)) (map show elems)++-- ShowDoc f [1,2,3,4] -> [showDoc 1,...,f(showDoc 3),f(showDoc 4)]+mapDocSeparator:: ShowDoc a => (Doc->Doc)->[a]->[Doc]+mapDocSeparator separador = mapSeparator separador . map showDoc++-- Muestra una tupla de elementos.+showTuple :: ShowDoc a => [a]->Doc+showTuple [a] = showDoc a+showTuple ls = char '('<> (hcat$ mapDocSeparator (char ','<>) ls)<>char ')'++-- Aplica una función a todos los argumentos de una lista menos al+-- primero. Se utiliza para insertar separadores en la lista.+mapSeparator::(a->a)->[a]->[a]+mapSeparator _ [] = []+mapSeparator separador (l:ls) = l:map separador ls++-- Inserta paréntesis o no, de acuerdo al valor del primer parámetro,+-- utilizando <> delante y ++ detrás de la expresión en el segundo +-- parámetro.+parlist:: Bool -> [Doc] -> Doc+parlist paren content = if paren + then char '(' <> + cat + (mapSeparator (text ""<+>) content+ ++[char ')'])+ else sep content++tab,stab::Int+tab=4 -- Indentación grande+stab=2 -- Indentación pequeña++-- Precedencias (ver HsPrec)+ttupleprec,tlambprec,tletprec,tcaseprec,+ tfappprec,thyloprec,tcappprec,tappprec,tsumprec::Precedence+ttupleprec=(0,None)+tlambprec=(0,RightAsoc)+tletprec=(0,RightAsoc)+tcaseprec=(0,RightAsoc)+thyloprec=(0,RightAsoc)+tsumprec =(1,None)+tfappprec=(maxprec,LeftAsoc)+tcappprec=(maxprec,LeftAsoc)+tappprec=(maxprec,LeftAsoc)++dec (p,a) = (p-1,a)++maxprec::Int+maxprec=10++-- ================================================================+-- Funciones de conversión.+-- ================================================================+++-- Pretty print para tuplas de 2 elementos.++instance (ShowDoc a,ShowDoc b) => ShowDoc (a,b) where+ showDoc (a,b) = char '('<>showDoc a<>char ','<+> showDoc b <>char ')'++instance ShowDoc Bool where+ showDoc True = text "True"+ showDoc False = text "False"++instance ShowDoc Def where+ showDoc (Defvalue name t) = vcat$ map showDef$ splitCase vs t'+ where getParams (Tlamb bv t) = let (l,t') = getParams t in (bv:l,t')+ getParams t = ([],t)+ isVar (Tvar _) = True+ isVar _ = False+ (vs,t') = getParams t+ -- tries to separate a case definition into equations+ -- it returns a list containing one element for each derived equation+ -- [(equation patterns,equation term)]+ splitCase :: [Boundvar] -> Term -> [([Pattern],Term)]+ splitCase bvs t = maybe [(map bv2pat bvs,t)] (uncurry$ zipWith (\p t->(patList p,t)))$ + mergeCasePatterns' p t+ where p = ptuple$ map bv2pat bvs+ patList (Ptuple ps) = ps+ patList p = [p]++ showDef (ps,t) = sep [text (show name) <+> hsep (map (toDoc (vars t)) ps) <+> char '=' + , nest 8$ showDoc t]+ toDoc vs p = showDocPrec tcappprec False (removeSpuriousPas vs p)+++-- Flattens nested case terms by carefully replacing patterns into patterns to remove+-- inner case constructs and increase the amount of alternatives in the outer case+-- constructs.++mergeCasePatterns :: Term -> Term+mergeCasePatterns t = mergeCPat id t+ where mergeCPat bvs (Tlamb bv t) = Tlamb bv$ mergeCPat (bvs . (bv:)) t+ mergeCPat bvs t = + let ps = map bv2pat (bvs [])+ pvs = lastVarsList ps+ in if null ps + then case t of+ Tcase t0 ps ts -> (\(ps,ts)-> Tcase t0 (concat ps) (concat ts))$+ unzip$ map unzip$ zipWith ((map removePas.) . mergeCase) ps ts + _ -> t + else if isTcase t then+ delCases$ uncurry (Tcase (ttuple (map Tvar pvs)))$ unzip$ map removePas$ mergeCase (ptuple$ map Pvar pvs) t+ else t+ mergeCase :: Pattern -> Term -> [(Pattern,Term)]+ mergeCase p t = case mergeCasePatterns' p t of+ Just (ps,ts) -> concat$ zipWith mergeCase ps ts+ Nothing -> [(p,t)]+ removePas (p,t) = (removeSpuriousPas (vars t) p,t)+ isTcase (Tcase _ _ _) = True+ isTcase _ = False++-- Removes Pas patterns which are not in a given set of variables.++removeSpuriousPas :: [Variable] -> Pattern -> Pattern+removeSpuriousPas vs (Pas v p@(Pas v' p')) | v==v' = removeSpuriousPas vs p+removeSpuriousPas vs (Pas v p@(Pvar v')) | v==v' = p+ | p==pany = if elem v vs then Pvar v else pany+removeSpuriousPas vs (Pas v p) | elem v vs = Pas v (removeSpuriousPas vs p)+ | otherwise = removeSpuriousPas vs p+removeSpuriousPas vs p@(Pvar v) = p+removeSpuriousPas vs p@(Plit _) = p+removeSpuriousPas vs (Ptuple ps) = Ptuple (map (removeSpuriousPas vs) ps)+removeSpuriousPas vs (Pcons c ps) = Pcons c (map (removeSpuriousPas vs) ps)++-- Merges the cases in the term to the given pattern. Returns Nothing+-- if there are no cases to merge.++mergeCasePatterns' :: Pattern -> Term -> Maybe ([Pattern],[Term])+mergeCasePatterns' p t = case removeAllCaseVar Nothing t of+ Just res -> mergeCasePatterns'' p res `mplus` Just ([p],[res])+ _ -> mergeCasePatterns'' p t+ where removeAllCaseVar res t = maybe res (\mt->removeAllCaseVar (Just mt) mt)$ removeCaseVars t+ removeCaseVars (Tcase t0 ps ts) + | length t0s > 1, + Just i<-msum (zipWith3 findVarPattern [0..] t0s pss) = Just (Tcase (listToTerm$ del i t0s) (map (removePattern i) ps) ts)+ where t0s = termList t0+ pss = transpose$ map patList ps+ removeCaseVars _ = Nothing+ findVarPattern i (Tvar v) ps | all (isPatternVar v) ps = Just i+ findVarPattern i _ ps = Nothing+ isPatternVar v (Pvar v') = v==v'+ isPatternVar v _ = False+ removePattern i (Ptuple ps) = toPat$ del i ps+ removePattern i _ = error "mergeCasePatterns': something that shouldn't had happened happened."+ listToTerm [t] = t+ listToTerm ts = Ttuple False ts+ termList (Ttuple _ ts) = ts+ termList t = [t]+ patList (Ptuple ps) = ps+ patList p = [p]+ toPat [p] = p+ toPat ps = Ptuple ps+ del i ls = take i ls ++ drop (i+1) ls++mergeCasePatterns'' :: Pattern -> Term -> Maybe ([Pattern],[Term])+mergeCasePatterns'' p (Tcase t0 ps ts)+ | all isAllowedTerm t0s + && orderMatches lvp t0s+ && all ((==length t0s) . length) pss+ && any (not.null.fst) sustss =+ Just (map (flip substitutePattern p . fst)$ sustss ,map snd sustss)+ where t0s = termList t0+ tvs = vars t0s+ pss = map patList ps+ sustss = zipWith (makeSustPairs tvs) pss ts+ lvp = lastVars p+ isAllowedTerm (Tvar v) = elem v lvp+ isAllowedTerm _ = False+ makeSustPairs tvs ps t = let ss = zipWith (makeSustPair t (vars t)) tvs ps+ in (map fst ss,substitution (concat . map snd$ ss) t)+ makeSustPair t tsvs v (Pvar v') | notElem v (varsB t) = ((v,Pvar v),[(v',Tvar v)])+ makeSustPair t tsvs v p | p/=pany = ((v,Pas v p),[])+ | elem v tsvs = ((v,Pvar v),[])+ | otherwise = ((v,pany),[])+ patList (Ptuple ps) = ps+ patList p = [p]+ termList (Ttuple _ ts) = ts+ termList t = [t]+ orderMatches (v:lvp) t0s@(Tvar v':t0ss) | v==v' = orderMatches lvp t0ss+ | otherwise = orderMatches lvp t0s+ orderMatches _ [] = True+ orderMatches _ _ = False+mergeCasePatterns'' _ t = Nothing++substitutePattern :: [(Variable,Pattern)] -> Pattern -> Pattern+substitutePattern subst p@(Pvar v) = maybe p id $ lookup v subst +substitutePattern subst p@(Plit _) = p +substitutePattern subst (Ptuple ps) = Ptuple$ map (substitutePattern subst) ps +substitutePattern subst (Pcons c ps) = Pcons c$ map (substitutePattern subst) ps +substitutePattern subst (Pas v p) = Pas v$ substitutePattern subst p +++-- lastVars returns the variables that can be replaced without breaking the pattern matching sequence.+-- e.g. in (C a (C2 b c) d) the variables that can be safely replaced are b c and d.++lastVars :: Pattern -> [Variable]+lastVars (Pvar v) = [v]+lastVars (Pcons c ps) = lastVarsList ps+lastVars (Ptuple ps) = lastVarsList ps+lastVars (Plit _) = []+lastVars (Pas _ p) = lastVars p+lastVarsList ps = let (vps,others) = break (not.isPvar) (reverse ps)+ in if null others then reverse (vars vps)+ else lastVars (head others)++reverse (vars vps)+ where isPvar (Pvar v) = True+ isPvar _ = False+++instance ShowDoc Variable where+ showDoc v = text (show v)++instance ShowDoc Term where+ showDocPrec _ _ (Tvar name) = text (show name)+ showDocPrec _ _ (Tlit literal) = text (show literal)++ showDocPrec _ _ (Ttuple _ [Tvar name]) = text (show name)+ showDocPrec _ _ (Ttuple _ terms) = + let+ tdocs = map (showDocPrec ttupleprec False) terms+ in + cat $ [char '(']+ ++ map (nest 1) (mapSeparator (char ','<>) tdocs)+ ++ [char ')']++ -- La siguiente operación está comentada para ilustrar el + -- comportamiento general de cada definición.+ showDocPrec prec left (Tlamb boundvar term) =+ let+ -- Obtengo la representación del subtérmino.+ t=showDocPrec tlambprec False term+ -- Construyo la representación de la lambda espresión.+ content = [char '\\' <> text (show boundvar) <+> text "->",+ nest tab t]+ -- Pregunto si hay que parentizar (función de HsPrec).+ -- Para hacer la pregunta se especifica la precedencia y+ -- asociatividad del operador que contiene la lambda+ -- expresión, y la precedencia y asociatividad de la + -- lambda expresión.+ paren = parentizar prec left tlambprec+ -- Parentizo la representación si es necesario.+ in parlist paren content++ showDocPrec prec left (Tlet variable term1 term2) =+ let+ t1=showDocPrec tletprec False term1+ t2=showDocPrec tletprec False term2+ content = [(text "let" <+> text (show variable) <+> equals <+> t1)+ $$ nest 1 (text "in" <+> t2)]+ paren = parentizar prec left tletprec+ in parlist paren content++ showDocPrec prec left (Tif term0 term1 term2) =+ let+ t0=showDocPrec tletprec False term0+ t1=showDocPrec tletprec False term1+ t2=showDocPrec tletprec False term2+ content = [vcat [sep [text "if" <+> t0,nest stab (text "then"<+>t1)],+ nest stab (text "else" <+> t2)]]+ paren = parentizar prec left tletprec+ in parlist paren content++ showDocPrec prec left (Tpar t) = char '(' <+> showDocPrec (0,None) False t <+> char ')'++ showDocPrec prec left (Tcase term ps' ts') =+ let+ tr=showDocPrec tcaseprec False term+ ts=map (showDocPrec tcaseprec False) ts'+ ps=map (showDocPrec tcaseprec False) ps'+ content = [text "case" <+> tr <+> text "of",+ nest stab $+ vcat [sep [p <+> text "->", nest tab t]+ | (p,t)<-zip ps ts]+ ]+ paren = parentizar prec left tcaseprec+ in parlist paren content++ showDocPrec _ _ (Tfapp variable [] ) = text (show variable)+ showDocPrec prec left (Tfapp variable terms) =+ let+ tds@(td:tdocs)=map (flip (showDocPrec ((if infx then dec else id)$ op_precedence))) terms+ content + | infx && length terms>1 = + (td True <+> text (show variable)):+ map (\t->nest 2$ t False) tdocs+ | infx = [td True<>text (show variable)]+ | otherwise = text (show variable):+ map (\t->nest 2$ t False) tds+ paren = infx && length terms<=1 || parentizar prec left op_precedence+ in+ parlist paren content+ where infx = esinfijo variable+ esinfijo (Vgen _ _) = False+ esinfijo (Vuserdef ('@':'b':cs)) = False+ esinfijo (Vuserdef (c:cs)) = not ((('a'<=c)&&(c<='z'))||(c=='_'))+ esinfijo _ = error infix_Operator_Without_Characters_In_Name+ op_precedence | infx && variable/=Vuserdef "/" && variable/=Vuserdef "-"+ && variable/=Vuserdef "+"+ = (1,RightAsoc)+ | otherwise = tfappprec+++ showDocPrec _ _ (Tcapp constructor []) = text constructor+ showDocPrec prec left (Tcapp constructor terms) =+ let+ tds@(td:tdocs)=map (flip (showDocPrec ((if esinfijo then dec else id)$ op_precedence))) terms+ content + | esinfijo && length terms>1 = td True <+> text constructor <+>+ hsep (map (\t->t False) tdocs)+ | esinfijo = td True<>text constructor+ | otherwise = text constructor <+> + hsep (map (\t->t False) tds)+ paren = esinfijo && length terms<=1 || parentizar prec left op_precedence+ in+ hpar paren content+ where esinfijo = case constructor of + "_" -> False+ (c:_)-> not (('A'<=c)&&(c<='Z')) && constructor/="[]"+ _ -> error infix_Constructor_Without_Characters_In_Name+ op_precedence | esinfijo = (fst tcappprec,RightAsoc)+ | otherwise = tcappprec++ showDocPrec prec left (Tapp term1 term2) =+ let+ t1=showDocPrec tappprec True term1+ t2=showDocPrec tappprec False term2+ paren = parentizar prec left tappprec+ content = t1 <+> t2+ in+ hpar paren content+ showDocPrec _ _ Tbottom = text "undef"++ showDocPrec prec left (Thyloapp v i ts pos t) = showDocPrec prec left (Tfapp v (thyloArgs i ts pos t))++-- showDocPrec _ _ _ = error display_Not_Define_For_Term++instance Show Boundvar where+ show = render.showDoc++instance ShowDoc Boundvar where+ showDoc (Bvar name) = text$ show name+ showDoc (Bvtuple _ vars) = showTuple vars++instance Show Pattern where+ show (Pvar name) = show name+ show (Ptuple patterns) = "("++ mishowList "," patterns ++")"+ show (Pcons name patterns) = "("++ name ++ foldr ((++).(" "++).show) "" patterns ++")"+ show (Plit literal) = show literal+ show (Pas v p) = show v++'@':show p++instance ShowDoc Pattern where+ showDocPrec prec left p@(Pvar v) = text (show v) + showDocPrec prec left (Pas v p) = text (show v)<>char '@'<>showDocPrec tcappprec False p+ showDocPrec prec left (Ptuple patterns) =+ let+ ps=map (showDocPrec ttupleprec False) patterns+ in+ (char '('<>hcat (mapSeparator (char ','<>) ps)<>char ')')+ showDocPrec _ _ (Pcons name []) = text name+ showDocPrec prec left (Pcons name patterns) =+ let+ tds@(td:tdocs)= map (flip (showDocPrec op_precedence)) patterns+ content+ | esinfijo name = td True <> text name <>+ hsep (map (\t->t False) tdocs)+ | otherwise = text name <+>+ hsep (map (\t->t False) tds)+ paren = parentizar prec left op_precedence+ in+ hpar paren content+ where esinfijo (c:cs) = not (('A'<=c)&&(c<='Z'))+ esinfijo _ = error infix_Constructor_Without_Characters_In_Name+ op_precedence | esinfijo name = (fst tcappprec,RightAsoc)+ | otherwise = tcappprec+ showDocPrec _ _ (Plit literal) = text (show literal)+++instance Show Literal where+ show (Lstring string) = show string+ show (Lint string) = string+ show (Lchar char) = show char+ show (Lrat string) = string+
+ HFusion/Internal/HsSyn.hs view
@@ -0,0 +1,262 @@+-- Please, see the file LICENSE for copyright and license information.++{-% -----------------------------------------------------------------------------+% $Id: HsSyn.lhs,v 1.24 2006/05/30 23:13:31 fdomin Exp $+%+% Un conjunto de datatypes que describen la gramática que se parsea.+%+% -----------------------------------------------------------------------------}++module HFusion.Internal.HsSyn where++import Char(isDigit)+import List(union,(\\),nub)++-- | Abstract syntax tree for programs that "HFusion" can handle.+data Prog = Prog [Def]++-- | Representation for function definitions.+data Def = Defvalue Variable Term++getDefName :: Def -> Variable+getDefName (Defvalue v _) = v++getDefTerm :: Def -> Term+getDefTerm (Defvalue _ t) = t+++-- | Representation of variables.+data Variable = Vuserdef String -- ^ Name found in the original program.+ | Vgen String Int -- ^ Generated identifier containing a prefix and an index.+ deriving Ord++instance Show Variable where+ show (Vuserdef name) = name+ show (Vgen p num) = p ++ show num++instance Eq Variable where+ Vuserdef v == Vuserdef v' = v==v'+ Vgen p i == Vgen p' i' = p==p' && i==i'+ v1 == v2 = show v1 == show v2+++str2var [] = Vuserdef ""+str2var s | null ds = Vuserdef s+ | otherwise = Vgen (reverse p) ((read (reverse ds))::Int)+ where (ds,p) = break (not . isDigit) (reverse s)++varPrefix :: Variable -> String+varPrefix (Vgen p _) = p+varPrefix (Vuserdef s) = reverse . dropWhile isDigit . dropWhile (=='_'). reverse$ s++-- | Representation for Literals.+data Literal = Lstring String -- ^ String literals+ | Lint String -- ^ Integer literals+ | Lchar Char -- ^ Character literals+ | Lrat String -- ^ Rational literals+ deriving (Eq)++-- | Representation for constructors.+type Constructor = String++-- | Representation for terms in programs handled by "HFusion".+data Term = Tvar Variable -- ^ Variables+ | Tlit Literal -- ^ Literals+ | Ttuple Bool [Term] -- ^ Tuples. The boolean argument tells if the tuple must be flattened+ -- when nested with others under an hylo application.+ | Tlamb Boundvar Term -- ^ Lambda expressions+ | Tlet Variable Term Term -- ^ Let expressions+ | Tcase Term [Pattern] [Term] -- ^ Case expressions+ | Tfapp Variable [Term] -- ^ Function application (saturated)+ | Tcapp Constructor [Term] -- ^ Constructor application+ | Tapp Term Term -- ^ General term application+ | Tbottom -- ^ Undefined computation++ | Tif Term Term Term -- ^ If expressions, only used for pretty printing+ | Tpar Term -- Parenthesized expressions, to better handle associativity of infix operators+ | Thyloapp Variable Int [Term] (Maybe [Int]) Term -- ^ Hylo application, only used for inlining+ -- Thyloapp name recargsCount non-recargs recarg recarg may be a tuple + deriving (Eq)+++-- | Calculates arguments of a Thyloapp++thyloArgs :: Int -> [Term] -> Maybe [Int] -> Term -> [Term]+thyloArgs 1 ts pos t = insertElems (zip ts$ maybe [0..] id pos) [t]+thyloArgs 0 ts pos t = insertElems (zip ts [0..]) []+thyloArgs i ts pos t = insertElems (zip ts$ maybe [0..] id pos) (flatten t)+ where flatten (Ttuple True ts) = concat (map flatten ts)+ flatten t = [t]+++insertElems :: [(a,Int)] -> [a] -> [a]+insertElems = insert 0+ where insert i xs [] = map fst xs + insert i [] as = as+ insert i xs@((x,ix):xss) as@(a:ass)+ | ix<=i = x : insert (i+1) xss as+ | otherwise = a : insert (i+1) xs ass++applyFst f (a,b) = (f a,b)+++bv2pat (Bvar v)=Pvar v+bv2pat (Bvtuple _ vs)=Ptuple (map bv2pat vs)++tapp (Tvar v) t = Tfapp v [t]+tapp (Tfapp v []) t = Tfapp v [t]+tapp t1 t2 = Tapp t1 t2++ttuple [a] = a+ttuple as = Ttuple False as++ptuple [a] = a+ptuple as = Ptuple as++bvtuple [a] = a+bvtuple as = Bvtuple False as+++-- | Representation of bound variables in lambda expressions.+data Boundvar = Bvar Variable -- Variables+ | Bvtuple Bool [Boundvar] -- ^ Bound variable tuples. Uses the boolean value like in 'Ttuple'.+ -- but when bounding input variables of hylomorphisms.+ deriving (Eq)++-- | Representation of patterns+data Pattern = Pvar Variable -- ^ Variables+ | Ptuple [Pattern] -- ^ Tuple patterns+ | Pcons Constructor [Pattern] -- ^ Constructor application patterns+ | Plit Literal -- ^ Literals+ | Pas Variable Pattern -- ^ \@\-pattern+ deriving (Eq)++pany = Pvar (Vuserdef "_")+++-- Representación de functores+-- Fue discutida, pero aún podría sufrir cambios.+newtype Func = Fsum [Fprod]+ deriving (Show,Eq)+type Fprod = (Int,Int)+++-- | Operation for collecting free variables without repetitions.++class Vars a where+ vars :: a -> [Variable]++instance Vars Variable where+ vars a = [a]++instance Vars Boundvar where+ vars (Bvar v) = [v]+ vars (Bvtuple _ vs) = vars vs++instance Vars Pattern where+ vars p@(Pvar v) | p/=pany = [v]+ | otherwise = []+ vars (Ptuple ps) = concat (map vars ps)+ vars (Pcons _ ps) = concat (map vars ps)+ vars (Plit _) = []+ vars (Pas v p) = v:vars p+ -- vars p = error "vars Pattern: not defined" -- ++ (not_Defined_For_Applied_Pattern p)++instance Vars a => Vars [a] where+ vars = concat.map vars++instance (Vars a, Vars b) => Vars (Either a b) where+ vars = either vars vars++instance Vars Term where+ vars (Tvar v) = [v]+ vars (Ttuple _ ps) = foldr union [] (map vars ps)+ vars (Tcapp _ ps) = foldr union [] (map vars ps)+ vars (Tlit _) = []+ vars (Tfapp fn ps) = foldr union [fn] (map vars ps)+ vars (Tapp t1 t2) = union (vars t1) (vars t2)+ vars (Tlamb bv t) = vars t \\ vars bv+ vars (Tlet v t0 t1) = union (vars t0) (vars t1 \\ [v])+ vars (Tpar t) = vars t+ vars (Tif t0 t1 t2) = union (vars t0) (union (vars t1) (vars t2))+ vars (Tcase t ps ts) = foldr union (vars t) (zipWith (\pi ti ->vars ti \\ vars pi) ps ts)+ vars Tbottom = []+ vars (Thyloapp v i ts _ t) = nub (v:(vars ts++vars t))++++-- | Operations for obtaining bound variables.++class VarsB a where+ varsB :: a -> [Variable]++instance (VarsB a) => (VarsB [a]) where+ varsB x = concat$ map varsB x++instance VarsB Term where+ varsB (Tvar _) = []+ varsB (Ttuple _ ps) = concat (map varsB ps)+ varsB (Tcapp _ ps) = concat (map varsB ps)+ varsB (Tlit _) = []+ varsB (Tfapp _ ps) = concat (map varsB ps)+ varsB (Tapp t1 t2) = varsB t1 ++ varsB t2+ varsB (Tlamb bv t) = varsB t ++ vars bv+ varsB (Tlet v t0 t1) = v : (varsB t0 ++ varsB t1)+ varsB (Tif t0 t1 t2) = varsB t0 ++ varsB t1 ++ varsB t2+ varsB (Tpar t) = varsB t+ varsB (Tcase t ps ts) = varsB t ++ concat (zipWith (\pi ti ->varsB ti ++ vars pi) ps ts)+ varsB Tbottom = []+ varsB (Thyloapp _ i ts _ t) = varsB ts++varsB t++instance (VarsB a, VarsB b) => VarsB (Either a b) where+ varsB = either varsB varsB+++-- | Alpha conversion.++class AlphaConvertible a where+ -- The [Variable] is the list of variables in scope (i.e. which can be replaced).+ alphaConvert :: [Variable] -> [(Variable, Variable)] -> a -> a++instance AlphaConvertible Variable where+ alphaConvert sc lvars v = if elem v sc then maybe v id $ lookup v lvars else v++instance AlphaConvertible Term where+ alphaConvert sc ss t@(Tvar v) = if elem v sc then maybe t Tvar $ lookup v ss else t+ alphaConvert sc ss (Tlamb bv t) = Tlamb (alphaConvert sc ss bv) (alphaConvert (sc++vars bv) ss t)+ alphaConvert sc ss (Tlet v t0 t1) = case lookup v ss of+ Just valor -> Tlet valor (alphaConvert (v:sc) ss t0) (alphaConvert (v:sc) ss t1)+ Nothing -> Tlet v (alphaConvert sc ss t0) (alphaConvert sc ss t1)+ alphaConvert sc ss (Tcase t0 ps ts) = Tcase (alphaConvert sc ss t0) (map (alphaConvert sc ss) ps) (zipWith alphaConvert' ps ts)+ where alphaConvert' p t = alphaConvert (sc++vars p) ss t+ alphaConvert sc ss t@(Tlit _) = t+ alphaConvert sc ss (Ttuple b ts) = Ttuple b$ map (alphaConvert sc ss) ts+ alphaConvert sc ss (Tfapp v ts) = case lookup v ss of+ Just valor -> foldl Tapp (Tvar valor) (map (alphaConvert sc ss) ts)+ Nothing -> Tfapp v (map (alphaConvert sc ss) ts)+ alphaConvert sc ss (Tcapp cons ts) = Tcapp cons (map (alphaConvert sc ss) ts)+ alphaConvert sc ss (Tapp t0 t1) = Tapp (alphaConvert sc ss t0) (alphaConvert sc ss t1)+ alphaConvert sc ss (Thyloapp v i ts pos t) = case lookup v ss of+ Just valor -> foldl Tapp (Tvar valor) (map (alphaConvert sc ss) (thyloArgs i ts pos t))+ Nothing -> Thyloapp v i (map (alphaConvert sc ss) ts) pos (alphaConvert sc ss t)+ alphaConvert sc ss t = error$ "alphaConvert: unexpected term"++instance (AlphaConvertible a, AlphaConvertible b) => AlphaConvertible (Either a b) where+ alphaConvert sc lvars = either (Left . alphaConvert sc lvars) (Right . alphaConvert sc lvars)++instance (AlphaConvertible a) => (AlphaConvertible [a]) where+ alphaConvert sc lvars x = map (alphaConvert sc lvars) x+++instance AlphaConvertible Pattern where+ alphaConvert sc lvars t@(Pvar v) = maybe t Pvar $ lookup v lvars+ alphaConvert sc lvars (Ptuple ps) = Ptuple (map (alphaConvert sc lvars) ps)+ alphaConvert sc lvars (Pcons c ps) = Pcons c (map (alphaConvert sc lvars) ps)+ alphaConvert sc lvars t@(Plit l) = t+ alphaConvert sc lvars (Pas v p) = Pas (maybe v id$ lookup v lvars) (alphaConvert sc lvars p)++instance AlphaConvertible Boundvar where+ alphaConvert sc lvars b@(Bvar v) = maybe b Bvar $ lookup v lvars+ alphaConvert sc lvars (Bvtuple b vs) = Bvtuple b$ alphaConvert sc lvars vs++
+ HFusion/Internal/HyloFace.lhs view
@@ -0,0 +1,666 @@+-- Please, see the file LICENSE for copyright and license information.++> {-# LANGUAGE TypeSynonymInstances #-}++% -----------------------------------------------------------------------------+% Interfaces for manipulating hylomorphisms and its components.+% -----------------------------------------------------------------------------++> module HFusion.Internal.HyloFace 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 input variables of a grouping of a mutual hylo.+> 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 f2 f3 (Tauphi t) = f1 t+> foldTau f1 f2 f3 (TauinF t) = f2 t+> foldTau f1 f2 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 f1 f2 f3 f4 f5 (TWsimple a) = f3 a+> foldTW f1 f2 f3 f4 f5 (TWacomp a) = f4 a+> foldTW f1 f2 f3 f4 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 [] v = []+> 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 [] v = []+> 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 f2 f3 (PFid v) = f1 v+> foldPF f1 f2 f3 (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 f2 f3 (PFid v) = f1 v+> foldPFM f1 f2 f3 (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 ps [] = []+> 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,i,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:as) = 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 (State VarGen) 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)))++
+ HFusion/Internal/HyloRep.lhs view
@@ -0,0 +1,223 @@+-- Please, see the file LICENSE for copyright and license information.++% -----------------------------------------------------------------------------+% $Id: HyloRep.lhs,v 1.63 2005/07/20 14:23:23 fdomin Exp $+%+% Aqui se encuentra la implementacion del la interfase HyloFace.+% Por los detalles de la especificacion ver HyloFace.lhs.+% -----------------------------------------------------------------------------+++>module HFusion.Internal.HyloRep(+> module HFusion.Internal.HyloFace+> ,module HFusion.Internal.HsSyn,Hylo(..)) where++> import HFusion.Internal.Utils++> import List+> import HFusion.Internal.HyloFace+> import HFusion.Internal.FsDeriv+> import HFusion.Internal.HsSyn+> import HFusion.Internal.Parsing.HyloContext+> import HFusion.Internal.Messages++ import Debug.Trace++ sss msg a = trace (msg++": "++show a) a+++ type InputLine = (Pattern,DReturnType)+ type DReturnType = ([(Variable,Variable)], [(Variable, Int, Term)], Term)++ El algoritmo de derivacion de hilomorfismos establece una+correspondencia entre los sumandos de los dos functores que involucra+el hylomorfismo. Utilizamos esta correspondencia para diseniar los+datos de entrada del constructor de hilomorfismos.+ Una linea es un conjunto de patrones, terminos y variables,+a traves de los cuales fluyen los datos correspondientes a un sumando+de los functores. Expresado con precision una linea tiene:+ *un termino correspondiente al algebra,+ *las variables de entrada del termino del algebra,+ *una componente de la transformacion natural intermedia del hilomorfismo.+ *un termino de la coalgebra+ *un patron de la coalgebra++ DReturnType es el tipo que devuelve el algortimo D, que caracteriza la+entrada buildHylo. Por informacion al respecto ver FsDeriv.+ El Pattern es el patron de la alternativa del case de coalgebra que se da+inicio a la linea.+++++> data Hylo a ca = Hylo { hylo_algebra :: Algebra a,+> hylo_nattrans :: [Etai],+> hylo_functor :: HyloFunctor,+> hylo_coalgebra :: Coalgebra ca,+> hylo_context :: Context,+> hylo_name :: Variable +> }++Hylo ((a,eta,ca),(bvs,v))+bvs son todas las variables que el hilomorfismo recibe menos la+ última que es bv.+v es el nombre del hilomorfismo.+a es el algebra+eta es la transformacion natural+ca es la coalgebra++ type InputLine = (Pattern,DReturnType)+ type DReturnType = ([(Variable,Variable)], [(Variable, Term)], Term)++> instance CHylo Hylo where++> buildHylo names ts = aA names ts >>= (return . zipWith buildHylo' names)+> where buildHylo' :: Variable -> ([Boundvar],[Term],[([Pattern],([(Variable,Variable)], [(Variable, Int,[[Int]], [Term])], Term))])+> -> Hylo Phii Psi+> buildHylo' name (vsm,t0,lns) = Hylo { hylo_algebra = a,+> hylo_nattrans = etas,+> hylo_functor = fncs,+> hylo_coalgebra = (vsm,t0,Psi ca),+> hylo_context = emptyContext,+> hylo_name = name }+> where+> (a,etas,fncs,ca)=unzip4$ map buildLine lns+> buildLine :: ([Pattern],([(Variable,Variable)], [(Variable, Int,[[Int]], [Term])], Term)) +> -> (Acomponent Phii,Etai,HFunctor,Psii)+> buildLine (pattern,(vs,vts,t)) =+> (wrapA (map Bvar$ phiNoRecVars++phiRecVars) (TWsimple t),idEta,HF .zip4 phiRecVars idxs ias.map PFid$ phiRecVars,+> Psii (pattern,zipWith (flip tupleterm.Tvar) psiNoRecVars phiNoRecVars+> ++zipWith (\v ts -> tupleterm v (recArgsToTerm ts)) phiRecVars psiRecTerms))+> where (phiRecVars,idxs,ias,psiRecTerms) = unzip4 vts+> (psiNoRecVars,phiNoRecVars) = unzip vs+> recArgsToTerm [t] = t+> recArgsToTerm ts = Ttuple True ts++> getAlgebra = hylo_algebra+> setAlgebra a h = h {hylo_algebra = a}++> getEta = hylo_nattrans+> setEta etas h = h {hylo_nattrans = etas}++> getCoalgebra = hylo_coalgebra+> setCoalgebra ca h = h {hylo_coalgebra = ca}++> getFunctor = hylo_functor+> setFunctor fncs h = h {hylo_functor = fncs}++> getContext = hylo_context+> setContext args h = h {hylo_context = args}++> getName = hylo_name+> setName name h = h {hylo_name = name}+++> consHylo a etas fncs ca = Hylo { hylo_algebra = a,+> hylo_nattrans = etas,+> hylo_functor = fncs,+> hylo_coalgebra = ca,+> hylo_context = emptyContext,+> hylo_name = Vuserdef "default"}+++> instance CoalgebraTerm Psii where+> getPatterns (Psii (p,_)) = p+> getTerms (Psii (_,tts)) = tts+> setTerms tts (Psii (vs,_)) = Psii (vs,tts)++> instance CoalgebraTerm OutFi where+> getPatterns (OutFc (c,args,_)) = [Pcons c (map Pvar args)]+> getTerms (OutFc (_,_,tts)) = tts+> setTerms tts (OutFc (c,vs,_)) = OutFc (c,vs,tts)+++++> instance HasComponents Psi where+> getComponentTerms (Psi psis) = map getTerms psis+> renamePatternVars (Psi psis) = do alts<-mapM rename psis+> return$ Psi alts+> where rename (Psii (p,tts)) = do (p',susts)<-regenPatternVars p+> let ts' = map (substitution (map snd2Term susts) . getTerm) tts+> return$ Psii (p',zipWith tupleterm (map getPosition tts) ts')+> wrapSigma a = WCApsi a++> snd2Term (a,b) = (a,Tvar b)++> instance HasComponents OutF where+> getComponentTerms (OutF outfs) = map (\(OutFc (_,_,outs))->outs) outfs+> renamePatternVars (OutF outfs) = do alts<-mapM rename outfs+> return$ OutF alts+> where rename (OutFc (c,vs,tts)) = do vs'<-mapM (getFreshVar . varPrefix) vs+> let ts' = map (substitution (zip vs$ map Tvar vs') . getTerm) tts+> return$ OutFc (c,vs',zipWith tupleterm (map getPosition tts) ts') +> wrapSigma a = WCAoutF a+++> regenSigmaPatternVars :: [(Variable,Variable)] -> PatternS -> VarGenState (PatternS,[(Variable,Variable)])+> regenSigmaPatternVars acc (PcaseS t0 p t1) = do (p',sustsp)<-regenPatternVars' acc p+> (t1',susts1)<-regenSigmaPatternVars sustsp t1+> return (PcaseS t0 p' t1',susts1)+> regenSigmaPatternVars acc (PcaseSana i t0 p t1) = do (p',sustsp)<-regenPatternVars' acc p+> (t1',susts1)<-regenSigmaPatternVars sustsp t1+> return (PcaseSana i t0 p' t1',susts1)+> regenSigmaPatternVars acc (PcaseR i t0 c vs ts) = do (ts',susts)<-regen ts +> return (PcaseR i t0 c vs ts',susts)+> where regen alts = do (ts',susts)<-chainAccM acc (:) []$ map (flip regenSigmaPatternVars .fst) alts+> let alts'= zipWith (\t (_,ps)->(t,ps)) ts' alts+> return (alts',susts)+> regenSigmaPatternVars acc (Ppattern v p) = do (p',sustsp)<-regenPatternVars' acc p+> return (Ppattern v p',sustsp)+> regenSigmaPatternVars acc t@Pdone = return (t,acc)++> instance HasComponents Sigma where+> getComponentTerms (Sigma (casemap,tts,_,_)) = concat$ zipWith replicate casemap tts+> renamePatternVars (Sigma (casemap,tts,pss,hss)) = +> do (tts',ts')<-rename tts pss+> return$ Sigma (casemap,tts',ts',hss)+> where rename :: [[TupleTerm]] -> [[PatternS]] +> -> VarGenState ([[TupleTerm]],[[PatternS]])+> rename tts ps = do tsusts <-mapM (mapM (regenSigmaPatternVars [])) ps+> let (ts',susts) = unzip . map unzip $ tsusts+> return (zipWith termSust tts (map (map snd2Term.concat) susts),ts')+> termSust :: [TupleTerm] -> [(Variable,Term)] -> [TupleTerm]+> termSust ts susts = map (\t -> tupleterm (getPosition t) (substitution susts (getTerm t))) ts+> wrapSigma a = WCAsigma a+++> instance HasComponents WrappedCA where+> getComponentTerms wac =+> case wac of+> WCApsi (_,_,wa) -> f wa+> WCAoutF (_,_,wa) -> f wa+> WCAsigma (_,_,wa) -> f wa+> where f wa=getComponentTerms wa+> renamePatternVars wac =+> case wac of+> WCApsi (v,t,wa) -> do wa'<-renamePatternVars wa;return$ WCApsi (v,t,wa')+> WCAoutF (v,t,wa) -> do wa'<-renamePatternVars wa;return$ WCAoutF (v,t,wa')+> WCAsigma (v,t,wa) -> do wa'<-renamePatternVars wa;return$ WCAsigma (v,t,wa')+> wrapSigma _ = error ("WrappedCA::wrapSigma: " ++ no_Sound_Operation_Aplication)+++> regenPatternVars :: [Pattern] -> VarGenState ([Pattern],[(Variable,Variable)])+> regenPatternVars ps = do (pss,stss) <- chainAccM [] (:) []$ map (flip regenPatternVars') ps+> return (pss,stss)+ +> regenPatternVars' :: [(Variable,Variable)] -> Pattern -> VarGenState (Pattern,[(Variable,Variable)])+> regenPatternVars' ss p@(Pvar v) | p/=pany =+> case lookup v ss of+> Nothing -> do u<-getFreshVar (varPrefix v)+> return (Pvar u,(v,u):ss)+> Just u -> return (Pvar u,ss)+> regenPatternVars' ss (Ptuple ps) = +> do (ps',susts)<-chainAccM ss (:) []$ map (flip regenPatternVars') ps+> return (Ptuple ps',susts)+> regenPatternVars' ss (Pcons c ps) = +> do (ps',susts)<-chainAccM ss (:) []$ map (flip regenPatternVars') ps+> return (Pcons c ps',susts)+> regenPatternVars' ss p = return (p,ss)++> chainAccM :: Monad m => a -> (b->c->c)-> c -> [a->m (b,a)] -> m (c,a)+> chainAccM ss f e = foldrM (\op (pss,ss)-> op ss >>= \(p,ss')->return (f p pss,ss')) (e,ss)+
+ HFusion/Internal/Inline.lhs view
@@ -0,0 +1,841 @@+-- Please, see the file LICENSE for copyright and license information.++> {-# LANGUAGE TypeSynonymInstances #-}+>module HFusion.Internal.Inline (+> inline+> ,showHylo+> ,ShowDocA+> ,CoalgebraPrintable+> ,applyHyloWithCntArgs +> ) where++> import List++> import HFusion.Internal.HyloRep+> import HFusion.Internal.Parsing.HyloContext+> import HFusion.Internal.RenVars+> import HFusion.Internal.HsPretty+> import HFusion.Internal.HsSyn+> import HFusion.Internal.Utils+> import Data.Char(isAlpha,isLower,isDigit)+> import Control.Monad.State(get,put,State,StateT(StateT),runState,evalState)+> import Control.Monad.Reader(Reader,runReader,ask,local)+> import Control.Monad.Identity(Identity(..))+> import qualified Data.Map as M(lookup)++ import Debug.Trace++ sss' t = trace (show t)+++> class Inlineable a where+> getInline :: [Term] -> a -> Term++ Type class for inline algebra components. +let phi = phi_1 \/...\/ phi_n, getInline [t_1,...,t_n] phi_i is the term representing the beta-reduction of+phi_i (t_1,...,t_n).++> class CAInlineable c where+> caGetInline :: [Term] -> Term -> Coalgebra c -> VarGenState Term++ Type class for inline coalgebra components. + let psi = \l->case t0 of p1 -> t1';...;pn -> tn'+ caGetInline [t_1,...,t_n] a psi is more or less the term representing+ (case t0 of p1 -> t_1;...;pn -> t_n)[a/l]+ caGetInline [] a psi is more or less the term representing+ (case t0 of p1 -> t1';...;pn -> tn')[a/l]++ This is not the exact behavior for coalgebras in sigma form, we may document the behavior for these in the future.++++> instance CAInlineable Psi where+> caGetInline ts arg (bv,t0,Psi psis) +> | null ts = return$ delCases$ substitution (zipTree [bvtuple bv] [arg])$ Tcase (toTerm t0) ps (map getCaTerm psis)+> | otherwise = return$ delCases$ substitution (zipTree [bvtuple bv] [arg])$ Tcase (toTerm t0) ps ts+> where getCaTerm =Ttuple False . map getTerm.getTerms+> ps=map (toPattern . getPatterns) psis+> eq (Tvar v') v = (v'==v)+> eq _ _ = False+> toTerm [t] = t+> toTerm ts = Ttuple False ts+> toPattern [p] = p+> toPattern ps = Ptuple ps++++> instance CAInlineable Sigma where+> caGetInline ts arg (bv,t0s,coalgebra) =+> do t<-inlineSigma t0s coalgebra ts+> return . substitution (zipTree [bvtuple bv] [arg]) . delCases$ t++> splitList :: [a] -> [Int] -> [[a]]+> splitList ls (i:is) = ls' : splitList lss is+> where (ls',lss) = splitAt i ls+> splitList ls [] = []++> insertRecvarCases :: [Term] -> [[PatternS]] -> Term -> Term+> insertRecvarCases ts pss t = foldr insertCase t (zip ts (head pss))+> where insertCase (t0t@(Tvar t0),p) t +> | t0/=v = Tcase t0t [Pvar v] [t]+> | otherwise = t+> where v = pvar p+> insertCase (t0,p) t = Tcase t0 [Pvar (pvar p)] [t]++> matchSigmaTerms :: [Term] -> [[PatternS]] -> [(Variable,Term)]+> matchSigmaTerms ts pss = zipWith matchCase ts (head pss)+> where matchCase t p = (pvar p,t)++> pvar :: PatternS -> Variable+> pvar (Ppattern v _) = v+> pvar (PcaseR _ v _ _ _) = v+> pvar (PcaseSana _ v _ _) = v+> pvar (PcaseS v _ _) = v+> pvar Pdone = error$ "pvar: unexpected PatterS: Pdone"++> zipTree :: [Boundvar] -> [Term] -> [(Variable, Term)]+> zipTree bvs ts = maybe (error ("zipTree: No coinciden las listas."++show bvs++show ts)) id$ zipTree' bvs ts+++> data InlST = InlST {fterms::[(Constructor,[[Term]->VarGenState Term])],gi::VarGen}++> inlineSigma :: [Term] -> Sigma -> [Term] -> VarGenState Term+> inlineSigma t0s (Sigma (casemap,ts,pss,hss)) ts' = +> do t<-inlineTHS (reorganizeSigma$ weaveTermS (splitList initialTerms casemap)$ pss)+> return$ insertRecvarCases t0s pss t+> where inlineTHS t = inlineTermS inlWCA (\ia ih -> lookupfapp ih (hss!!ia)) (matchSigmaTerms t0s pss) t+> getCaTerm = Ttuple False . map getTerm+> initialTerms | null ts' = map getCaTerm ts+> | otherwise = ts'+> inlWCA :: Int -> Int -> [(Variable,Term)] -> Variable -> +> (Acomponent InF->(Term->Term,[Term])->State InlST Term)->State InlST Term+> inlWCA ia ih sust t0 f = +> do let Just (_,inFs,etas,wca,fapp) = hss!!ia+> k<-get+> let (wca',i')=runState (renamePatternVars wca) (gi k) -- renombrar variables de patrones+> put (k {gi=i'})+> ts<-sequence$ zipWith f inFs (inlEtas wca' sust etas)+> k<-get+> let (t,i')=runState (inlCA wca' (substitution sust (Tvar t0)) ts) (gi k)+> put (k {gi=i'})+> return t+> inlEtas wca sust etas = zipWith reduceTrans (map (map (substitution sust . getTerm))$ getComponentTerms wca) etas+> inlCA (WCApsi c) t0 ts = caGetInline ts t0 c+> inlCA (WCAoutF c) t0 ts = caGetInline ts t0 c+> inlCA (WCAsigma c) t0 ts = caGetInline ts t0 c+> lookupfapp i (Just (_,_,_,_,fapp)) = fapp i+> lookupfapp i _ = error "lookupfapp: unexpected case"+> inlineTermS inlWCA fapp sust t =+> case t of +> TtermS t -> return t+> TcaseS t0 p t a -> do t'<-inlS t+> a'<-inlS a+> return$ Tcase (substitution sust (Tvar t0)) (conda a p pany) (conda a t' a')+> TcaseSana ia ih t0 p t a -> do t'<-inlS t+> a'<-inlS a+> return$ Tcase (fapp ia ih (substitution sust (Tvar t0)))+> (conda a p pany) (conda a t' a')+> TcaseR ia ih t0 ps a -> do let fts'=map inlAlt' ps+> a'<-inlS a+> i<-get+> let (res,k)=runState (inlWCA ia ih sust t0$ inlA (inlTermS a'))$ InlST fts' i+> put (gi k)+> return res+> TbottomS -> return$ Tbottom+> where conda TbottomS t1 t2 = [t1]+> conda _ t1 t2 = [t1,t2]+> inlS = inlineTermS inlWCA fapp sust+> inlAlt' (c,vrs,ts) = (c,map (inlAlt vrs) ts)+> inlAlt :: [Variable] -> (TermS,[Variable]) -> [Term] -> VarGenState Term+> inlAlt vrs (t,nrs) ts = do let (recs,nrecs) = partition (flip notElem nrs.fst)$ zip vrs ts+> t'<-inlineTermS inlWCA fapp (sust++recs) t+> return (foldr (\(u,t0) ti->Tcase t0 [(Pvar u)] [ti]) t' nrecs)+> inlTermS a (InF (c',_)) ts sust = +> do k<-get +> case lookup c' (fterms k) of+> Just fts -> do k<-get+> let (t,i')=runState (head fts ts) (gi k)+> put (k {fterms=inlstupd c' (tail fts) (fterms k),gi=i'})+> return t+> Nothing -> return a+> inlstupd c l [] = []+> inlstupd c l (h@(c',_):as) | c==c' = (c,l):as+> | otherwise = h: inlstupd c l as+++It follows a representation of the term woven from PatternSs.++> data TermS = TcaseS Variable Pattern TermS TermS++ [| TcaseS v p t1 t2 |] = case v of p -> [| t1 |]; _ -> [| t2 |]++> | TcaseSana Int Int Variable Pattern TermS TermS++ [| TcaseSana ia ih v p t1 t2 |] = case ana(beta) v of p -> [| t1 |]; _ -> [| t2 |]++ ia is the argument index, which coalgebra is being applied here.+ ih is the index of the coalgebra term to select from the mutual hylo.++> | TcaseR Int Int Variable [(Constructor,[Variable],[(TermS,[Variable])])] TermS++ [| TcaseR ia ih v alts t2 |] = case beta v of [| alts |]; _ -> [| t2 |]+ [| (c,args,[(t1,_), ... ,(tn,_)]) |] = (c1,args)->[| t1 |]; ...;(cn,args)->[|tn|] ++ ia is the argument index, which coalgebra is being applied here.+ ih is the index of the coalgebra term to select from the mutual hylo.++> | TtermS Term++ [| TtermS t |] = t++> | TbottomS++ [| TbottomS |] = _|_++> deriving Show+++It follows a function to weave a TermS from a lists PatternSs. + waveTermS [t1...tn] [[p11...p1n]...[[pm1...pmn]] +is a case term like++ case (v1,...,vn) of+ (p11,...,pm1) -> t1+ ...+ (p1n,...,pmn) -> tn++> weaveTermS :: [[Term]] -> [[PatternS]] -> TermS+> weaveTermS tss pss = foldr (\(ps,ts) tb -> fst$ runState (toTermS 0 ps tb) ts) TbottomS (zip pss tss)+> where toTermS :: Int -> [PatternS] -> TermS -> State [Term] TermS+> toTermS i (p:ps) tb = toTermS' i p (toTermS (i+1) ps tb) tb+> toTermS _ [] tb = do ts<-get+> put (tail ts)+> return$ TtermS (head ts)+> toTermS' :: Int -> PatternS -> State [Term] TermS -> TermS -> State [Term] TermS+> toTermS' ia (PcaseS t0 p t1) t tb = +> do t'<-toTermS' ia t1 t tb+> return$ TcaseS t0 p t' tb+> toTermS' ia (PcaseSana ih t0 p t1) t tb = +> do t'<-toTermS' ia t1 t tb+> return$ TcaseSana ia ih t0 p t' tb+> toTermS' ia (PcaseR ih v c vrs []) t tb = return tb+> toTermS' ia (PcaseR ih v c vrs ts) t tb = +> do ts' <- mapM (toTermSalts' ia t tb) ts+> return$ TcaseR ia ih v [(c,vrs,ts')] tb+> toTermS' ia (Ppattern v p) t tb = t >>= \t -> return$ TcaseS v p t tb+> toTermS' ia Pdone t _ = t+> toTermSalts' ia t tb (t',recs) = toTermS' ia t' t tb >>= \r-> return (r,recs)+++We eliminate with the following function spurious cases that appear when inlining the+patterns of sigma. By analyzing the code it is possible to decide which branches will+be taken in many cases. This routine also saves a lot of variables.++This type represents what we know from the context of a given term.+We know that we are under an alternative of a case on variable v,+the specific alternative is Just (constructor,choice index), or nothing if we are+on a default alternative; for every alternative of that case we store+the constructor, the variables used as arguments, and which term corresponded+for those alternatives.++> type NodeDown = (Variable,Either (Maybe (Constructor,Int),[(Constructor,[Variable],[(TermS,[Variable])])])+> (Pattern,Bool))++ (v,c,i,alts) v es la variable sobre la que se aplica la coalgebra argumento.+ c es el constructor que resulto de aplicar la coalgebra argumento.+ i es la alternativa corespondiente del constructor (0-based)+ alts son las alternativas del case en que se obtuvo el constructor c.++> type NodeUp = (Variable,[(Constructor,[Variable],[(TermS,[Variable])])])++> reorganizeSigma :: TermS -> TermS+> reorganizeSigma = snd . rs [] []+> where rs :: [NodeDown] -> [Either (TermS->TermS) Variable] -> TermS -> ([NodeUp],TermS)+> rs ns _ t@(TtermS _) = ([],t)+> rs ns ctx (TcaseS t0 p t a) | not (isRefusable p) =+> let (adds',t') = rs ns (Left (\t->TcaseS t0 p t TbottomS):ctx) t+> in (adds', TcaseS t0 p t' TbottomS)+> rs ns ctx (TcaseS t0 p t a) =+> case lookup t0 ns of+> Just (Right (p',True)) +> | matches p' p ->+> case matchingSubsts (Just t0) p' p of+> Just sust -> +> let mkTermS t = foldr (\(t0r,p) tr->TcaseS t0r p tr TbottomS) t sust+> (adds',t')=rs ((t0,Right (p,True)):ns) (Left mkTermS:ctx) t+> in (adds',mkTermS t')+> Nothing -> let (adds',t')=rs ((t0,Right (p,True)):ns) (Left (\t->TcaseS t0 p t TbottomS):ctx) t+> in (adds',TcaseS t0 p t' TbottomS)+> | otherwise -> rs ns ctx a+> Just (Right (p',False)) | matches p p' -> rs ns ctx a+> _ ->+> let (adds',t')=rs ((t0,Right (p,True)):ns) (Left (\t->TcaseS t0 p t a'):ctx) t+> (adds'',a')=rs ((t0,Right (p,False)):ns) ctx a+> in (adds' ++ adds'',TcaseS t0 p t' a')+> rs ns ctx (TcaseSana ia ih t0 p t a) | not (isRefusable p) = +> let (adds',t') = rs ns (Left (\t->TcaseSana ia ih t0 p t TbottomS):ctx) t+> in (adds', TcaseSana ia ih t0 p t' TbottomS)+> rs ns ctx (TcaseSana ia ih t0 p t a) = +> let (adds',t')=rs ns (Left (\t->TcaseSana ia ih t0 p t a'):ctx) t+> (adds'',a')=rs ns ctx a+> in (adds' ++ adds'',TcaseSana ia ih t0 p t' a')+> rs ns ctx (TcaseR ia ih t0 ps a) =+> case lookup t0 ns of+> Just (Left (Just (c,i),ps')) -> +> case find (\(c',_,_)->c==c') ps of+> Just (_,vrs',ts') -> let (_,vrs,_)= maybe (error ("reorganizeSigma: i have a problem with constructor "++c))+> id $ find (\(c',_,_)->c==c') ps'+> in rs ns (Right t0:ctx) . substituteTerms (zip vrs' vrs) . fst . (ts'!!) $ i+> Nothing -> rs ns ctx a+> Just (Left (Nothing,ps')) -> let d=ps `diff` ps'+> (adds,d')= applyCtx t0 ctx$ recurse t0 ns ctx d+> r@(addsa,da)=rs ns ctx a+> in if null d then r else ((t0,d'):(addsa++adds),da)+> _ -> let ctx' = Right t0:ctx +> (adds,ps') = recurse t0 ns ctx' ps+> (adds',a') = rs ((t0,Left (Nothing,ps)):ns) ctx' a+> (addnow,pass) = partition ((==t0).fst) (adds++adds')+> in (pass,TcaseR ia ih t0 (ps'++concat (map snd addnow)) a')+> rs ns ctx TbottomS = ([],TbottomS)++> recurse v ns ctx ps = let (addss,ps')=unzip $ map (rs' v ns ctx ps) ps+> in (concat addss,ps')++> isRefusable (Pas _ p) = isRefusable p+> isRefusable (Pvar _) = False+> isRefusable _ = True+> applyCtx v ctx (adds,d) = (adds,map (\ (c,vs,ts)-> (c,vs,map (appCtx v ctx) ts)) d)+> appCtx v ctx (s,pos) = (foldl appf s (takeWhile (either (const True) (v/=)) ctx),pos)+> appf s (Left f) = f s+> appf s _ = s++> rs' v ns ctx ps (c,vrs,ts) = let (addss,ts')=unzip $ map (rs'' v c ns ctx ps) (zip ts [0..])+> in (concat addss,(c,vrs,ts'))+> rs'' v c ns ctx ps ((t,pos),i) = let (adds,t')=rs ((v,Left (Just (c,i),ps)):ns) ctx t+> in (adds,(t',pos))++> diff l1 l2 = let notinl2 (c,_,_) = maybe True (const False) $ find (\(c',_,_)->c==c') l2 +> in filter notinl2 l1++ matches p0 p1 returns True iff all expressions matching p0 also match p1.++> matches (Pas _ p) p' = matches p p'+> matches p (Pas _ p') = matches p p'+> matches _ (Pvar v) = True+> matches (Pvar v) _ = False+> matches (Ptuple ps) (Ptuple ps') = length ps == length ps' && and (zipWith matches ps ps')+> matches (Pcons c ps) (Pcons c' ps') = c==c' && length ps == length ps' && and (zipWith matches ps ps')+> matches (Plit l) (Plit l') = l==l'+> matches _ _ = False++ matchingSubsts v p0 p1 returns (Just sustst) iff all expressions matching p0 also match p1,+ provided that the given matches in susts can be done.+ v is the variable the patterns are checked against.++> matchingSubsts :: Maybe Variable -> Pattern -> Pattern -> Maybe [(Variable,Pattern)]+> matchingSubsts v (Pas vp p) p' = matchingSubsts (Just vp) p p'+> matchingSubsts v (Pvar vp) p = Just [(vp,p)]+> matchingSubsts (Just v) _ p1@(Pvar _) = Just [(v,p1)]+> matchingSubsts v (Ptuple ps) (Ptuple ps') +> | length ps == length ps' = +> sequence (zipWith (matchingSubsts Nothing) ps ps') >>= return . concat+> matchingSubsts v (Pcons c ps) (Pcons c' ps') +> | c==c' && length ps == length ps' = +> sequence (zipWith (matchingSubsts Nothing) ps ps') >>= return . concat+> matchingSubsts v (Plit l) (Plit l') | l==l' = Just []+> matchingSubsts _ _ _ = Nothing++ safeMatch p returns true if there is no way to have pattern matching of p fail.++> safeMatch (Pvar _) = True+> safeMatch (Pas _ p) = safeMatch p+> safeMatch _ = False++> substituteTerms :: [(Variable,Variable)]->TermS->TermS+> substituteTerms susts (TtermS t) = TtermS (substitution (map (\(v1,v2)->(v1,Tvar v2)) susts) t)+> substituteTerms susts (TcaseS t0 p t a) = +> case lookup t0 susts of+> Just v -> TcaseS v p (substituteTerms susts t) (substituteTerms susts a)+> Nothing -> TcaseS t0 p (substituteTerms susts t) (substituteTerms susts a)+> substituteTerms susts (TcaseSana ia ih t0 p t a) = +> case lookup t0 susts of+> Just v -> TcaseSana ia ih v p (substituteTerms susts t) (substituteTerms susts a)+> Nothing -> TcaseSana ia ih t0 p (substituteTerms susts t) (substituteTerms susts a)+> substituteTerms susts (TcaseR ia ih t0 ps a) = +> let recf (c,vrs,ts) = (c,vrs,map (\(t,pos)->(substituteTerms susts t,pos)) ts)+> in case lookup t0 susts of+> Just v -> TcaseR ia ih v (map recf ps) (substituteTerms susts a)+> Nothing -> TcaseR ia ih t0 (map recf ps) (substituteTerms susts a)+> substituteTerms susts TbottomS = TbottomS+++++> instance CAInlineable OutF where+> caGetInline ts arg (bv,t0:_,OutF psis) +> | null ts = return$ substitution (zipTree [bvtuple bv] [arg])$ Tcase t0 ps (map getCaTerm psis)+> | otherwise = return$ substitution (zipTree [bvtuple bv] [arg])$ Tcase t0 ps ts+> where getCaTerm =Ttuple False . map getTerm.getTerms+> ps=map (toPattern . getPatterns) psis+> eq (Tvar v') v = (v'==v)+> eq _ _ = False+> toPattern [p] = p+> toPattern ps = Ptuple ps+> caGetInline ts arg (bv,[],OutF psis) = error$ "caGetInline: unexpected empty list of terms"+++++> instance (Inlineable a) => Inlineable (Acomponent a) where+> getInline terminosEntrada (Acomp (vs, termwrapper)) = maybe nop ok$ zipTree' vs terminosEntrada+> where ok parejasSubstituciones = substitution parejasSubstituciones$ getInline terminosEntrada termwrapper+> nop = Tcase (ttuple terminosEntrada) [ptuple (map bv2pat vs)] [getInline (map bv2term vs) termwrapper]++> instance (Inlineable a) => Inlineable (TauTerm a) where+> getInline terminosEntrada (Taucons cons ts phi etai) =+> let tsinlines = map (getInline terminosEntrada) ts+> (fts,newts) = reduceTrans tsinlines etai+> in fts$ getInline newts phi+> getInline _ (Tausimple t) = t+> getInline terminosEntrada (Taucata ft t) = ft (getInline terminosEntrada t)+> getInline terminosEntrada (Taupair term tauTerm) =+> let tauTermInline = getInline terminosEntrada tauTerm+> in Ttuple False [term, tauTermInline]++> instance Inlineable Phii where+> getInline _ t = t++> instance Inlineable Tau where+> getInline terminosEntrada (Tauphi phi) =+> getInline terminosEntrada phi+> getInline terminosEntrada (TauinF inf) =+> getInline terminosEntrada inf+> getInline terminosEntrada (Tautau tau) =+> getInline terminosEntrada tau++> instance Inlineable InF where+> getInline _ (InF (cons, ts)) =+> (Tcapp cons ts)++> instance (Inlineable a) => Inlineable (TermWrapper a) where++> getInline terminosEntrada (TWcase term patterns termWrappers) =+> let+> terminos = map (getInline terminosEntrada) termWrappers+> in+> Tcase term patterns terminos++ [| TWcase t0 ps ts |] = case t0 of ps[i] -> [| ts[i] |]++> getInline terminosEntrada tw@(TWeta termWrapper etai) = +> let (fts,resultadosEta) = reduceTrans terminosEntrada etai+> in fts$ getInline resultadosEta termWrapper++ [| TWeta a eta |] = a.eta++> getInline terminosEntrada (TWsimple a) =+> getInline terminosEntrada a++ [| TWsimple a |] = [| a |]++> getInline terminosEntrada (TWacomp acomponent) =+> getInline terminosEntrada acomponent++ [| TWacomp a |] = [| a |]++> getInline _ (TWbottom) =+> (Tlamb (Bvtuple False []) Tbottom) -- bottom++ [| TWbottom |] = \_ -> _|_++A function used for debugging purposes++ showRawTW :: TermWrapper a -> Doc+ showRawTW (TWcase t0 ps tw) = (text "case"<+>showDoc t0<+> text "of")+ $$ vcat (zipWith (\p t -> showDoc p<+>text "->"<+>showRawTW t) ps tw)+ showRawTW (TWeta tw e) = showRawTW tw <+>text "."<+>showDoc e+ showRawTW (TWsimple a) = text "TWsimple a"+ showRawTW (TWacomp a) = text "TWacomp "<+>text (show (getVars a))<+>showRawTW (unwrapA a)+ showRawTW TWbottom = text "TWbottom"++++> inline :: (CHylo h, CAInlineable ca, Inlineable a, HasComponents ca) => [h a ca] -> h a ca -> VarGenState Def+> inline hs hylo =+> let +> (boundvar, t0, coalgebra) = getCoalgebra hylo+> algebra = getAlgebra hylo+> eta = getEta hylo+> functor = getFunctor hylo+> tupleTerms = getComponentTerms coalgebra +> terminosAlternativas = map (map getTerm) tupleTerms+> varsAlts = map (map getPosition) tupleTerms+> etaResults = map (flip reduceTrans)$ zipWith3 (\e tts fnc -> e `rightCompose` inlineDelta hs tts fnc) eta tupleTerms functor+> phis = zipWith (\ etaRes algebrai terminos -> +> let (etaf,ts) = etaRes terminos+> in etaf (getInline ts algebrai)) +> etaResults algebra+> in do i<-get+> let cainl=caGetInline (zipWith ($) phis terminosAlternativas) +> (bv2term (bvtuple boundvar)) (getCoalgebra hylo)+> (cainlres,i') = runState cainl i+> put i'+> return$ Defvalue (getName hylo)$ removeHyloApps$ nullPatternVariables$ mergeCasePatterns$ +> foldr Tlamb cainlres$ concat$ (map flattenBv)$ boundvar+> where flattenBv (Bvtuple True bvs) = concat$ map flattenBv bvs+> flattenBv bv = [bv]++Creates a term resembling a natural transformation, but it is not as it injects the explicit recursive calls.++> inlineDelta :: CHylo h => [h a ca] -> [TupleTerm] -> HFunctor -> EtaOp+> inlineDelta hs tts fnc =+> let ps=map (\tt -> let p=getPosition tt in (p,getRecIndex fnc p)) tts +> in EOsust (map fst ps) +> (zipWith mksust ps (map (expanded fnc.fst) ps))+> (map (Bvar . fst) ps)+> where mksust (rv,ri) pf = let tp = Tvar rv+> in mapStructure (applyHylo (hs!!maybe 0 id ri) tp) tp pf+> applyHylo h t = applyHyloWithCntArgs h [] Nothing t++> applyHyloWithCntArgs :: CHylo h => h a ca -> [Term] -> Maybe [Int] -> Term -> Term+> applyHyloWithCntArgs h cntargs cntpos t = Thyloapp (getName h) (sum$ map countArgs bvs) cntargs cntpos t+> where (bvs,_,_)=getCoalgebra h+> countArgs (Bvtuple True bvs) = sum (map countArgs bvs)+> countArgs bv = 1+++> instance Show EtaOp where+> show = render.showDoc++> instance ShowDoc EtaOp where+> showDoc (EOgeneral bvs tts) = text "(\\"<>showTuple bvs<>text "->"<>showTuple tts<>char ')'+> showDoc EOid = text "id"+> showDoc (EOsust vs ts vss) = text "(\\"<>showTuple vss<>text "->"<>showTuple (map (sust$ zip vs ts) vss)<>char ')'+> where sust vts (Bvar v) = maybe (Tvar v) id$ lookup v vts+> sust vts (Bvtuple b vs) = Ttuple b$ map (sust vts) vs+> showDoc (EOlet t0s ps vs ts) = text "(\\"<>showTuple vs+> <>text "->case"<+>showTuple t0s<+>text "of"$$+> (showTuple ps<+>text "->"<>showTuple ts<>char ')')++> removeHyloApps :: Term -> Term+> removeHyloApps = transformTerm remHApp+> where remHApp _ (Thyloapp v i ts pos t) = Tfapp v (thyloArgs i ts pos t)+> remHApp _ (Tlamb (Bvtuple True bv) t) = foldr Tlamb t$ concat$ map flattenbv bv+> remHApp _ t = t+> flattenbv (Bvtuple True bvs) = concat$ map flattenbv bvs+> flattenbv bv = [bv]++Inlining of natural transformations.+Receives the input terms, the nat transformation to apply, and+returns a function and the terms of the tuple which results from +applying the natural transformation. The function is expected+to be applied to the terms resulting from several+natural transformations applied in sequence.++> reduceTrans :: [Term] -> Etai -> (Term->Term,[Term])+> reduceTrans ts (Etai (etasIzq, etasDer)) = (ftr.fti,tsall)+> where (fti,tsall)=reduceFromRight etasIzq tsr+> (ftr,tsr)=reduceFromRight (reverse etasDer) ts+> reduceFromRight etas tr = foldr atomicOperation' (id,tr) etas+> atomicOperation' etaop (ft,ts) = let (ft',ts')=atomicOperation etaop ts+> in (ft.ft',ts')++> atomicOperation :: EtaOp -> [Term] -> (Term->Term,[Term])+> atomicOperation eta terminosContexto =+> case eta of+> EOid -> (id,terminosContexto)+> EOgeneral vs ts -> case zipTree' vs terminosContexto of+> Just sust -> (id,map (substitution sust) ts)+> _ -> (Tcase (ttuple terminosContexto) [Ptuple (map bv2pat vs)].(:[]),ts)+> EOsust vks ts vs ->+> let termino = map (substitution ((zip vks ts))) (map bv2term vs)+> in case zipTree' vs terminosContexto of+> Just zips -> (id,map (substitution zips) termino)+> _ -> (Tcase (ttuple terminosContexto) [Ptuple (map bv2pat vs)].(:[]),termino)+> EOlet t0s ps vs ts -> let sust = zip vs terminosContexto in+> (Tcase (ttuple (map (substitution sust) t0s)) [ptuple ps].(:[]), map (substitution sust) ts)++> data InlAEnv = InlAEnv {terms::[Term], susts::[(Variable,Term)]}++Inlining de componentes de algebra.++> inlA :: Monad m => (a->[Term]->[(Variable,Term)]->m Term) -> Acomponent a -> (Term->Term,[Term]) -> m Term+> inlA f inF (fts,ts) = maybe bad ok (zipTree' (getVars inF) ts)+> where ok sts = runReader (inlTW f$ unwrapA inF) (InlAEnv ts sts) >>= return . fts+> bad = do t<-runReader (inlTW f$ unwrapA inF)$ InlAEnv ts []+> return$ fts$ Tcase (ttuple ts) [ptuple (map bv2pat (getVars inF))] [t]++Esta función es para hacer el inlining de cosas que tienen componentes de tipo TermWrapper.++> inlTW :: Monad m => (a->[Term]->[(Variable,Term)]->m Term) -> TermWrapper a -> Reader InlAEnv (m Term)+> inlTW = inlTW' False+> inlTW' :: Monad m => Bool -> (a->[Term]->[(Variable,Term)]->m Term) -> TermWrapper a -> Reader InlAEnv (m Term)+> inlTW' b f tw = foldTW hcase (if b then heta' else heta) hsimple hacomp (return (return Tbottom)) tw+> where hcase t0 ps ts = do env<-ask+> ts'<-sequence ts+> return (do ts''<-sequence ts';return (Tcase (substitution (susts env) t0) ps ts''))+> --heta t eta = local (\k->k {terms=reduceTrans (terms k) eta}) t+> heta = heta'+> heta' mmt eta = do env<-ask+> let (ft,ts)=reduceTrans (terms env) eta+> local (\k->k {terms=ts}) (do mt<-mmt;return (do t<-mt;return (ft t)))+> hsimple inf = do env<-ask; return$ f inf (terms env) (susts env)+> hacomp inF = do env<-ask; maybe (bad env) (ok env)$ zipTree' (getVars inF) (terms env)+> where ok env sts = local (\k->k {susts=sts})$ inlTW f (unwrapA inF)+> bad env = local (\k->k {susts=filter (flip notElem (vars (getVars inF)).fst) (susts k)}) $ +> do m<-inlTW f (unwrapA inF)+> return$ do t<-m+> return$ Tcase (ttuple (terms env)) [ptuple (map bv2pat (getVars inF))] [t]+++> termS2Term :: (Int->Int->[Term]->Term)->TermS->Term+> termS2Term _ TbottomS = Tbottom+> termS2Term f (TcaseS t0 p t v) = +> case v of +> TbottomS -> Tcase (Tvar t0) [p] [termS2Term f t]+> _ -> Tcase (Tvar t0) [p,pany] [termS2Term f t,termS2Term f v]+> termS2Term f (TcaseSana ia ih t0 p t v) = +> case v of +> TbottomS -> Tcase (applyana (Tvar t0)) [p] [termS2Term f t]+> _ -> Tcase (Tvar t0) [p,pany] [termS2Term f t,termS2Term f v]+> where applyana = Tapp (Tlit$Lint$ "[("++(show$ f ia ih [])++")]")+> termS2Term f (TcaseR ia ih t0 ps v) = +> case v of +> TbottomS -> Tcase (f ia ih [Tvar t0]) (concat (map mkPattern ps)) (concat (map mkTerm ps)) +> _ -> Tcase (f ia ih [Tvar t0]) (concat (map mkPattern ps)++[pany]) (concat (map mkTerm ps)++[termS2Term f v]) +> where pf (c,vrs) i = Ptuple [Pvar (Vuserdef (c++show i)),Ptuple (map Pvar vrs)]+> alt2Term vrs (t,_) = termS2Term f t+> mkPattern (c,vrs,ts) = zipWith pf (replicate (length ts) (c,vrs)) [1..]+> mkTerm (c,vrs,ts) = map (alt2Term vrs) ts+> termS2Term _ (TtermS t) = t+++Replaces unused variables with "_" in patterns.++> nullPatternVariables :: Term -> Term+> nullPatternVariables = transformTerm f+> where f _ (Tcase t0 ps ts) = Tcase t0 (zipWith subst ps ts) ts+> f _ t = t+> subst p t = alphaConvert [] (zip (filter (isLegalStart . head . show) (vars p \\ vars t)) (repeat (Vuserdef "_"))) p+> isLegalStart c = isAlpha c && isLower c || isDigit c+++Pretty printing hylomorphism-shaped+++> showHylo :: (CHylo hylo,ShowDocA a,HasComponents ca,CoalgebraPrintable ca) => Bool -> VarGen -> hylo a ca -> String+> showHylo isTau i h =+> let s = text "--------------"+> in render $+> text ("Hylo "++show (getContext h)) $$+> nest 2 (s $$+> (showDocA i (getAlgebra h)) $$ s $$+> (vcat (map showDoc (getEta h))) $$ s $$+> (if deltaToPrint tts (getFunctor h) +> then printDeltas tts (getFunctor h) +> else empty+> ) $$+> printCA 0 0 vsm t0 coalg $$ s $$+> (showFunctor coalg (getFunctor h)))+> where+> (vsm,t0,coalg) = getCoalgebra h+> tts=getComponentTerms coalg+> showFunctor ca fncs=+> let fcts=zipWith printProds tts fncs+> in if not (null tts) then foldl ((<+>).(<+>char '+')) (head fcts) (tail fcts) else empty+> printProds [] fnc = text "1"+> printProds tts fnc = let prods=map (printFnc fnc.getPosition) tts+> in if not (null prods) then foldl ((<>).(<>char 'x')) (head prods) (tail prods) else empty+> printFnc fnc p = maybe (char 'C') (\i->showDocPF i (expanded fnc p))$ getRecIndex fnc p +> printDeltas ts@(tts:ttss) fs@(f:fncs) =+> text "delta" $$ +> nest 4 (vcat (+> (if isDeltaId tts f then text "id" else printDelta tts f)+> : zipWith printDelta ttss fncs)+> )+> $$ text "end delta" +> printDeltas _ _ = empty +> deltaToPrint tts fncs = any (not . uncurry isDeltaId)$ zip tts fncs+> isDeltaId tts fnc = all (foldPF (const True) (const True) (const False) . expanded fnc)$ map getPosition tts+> printDelta tts fnc = let vs = map getPosition tts+> in showDoc$ Tlamb (Bvtuple False (map Bvar vs)) +> (Ttuple False (map (\v->mapStructure (Tvar v) (Tvar v)$ expanded fnc v) vs))++Class for printing coalgebras. The first Int argument specifies how nested is the coalgebra;+it is mainly used for generating names like sigma0, sigma1, ....++> class CoalgebraPrintable a where+> printCA :: Int -> Int -> [Boundvar] -> [Term] -> a -> Doc++> instance CoalgebraPrintable WrappedCA where+> printCA i ia v t wac =+> case wac of+> WCApsi (_,_,wa) -> f wa+> WCAoutF (_,_,wa) -> f wa+> WCAsigma (_,_,wa) -> f wa+> where f wa=printCA i ia v t wa++> showDocWCA i ia wac =+> case wac of+> WCApsi wa -> f wa+> WCAoutF wa -> f wa+> WCAsigma wa -> f wa+> where f (v,t0,a) = printCA i ia v t0 a++++> instance CoalgebraPrintable Sigma where+> printCA i ia v t0s coalg = showDocSigma i ia v t0s coalg++> instance CoalgebraPrintable Psi where+> printCA _ _ vsm t0 coalg = char '\\'<>text (show (bvtuple vsm))<>text "->case"+> <+>showDoc (Ttuple False t0)<+>text "of"$$ nest 4 (showDoc coalg)++> instance CoalgebraPrintable OutF where+> printCA _ _ vsm t0 coalg = char '\\'<>text (show (bvtuple vsm))<>text "->case"+> <+>showDoc (Ttuple False t0)<+>text "of"$$ nest 4 (showDoc coalg)+++> showDocPF i (PFprod (p:ps)) = char '('<>hcat (showDocPF i p:map ((char 'x'<>).showDocPF i) ps)<>char ')'+> showDocPF i (PFprod _) = text "()"+> showDocPF i (PFid _) = text ("PI_"++show i)+> showDocPF i (PFcnt _) = char 'C'++> instance ShowDoc Psi where+> showDoc (Psi alts) =+> vcat$ zipWith (\i a->showDoc (toPattern . getPatterns$ a)<+>text "->"<+>+> (showDoc (Ttuple False [Tlit (Lint (show i)), Ttuple False .map getTerm$ getTerms a]))) [1..] alts+> where toPattern [p] = p+> toPattern ps = Ptuple ps++> instance ShowDoc OutF where+> showDoc (OutF alts) =+> vcat$ zipWith (\i (OutFc (c,vs,tts))->showDoc (Pcons c (map Pvar vs)) <+> text "->" <+>+> (showDoc (Ttuple False [Tlit (Lint (show i)),(Ttuple False .map getTerm$ tts)]))) [1..] alts+++> showDocSigma i ia bvs t0s (Sigma (casemap,tts,pss,hss)) =+> (prefix i ia <+>text ("Sigma_"++show i) <> +> cat (text "(" : map (nest 2) (mapSeparator (text ","<+>) sigmaargs)++[text ")"]) +> $$) . nest 2 . (text "where" <+>) $ +> (((text ("Sigma_"++show i++" =") <+>) . showDoc . +> Tlamb (Bvtuple False [ Bvar (beta ia) | (ia,Just _)<-zip [0..] hss]) . +> Tlamb (bvtuple bvs) . nullPatternVariables . delCases . insertRecvarCases t0s pss .+> termS2Term (\ia ih->Tfapp (beta ia)) . +> reorganizeSigma . weaveTermS (zipWith (zipWith mksum) +> (splitList [1..] casemap) +> (zipWith replicate casemap tts))$ pss )+> $$ vcat [ showCA ia h | (ia,Just h)<-zip [0..] hss])+> where sigmaargs = [ text (eta' ia++"."++eta'' ia++"."++psi ia) | (ia,Just _)<-zip [0..] hss]+> prefix 0 _ = empty+> prefix _ ia = text (psi ia++" =")+> showCA ia (_,acomps,etas,ca,_) = +> text (eta' ia) <+> char '=' <+> vcat (map showDoc (evalState (mapM buildeta' acomps) []))+> $$ text (eta'' ia) <+> char '=' <+> vcat (map showDoc etas)+> $$ innerPrefix ca ia <+> showDocWCA (i+1) ia ca+> psi ia = "psi_"++show ia++"'"+> eta' ia = "eta_"++show ia++"'"+> eta'' ia = "eta_"++show ia++"''"+> innerPrefix (WCAsigma _) _ = empty+> innerPrefix _ ia = text (psi ia++" =") +> mksum i tts = Ttuple False [Tlit (Lint (show i)),Ttuple False$ map getTerm tts]+> beta ia = Vuserdef ("@beta_"++show ia)+> buildeta' acomp = do let bvs=getVars acomp+> t<-inlA inF2Term acomp (id,map bv2term bvs)+> return$ Tlamb (Bvtuple False bvs) t+> inF2Term:: InF -> [Term] -> [(Variable,Term)] -> State [(Constructor,Int)] Term+> inF2Term (InF (c,_)) ts _ = do i<-geti c; return$ Ttuple False [Tlit $ Lint $ c++show i,Ttuple False ts]+> geti :: Constructor->State [(Constructor,Int)] Int+> geti c = StateT (\st->Identity$ maybe (1,(c,1):st) (\i->(i+1,upd c st)) $ lookup c st)+> upd c ((c',i):cs) = (c,i+1):cs+> upd c [] = [(c,1)]++> class ShowDocA a where+> showDocA :: VarGen -> Algebra a -> Doc+> instance ShowDocA InF where+> showDocA _ ls = vcat (map (showDoc.acomp2term) ls)+> instance ShowDocA Phii where+> showDocA _ ls = vcat (map (showDoc.acomp2term) ls)++> class Acomp2Term a where+> acomp2term :: Acomponent a -> Term+> instance Acomp2Term InF where+> acomp2term = a2term tinF+> where tinF (InF (c,_)) ts sust = Tcapp c ts+> instance Acomp2Term Phii where+> acomp2term = a2term tphii+> where tphii t ts sust = substitution sust t+> instance Acomp2Term Tau where+> acomp2term = a2term ttau+> where ttau tau ts sust = let f tw=tw2term ts sust tterm tw+> in foldTau f f f tau+> tterm t ts sust= tterm' t ts sust+> tterm' t ts sust = let tt t=tterm' t ts sust+> in case t of+> Taucons c taus a eta -> +> let (fts,ets) = reduceTrans (map tt taus) eta+> in fts$ Tapp (acomp2term a) (Ttuple False ets)+> Taupair t tau -> Ttuple False [t,tt tau]+> Taucata ft tau -> ft (tt tau)+> Tausimple t -> substitution sust t++> instance ShowDocA Tau where+> showDocA di ls = vcat (map (showDoc.a2term (ttau csalg)) ls)+> $$ text "--"+> $$ vcat (map showcsalg csalg)+> where i = maybe 0 id$ M.lookup "a" di+> csalg::[(Constructor,(Int,(Term,Etai)))]+> csalg = zip cons$ zip [i..] as+> (cons,as)=unzip$ evalState (do mapM_ (collect.unwrapA) ls;get) []+> showcsalg (_,(i,(a,eta))) = showDoc (Vgen "a" i) <+> text "= (" <> showDoc a <> text ") ." <+> showDoc eta+> collect = foldTWM hcase (const.const (return ())) colTau (collect.unwrapA) (return ())+> colTau = foldTau collect' collect' collect'+> collect' tw= foldTWM hcase (const.const (return ())) tc (collect'.unwrapA) (return ()) tw+> hcase t0 ps tws = return ()+> tc (Taucons c taus a eta) =+> do ls<-get+> case lookup c ls of+> Nothing -> put ((c,(acomp2term a,eta)):ls)+> Just _ -> return ()+> tc (Taupair t tau) = tc tau+> tc _ = return ()+> ttau csalg tau ts sust = let f tw=tw2term ts sust (tau2term csalg) tw+> in foldTau f f f tau++> a2term :: (a ->[Term] -> [(Variable,Term)] -> Term) -> Acomponent a -> Term+> a2term f a =Tlamb (bvs (getVars a)) (tw2term (map bv2term (getVars a)) [] f$ unwrapA a)+> where bvs [bv]=bv+> bvs ls = Bvtuple False ls++> tw2term :: [Term] -> [(Variable,Term)] -> (a -> [Term] -> [(Variable,Term)] -> Term) -> TermWrapper a -> Term+> tw2term ts sust f tw = runIdentity$ runReader (inlTW' True (\a b->Identity . f a b) tw)$ InlAEnv ts sust++> tau2term :: [(Constructor,(Int,c))] -> TauTerm a -> [Term] -> [(Variable,Term)] ->Term+> tau2term ls t ts sust =+> let tt t=tau2term ls t ts sust+> in case t of+> Taucons c taus a eta -> Tfapp (maybe (error "tau2term: No se encuentra el constructor") (Vgen "a" . fst)$ lookup c ls)+> [Ttuple False (map tt taus)]+> Taupair t tau -> Ttuple False [t,tt tau]+> Taucata ft tau ->+> let cs=map (Vgen "a".fst.snd) ls+> showcomma (a:as) = concat$ show a : map ((',':).show) as+> showcomma _ = []+> applycata=Tapp .Tlit .Lint .("(|"++).(++"|)").showcomma$ cs+> t=tt tau+> in case ft t of+> Ttuple b _ -> Ttuple b [t,applycata t]+> _ -> applycata t+> Tausimple t -> substitution sust t++> instance ShowDoc TupleTerm where+> showDoc (Tterm t p) = char '('<>showDoc t<+>char ','<+>(text$ show p)<>char ')'+++> instance Show Etai where+> show = render.showDoc++> instance ShowDoc Etai where+> showDoc e@(Etai (l1,l2))+> | isIdEta e = text "id"+> | otherwise = sep (mapDocSeparator (char '.'<>) $ l1++reverse l2)
+ HFusion/Internal/Messages.lhs view
@@ -0,0 +1,167 @@+-- Please, see the file LICENSE for copyright and license information.++++> module HFusion.Internal.Messages where++alg/Inline.lhs++> inlineTerm_Variable_Not_Found = "inlineTermS: Couldn't find the variable."+> termS_Not_Expected_Form = "The TermS is not an expected form."+> constructor_withOut_Variables = "A constructor has been detected without an empty variable associated with it."+> definition_Fault = "Fault in the function's definition"+> reading_Fault = "Error while loading the function"++interprete/SystemInterface.lhs++> functions_Not_Found nombre1 nombre2 = ("The functions " ++ (show nombre1) ++ " and " ++ (show nombre2) ++ " couldn't be found.")+> function_Not_Found nombre1 = "The function " ++ (show nombre1) ++ " couldn't be found."+> not_Found nombre1 = (show nombre1) ++ " couldn't be found."+> file_Not_Found filename = "The file " ++ (show filename) ++ " couldn't be found."+> function_Not_Found_Either_File_AND_System nombre1 = "The function " ++ (show nombre1) ++ " couldn't be found neither in the file nor the system." +> function_Not_Found_In_File nombre1 = "The function " ++ (show nombre1) ++ " couldn't be found in the system." +> function_Not_Found_In_System nombre1 = "The function " ++ (show nombre1) ++ " couldn't be found in the system." +> couldnt_Load = "Couldn't load the file."+> comparation = "COMPARISON"+> both_Defs_Are_Same_Function = "Both definitions corresponds to the same function." +> defintions_Are_Diferent_Functions name inlineMon inlineFile = "The definition of " ++ (show name) ++ " in the file: \n\n " ++ (show inlineMon) ++ "\n and in the file the " ++ (show name) ++ " is defined as follows: \n\n " ++ (show inlineFile) +> couldnt_Load_From_File filename = "Could not load the definitions from the file: " ++ filename +> not_Found_Specified_Functions = "Some of those function couldn't be found."+> directory_Not_Found directorio = "The directory " ++ directorio ++ " couldn't be found."+> unknown_Error_While_Loading archivo = "Unknow error while loading the file: " ++ archivo ++ "."+> comparation_All_Functinos = "COMPARISON OF THE FRAMEWORK FUNCTIONS"+> everyDef_Is_Ok = "Every definition from the framework match with the definition recorded in the files.\n"+> the_Diff_Defs_Are_Listed_Below = "The functions which are has different definitions are the following:"+> error_Trying_Load_Hylo def = "Error while loading hylomorphism = " ++ (show def)+> ok_Comparison_Label = "OK " +> err_Comparison_Label = "ERR_FUS " ++alg/FuseFace.lhs++> left_Hylo_Not_Sigma_Form = "Leftmost hylomorphism is not in Sigma form, nor InF."+> right_Hylo_Not_Tau_Form = "Rightmost hylomorphism is not in Tau form, nor OutF." +> fuseOperation_Label ="fuse"+> fuse_Tau_Operation_Label = "Taufuse"+> first_Hylo_Not_OutF_Form = "The first hylomorphism isn't in a OutF's form."+> second_Hylo_Not_Phi_Form = "The second hylomorphism isn't in a generic's form."+> fuse_Sigma_Operation_Label = "Sigmafuse" +> first_Hylo_Not_Psi_Form = "The first hylomorphism isn't in a generic's form."+> second_Hylo_Not_InF_Form = "The second hylomorphism isn't in InF's form." +> couldnt_Fuse_Hylos = "Couldn't fuse the hylomorphisms."++alg/FunctorRep.lhs++> coalgebra_Should_Not_Return_Terms_Diffrent_From_Vars = "getCata: The coalgebra shouldn't return non-variable terms."+> not_Recibed_OutF = "etaPara: Didn't recived OutF." +> var_Rec_Not_Binded = " A recursive variable is not bound" +> tWeta_Unexpected = "Unexpected TWeta founded."+> twaComp_Unexpected = " Unexpected TWacomp founded."+> twBottom_Unexpected = " Unexpected TWbottom founded."+> getCata_Label = "getCata"+> unexpected_Constructed_Pair = " Expected pair."+> unexpected_Non_Variables = "Unexpected non-variables." +> unexpected_Pattern p = " Pattern didn't expected "++ show p+> variable_Not_Found vt = " Input variable not found "++show vt ++lib/Utils.lhs++> not_Defined_For_Applied_Pattern p = " Not defined for the applied pattern:"++show p+> not_Defined_For_Applied_Term t = " Not defined for the applied term:"++show t+++lib/HsPretty.lhs++> infix_Operator_Without_Characters_In_Name = "Infix operator without a name"+> infix_Constructor_Without_Characters_In_Name = "Infix constructor without a name" +> display_Not_Define_For_Term = "It is not defined the way to show the term." +++alg/HyloRep++> no_Sound_Operation_Aplication = "It has no sense to invoke the requested operation."++interprete/Sistema.hs++> could_not_read_any_input = "We could not read any input. Chances are that the file is empty,\n"+++> "does not exists or you don't have enough privileges to read it."+> problem_Label = "Problem: "+> nonCommand_Label = "Not a command."+> error_Found_In_Grammar m line = "Error found in the grammar, " ++ m ++ "\n" ++ line +> bad_File_Form = "The file is not in the proper format." +> not_Tau_Derived_For_Function = "The requested function doesn't have the Tau derived." +> not_Sigma_Derived_For_Function = "The requested function doesn't have the Sigma derivated." +> here_We_Display_All_Defs = "This is the list of definitions in the environment"+> finish_OK_Label = "Successfully terminated." +> error_Exception ctx = "An error exception detected:" ++ ctx +> welcmssg = "Welcome to the Interactive Fusion System."+> homedir = "/inco/group02/fusion/usr/mgiorgi/src"+> load_command = "load fn load definitions form file fn"+> cmd_command = "!cmd executes de cmd command"+> save_command = "save f1..fn saves all files f1..fn"+> hylo_command = "hn: dispplays the definition of hn as hylomorphism"+> envi_command = "env displays the list of definitions in the environment"+> def_command = "hn displays the recursive definition of hn"+> fuse_command = "nh = h1 . h2 fuse h1.h2 & binds the result to the identifier nh"+> help_command = "help shows the available commands" +> check_command = "checkfile fn matches the definitions of previous fusions calculations in a repository" +> assertEq_command= "assertEq f g prints an error messages if the definitions are different (modulus alpha conversion)" +> cata_command = "cata h displays h as catamorphism" +> ana_command = "ana h displays h as anamorphism" +> quit_command = "quit ends the program"+++/parser/HsLexer++> iError_Empty_Context = "Internal error: empty context in lexToken"+> iError_Empty_Input_In_LexToken = "Internal error: empty input in lexToken" +> iError_lexChar = "Internal error: lexChar" +> illegal_Float = "Illegal float" +> illegal_Character c = "illegal character \'" ++ show c ++ "\'\n" +> improperly_Terminated_Char_Const = "Improperly terminated character constant" +> improperly_Terminated_Str = "Improperly terminated string" +> illegal_Char_Str_Gap = "Illegal character in string gap" +> iError_stringGap = "Internal error: stringGap" +> illegal_Ctrl_Char = "Illegal control character" +> iError_nestedComment = "Internal error: nestedComment" +++/parser/Env.hs++> isNot_Env n = "getAllDefEnv: " ++ n ++ " is not in environment"++/parser/HsParseMonad.hs++> iError_Empty_Context_In_PopContext = "Internal error: empty context in popContext"+> error_Label = "ERROR: " ++/interprete/Exception.hs++> cannot_Find_Label x = "cannot find " ++ show x++/alg/SystemMonDef.lhs++> not_Satured t = "The term (" ++ (show t) ++ ") is a recursive call (possibly mutual) which changes\n"+++> "an argument other than the last one.\n"+++> "Only the last recursive argument may differ from that of the initial invocation.\n"+++> "Is there any way you could rewrite the definition to meet this restriction?"++ "It also may be the case that equations of a definition where typed giving \n"+++ "different names to constant arguments in some of them.\n"+++ "Example:\n\n"+++ "filter p [] = ... \n"+++ "filter q (a:as) = ... \n"+++ "Please rewrite the equations so they use the same names for the same\n constant arguments.\n\n"+++ "Example:\n"+++ "filter p [] = ... \n"+++ "filter p (a:as) = ... \n"++> not_Expected t = "Not expected: (" ++ (show t) ++ ")."+> not_Derivable = "Not derivable."+> not_Legal_Term = "Not legal term."+> not_InF_Term = "The algebra of the hylomorphism is not InF."+> not_OutF_Term = "The coalgebra of the hylomorphism is not OutF."+> unmatched_F_Error = "The funtors do not match"+> debug_Message t chrs = "Debug message for the term " ++ (show t) ++ ":" ++ chrs+> error_Message chrs = chrs++
+ HFusion/Internal/Parsing/HyloContext.lhs view
@@ -0,0 +1,129 @@+-- Please, see the file LICENSE for copyright and license information.++> module HFusion.Internal.Parsing.HyloContext(+> Context+> ,emptyContext -- :: Context+> ,extractContext -- :: [Def] -> [(Context,Def)]+> ,mergeContext -- :: [(Context,Def)] -> [Def]+> ,findConstantArguments -- :: [Def] -> [Int]+> ,getConstantArgs -- :: Context -> [Variable]+> ,getCntArgPos -- :: Context -> Maybe [Int]+> ,combineContexts -- :: Context -> Context -> Context+> ) where+> import HFusion.Internal.HsSyn+> import HFusion.Internal.HsPretty+> import HFusion.Internal.Utils+> import List(intersect,find,(\\),delete)++A context contains the constant arguments with their recursive positions, if available.++> data Context = Ctx [Variable] (Maybe [Int])+> deriving Show++> emptyContext :: Context+> emptyContext = Ctx [] Nothing++> getConstantArgs :: Context -> [Variable]+> getConstantArgs (Ctx vrs _) = vrs++> getCntArgPos :: Context -> Maybe [Int]+> getCntArgPos (Ctx _ pos) = pos++> combineContexts :: Context -> Context -> Context+> combineContexts (Ctx vs _) (Ctx vs' _) = Ctx (vs++vs') Nothing++> instance Vars Context where+> vars (Ctx vs _) = vs++> instance AlphaConvertible Context where+> alphaConvert sc ss (Ctx vrs pos) = Ctx (map (alphaConvert sc ss) vrs) pos++> extractContext :: [Def] -> [(Context,Def)]+> extractContext dfs@(firstd:taild) = (ctx,removeArgsDef firstd) +> : map (\d -> (ctx,sustDef (zip vrs (getVars d))$ removeArgsDef d)) taild+> where idxs = findConstantArguments dfs+> vrs = getVars firstd+> ctx = Ctx vrs (Just idxs)+> getVars :: Def -> [Variable]+> getVars (Defvalue _ t) = [ v | (i,Bvar v)<-zip [0..] (fst$ extractVars t), elem i idxs ]+> removeArgsDef (Defvalue v t) = Defvalue v (removeArgs (map getDefName dfs) idxs t)+> sustDef ss (Defvalue v t) = Defvalue v (substitution ss' t)+> where ss' = map (\(v,v')->(v,Tvar v'))$ filter (\(v,v')->v/=v')$ ss+> extractContext [] = [] ++> mergeContext :: [(Context,Def)] -> [Def]+> mergeContext dfs = map (merge (map (getDefName.snd) dfs)) dfs +> where merge fs (Ctx vs idxs,Defvalue v t) = Defvalue v (addArgs fs (zip vs$ maybe [0..] id idxs) t)++removeArgs rmvs f t +Removes arguments from a given recursive definition f = t. +rmvs is the list of indexes of arguments to remove from each mutually recursive definition++> removeArgs :: [Variable] -> [Int] -> Term -> Term+> removeArgs fs idxs t = foldr Tlamb (rmFromCalls (fs\\vars vsis) t') (removeFromList vsis idxs)+> where (vsis,t') = extractVars t+> rmFromCalls = transformTerm . removeFromCalls+> removeFromCalls fs t@(Tfapp v ts) tr | elem v fs = Tfapp v (removeFromList ts idxs)+> | otherwise = tr+> removeFromCalls fs (Tcase t0 ps ts) _ = Tcase (rmFromCalls fs t0) ps +> (zipWith (rmFromCalls . (fs\\) . vars) ps ts)+> removeFromCalls fs (Tlet v t0 t1) _ = Tlet v (rmFromCalls (delete v fs) t0) (rmFromCalls (delete v fs) t1)+> removeFromCalls fs (Tlamb bv t) _ = Tlamb bv (rmFromCalls (fs\\vars bv) t)+> removeFromCalls fs t tr = tr+> removeFromList xs idxs = [ x | (i,x)<-zip [0..] xs,notElem i idxs]++Adds some variables at the beginning of recursive calls and definitions.+addArgs [r] [v1,v2] (\v -> ... r vk ...)+yields+\v1 v2 v -> r v1 v2 vk++> addArgs :: [Variable] -> [(Variable,Int)] -> Term -> Term+> addArgs fs vs t = foldr Tlamb (addArgCalls fs t') (insertElems (map (applyFst Bvar) vs) vsis)+> where (vsis,t') = extractVars t+> tvs = map (applyFst Tvar) vs+> addArgCalls = transformTerm . addToCalls+> addToCalls fs t@(Tfapp v ts) tr | elem v fs = Tfapp v (insertElems tvs ts)+> | otherwise = tr+> addToCalls fs (Tcase t0 ps ts) _ = Tcase (addArgCalls fs t0) ps +> (zipWith (addArgCalls . (fs\\) . vars) ps ts)+> addToCalls fs (Tlet v t0 t1) _ = Tlet v (addArgCalls (delete v fs) t0) (addArgCalls (delete v fs) t1)+> addToCalls fs (Tlamb bv t) _ = Tlamb bv (addArgCalls (fs\\vars bv) t)+> addToCalls fs t tr = tr+++returns the indexes of the constant arguments of a mutually recursive definitions.++> findConstantArguments :: [Def] -> [Int]+> findConstantArguments dfs = foldr1 intersect . map (findConstantArgs' (map getDefName dfs))$ dfs+> where findConstantArgs' fs (Defvalue v t) = getIndexes$ foldr (zipWith matchArg) (map maybeBvar vsis) (collectCalls (fs\\vars vsis) t')+> where (vsis,t') = extractVars t+> collectCalls :: [Variable] -> Term -> [[Maybe Variable]]+> collectCalls fn t =+> case t of+> Tvar _ -> []+> Tlit _ -> []+> Ttuple _ ts -> concatMap (fcaa fn) ts+> Tcase t0 ps ts -> fcaa fn t0 ++ concat (zipWith (\p->except p . fcaa (fn\\vars p)) ps ts)+> Tcapp _ ts -> concatMap (fcaa fn) ts+> Tapp t0 t1 -> fcaa fn t0 ++ fcaa fn t1+> Tlet v t0 t1 -> except v (fcaa (delete v fn) t0 ++ fcaa (delete v fn) t1)+> Tlamb bv t -> except bv$ fcaa (fn\\vars bv) t+> Tfapp v ts -> if elem v fn && null (intersect fn (vars ts))+> then [map maybeTvar ts]+> else concatMap (fcaa fn) ts+> _ -> error ("findConstantArgs: non-expected term: "++show t)+> where fcaa fn = collectCalls fn +> except :: Vars a => a -> [[Maybe Variable]] -> [[Maybe Variable]]+> except t = map (map except')+> where tvs = vars t+> except' (Just v) | elem v tvs = Nothing+> except' mv = mv+> maybeTvar (Tvar v) = Just v+> maybeTvar _ = Nothing+> maybeBvar (Bvar v) = Just v+> maybeBvar _ = Nothing+> matchArg (Just v) (Just v') | v==v' = Just v+> matchArg _ _ = Nothing+> getIndexes ls = [ i | (i,Just _)<-zip [0..] ls ]++
+ HFusion/Internal/Parsing/HyloParser.lhs view
@@ -0,0 +1,271 @@+-- Please, see the file LICENSE for copyright and license information.++>module HFusion.Internal.Parsing.HyloParser(parse,parseResult2FusionState,parseHsModule,deriveHylos) where++ import qualified HsParser as P(parse,ParseResult(..))++> import Language.Haskell.Parser(parseModule,ParseResult(..))+> import Language.Haskell.Syntax(SrcLoc,HsModule)+> import HFusion.Internal.Parsing.Translator++> import HFusion.Internal.HsSyn+> import HFusion.Internal.Utils+> import HFusion.Internal.RenVars+> import HFusion.Internal.FuseFace+> import HFusion.Internal.FsDeriv+> import HFusion.Internal.HyloFace+> import HFusion.Internal.Parsing.HyloContext+> import Control.Monad(zipWithM)+> import Control.Monad.Error(throwError,runErrorT)+> import Control.Monad.Trans(lift)+> import Control.Monad.State(StateT(..),State,MonadState(..))+> import List(partition,intersect,union,find,findIndex,nubBy,(\\),deleteFirstsBy,delete,sort)++-- Posición de un token. Es utilizada por el parser y el +-- lexer para resolver los problemas del layout.+ data SrcLoc = SrcLoc Int Int -- (Line, Indentation)+ deriving (Eq,Ord,Show)+++> parse :: String -> FusionState [HyloT]+> parse inp = parseResult2FusionState (parseModule inp) >>= hsModule2HsSyn >>=+> lift . deriveHylos >>= \(errors,hs) -> if null errors then return hs+> else throwError (snd$ head errors)++> -- | Obtains hylomorphisms representing functions in the original program.+> -- +> -- The hylomorphisms are returned in the second component of the output. +> -- If a hylomorphism cannot be derived for some (possibly) mutually recursive +> -- function definitions, then they are returned in the first component of the +> -- output together with the error obtained when attempting derivation.+> deriveHylos :: [Def] -> VarGenState ([([Def],FusionError)],[HyloT])+> deriveHylos dfs = removeInputVar dfs >>= +> handleRegularFunctions . getCycles >>= \ cdfs -> +> mapM (runErrorT . deriveHylo) cdfs >>= \ehs ->+> return (concat (zipWith (\df -> either ((:[]) . ((,) df)) (const [])) cdfs ehs)+> ,concat (map (either (const []) (:[])) ehs))+++> -- | This is a convenience function that allows to handle parsing an 'HsModule'+> -- as a 'FusionState' computation.+> -- +> -- @parseResult2FusionState (Language.Haskell.Parser.parseModule sourceCode)@+> parseResult2FusionState :: ParseResult HsModule -> FusionState HsModule+> parseResult2FusionState = catchParseState return (\loc -> throwError . ParserError loc)++> parseHsModule :: HsModule -> VarGenState ([FusionError],[HyloT])+> parseHsModule m = +> hsModule2HsSyn_ m >>= +> removeInputVar . snd >>= +> handleRegularFunctions . getCycles >>=+> (\dss -> do he <- mapM (runErrorT . deriveHylo) dss+> return (concat (map (either (:[]) (const [])) he),concat (map (either (const []) (:[])) he))+> )+++ catchParseState :: (a->b) -> (String->b) -> P.ParseResult a -> b+ catchParseState f h (P.Ok _ p) = f p+ catchParseState f h (P.Failed err) = h err++> catchParseState :: (a->b) -> (SrcLoc->String->b) -> ParseResult a -> b+> catchParseState f h (ParseOk p) = f p+> catchParseState f h (ParseFailed loc err) = h loc err+++getCycles agrupa las definiciones de funciones mutuamente recursivas.++> getCycles :: [Def] -> [[Def]]+> getCycles defs = let idxs=findCycles (getDependencyGraph defs)+> in map (map (defs!!). sort) idxs++> collect :: [Maybe a] -> [a]+> collect = foldr (\a r->maybe r (:r) a) []++Groups indexes identifying mutual recursive definitions.++> getDependencyGraph :: [Def] -> [[Int]]+> getDependencyGraph ds = map (dps (zip (map getV ds) [0..])) ds+> where dps ps (Defvalue v t) = collect .map (flip lookup ps).vars$ t+> getV (Defvalue v t) = v++> findCycles :: [[Int]] -> [[Int]]+> findCycles g = joinCycles [] $ concat $ map (follow [] g) [0..length g-1]+> where follow :: [Int] -> [[Int]] -> Int -> [[Int]]+> follow vs g i | elem i vs = [i:takeWhile (/=i) vs]+> | otherwise = concat$ map (follow (i:vs) g) (g!!i)+> joinCycles :: [[Int]] -> [[Int]] -> [[Int]]+> joinCycles ant (is:iss) = let (cs1,cs2) = partition (null.intersect is) ant+> in joinCycles (foldr union is cs2:cs1) iss+> joinCycles ant [] = ant+++removeInputVar transforms a case expression:+ case v0 of+ c p1 ... 1n -> ... v0 ...+ ...+into+ case v0 of+ c p1 ... 1n -> ... (c p1 ... pn) ...+ ...++> removeInputVar :: [Def] -> VarGenState [Def]+> removeInputVar defs = mapM removeInputVar' defs+> removeInputVar' (Defvalue v t) = inTlamb t >>= return . Defvalue v+> where inTlamb :: Term -> VarGenState Term+> inTlamb (Tlamb bv t) = inTlamb t >>= return . Tlamb bv+> inTlamb (Tcase t0@(Tvar v0) ps ts) = sequence (zipWith (selectP v0) ps ts) >>= return . uncurry (Tcase t0) . unzip+> inTlamb t = return t+> selectP v0 p t | not (elem v0 (vars p)) && elem v0 (vars t) = +> renamePany p >>= \p'-> return (p',substitution [(v0,pat2term p')] t)+> | otherwise = return (p,t)+> renamePany (Pvar (Vuserdef "_")) = getFreshVar "v" >>= return . Pvar+> renamePany p@(Pvar _) = return p+> renamePany (Ptuple ps) = mapM renamePany ps >>= return . Ptuple+> renamePany (Pcons c ps) = mapM renamePany ps >>= return . Pcons c+> renamePany (Pas v p) = renamePany p >>= return . Pas v+> renamePany p@(Plit _) = return p+> pat2term (Pvar v) = Tvar v+> pat2term (Ptuple ps) = Ttuple False$ map pat2term ps+> pat2term (Pcons c ps) = Tcapp c$ map pat2term ps+> pat2term (Plit l) = Tlit l+> pat2term (Pas v _) = Tvar v+++> type CallDescription = (Variable,Def,Int,[Variable],Term)++handleRegularFunctions creates new definition where recursion of regular functors+can be expressed with mutually recursive functions.++> handleRegularFunctions :: [[Def]] -> VarGenState [[Def]]+> handleRegularFunctions dss = handleRegularFunctions' dss [] (map (const []) dss) dss+> handleRegularFunctions' :: [[Def]] -> [CallDescription] -> [[Variable]] -> [[Def]] -> VarGenState [[Def]]+> handleRegularFunctions' p calls dns [] = return p+> handleRegularFunctions' p calls dns ds = +> do cs<-zipWithM (getCallDefs p calls) dns ds+> let (dfs,nfs)=unzip cs+> if all null nfs then return dfs+> else mapM (mapM buildDef . nubBy eq) nfs +> >>= handleRegularFunctions' (zipWith (++) dfs (zipWith (deleteFirstsBy eqDefs) p dfs)) +> (calls++concat nfs) (zipWith (++) dns (map (map getDefName) ds))+> >>= return . zipWith (++) dfs+> where eq (v1,d1,i1,_,t1) (v2,d2,i2,_,t2) = i1==i2 && (getDefName d1)==(getDefName d2) && t1==t2+> getCallDefs :: [[Def]] -> [CallDescription] -> [Variable] -> [Def] -> VarGenState ([Def],[CallDescription])+> getCallDefs p calls dns ds = mapM (getCalls p calls (dns++map getDefName ds)) ds +> >>= (\ (dfs,m)-> return (dfs,concat m)) . unzip+> eqDefs d d' = getDefName d == getDefName d'++> buildDef :: CallDescription -> VarGenState Def+> buildDef (u,d,i,vs,t) = buildDef' u i vs t d+> buildDef' u i vs t (Defvalue nd t0) = +> do (us,t')<-regenVars t+> t0'<-regenConstantArgs t t0+> let (bvs,t0'') = getInputVars t0'+> (ant,pos)=splitAt i bvs+> bs=vars ant++vars (tail pos)+> return$ Defvalue u (foldr Tlamb (adapt bs us t' (head pos) t0'') (map Bvar us++ant++tail pos))+> where adapt bs us t (Bvar l) t0 = substitution [(l,t)]$ adaptr bs us t0+> adapt bs us t bv t0 = Tcase t [bv2pat bv] [adaptr bs us t0]+> getInputVars (Tlamb bv t) = let (bs,t')=getInputVars t in (bv:bs,t')+> getInputVars t = ([],t)+> bv2pat (Bvar v) = Pvar v+> bv2pat (Bvtuple _ bvs) = Ptuple (map bv2pat bvs)+> regenConstantArgs t t0 = do let freeVars = vars t \\ vs+> us<-mapM (getFreshVar . varPrefix) freeVars+> return$ alphaConvert [] (zip freeVars us) t0+> regenVars t = do us<-mapM (getFreshVar . varPrefix) vs+> return (us,substitution (zip vs (map Tvar us)) t)+> adaptr bs us (Ttuple b ts) = Ttuple b (map (adaptr bs us) ts)+> adaptr bs us (Tcapp c ts) = Tcapp c (map (adaptr bs us) ts)+> adaptr bs us (Tcase t0 ps ts) = Tcase (adaptr bs us t0) ps +> (zipWith (\p->adaptr (vars p++bs) us) ps ts)+> adaptr bs us (Tlet v t0 t1) = Tlet v (adaptr (v:bs) us t0) (adaptr (v:bs) us t1)+> adaptr bs us (Tlamb v t) = Tlamb v (adaptr (vars v++bs) us t)+> adaptr bs us (Tapp t0 t1) = tapp (adaptr bs us t0) (adaptr bs us t1)+> adaptr bs us (Tfapp fv ts) | elem fv bs = Tfapp fv (map (adaptr bs us) ts)+> | fv == nd = let (ant,pos)=splitAt i (map (adaptr bs us) ts)+> in Tfapp u (map Tvar us++ant++tail pos)+> | otherwise = Tfapp fv (map (adaptr bs us) ts)+> adaptr bs us t = t++getCalls collects the information about each recursive call that can be rewritten as+a call to a recursive function which fixates one of the arguments. +The returned pair (def,l) contains the rewritten definition (with fresh vars for some+recursive calls), and l is a list containing data for each of the new definitions+to be introduced. ++Each item in the list is a tuple (u,def,i,vrs,t) where +u is the name for the new definition, +def is the definition to be rewritten with a fixated argument, +i is the index of the fixated argument, +vrs are the bounded variables appearing in the term in the ith argument,+and t is that term.++> getCalls :: [[Def]] -> [CallDescription] -> [Variable] -> Def -> VarGenState (Def,[CallDescription])+> getCalls ps calls ds d@(Defvalue v t) = runStateT (do (t',ds')<-getCalls' [] t; return$ (Defvalue v t',ds')) calls >>= return . fst+> where getCalls' :: [Variable] -> Term -> StateT [CallDescription] (State VarGen) (Term,[CallDescription])+> getCalls' bs (Ttuple b ts) = do (ts',ns)<-mapGetCalls' bs ts+> return (Ttuple b ts',ns)+> getCalls' bs (Tlamb bv t) = do (t',ns)<-getCalls' (bs++vars bv) t; return (Tlamb bv t',ns)+> getCalls' bs (Tcase t0 ps ts) = do (t0',n0)<-getCalls' bs t0+> res<-sequence$ zipWith (getCalls'.(bs++).vars) ps ts+> let (ts',ns)=unzip res+> return (Tcase t0' ps ts',n0++concat ns)+> getCalls' bs (Tapp t0 t1) = do (t0',n0)<-getCalls' bs t0+> (t1',n1)<-getCalls' bs t1+> return (tapp t0' t1',n0++n1)+> getCalls' bs (Tlet v t0 t1) = do (t0',n0)<-getCalls' (v:bs) t0+> (t1',n1)<-getCalls' (v:bs) t1+> return (Tlet v t0' t1',n0++n1)+> getCalls' bs (Tcapp c ts) = do (ts',ns)<-mapGetCalls' bs ts+> return (Tcapp c ts',ns)+> getCalls' bs (Tfapp v ts) =+> do (ts',ns)<-mapGetCalls' bs ts+> let rr = return (Tfapp v ts',ns)+> mi = [ p | p@(_,t)<-zip [0..] ts', any (flip elem (vars t)) ds ]+> checkNoPattern (idxs,d@(Defvalue v t)) = +> if not (null mi) -- there is a recursive call+> && all (flip elem idxs.fst) mi -- all recursive calls appear in constant positions+> && all callIsOkToSpecialize mi +> then mr (fst (head mi)) d+> else rr+> where (vargs,t') = extractVars t+> callIsOkToSpecialize (i,Tfapp v' ts) = +> elem v' ds && all isVar ts +> && (length ts < lengthvargs'+> || length ts==lengthvargs'+> -- variable is used at most once+> && countLinear (getVar (vargs!!i)) t'<2)+> where lengthvargs' = maybe (error "lengthvars'") +> (length.fst.extractVars.getDefTerm) $ find ((v'==).getDefName)$ concat ps+> callIsOkToSpecialize (i,Tvar _) = True+> callIsOkToSpecialize _ = False+> isVar (Tvar _) = True+> isVar _ = False+> getVar (Bvar v) = v+> getVar _ = error "getCalls': getVar"+> mr i d = do let (ant,pos)=splitAt i ts'+> vs = filter (\x-> elem x bs) (vars (head pos))+> calls<-get+> case find (\(_,d',i',vs',t')-> i'==i +> && getDefName d'==getDefName d+> && vs==vs'+> && t'==head pos) +> calls of+> Nothing -> do u<-lift$ getFreshVar (varPrefix v)+> let c = (u,d,i,vs,head pos)+> put (c:calls)+> return (Tfapp u (map Tvar vs++ant++tail pos),c:ns)+> Just c@(u,_,_,_,_) -> return (Tfapp u (map Tvar vs++ant++tail pos),ns)+> if elem v bs then rr+> else maybe rr checkNoPattern (lookupDef v (map constantArgs ps) ps)+> getCalls' _ t = return (t,[])+> constantArgs :: [Def] -> [Int]+> constantArgs dfs = findConstantArguments dfs +> mapGetCalls' bs ts = do res<-mapM (getCalls' bs) ts+> let (ts',ns)=unzip res+> return (ts',concat ns)+> lookupDef :: Variable -> [[Int]] -> [[Def]] -> Maybe ([Int],Def)+> lookupDef v argidxs ps = find ((v==).getDefName.snd)$ [ (idxs,df) | (idxs,dfs)<-zip argidxs ps, df<-dfs]+++
+ HFusion/Internal/Parsing/Translator.lhs view
@@ -0,0 +1,306 @@+-- Please, see the file LICENSE for copyright and license information.++> module HFusion.Internal.Parsing.Translator(hsModule2HsSyn,hsModule2HsSyn_) where++> import HFusion.Internal.HsSyn+> import HFusion.Internal.Utils++> import Char(isUpper,isLower)+> import Maybe(catMaybes)+> import List(transpose,nub)+> import Control.Monad.Error(throwError,runErrorT)+> import Control.Monad.Trans(lift)+> import Control.Monad.State(get,put)+> import Language.Haskell.Syntax+> import qualified Data.Map as M(insertWith)+> import HFusion.Internal.RenVars+> import HFusion.Internal.HyloFace++ import Debug.Trace++ import HsPretty++ sss t = trace (show t) t+ sss' t = trace (show t)++> -- | Converts an 'HsModule' into the abstract syntax tree used by HFusion.+> -- The HsModule can be obtained by parsing a Haskell program with +> -- 'Language.Haskell.Parser.parseModule'+> hsModule2HsSyn :: HsModule -> FusionState [Def]+> hsModule2HsSyn m = do p <- lift (hsModule2HsSyn_ m)+> case p of+> ([],dfs) -> return dfs+> (e:_,_) -> throwError e+++> hsModule2HsSyn_ :: HsModule -> VarGenState ([FusionError],[Def])+> hsModule2HsSyn_ (HsModule _ _ _ _ decls) = +> do m<-mapM (runErrorT . convertDecl2Def) ((filter selectd) decls)+> return (concat (map (either (:[]) (const [])) m),concat . map (either (const []) (:[])) $ m)+> where selectd (HsFunBind _) = True+> selectd (HsPatBind _ (HsPVar hsName) _ _) = True+> selectd _ = False++> convertDecl2Def :: HsDecl -> FusionState Def+> convertDecl2Def hsDecl =+> case hsDecl of+> HsFunBind hsMatches -> f hsMatches +> HsPatBind loc (HsPVar hsName) hsRhs hsDecls -> f [HsMatch loc hsName [] hsRhs hsDecls]+> HsForeignExport _ _ _ _ _ -> fail "foreign exports are not supported"+> HsForeignImport _ _ _ _ _ _ -> fail "foreign imports are not supported"+> HsTypeSig _ _ _ -> fail "type signatures are not supported"+> HsDefaultDecl _ _ -> fail "Default declarations are not supported"+> HsInstDecl _ _ _ _ _ -> fail "Instance declarations are not supported"+> HsClassDecl _ _ _ _ _ -> fail "Class declarations are not supported"+> HsNewTypeDecl _ _ _ _ _ _ -> fail "New type declarations are not supported"+> HsInfixDecl _ _ _ _ -> fail "Infix declarations are not supported"+> HsTypeDecl _ _ _ _ -> fail "Type declarations are not supported"+> HsDataDecl _ _ _ _ _ _ -> fail "Data declarations are not supported"+> HsPatBind _ _ _ _ -> fail "non variable pattern bindings are not supported"+> where f hsMatches =+> do r <- mapM convertHsMatch hsMatches+> let (ns,args,ts)= unzip3 r+> if null ns then fail "convertDecl2Term: we got an empty declaration"+> else lift (updateVariableGeneratorState (nub (vars (head ns)++vars args++varsB ts))+> >> joinEquations args ts >>= return . Defvalue (head ns))+> updateVariableGeneratorState vs = do gi<-get; put (foldr updateSt gi vs)+> updateSt (Vgen p i) gi = M.insertWith max p (i+1) gi+> updateSt (Vuserdef s) gi = case str2var s of+> v@(Vgen _ _) -> updateSt v gi+> _ -> gi++++> joinEquations :: [[Either Pattern Variable]] -> [Term] -> VarGenState Term+> joinEquations args ts = do (vs,t) <- renameVars (unifyPatterns args) ts+> return (foldr (Tlamb . Bvar) t vs)+> where renameVars args ts = do let args' = transpose args+> vs' <- mapM genVar args'+> (vs'',ts')<- susts vs' args' args ts+> let vps=leftPos vs''+> t | null vps = head ts'+> | null (tail vps) = Tcase (Tvar (head vps)) (map head$ map leftPos args) ts'+> | otherwise = Tcase (Ttuple False$ map Tvar vps) (map Ptuple$ map leftPos args) ts'+> return (map (either id id) vs'',t)+> leftPos = map (either id (error "joinEquations")) . filter (either (const True) (const False))+> genVar ls@(Left _:_) = getFreshVar "v" >>= return . Left+> genVar ls@(Right v:_) = return (Right v)+> genVar _ = error "joinEquations: This should never had hapenned."+> susts :: [Either Variable Variable] -> [[Either Pattern Variable]] -> +> [[Either Pattern Variable]] -> [Term] -> VarGenState ([Either Variable Variable],[Term])+> susts vs' args' args ts = let inds = catMaybes$ zipWith (\i b->if b then (Just i) else Nothing) [0..]$ +> zipWith checkEq vs' args'+> in do us<-mapM (const (getFreshVar "v")) inds+> let inds' = zip inds us+> return (map (toVar inds') (zip [0..] vs'), zipWith (susts' vs' inds') args ts)+> susts' :: [Either Variable Variable] -> [(Int,Variable)] -> [Either Pattern Variable]->Term->Term+> susts' vs' inds' arg t = substitution (map (toPair arg) inds') t+> checkEq (Right a) ls = any (either (const False) (a/=)) ls+> checkEq _ _ = False+> toPair l (i,u) = either (error "joinEquations") (\v->(v,Tvar u)) (l!!i)+> toVar inds' (i,e) = either Left (\v->Right$ maybe v id$ lookup i inds') e+++> unifyPatterns :: [[Either Pattern Variable]] -> [[Either Pattern Variable]]+> unifyPatterns args = map (map fitPS . zip [0..]) args+> where fitPS (i,e) = either Left (if pindexElem i args then Left .Pvar else Right) e+> pindexElem :: Int -> [[Either Pattern Variable]] -> Bool+> pindexElem i l = let isPat = either (const True) (const False) in any (isPat .(!!i)) l+++> convertHsMatch :: HsMatch -> FusionState (Variable,[Either Pattern Variable],Term)+> convertHsMatch (HsMatch loc hname hpat rhs []) = do t<-convertRhs2Term loc rhs+> ps<-mapM (convertPat2MyPat loc) hpat+> return (str2var (convertHsName2String hname),map analisePat ps,t)+> convertHsMatch (HsMatch loc _ _ _ _) = throwError (ParserError loc "\"where\" clauses are not supported.")+++> analisePat :: Pattern -> Either Pattern Variable+> analisePat (Pvar v) = Right v+> analisePat p = Left p++> convertRhs2Term :: SrcLoc -> HsRhs -> FusionState Term+> convertRhs2Term loc hsRhs =+> case hsRhs of+> HsUnGuardedRhs hsExp -> convertHsExp2Term loc hsExp [] >>= (return .fixInfixAssoc)+> HsGuardedRhss hsGuardedRhss -> throwError (ParserError loc "Guarded definitions are not supported.")+++> convertHsExp2Term :: SrcLoc -> HsExp -> [Term] -> FusionState Term+> convertHsExp2Term loc exp args =+> let wildTerm = Tvar $ Vuserdef "_"+> appArgs t args = foldl Tapp t args+> in case exp of+> HsVar hsQName -> return $ convertHsQName2Term hsQName args+> HsCon hsQName -> return $ convertHsQName2Term hsQName args+> HsLit hsLiteral -> return $ Tlit (convertLit2Lit hsLiteral)+> HsInfixApp hsExp hsQOp hsExp1 -> do t0<-convertHsExp2Term loc hsExp []+> t1<-convertHsExp2Term loc hsExp1 []+> return$ convertHsQName2Term (convertHsQOP2Variable hsQOp) (t0:t1:args)+> HsApp hsExp hsExp1 -> convertHsExp2Term loc hsExp1 [] >>= convertHsExp2Term loc hsExp . (:args)+> HsNegApp hsExp -> convertHsExp2Term loc hsExp [] >>= \t-> return (appArgs(Tfapp (Vuserdef "-") [t]) args)+> HsLambda loc hsPats hsExp -> do ps<-mapM (convertPat2MyPat loc) hsPats+> ps'<-mapM ps2bv ps+> t<-convertHsExp2Term loc hsExp args+> return$ foldr Tlamb t ps'+> where ps2bv (Pvar v) = return $ Bvar v+> ps2bv (Ptuple ps) = mapM ps2bv ps >>= return . Bvtuple False+> ps2bv _ = throwError (ParserError loc "Constructors are not allowed in patterns in lambda abstractions.")+> HsLet hsDecls hsExp -> do t<- convertHsExp2Term loc hsExp []+> listaVarsTerms <- mapM (convertHsLetsDect2PatyTerm loc) hsDecls+> return (appArgs (foldr (\(p,t0) -> Tcase t0 [p] . (:[])) t listaVarsTerms) args)+> HsIf hsExp hsExp1 hsExp2 -> do t0<-convertHsExp2Term loc hsExp []+> let trueCase = Pcons "True" []+> falseCase = Pcons "False" []+> termTrue<- convertHsExp2Term loc hsExp1 []+> termFalse<- convertHsExp2Term loc hsExp2 []+> return (appArgs (Tcase t0 [trueCase,falseCase] [termTrue,termFalse]) args)+> HsCase hsExp hsAlts -> do t0 <- convertHsExp2Term loc hsExp []+> alternativas <- mapM converthsAlt2PatyTerm hsAlts+> let pats = map fst alternativas+> terms = map snd alternativas+> return (appArgs (Tcase t0 pats terms) args)+> HsTuple hsExps -> do ts <- mapM (flip (convertHsExp2Term loc) []) hsExps+> return (appArgs (Ttuple False ts) args)+> HsList hsExps -> do ts <- mapM (flip (convertHsExp2Term loc) []) hsExps+> return (appArgs (foldr (\t1 t2->Tcapp ":" [t1,t2]) (Tcapp "[]" []) ts) args)+> HsParen hsExp -> convertHsExp2Term loc hsExp args >>= (return . Tpar)+> HsLeftSection hsExp hsQOp -> do t<-convertHsExp2Term loc hsExp []+> return $ convertHsQName2Term (convertHsQOP2Variable hsQOp) (t:args)+> HsRightSection hsQOp hsExp -> do t1<-convertHsExp2Term loc hsExp []+> if null args then throwError (ParserError loc "Non applied right sections are not supported.")+> else return $ convertHsQName2Term (convertHsQOP2Variable hsQOp) (head args:t1:tail args)+> _ -> throwError (ParserError loc "This kind of term is not supported.")+++> converthsAlt2PatyTerm :: HsAlt -> FusionState (Pattern, Term)+> converthsAlt2PatyTerm (HsAlt loc hsPat hsGuardedAlts hsDecls) =+> do pat <- convertPat2MyPat loc hsPat+> term <- convertHsGuardedAlts2Term loc hsGuardedAlts+> return (pat, term)++> convertHsGuardedAlts2Term :: SrcLoc -> HsGuardedAlts -> FusionState Term+> convertHsGuardedAlts2Term loc x =+> case x of+> HsUnGuardedAlt hsExp -> convertHsExp2Term loc hsExp []+> HsGuardedAlts hsGuardedAlt -> throwError (ParserError loc "Guarded alternatives are not supported.")+++> convertPat2MyPat :: SrcLoc -> HsPat -> FusionState Pattern+> convertPat2MyPat loc = convertPat2MyPat' loc . changeConsAssoc +> convertPat2MyPat' loc hsPat =+> case hsPat of+> HsPVar hsName -> return $ Pvar (str2var$ convertHsName2String hsName)+> HsPLit hsLiteral -> return $ Plit (convertLit2Lit hsLiteral)+> HsPInfixApp hsPat1 hsQName hsPat2 ->+> do hsRes1 <- convertPat2MyPat' loc hsPat1+> hsRes2 <- convertPat2MyPat' loc hsPat2+> return$ convertHsQName2Pattern hsQName [hsRes1,hsRes2]+> HsPApp hsQName hsPats -> do ps<-mapM (convertPat2MyPat' loc) hsPats+> return$ convertHsQName2Pattern hsQName ps+> HsPTuple hsPats -> do ps<-mapM (convertPat2MyPat' loc) hsPats+> return $ Ptuple ps+> HsPList hsPats -> do ps<-mapM (convertPat2MyPat' loc) hsPats+> return (foldr (\t1 t2->Pcons ":" [t1,t2]) (Pcons "[]" []) ps)+> HsPParen hsPat -> (convertPat2MyPat' loc) hsPat+> HsPWildCard -> return pany+> HsPAsPat hsName hsPat -> do p<-convertPat2MyPat loc hsPat+> return$ Pas (str2var$ convertHsName2String hsName) p+> _ -> throwError (ParserError loc "This kind of pattern is not supported.")++> changeConsAssoc :: HsPat -> HsPat+> changeConsAssoc (HsPInfixApp pat (Special HsCons) a3) =+> case changeConsAssoc pat of +> HsPInfixApp a1 (Special HsCons) a2 ->+> HsPInfixApp a1 (Special HsCons) (HsPInfixApp a2 (Special HsCons) a3)+> p -> HsPInfixApp p (Special HsCons) (changeConsAssoc a3)+> changeConsAssoc (HsPTuple hsPats) = HsPTuple (map changeConsAssoc hsPats)+> changeConsAssoc (HsPList hsPats) = HsPList (map changeConsAssoc hsPats)+> changeConsAssoc (HsPParen hsPat) = HsPParen (changeConsAssoc hsPat)+> changeConsAssoc (HsPApp hsQName hsPats) = HsPApp hsQName (map changeConsAssoc hsPats)+> changeConsAssoc p = p++> convertHsLetsDect2PatyTerm :: SrcLoc -> HsDecl -> FusionState (Pattern,Term)+> convertHsLetsDect2PatyTerm loc declaracion =+> case declaracion of+> HsPatBind loc hsPat hsRhs hsDecls -> do p <- convertPat2MyPat loc hsPat+> t <- convertRhs2Term loc hsRhs+> return (p,t)+> _ -> do Defvalue v t<-convertDecl2Def declaracion+> return (Pvar v,t)++++> convertHsName2String :: HsName -> String+> convertHsName2String name =+> case name of+> HsIdent str -> str+> HsSymbol str -> str++> convertHsQName2Pattern :: HsQName -> [Pattern] -> Pattern+> convertHsQName2Pattern hsQName args =+> case hsQName of+> Qual (Module modulo) hsName -> Pcons (modulo ++ "." ++ convertHsName2String hsName) args+> UnQual hsName | isLower (head n) -> Pvar (str2var n)+> | otherwise -> Pcons n args+> where n = convertHsName2String hsName+> Special HsUnitCon -> Pcons "()" args+> Special HsListCon -> foldr (\p -> Pcons ":" . (p:) . (:[])) (Pcons "[]" []) args+> Special HsFunCon -> Pcons "->" args+> Special (HsTupleCon i) -> Ptuple args+> Special HsCons -> Pcons ":" args++> convertHsQName2Term :: HsQName -> [Term] -> Term+> convertHsQName2Term hsQName args =+> case hsQName of+> Qual (Module modulo) hsName -> cons (modulo ++ "." ++ convertHsName2String hsName ) args+> UnQual hsName -> cons (convertHsName2String hsName) args+> Special HsUnitCon -> Tcapp "()" args+> Special HsListCon -> foldr (\p->Tcapp ":" .(p:) . (:[])) (Tcapp "[]" []) args+> Special HsFunCon -> Tcapp "->" args+> Special (HsTupleCon i) -> Ttuple False args+> Special HsCons -> Tcapp ":" args+> where cons s | isUpper (head s) = Tcapp s+> | not (null args) = Tfapp (str2var s)+> | otherwise = const (Tvar (str2var s))++> convertLit2Lit :: HsLiteral -> Literal+> convertLit2Lit lit =+> case lit of+> HsInt integer -> Lint (show integer)+> HsChar char -> Lchar char+> HsString string -> Lstring string+> HsFrac rational -> Lrat (show rational)+> HsCharPrim char -> Lchar char+> HsStringPrim string -> Lstring string+> HsIntPrim integer -> Lint (show integer)+> HsFloatPrim rational -> Lrat (show rational)+> HsDoublePrim rational -> Lrat (show rational)++> convertHsQOP2Variable :: HsQOp -> HsQName+> convertHsQOP2Variable op =+> case op of+> HsQVarOp hsQName -> hsQName+> HsQConOp hsQName -> hsQName+++Asocia : como operador infijo a derecha y elimina parentesis.++> fixInfixAssoc :: Term -> Term+> fixInfixAssoc (Ttuple False ps) = Ttuple False $ map fixInfixAssoc ps+> fixInfixAssoc (Tapp t1 t2) = Tapp (fixInfixAssoc t1) (fixInfixAssoc t2)+> fixInfixAssoc (Tlamb bv t) = Tlamb bv (fixInfixAssoc t)+> fixInfixAssoc (Tlet v t0 t1) = Tlet v (fixInfixAssoc t0) (fixInfixAssoc t1)+> fixInfixAssoc (Tcase t ps ts) = Tcase (fixInfixAssoc t) ps (map fixInfixAssoc ts)+> fixInfixAssoc (Tpar t) = fixInfixAssoc t+> fixInfixAssoc (Tcapp n1 ts1@(t1@(Tcapp _ (_:_)):tss1)) =+> case fixInfixAssoc t1 of+> Tcapp n2 ts2 | infx n1 && infx n2 -> Tcapp n2 (init ts2 ++ [Tcapp n1 (last ts2:map fixInfixAssoc tss1)])+> | otherwise -> Tcapp n1 $ map fixInfixAssoc ts1+> _ -> error "fixInfixAssoc Term: unexpected output."+> where infx n = n==":"+> fixInfixAssoc (Tcapp n ts) = Tcapp n $ map fixInfixAssoc ts+> fixInfixAssoc (Tfapp v ts) = Tfapp v $ map fixInfixAssoc ts+> fixInfixAssoc t@(Tvar _) = t+> fixInfixAssoc t@(Tlit _) = t+> fixInfixAssoc t = error "fixInfixAssoc Term: not defined."
+ HFusion/Internal/RenVars.lhs view
@@ -0,0 +1,248 @@+-- Please, see the file LICENSE for copyright and license information.++> module HFusion.Internal.RenVars (renameVariables,AlphaConvertible(..),VarsB(..))+> where++> import HFusion.Internal.Utils+> import HFusion.Internal.Parsing.HyloContext+> import List((\\),intersect,nub)+> import HFusion.Internal.HyloFace+> import HFusion.Internal.HsSyn+> import HFusion.Internal.Messages++ import Debug.Trace++ sss msg a = trace (msg++": "++show a) a++> renameVariables :: (VarsB a', VarsB ca', AlphaConvertible ca', AlphaConvertible a', VarsB a, +> Vars a', Vars ca', AlphaConvertible a, Vars a,AlphaConvertible ca, Vars ca, VarsB ca, CHylo h) => +> (h a ca) -> (h a' ca') -> [Variable] -> VarGenState (h a ca, h a' ca')+> renameVariables left right fvright = +> do right'<-if null i0 then return right+> else do us <- mapM (getFreshVar . varPrefix) i0+> return (alphaConvert' (zip i0 us) right)+> let i1 = nub$ intersect (vars' right'++fvright) (varsB' left)+> left'<-if null i1 then return left+> else do us <- mapM (getFreshVar . varPrefix) i1+> return (alphaConvert' (zip i1 us) left)+> return (left',right')+> where i0 = nub$ intersect (vars' left) (varsB' right)+> vars' h = getName h : ( (\(bv,t0,c)->varsB c++vars c++vars t0++vars bv) $ getCoalgebra h) ++ vars (getAlgebra h)+> ++ vars (getEta h) ++ vars (getContext h) ++ (\(bvs,_,_)->vars bvs) (getCoalgebra h)+> varsB' h = ( (\(bv,t0,c)-> varsB c++varsB t0 ++ vars bv) $ getCoalgebra h) +> ++ varsB (getAlgebra h) ++ vars (getContext h)+> alphaConvert' ss h = +> let constantArgs_h = getConstantArgs (getContext h)+> (bv,t0,c) = getCoalgebra h+> sc' = constantArgs_h ++ vars bv+> in setName (getName h) $ setContext (alphaConvert constantArgs_h ss$ getContext h) $+> consHylo (alphaConvert constantArgs_h ss $ getAlgebra h) +> (alphaConvert constantArgs_h ss $ getEta h) (getFunctor h)+> ((\(bv,t0,c)->(alphaConvert constantArgs_h ss bv,+> alphaConvert sc' ss t0,+> alphaConvert sc' ss c)) $ getCoalgebra h)++===========================+Bounded variables+===========================++> instance (VarsB a) => VarsB (Acomponent a) where+> varsB (Acomp (bvs, termwrapper)) = varsB termwrapper ++ vars bvs++> instance VarsB PatternS where+> varsB (PcaseS t0 pat termS) = varsB termS ++ vars pat+> varsB (PcaseSana _ t0 pat termS) = varsB termS ++ vars pat+> varsB (PcaseR _ t0 _ _ ts) = concat (map (varsB.fst) ts)+> varsB (Ppattern v p) = vars p+> varsB Pdone = []+++> instance VarsB Sigma where+> varsB (Sigma (_,listatps,pss,hss)) = concat (map varsB pss)++> instance VarsB WrappedCA where+> varsB (WCApsi (bv, t0, psi)) = varsB t0 ++ varsB psi ++ vars bv+> varsB (WCAoutF (bv, t0, outf)) = varsB t0 ++ varsB outf ++ vars bv+> varsB (WCAsigma (bv, t0, sigma)) = varsB t0 ++ varsB sigma ++ vars bv++> instance VarsB InF where+> varsB (InF (cons,ts)) = varsB ts++> instance VarsB Tau where+> varsB (Tauphi tauphii) = varsB tauphii+> varsB (TauinF tauinf) = varsB tauinf+> varsB (Tautau tautau) = varsB tautau++> instance VarsB a => VarsB (TermWrapper a) where+> varsB = foldTW (\t0 pts vs -> varsB t0 ++ vars pts ++ concat vs) const varsB varsB [] ++> instance (VarsB a) => VarsB (TauTerm a) where+> varsB t = []++> instance VarsB OutF where+> varsB (OutF outfis) = varsB outfis++> instance VarsB OutFi where+> varsB (OutFc (cons,vs,tps)) = vs++> instance VarsB Psi where+> varsB (Psi psis) = varsB psis++> instance VarsB Psii where+> varsB (Psii (pat, tps)) = vars pat++> instance VarsB TupleTerm where+> varsB tt = []+++======================================================================+Defino las instance de Vars+======================================================================++> instance (Vars a) => Vars (Acomponent a) where+> vars (Acomp (bvs, termwrapper)) = vars termwrapper \\ vars bvs++> instance Vars Sigma where+> vars (Sigma (_,listatps,pss,hss)) = vars listatps ++ concat (map varshs hss)+> where varshs (Just (_,apcomsInf,etais,wca,functerms)) = vars apcomsInf ++ vars wca+> varshs _ = []++> instance Vars WrappedCA where+> vars (WCApsi (bv, t0, psi)) = (vars t0 ++ vars psi) \\ vars bv+> vars (WCAoutF (bv, t0, outf)) = (vars t0 ++ vars outf) \\ vars bv+> vars (WCAsigma (bv, t0, sigma)) = (vars t0 ++ vars sigma) \\ vars bv++> instance Vars InF where+> vars (InF (cons,ts)) = vars ts++> instance Vars Tau where+> vars (Tauphi tauphii) = vars tauphii+> vars (TauinF tauinf) = vars tauinf+> vars (Tautau tautau) = vars tautau++> instance Vars a => Vars (TermWrapper a) where+> vars = foldTW (\t0 pts vs -> vars t0 ++ (concat vs \\ vars pts)) (\vs eta->vs++vars eta) vars vars [] ++> instance (Vars a) => Vars (TauTerm a) where+> vars (Taucons cons tauterms a etai) = vars tauterms ++ vars a ++ vars etai+> vars (Tausimple term) = vars term+> vars (Taupair term tauterm) = vars term ++ vars tauterm+> vars (Taucata func tauterm) = vars tauterm++> instance Vars OutF where+> vars (OutF outfis) = vars outfis++> instance Vars OutFi where+> vars (OutFc (cons,vs,tps)) = vars tps \\ vs++> instance Vars Psi where+> vars (Psi psis) = vars psis++> instance Vars Psii where+> vars (Psii (pat, tps)) = vars tps \\ vars pat++> instance Vars TupleTerm where+> vars tt = vars (getTerm tt)++> instance Vars EtaOp where+> vars EOid = []+> vars (EOgeneral bvs ts) = vars ts \\ vars bvs+> vars (EOsust vs ts bvs) = vars ts \\ vars bvs+> vars (EOlet ts ps vs ts1) = (vars ts ++ (vars ts1 \\ vars ps)) \\ vs++> instance Vars Etai where+> vars (Etai (etaOp1,etaOp2)) = vars etaOp1 ++ vars etaOp2++++> instance (AlphaConvertible a) => AlphaConvertible (Acomponent a) where+> alphaConvert sc lvars (Acomp (vs, termwrapper)) = Acomp (alphaConvert sc lvars vs,alphaConvert (sc++vars vs) lvars termwrapper)++> instance AlphaConvertible EtaOp where+> alphaConvert sc lvars EOid = EOid+> alphaConvert sc lvars (EOgeneral bvs ts) = EOgeneral (alphaConvert sc lvars bvs) (alphaConvert (sc++vars bvs) lvars ts)+> alphaConvert sc lvars (EOsust vs ts bvs) = EOsust (alphaConvert sc' lvars vs) +> (alphaConvert sc' lvars ts) +> (alphaConvert sc lvars bvs)+> where sc'=sc++vars bvs+> alphaConvert sc lvars (EOlet ts ps vs ts1) = EOlet (alphaConvert sc' lvars ts) +> (alphaConvert sc' lvars ps)+> (alphaConvert sc lvars vs) +> (alphaConvert (sc'++vars ps) lvars ts1)+> where sc'=sc++vs++> instance AlphaConvertible Etai where+> alphaConvert sc lvars (Etai (etaOp1,etaOp2)) = Etai (alphaConvert sc lvars etaOp1, alphaConvert sc lvars etaOp2)++> instance (AlphaConvertible a) => AlphaConvertible (TermWrapper a) where+> alphaConvert sc lvars tw = foldTW (\t0 ps ts sc -> TWcase (alphaConvert sc lvars t0) ps (zipWith ($) ts (map ((sc++).vars) ps))) +> (\t e sc ->TWeta (t sc) (alphaConvert sc lvars e)) (\t sc -> TWsimple (alphaConvert sc lvars t) )+> (\t sc -> TWacomp (alphaConvert sc lvars t)) (const TWbottom) tw sc+++======================================================================+Coalgebra+======================================================================++> instance AlphaConvertible Psi where+> alphaConvert sc lvars (Psi psis) = Psi (alphaConvert sc lvars psis)++> instance AlphaConvertible Psii where+> alphaConvert sc lvars (Psii (pat, tuplets)) = Psii (alphaConvert sc lvars pat,alphaConvert (sc++vars pat) lvars tuplets)++> instance AlphaConvertible TupleTerm where+> alphaConvert sc lvars (Tterm term position) = Tterm (alphaConvert sc lvars term) position++> instance AlphaConvertible InF where+> alphaConvert sc lvars (InF (cons, ts)) = InF (cons,alphaConvert sc lvars ts)++> instance AlphaConvertible Sigma where+> alphaConvert sc lvars (Sigma (casemap,listatupleterms, pss, hss)) = +> Sigma (casemap,alphaConvert (sc++varsB pss) lvars listatupleterms, +> map (alphaConvert sc lvars) pss, map ss hss)+> where ss (Just (i,compsInf, etais, wrappedCa, funcTermTerm)) = +> Just (i,alphaConvert sc lvars compsInf, alphaConvert sc lvars etais, alphaConvert sc lvars wrappedCa, funcTermTerm)+> ss _ = Nothing++> instance AlphaConvertible WrappedCA where+> alphaConvert sc lvars (WCApsi (bound,term,psi)) = WCApsi (alphaConvert sc lvars bound,alphaConvert sc' lvars term,alphaConvert sc' lvars psi)+> where sc'=sc++vars bound+> alphaConvert sc lvars t@(WCAoutF (bound,term,outf)) = WCAoutF (alphaConvert sc lvars bound,alphaConvert sc' lvars term,alphaConvert sc' lvars outf)+> where sc'=sc++vars bound+> alphaConvert sc lvars (WCAsigma (bound,term,sigma)) = WCAsigma (alphaConvert sc lvars bound,alphaConvert sc' lvars term,alphaConvert sc' lvars sigma)+> where sc'=sc++vars bound++> instance AlphaConvertible PatternS where+> alphaConvert sc susts (PcaseS t0 p t) = PcaseS (alphaConvert sc susts t0)+> (alphaConvert sc susts p)+> (alphaConvert sc' susts t) +> where sc'=sc++vars p+> alphaConvert sc susts (PcaseSana i t0 p t) = PcaseSana i (alphaConvert sc susts t0)+> (alphaConvert sc susts p)+> (alphaConvert sc' susts t)+> where sc'=sc++vars p+> alphaConvert sc susts (PcaseR i t0 c vrs ts) = PcaseR i (alphaConvert sc susts t0) c (alphaConvert vrs susts vrs)+> (map (\ (t,pos)-> (alphaConvert (vrs++sc) susts t,pos)) ts)+> alphaConvert sc susts (Ppattern v p) = Ppattern v (alphaConvert sc susts p)+> alphaConvert sc susts t@Pdone = t++> instance AlphaConvertible OutFi where+> alphaConvert sc lvars (OutFc (cons,vars,tupleterms)) = OutFc (cons,alphaConvert sc lvars vars,alphaConvert (sc++vars) lvars tupleterms)++> instance AlphaConvertible OutF where+> alphaConvert sc lvars (OutF outfis) = OutF (alphaConvert sc lvars outfis)++> instance AlphaConvertible Tau where+> alphaConvert sc lvars (Tauphi tau) = Tauphi (alphaConvert sc lvars tau)+> alphaConvert sc lvars (TauinF tau) = TauinF (alphaConvert sc lvars tau)+> alphaConvert sc lvars (Tautau tau) = Tautau (alphaConvert sc lvars tau)++> instance (AlphaConvertible a) => AlphaConvertible (TauTerm a) where+> alphaConvert sc lvars (Taucons cons tauterms a etai) = Taucons cons (alphaConvert sc lvars tauterms) +> (alphaConvert sc lvars a) (alphaConvert sc lvars etai)+> alphaConvert sc lvars (Tausimple term) = Tausimple (alphaConvert sc lvars term)+> alphaConvert sc lvars (Taupair term tauterm) = Taupair (alphaConvert sc lvars term) (alphaConvert sc lvars tauterm)+> alphaConvert sc lvars (Taucata func tauterm) = Taucata (alphaConvert sc lvars.func) (alphaConvert sc lvars tauterm)+++
+ HFusion/Internal/Utils.lhs view
@@ -0,0 +1,399 @@+-- Please, see the file LICENSE for copyright and license information.++% -----------------------------------------------------------------------------+% $Id: Utils.lhs,v 1.28 2006/05/30 23:13:31 fdomin Exp $+%+% Los algoritmos que crean y modifican hilomorfismos se espera que+% utilicen esta monada para realizar el manejo de errores y la+% generacion de variables frescas.+%+% -----------------------------------------------------------------------------++> module HFusion.Internal.Utils where+> import HFusion.Internal.HsSyn+> import List++> import HFusion.Internal.Messages+> import Control.Monad+> import Control.Monad.State+> import Control.Monad.Error+> import Language.Haskell.Syntax(SrcLoc(..))+> import qualified Data.Map as M(empty,adjust,Map,insert,lookup) ++> import Debug.Trace++> sss s a = trace (s++": "++show a) a++> -- | Data used to generate variables.+> -- The map stores for each variable name generated so far+> -- which was the index last used to generate a fresh variable+> -- with such a name as prefix.+> type VarGen = M.Map String Int++> type VarGenState a = State VarGen a++> -- | Creates a variable generator +> newVarGen = M.empty++> getFreshVar :: String -> VarGenState Variable+> getFreshVar p = do dict<-get+> case M.lookup p dict of+> Just i -> put (M.adjust (+1) p dict) >> return (Vgen p i)+> _ -> put (M.insert p 1 dict) >> return (Vgen p 0)+++ dfilter devuelve una lista con los elementos que satisface un predicado dado y otra lista con los que no.++> dfilter :: (a->Bool)->[a]->([a],[a])+> dfilter p (a:as) | (p a) = (a:r1,r2)+> | otherwise = (r1,a:r2)+> where (r1,r2)= dfilter p as+> dfilter p _ = ([],[])++Convierte una variable ligada en un termino.++> bv2term :: Boundvar -> Term+> bv2term (Bvar v) = Tvar v+> bv2term (Bvtuple b vs) = Ttuple b (map bv2term vs)++> wrap a = [a]++> mapSel s i f (h:ls) =+> case lookup i s of+> Nothing -> h : mapSel s (i+1) f ls+> Just a -> f a h : mapSel s (i+1) f ls+> mapSel s i f [] = []+++substitutionPattern++> substitutionPattern :: [(Variable,Variable)] -> Pattern -> Pattern+> substitutionPattern sust pat =+> case pat of+> Pvar variable -> case lookup variable sust of+> Just v' -> Pvar v'+> _ -> pat+> Ptuple tupla -> Ptuple (map (substitutionPattern sust) tupla)+> Pcons cons pats -> Pcons cons (map (substitutionPattern sust) pats)+> Plit lit -> pat+> Pas v p -> case lookup v sust of+> Just v' -> Pas v' (substitutionPattern sust p)+> _ -> substitutionPattern sust p++susbtitution++La siguiente funcin realiza la substitucion de una lista de variables con terminos asociados para un termino+dado.++Parametros de entrada:++1) Lista de parejas (Variable, Term) para las cuales se efectuara la substitucion.+2) El termino sobre el cual se realizara la substitucion++Resultado:++Un termino del tipo Term resultado de efectuar las respectivas sustituciones de las variables por los terminos asociadosa estas.++> substitution :: [(Variable,Term)] -> Term -> Term++> substitution [] term = term+> substitution ss t = +> let+> except exp = let diff (v,val) = not (elem v (vars exp))+> in substitution (filter diff ss)+> in+> case t of++ Dado un termino que representa una variable se busca la misma en la lista de variables a sustituir, en caso de que la busqueda fuera exitosa se retorna el termino asociado en la lista de substituciones con esa variable. En caso constrario se retorna el termino original.++> Tvar v -> case lookup v ss of+> Just valor -> valor+> Nothing -> t++ El caso en que el termino evaluado fuera una lambda expresion toma en consideracion los casos de las variables que no son definidos en la lambda expresion. De no ser asi se estaria modificando la semantica de dicha expresion.++> Tlamb bv t -> Tlamb bv $ except bv t++ De la misma forma que el caso de las lambda expresiones, las expresiones let realizan las substituciones sobre los terminos asociados a estas para las variables fuera del scope del let.++> Tlet v t0 t1 -> Tlet v (except v t0) (except v t1)++ Cuando se esta evaluando un termino case se retorna un nuevo case resultado de sustituir en los terminos asociados con los patrones las variables que no estan ligadas a los ultimos.++> Tcase t0 ps ts -> let t0new = substitution ss t0+> in Tcase t0new ps (zipWith except ps ts)++ Los terminos literales no sufren modificaciones en la operaciones de substitucion.++> Tlit _ -> t++ El resto de las alternativas evaluadas por la funcion operan de la misma forma, es decir componiendo un nuevo termino apartir de las substituciones sobre los subterminos que definian al termino original.++> Ttuple b ts -> Ttuple b $ map (substitution ss) ts++> Tfapp v ts ->+> let+> mts = map (substitution ss) ts+> in+> case lookup v ss of+> Just valor -> case valor of Tfapp v' ts' -> Tfapp v' (ts'++mts)+> _ -> foldl tapp valor mts+> Nothing -> Tfapp v mts+> Tcapp cons ts ->+> let+> nts = map (substitution ss) ts+> in+> Tcapp cons nts+> Tapp t0 t1 ->+> let+> newt0 = substitution ss t0+> newt1 = substitution ss t1+> in+> Tapp newt0 newt1+> Thyloapp v i ts pos t ->+> let+> mts = map (substitution ss) ts+> t' = substitution ss t+> in+> case lookup v ss of+> Just valor -> case valor of Tfapp v' ts' -> Tfapp v' (ts'++thyloArgs i mts pos t')+> _ -> foldl tapp valor (thyloArgs i mts pos t')+> Nothing -> Thyloapp v i mts pos t'+> t -> t+++> foldrM:: (Monad m) => (a -> b-> m b) -> b -> [a] -> m b+> foldrM f b0 [] =+> do+> return b0+> foldrM f b0 (a:as) =+> do+> resTail <- foldrM f b0 as+> resHead <- f a resTail+> return resHead+++ The following algorithm eliminates spurious cases.++> delCases :: Term -> Term+> delCases (Tlet a t0 t1) = Tlet a (delCases t0) (delCases t1)+> delCases (Tcase t0 (p@(Pvar x):_) (t:_))+> | p == pany = t'+> | countx == 0 = t'+> | otherwise = case t0 of+> Tvar u -> substitution [(x,t0)] t'+> _ -> if isRecTuple t0 || countx == 1+> then substitution [(x,t0)] t'+> else Tcase t0 [p] [t']+> where t'=delCases t+> countx = countLinear x t'+> isRecTuple (Ttuple True _) = True+> isRecTuple _ = False+> delCases (Tcase t0 (p:ps) (t:ts)) = +> let (ps',ts')=select ps ts+> res = Tcase t0 (p:ps') (map delCases (t:ts'))+> in case (t0,p) of+> (Tcapp c [],Pcons c' []) | c==c' -> delCases t+> | otherwise -> res+> _ -> res+> where select (p@(Pvar v):_) (t:_) = ([p],[t])+> select (p:ps) (t:ts) = let (ps',ts')=select ps ts+> in (p:ps',t:ts')+> select ps ts = (ps,ts)+> delCases t = t++countLinear v t, counts occurrenses of variable v in t on a same branch of evaluation+through cases and ifs++> countLinear :: Variable -> Term -> Int+> countLinear v (Tvar v') = if v==v' then 1 else 0+> countLinear v (Tlit _) = 0+> countLinear v (Ttuple _ ts) = sum (map (countLinear v) ts)+> countLinear v (Tfapp v' ts) = sum (map (countLinear v) ts) + if v==v' then 1 else 0+> countLinear v (Tcapp c ts) = sum (map (countLinear v) ts)+> countLinear v (Tapp t0 t1) = countLinear v t0 + countLinear v t1+> countLinear v (Tif t0 t1 t2) = countLinear v t0 + max (countLinear v t1) (countLinear v t2)+> countLinear v (Tlet v' t0 t1) = if v==v' then 0 else countLinear v t0 + countLinear v t1+> countLinear v (Tlamb v' t) = if elem v (vars v') then 0 else countLinear v t+> countLinear v (Tcase t0 ps ts) = maximum (zipWith (\p t-> if elem v (vars p) then 0 else countLinear v t) ps ts) + countLinear v t0+> countLinear v (Thyloapp v' i ts _ t) = sum (map (countLinear v) ts) + countLinear v t + if v==v' then 1 else 0+> countLinear v (Tpar t) = countLinear v t+> countLinear v Tbottom = 0+++extractVars (\v1 -> ... -> \vn -> t)+yields ([v1,...,vn],t)++> extractVars :: Term -> ([Boundvar],Term)+> extractVars = extractVars' id+> where extractVars' f (Tlamb bv t) = extractVars' (f.(bv:)) t+> extractVars' f t = (f [],t)+++Devuelve las variables libres de un termino pero si estan repetidas aparecen repetidas en la lista+retornada.++> vars' :: Term -> [Variable]+> vars' (Tvar v) = [v]+> vars' (Ttuple _ ps) = concat (map vars' ps)+> vars' (Tcapp _ ps) = concat (map vars' ps)+> vars' (Tlit _) = []+> vars' (Tfapp fn ps) = concat ([fn]:(map vars' ps))+> vars' (Tapp t1 t2) = vars' t1 ++ vars' t2+> vars' (Tlamb bv t) = vars' t \\ vars bv+> vars' (Tif t0 t1 t2) = vars' t0 ++ vars' t1 ++ vars' t2+> vars' (Tlet v t0 t1) = vars' t0 ++ (vars' t1 \\ [v])+> vars' (Tcase t ps ts) = concat (vars' t:zipWith (\pi ti ->vars' ti \\ vars pi) ps ts)+> vars' Tbottom = []+> vars' (Thyloapp v i ts _ t) = v:(concat (map vars' ts)++vars' t)+> vars' (Tpar t) = vars' t++Transforms boolean cases in if's and one alternative cases into lets++> polishTerm :: Term -> Term+> polishTerm (Ttuple b ps) = Ttuple b$ map polishTerm ps+> polishTerm (Tcapp n ps) = Tcapp n $ map polishTerm ps+> polishTerm (Tfapp fn ps) = Tfapp fn (map polishTerm ps)+> polishTerm (Tapp t1 t2) = Tapp (polishTerm t1) (polishTerm t2)+> polishTerm (Tlamb bv t) = Tlamb bv (polishTerm t)+> polishTerm (Tlet v t0 t1) = Tlet v (polishTerm t0) (polishTerm t1)+> polishTerm (Tcase t [Pvar v] (ti:_)) = Tlet v (polishTerm t) (polishTerm ti)+> polishTerm (Tcase t (Pcons "True" []:Pcons "False" []:_) (t1:t2:_)) = Tif (polishTerm t) (polishTerm t1) (polishTerm t2)+> polishTerm (Tcase t (Pcons "True" []:Pvar (Vuserdef "_"):_) (t1:t2:_)) = Tif (polishTerm t) (polishTerm t1) (polishTerm t2)+> polishTerm (Tcase t (Pcons "False" []:Pcons "True" []:_) (t1:t2:_)) = Tif (polishTerm t) (polishTerm t2) (polishTerm t1)+> polishTerm (Tcase t (Pcons "False" []:Pvar (Vuserdef "_"):_) (t1:t2:_)) = Tif (polishTerm t) (polishTerm t2) (polishTerm t1)+> polishTerm (Tcase t ps ts) = Tcase (polishTerm t) ps (map polishTerm ts)+> polishTerm t@(Tvar _) = t+> polishTerm t@(Tlit _) = t+> polishTerm (Tif t0 t1 t2) = Tif (polishTerm t0) (polishTerm t1) (polishTerm t2)+> polishTerm (Tpar t) = Tpar (polishTerm t)+> polishTerm t = t -- error ("polishTerm Term: not defined: " ++ show t)++> polishDef :: Def -> Def+> polishDef (Defvalue v t) = Defvalue v (polishTerm t)+++> removeIfAndLets :: Term -> Term+> removeIfAndLets = transformTerm remIfLets+> where remIfLets _ (Tif t0 t1 t2) = Tcase t0 [Pcons "True" [],Pcons "False" []] [t1,t2]+> remIfLets _ (Tlet v t0 t1) = Tcase t0 [Pvar v] [t1]+> remIfLets _ t = t+++Applies a function to each subterm of a term.+In the first argument the original subterms are given, and in the other the +result of applying the function over them.++> transformTerm :: (Term -> Term -> Term) -> Term -> Term+> transformTerm f t = f t (tr t)+> where tr (Tcase t ps ts) = Tcase (transformTerm f t) ps (map (transformTerm f) ts)+> tr (Tfapp v ts) = Tfapp v (map (transformTerm f) ts)+> tr (Tcapp c ts) = Tcapp c (map (transformTerm f) ts)+> tr (Ttuple b ts) = Ttuple b (map (transformTerm f) ts)+> tr (Thyloapp v i ts pos t) = Thyloapp v i (map (transformTerm f) ts) pos (transformTerm f t)+> tr (Tlamb bv t) = Tlamb bv (transformTerm f t)+> tr (Tlet v t0 t1) = Tlet v (transformTerm f t0) (transformTerm f t1)+> tr (Tapp t0 t1) = Tapp (transformTerm f t0) (transformTerm f t1)+> tr (Tif t0 t1 t2) = Tif (transformTerm f t0) (transformTerm f t1) (transformTerm f t2)+> tr (Tpar t) = Tpar (transformTerm f t)+> tr t@(Tvar _) = t+> tr t@(Tlit _) = t+> tr t@Tbottom = t+++zipTree++> zipTree' :: [Boundvar] -> [Term] -> Maybe [(Variable, Term)]+> zipTree' [] [] = Just []+> zipTree' (v:vs) (t:ts) =+> case (v,t) of+> (Bvtuple _ bvs', Ttuple _ ts') -> do z1<-zipTree' bvs' ts';z2<-zipTree' vs ts;return (z1++z2)+> (Bvar bv, t) -> do z<-zipTree' vs ts;return ((bv, t):z)+> _ -> Nothing+> zipTree' _ _ = Nothing++concatMaybes++Retorna los elementos de una lista de Maybe a almacenados en el constructor Just.++> concatMaybes :: [Maybe a] -> [a]+> concatMaybes [] = []+> concatMaybes (x:xs) =+> let+> res = concatMaybes xs+> in+> case x of+> Just y ->+> y : res+> Nothing ->+> res++insertAt++> insertAt :: a -> Int -> [a] -> [a]+> insertAt x i ls = (take i ls) ++ [x] ++ (drop (i+1) ls)+++deleteEvery++> deleteEvery :: (Eq a) => a -> [a] -> [a]+> deleteEvery x [] = []+> deleteEvery x (l:ls) = if (x==l) then (deleteEvery x ls) else l : (deleteEvery x ls)++deleteEverys++> deleteEverys :: (Eq a) => [a] -> [a] -> [a]+> deleteEverys [] lista = lista+> deleteEverys (d:deletes) lista = let res = (deleteEvery d lista) in deleteEverys deletes res++insertNew++> insertNew :: (Eq a) => [a] -> [a] -> [a]+> insertNew [] lista = lista+> insertNew (new:news) lista = if (elem new lista) then (insertNew news lista) else new : (insertNew news lista)++cascadeLambda++> cascadeLambda :: [Boundvar] -> Term -> Term+> cascadeLambda [] t = t+> cascadeLambda (v:vs) t = Tlamb v (cascadeLambda vs t)++++> equalTerms :: [(Variable, Variable)] -> Term -> Term -> Maybe (Term,Term)+> equalTerms tbl (Tlit l) (Tlit l') | l==l' = Nothing+> equalTerms tbl (Tvar v) (Tvar v') | maybe (v==v') (==v')$ lookup v tbl = Nothing+> equalTerms tbl (Tlamb bvs0 t0) (Tlamb bvs1 t1) = equalTerms (zip (vars bvs0) (vars bvs1) ++ tbl) t0 t1+> equalTerms tbl (Tcase t0 ps0 ts0) (Tcase t1 ps1 ts1) | and (zipWith equalPatterns ps0 ps1) = +> equalTerms tbl t0 t1 `mplus`+> msum ((zipWith (\(p,p') (t,t') -> equalTerms (zipPatterns p p' []++tbl) t t')+> (zip ps0 ps1) (zip ts0 ts1)))+> equalTerms tbl (Ttuple _ ts0) (Ttuple _ ts1) = msum$ zipWith (equalTerms tbl) ts0 ts1+> equalTerms tbl (Tcapp cons0 ts0) (Tcapp cons1 ts1) | cons0==cons1 = msum$ zipWith (equalTerms tbl) ts0 ts1 +> equalTerms tbl (Tfapp v0 ts0) (Tfapp v1 ts1) | maybe (v0==v1) (==v1)$ lookup v0 tbl =+> msum$ zipWith (equalTerms tbl) ts0 ts1+> equalTerms tbl (Tlet vi0 ti0 ti1) (Tlet vd0 td0 td1) = equalTerms tbl ti0 td0 `mplus` equalTerms ((vi0,vd0):tbl) ti1 td1+> equalTerms tbl (Tif tb0 ti0 ti1) (Tif tb1 td0 td1) = equalTerms tbl tb0 tb1 `mplus` equalTerms tbl ti0 td0 `mplus` equalTerms tbl ti1 td1+> equalTerms tbl (Tapp ti0 ti1) (Tapp td0 td1) = equalTerms tbl ti0 td0 `mplus` equalTerms tbl ti1 td1+> equalTerms tbl (Tpar t0) (Tpar t1) = equalTerms tbl t0 t1+> equalTerms tbl (Tapp (Tvar v0) t0) t1 = equalTerms tbl (Tfapp v0 [t0]) t1+> equalTerms tbl t0 (Tapp (Tvar v1) t1) = equalTerms tbl t0 (Tfapp v1 [t1])+> equalTerms tbl t0 t1 = Just (t0,t1)++> zipPatterns :: Pattern -> Pattern -> [(Variable, Variable)] -> [(Variable, Variable)]+> zipPatterns (Pvar v0) (Pvar v1) tbl = (v0,v1):tbl+> zipPatterns (Ptuple pis) (Ptuple pds) tbl = foldr ($) tbl$ zipWith zipPatterns pis pds+> zipPatterns (Pcons ci pis) (Pcons cd pds) tbl | ci == cd = foldr ($) tbl$ zipWith zipPatterns pis pds+> zipPatterns (Pas v0 p0) (Pas v1 p1) tbl = zipPatterns p0 p1 ((v0,v1):tbl)+> zipPatterns _ _ tbl = tbl++Tells if two patterns have the same structure++> equalPatterns :: Pattern -> Pattern -> Bool+> equalPatterns (Pvar v0) (Pvar v1) = True+> equalPatterns (Ptuple pis) (Ptuple pds) = and$ zipWith equalPatterns pis pds+> equalPatterns (Pcons ci pis) (Pcons cd pds) = ci == cd && and (zipWith equalPatterns pis pds)+> equalPatterns (Plit l0) (Plit l1) = l0==l1+> equalPatterns (Pas v0 p0) (Pas v1 p1) = equalPatterns p0 p1+> equalPatterns _ _ = False+
+ LICENSE view
@@ -0,0 +1,41 @@+The hfusion package is (c) copyright 2002 to the original authors+and contributors listed here. If you add or modify code, please +add your name here.++Authors and contributors:+ Facundo Dominguez+ Alberto Pardo+ Marcelo Giorgi++---+Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met:++* Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in +the documentation and/or other materials provided with the +distribution.++* Neither name of the authors nor the names of the contributors +may be used to endorse or promote products derived from this +software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE ORIGINAL AUTHORS AND THE +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT+OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE.++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hfusion.cabal view
@@ -0,0 +1,50 @@+name: hfusion+version: 0.0.1+build-type: Simple+cabal-version: >= 1.6+license: BSD3+license-file: LICENSE+author: Facundo Dominguez+maintainer: facundominguez @ f i n g . e d u . u y+stability: experimental+homepage: http://www.fing.edu.uy/inco/proyectos/fusion+category: Program Transformation+synopsis: A library for fusing a subset of Haskell programs.+description:+ This package implements algorithms for fusing pure functions which can+ be written as primitive recursive functions or as hylomorphisms. The+ functions can be mutually recursive and make recursion over multiple+ arguments.+++library+ build-depends: base<5, mtl, haskell-src, haskell98, containers, pretty+ exposed-modules:+ HFusion.HFusion+ other-modules:+ HFusion.Internal.HyloFace+ ,HFusion.Internal.HyloRep+ ,HFusion.Internal.FsDeriv+ ,HFusion.Internal.FunctorRep+ ,HFusion.Internal.FuseEnvironment+ ,HFusion.Internal.FuseFace+ ,HFusion.Internal.HsPrec+ ,HFusion.Internal.HsPretty+ ,HFusion.Internal.HsSyn+ ,HFusion.Internal.Inline+ ,HFusion.Internal.Messages+ ,HFusion.Internal.RenVars+ ,HFusion.Internal.Utils+ ,HFusion.Internal.Parsing.Translator+ ,HFusion.Internal.Parsing.HyloParser+ ,HFusion.Internal.Parsing.HyloContext++source-repository head+ type: darcs+ location: http://www.fing.edu.uy/inco/proyectos/fusion/darcs/hfusion/++source-repository this+ type: darcs+ location: http://www.fing.edu.uy/inco/proyectos/fusion/darcs/hfusion/+ tag: 0.0.1+