hfusion 0.0.4 → 0.0.5
raw patch · 20 files changed
+615/−462 lines, 20 files
Files
- HFusion/CHANGELOG.hs +36/−0
- HFusion/HFusion.hs +21/−22
- HFusion/Internal/FsDeriv.lhs +6/−9
- HFusion/Internal/FunctorRep.lhs +99/−74
- HFusion/Internal/FuseEnvironment.lhs +1/−5
- HFusion/Internal/FuseFace.lhs +75/−50
- HFusion/Internal/HsPrec.hs +9/−11
- HFusion/Internal/HsPretty.hs +60/−102
- HFusion/Internal/HsSyn.hs +17/−14
- HFusion/Internal/HyloFace.lhs +32/−18
- HFusion/Internal/HyloRep.lhs +1/−2
- HFusion/Internal/Inline.lhs +62/−62
- HFusion/Internal/Messages.lhs +1/−1
- HFusion/Internal/Parsing/HyloContext.lhs +11/−10
- HFusion/Internal/Parsing/HyloParser.lhs +15/−17
- HFusion/Internal/Parsing/Translator.lhs +15/−17
- HFusion/Internal/RenVars.lhs +21/−22
- HFusion/Internal/ShowHyloRep.hs +106/−0
- HFusion/Internal/Utils.lhs +23/−23
- hfusion.cabal +4/−3
+ HFusion/CHANGELOG.hs view
@@ -0,0 +1,36 @@+-- |+-- Version 0.0.5+--+-- * Implements searching and fusing explicit compositions of hylomorphisms in expressions. E.g. +--+-- > ... map f (filter p (map g xs)) ...+--+-- but not+--+-- > ... map f . filter p . map g ...+--+-- or+--+-- > h = map f+-- > k = filter p+-- > ... h (k (map g xs)) ...+--+-- * Fixes fusion of @tails . map@ with @tails@ defined as:+-- +-- > tails :: [a] -> [[a]]+-- > tails [] = []+-- > tails xs@(_:xss) = xs : tails xss+--+-- * Fixed derivation of mutual hylos from definitions where each one +-- uses a different set of names for the constant arguments. +--+-- * Fixed pretty printing of terms in the presence of infix constructors.+-- HFusion doesn't support specifying precedences and associativity for infix operators really.+-- I've tried to have the common infix operators (@(:),(+),(*),(-),(^),(++)@) printed resonably, however.+--+-- Version 0.0.4+--+-- * Fuses spoon-feeded compositions. +--+module HFusion.CHANGELOG() where+
HFusion/HFusion.hs view
@@ -1,45 +1,43 @@ -- Please, see the file LICENSE for copyright and license information. --- | Functions exported by this module can be used to fuse programs as follows:+-- | Functions exported by this module can be used to fuse programs as shown below.+-- The following program reads some Haskell definitions from the standard input+-- and prints the transformed definitions to the standard output. -- -- > import HFusion.HFusion -- > import Control.Monad.Trans(lift) -- > import Language.Haskell.Parser(parseModule)--- >--- > fuseDefinitions :: String -> Either FusionError String--- > fuseDefinitions 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", which are expected--- > -- to be defined in the sourceCode parameter, composing --- > -- "filter" on the second argument of "zip" and naming "zf"--- > -- the resulting recursive definition.--- > >>= fuse "zip" 2 "filter" ["zf"]--- > -- Translate the result from HFusion AST to Haskell source code.--- > >>= return . hsSyn2HsSourceCode+--+-- > 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 +-- > -- Fuse compositions in the program.+-- > >>= \dfs -> lift (fuseDefinitions dfs dfs) +-- > -- Pretty print the result.+-- > >>= return . hsSyn2HsSourceCode . uncurry (++) -- >--- > main = do cs <- readFile "examples.hs"--- > putStr$ either (("There was an error: "++) . show) id$ fuseDefinitions cs+-- > main = do cs <- getContents+-- > 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])+ ,fuseDefinitions -- :: [Def] -> [Def] -> VarGenState [Def] ,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(..)+ ,FusionState ,VarGen,newVarGen ,parseResult2FusionState -- :: ParseResult HsModule -> FusionState HsModule -- * Abstract syntax tree- ,Def(..),Term(..),Pattern(..),Variable(..),Constructor(..),Literal(..),Boundvar(..)+ ,Def(..),Term(..),Pattern(..),Variable(..),Constructor,Literal(..),Boundvar(..) ) where import HFusion.Internal.HsSyn hiding (Vars,VarsB,AlphaConvertible)@@ -49,6 +47,7 @@ import HFusion.Internal.FuseFace import HFusion.Internal.HyloFace import HFusion.Internal.Utils+import HFusion.Internal.Compositions import Control.Monad.Trans(lift) import Control.Monad(liftM2) import Control.Arrow(first,(&&&))@@ -80,6 +79,6 @@ -- | Pretty prints a set of definitions into Haskell source code. hsSyn2HsSourceCode :: [Def] -> String-hsSyn2HsSourceCode = unlines . map ((++"\n").show)+hsSyn2HsSourceCode = unlines . map ((++"\n").show . polishDef)
HFusion/Internal/FsDeriv.lhs view
@@ -9,7 +9,6 @@ > 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)@@ -84,6 +83,7 @@ > Tvar v -> if elem v c1 then do u<-lift$ getFreshVar (varPrefix v); return ([(v,u)],[],Tvar u) > else return ([],[],t) > Tlit _ -> return ([],[],t)+> Tbottom -> return ([],[],t) > Ttuple b ts -> do res<- mapM d ts > let (vs,ps,ts') = unzip3 res > return (foldr (++) [] vs, concat ps, Ttuple b ts')@@ -164,7 +164,7 @@ > aA fs ts = sequence . zipWith (aA' id (zip fs (map countArgs ts))) fs$ ts > where countArgs (Tlamb _ t) = 1 + countArgs t-> countArgs t = 0+> countArgs _ = 0 Having found the last lambda expression, function aA'' is called @@ -219,18 +219,15 @@ > (union (vars recs) (vars ps)) fs ti > return (ps,r) > adaptPattern recs [] p = ptuple$ map (toPat (vars p))$ concat$ recs-> adaptPattern recs t0s p = +> adaptPattern recs _ 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 _ _ [] _ = []+> splitVars _ _ as [] = [as] > splitVars bst p as bs = let (as',ass) = break (flip any bst . p) as > (bs',bss) = break (p (head ass)) bs > tail' [] = []@@ -273,7 +270,7 @@ > remPas (Pas _ p) = p > remPas p = p > getPas u (Pas v _) = Just (v,u)-> getPas u _ = Nothing+> getPas _ _ = Nothing > isPas (Pas _ _) = True > isPas _ = False
HFusion/Internal/FunctorRep.lhs view
@@ -7,7 +7,6 @@ > import HFusion.Internal.HyloRep > import HFusion.Internal.Parsing.HyloContext-> import HFusion.Internal.HyloFace > import List > import Maybe(catMaybes) > import HFusion.Internal.Utils@@ -23,7 +22,6 @@ import Debug.Trace > import HFusion.Internal.Inline-> import HFusion.Internal.HsPretty sss t = trace (show t) @@ -41,7 +39,9 @@ > 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) +> else if patternRepeated (map (head . getPatterns) psis)+> || distinct (head vsm) (head t0) +> || any (varsFreeInOutput (vars vsm)) psis > then throwError NotOutF > else do res<-sequence$ zipWith3 analizePsii (getFunctor h) (getEta h) psis > let (etas,outF,fncs)=unzip3 res@@ -69,18 +69,19 @@ > OutFc (c,inputs,t0s++nchange), > makePosNR vss fnc) > _ -> throwError NotOutF+> varsFreeInOutput :: [Variable] -> Psii -> Bool+> varsFreeInOutput vs (Psii (ps,ts)) = null (vs \\ (vars ts \\ vars ps)) > 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+> patternRepeated (Pcons c _:ps) = any (has c) ps || patternRepeated ps+> patternRepeated [] = False+> patternRepeated _ = True > has c (Pcons c' _) = c==c'-> has c _ = True-> tt2v ts v = filter ((v==).t2v.getTerm) ts+> has _ _ = True > t2v (Tvar v) = v > t2v _ = error$ coalgebra_Should_Not_Return_Terms_Diffrent_From_Vars @@ -97,9 +98,9 @@ > (vsm,t0s,Psi psis)=getCoalgebra h > analizePsii fnc etai psii = > let isNonVarRec tt = case getTerm tt of-> Tvar v -> False+> Tvar _ -> False > Ttuple _ ts | all isVar ts && length ts==length t0s -> False-> t -> isRec fnc$ getPosition tt+> _ -> isRec fnc$ getPosition tt > isVar (Tvar _) = True > isVar _ = False > ts = getTerms psii@@ -229,8 +230,9 @@ > 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 :: (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,[(Int,Int)],[hylo a ca]) > fusionarSimple hs1 i1 hs2 i2 = fusionarSimpleAcc [((i1,i2),0)] [(i1,i2)] > where > fusionarSimpleAcc accfi@((_,acci):_) is = @@ -241,10 +243,12 @@ > 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"+> in if null nused then return ( sum ws+> , map fst$ sortBy (\a b -> compare (snd a) (snd b)) accfi' +> , hs') +> else do (w,res,hss)<-fusionarSimpleAcc accfi' nused+> return (w+sum ws,res, hs'++hss)+> fusionarSimpleAcc [] _ = 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 = @@ -266,10 +270,10 @@ > 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)])) +> buildAlg _ fnc2 _ (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))=+> buildAlg lines1 fnc2 _ (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@@ -277,8 +281,6 @@ > 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),@@ -302,7 +304,7 @@ > 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])+> [h a OutF] -> Int -> [h Phii cb] -> Int -> VarGenState (Int,[(Int,Int)],[h Tau cb]) > fusionarTau hs1 i1 hs2 i2 = fusionarTauAcc [((i1,i2),0)] [(i1,i2)] > where > fusionarTauAcc accfi@((_,acci):_) is = @@ -313,11 +315,13 @@ > 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"+> if null nused then return ( sum ws+> , map fst$ sortBy (\a b -> compare (snd a) (snd b)) accfi' +> , hs') +> else fusionarTauAcc accfi' nused >>= (\(w,res,hss)->return (w+sum ws,res,hs'++hss))+> fusionarTauAcc [] _ = error$ "fusionarTauAcc: unexpected empty request list" > fusionarTau' (i1,i2) =-> do (h1,h2')<-renameVariables (hs1!!i1) (hs2!!i2) []+> do (_,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@@ -330,7 +334,6 @@ > 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@@ -342,11 +345,11 @@ > two (Bvtuple False [Bvar a,Bvar b]) = [(a,b)] > two _ = [] > h1 = hs1 !! i1-> fapp i1 t =Ttuple False [t,applyHyloWithCtxCntArgs (getContext h1) h1 t]+> fapp _ 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."+> pi2' t= case t of Ttuple _ [_,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@@ -358,7 +361,7 @@ > case t of > Tcapp c ts -> > case find (fbranch c) (psis!!ih1) of-> Just (phii,etai,fnc1,ca@(OutFc (_,input,output))) -> +> Just (phii,etai,fnc1,(OutFc (_,input,output))) -> > do res<-sequence$ zipWith (match fnc1 fnc2 output) input ts > let (acc,taus)=unzip res > (matches,ders,hused)=unzip3 acc@@ -394,7 +397,7 @@ > 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 = +> parear fnc output _ = > 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@@ -412,10 +415,10 @@ > (return (f3,TWbottom)) > where getPairs = concat.map getPair > getPair (Bvtuple _ [Bvar v1,Bvar v2]) = [(v1,v2)]-> getPair bv = []+> getPair _ = [] - 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.+ This function is appropriate for converting a hylomorphism into a paramorphism when it is+about to beign fused with another hylomorphism 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 = @@ -456,11 +459,19 @@ > data STfl = STfl {ivar::VarGen,matches::Int} +> -- | Returns:+> -- * the number of recursive calls the result of fusion will have+> -- * the patterns of the resulting coalgebra+> -- * the pairs of hylomorphism that need to be fused. Each pair specifies the position in the output of the+> -- coalgebra on which the result of fusion should be called, the index identifying the mutual component+> -- of the left hylomorphism, the index identfying the argument on which the composition occurs and+> -- the index identfying the mutual component of the unfold to fuse. There is one list of pairs for each+> -- alternative of the sigma coalgebra (after taking into account duplicated constructor occurences in inF). > deriveSigmaPatterns :: Int -> Int -> [(PatternS,[TupleTerm],HFunctor)] > -> [[(Acomponent InF,HFunctor)]] -> VarGenState (Int,[PatternS],[[((Position,Int),(Int,Int))]])-> deriveSigmaPatterns ih2 ia pts inF = +> deriveSigmaPatterns ih2 _ pts inF = > do i<-get -> let (pshused,STfl i' matches) = runState (mapM (derivePattern' inF)$ pts) (STfl i 0)+> 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)@@ -468,8 +479,11 @@ > 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' inF (Ppattern v p@(Pvar _),tts,fnc1) = derivePattern ih2 v inF p tts fnc1 Pdone+> derivePattern' inF (Ppattern v p,tts,fnc1) = derivePattern ih2 v inF p tts fnc1 Pdone >>= \(ps,hused0) ->+> derivePattern ih2 v inF (Pvar v) tts fnc1 Pdone >>= \(_,hused1) -> +> return (ps, [ l1++l2 | l1<-hused0, l2<-hused1])+> derivePattern' _ (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 = @@ -488,31 +502,28 @@ > removePas (Pas _ p) = p > removePas p = p > buildAlt args (inFs,fnc2) = mapM (checkArg args fnc2) $ inFs-> checkArg args fnc2 (InF (c,ts)) = +> checkArg args fnc2 (InF (_,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 =+> derivePattern ih2 t0 _ 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+> derivePattern ih2 t0 _ p _ _ t = return (PcaseSana ih2 t0 p t,[[]])+> isValidRecArg _ vp tt = all (isValidInPos vp)$ (termToList (getTerm tt))+> isValidInPos _ (Tvar _) = True > isValidInPos vp t = notElem vp (vars t) > termToList (Ttuple _ ts) = ts > termToList t = [t]@@ -533,17 +544,17 @@ > 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+> PcaseS _ _ t -> countCases t+> PcaseSana _ _ _ t -> countCases t+> PcaseR _ _ _ _ ps -> sum$ map (countCases . fst) ps > _ -> error$ "FunctorRep: countCases: " ++ (unexpected_Pattern p) Constructs sigma. Returns the branches of the corresponding hylomorphism. -> getSigma :: (CHylo h, HasComponents b, TermWrappable a ) => [h a ca] -> [[(Acomponent InF,HFunctor)]] -> +> getSigma :: (CHylo h, HasComponents b, TermWrappable a ) => [[(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 = +> getSigma 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 = @@ -600,7 +611,7 @@ > 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 (Ppattern _ _) = False > noNestedCons _ = False > isVar (Pvar _) = True > isVar _ = False@@ -610,7 +621,7 @@ > 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)+> addInFNoConstructorCase _ pss tts fnc1s as casemap _ = return (pss,tts,fnc1s,as,casemap) > replicateList :: [Int] -> [a] -> [a] > replicateList is = concat . zipWith replicate is@@ -628,20 +639,30 @@ > 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 = +> -- | Builds a natural transformation for a paramorphism wich applies a given function in +> -- copies of recursive positions. +> etaParaSigma :: [PatternS] -- ^ patterns of sigma+> -> [Boundvar] -- ^ input variables of sigma+> -> Int -- ^ index identifying the argument on which the fusion is made+> -> Int -- ^ index identifying the mutual component of the unfold+> -> [(Position,Int)] -- ^ hylomorphism component (Int) producing the value returned in the given position of the sigma coalgebra +> -> (Int -> Term -> Term) -- ^ function which applies the given component of the unfold to the given term+> -> HFunctor -- ^ original functor of sigma+> -> HFunctor -- ^ functor of sigma after transforming the sigma hylo into a paramorphism+> -> [TupleTerm] -- ^ terms returned by sigma+> -> VarGenState EtaOp+> etaParaSigma ps 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)+> let rs = topmostVar ps ++ (vars (v0s!!ia) \\ (vars ps)) ++ (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) +> topmostVar (PcaseR _ v _ _ _ : _) = [v]+> topmostVar _ = [] > applyh :: [Variable] -> Boundvar -> TupleTerm -> Term > applyh recs bv tt = > let seltt = bv2term bv@@ -658,33 +679,35 @@ > | 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+> buildHyloApp _ _ _ 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 _ fconst bv (PFcnt _) = fconst bv+> mapStructureBv fid _ 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+> mapStructureBv _ _ 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 =+> where psiToSigma' _ 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+> pattern2Ppattern t 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 :: (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,[(Int,[(Int,Int)])],[hylo a Sigma]) > fusionarSigma hs1 i1 ia' hs2 i2 = fusionarSigmaAcc [((i1,[(ia,i2)]),0)] [(i1,[(ia,i2)])] > where-> (v0s',t0s',_)=getCoalgebra (hs1!!i1)+> (v0s',_,_)=getCoalgebra (hs1!!i1) > ia = max 0 (min (length v0s'-1) ia') > fusionarSigmaAcc accfi@((_,acci):_) is = > do res<-mapM fusionarSigma' is@@ -696,9 +719,11 @@ > 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"+> if null nused then return ( sum ws+> , map fst$ sortBy (\a b -> compare (snd a) (snd b)) accfi' +> , hs')+> else fusionarSigmaAcc accfi' nused >>= (\(w,res,hss)->return (w+sum ws,res,hs'++hss))+> fusionarSigmaAcc [] _ = 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@@ -722,7 +747,7 @@ > 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+> etaParaSigma 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 = @@ -744,7 +769,7 @@ > 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+> do (matches,caS,branches,hused)<-getSigma 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)@@ -754,9 +779,9 @@ > isPpattern _ = False > instance Vars PatternS where-> vars (PcaseS t0 pat termS) = vars termS ++ vars pat+> vars (PcaseS _ 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 (Ppattern _ p) = vars p > vars Pdone = []
HFusion/Internal/FuseEnvironment.lhs view
@@ -16,7 +16,6 @@ > 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)@@ -26,8 +25,6 @@ > 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] @@ -64,14 +61,13 @@ > 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))+> (_,_,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)]
HFusion/Internal/FuseFace.lhs view
@@ -10,15 +10,18 @@ > module HFusion.Internal.FuseFace( > fusionar, +> fusionar', > fusionarTau, > fusionarSigma, > getCata, > getAna, > HyloT, > showHT, +> showHTRep, > deriveHylo, > inline, > getConstantArgCount,+> getConstantArgPos, > getNames, > renameHT, > WrapHT(..),WrapHA(..)@@ -29,9 +32,11 @@ > import HFusion.Internal.Parsing.HyloContext > import qualified HFusion.Internal.FunctorRep as F > import qualified HFusion.Internal.Inline as I+> import qualified HFusion.Internal.ShowHyloRep as SR > import Control.Monad.Error(throwError,catchError) > import Control.Monad.Trans(lift) > import Control.Monad.State(get)+> import Control.Arrow(second) > import List((\\)) > import HFusion.Internal.RenVars@@ -54,21 +59,32 @@ > where names=tuple (map getName hss) > tuple [] = "()" > tuple (n:ns) = '(': show n ++ concat (map ((',':).show) ns) ++ ") =\n"-> show'' _ t _ = ""+> show'' _ _ _ = "" +> showHTRep :: HyloT -> String+> showHTRep h = foldHT show' show' show' h+> where show' h = foldHA show'' show'' show'' h+> show'' hss@(h:hs) = (names ++)$ concat $ (SR.showHyloRep h :) $ +> map ("\n------------------------------\n"++)$ map SR.showHyloRep hs+> where names=tuple (map getName hss)+> tuple [] = "()"+> tuple (n:ns) = '(': show n ++ concat (map ((',':).show) ns) ++ ") =\n"+> show'' _ = ""++ > 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+> foldHT f1 _ _ (HTp a) = f1 a+> foldHT _ f2 _ (HTi a) = f2 a+> foldHT _ _ 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+> foldHA f1 _ _ (HAp a) = f1 a+> foldHA _ f2 _ (HAo a) = f2 a+> foldHA _ _ f3 (HAs a) = f3 a > class WrapHA ca where > wrapHA :: [Hylo a ca] -> HA a@@ -120,7 +136,7 @@ > in buildHylo vs ts >>= (return.wrapHT.wrapHA.zipWith setContext ctxs) -> fusionar :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionar :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,[(Int,[(Int,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@@ -129,7 +145,9 @@ > 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)+> -- | Works like @fusionar@ but it takes the argument index as relative to recursive arguments+> -- and does not attempt to rederive hylos before fusion.+> fusionar' :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,[(Int,[(Int,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@@ -139,7 +157,8 @@ > 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+> fuseCataAna h1 h2 = let f h2 i2 = F.fusionarSimple h1 ih1 h2 i2+> >>= mapFusionIndexes >>= 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@@ -148,24 +167,27 @@ > 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+> 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)+> wrapHylos (m,r,h) = do vs<-sequence $ replicate (length h-length names) (lift (getFreshVar "v"))+> return (m,r,wrapHT.wrapHA.zipWith setName (names++vs)$ h) -> fusionarTau :: [Variable] -> HyloT -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> mapFusionIndexes :: Monad m => (Int,[(Int,Int)],c) -> m (Int,[(Int,[(Int,Int)])],c)+> mapFusionIndexes (i,is,c) = return (i, map (second ((:[]) . (,) 0)) is,c)++> fusionarTau :: [Variable] -> HyloT -> Int -> HyloT -> Int -> FusionState (Int,[(Int,[(Int,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+> fuseCataHylo h1 h2 = let f h1 h2= lift (F.fusionarTau h1 ih1 h2 ih2) >>= mapFusionIndexes >>= 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)+> wrapHylos (m,r,h) = do vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")+> return (m,r,wrapHT.wrapHA.zipWith setName (names++vs)$ h) -> fusionarSigma :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,HyloT)+> fusionarSigma :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,[(Int,[(Int,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@@ -178,9 +200,9 @@ > 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+> wrapHylos res = do (m,r,h)<-res > vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")-> return (m,wrapHT.wrapHA.zipWith setName (names++vs)$ h)+> return (m,r,wrapHT.wrapHA.zipWith setName (names++vs)$ h) > getCata :: HyloT -> FusionState HyloT@@ -195,9 +217,11 @@ > 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)+> wrapHylos :: (WrapHT a,WrapHA b) => [Variable] +> -> (Int,[(Int,[(Int,Int)])],[Hylo a b])+> -> FusionState (Int,[(Int,[(Int,Int)])],HyloT)+> wrapHylos names (m,r,h) = do vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")+> return (m,r,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)@@ -210,35 +234,37 @@ > 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+> oksigma h1' h2' r3@(m3,_,_) =+> do r1@(m1,_,_)<-F.fusionarSimple h1' ih1 h2' ih2 >>= mapFusionIndexes+> r2@(m2,_,_)<-lift$ F.fusionarTau h1' ih1 h2 ih2 >>= mapFusionIndexes > 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+> then if m1>=m3 then wrapHylos names r1+> else wrapHylos names r3+> else if m2>=m3 then wrapHylos names r2+> else wrapHylos names r3+> okCataBadAna h1' _ = lift (F.fusionarTau h1' ih1 h2 ih2) >>= mapFusionIndexes >>= wrapHylos names > badCataOkAna h2' = do h1''<-F.psiToSigma h1-> (m3,hh3)<-F.fusionarSigma h1'' ih1 ia h2' ih2; wrapHylos names m3 hh3+> F.fusionarSigma h1'' ih1 ia h2' ih2 >>= wrapHylos names > 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+> badsigma h1' h2' _ = do r1@(m1,_,_)<-F.fusionarSimple h1' ih1 h2' ih2 >>= mapFusionIndexes+> r2@(m2,_,_)<-lift$ F.fusionarTau h1' ih1 h2 ih2 >>= mapFusionIndexes > if m1>=m2-> then wrapHylos names m1 hh1-> else wrapHylos names m2 hh2+> then wrapHylos names r1+> else wrapHylos names r2 -> 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 :: (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,[(Int,[(Int,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+> okcataana h2'= do r1@(m1,_,_)<-F.fusionarSimple h1 ih1 h2' ih2 >>= mapFusionIndexes+> r2@(m2,_,_)<-lift$ F.fusionarTau h1 ih1 h2 ih2 >>= mapFusionIndexes > 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+> then wrapHylos names r1+> else wrapHylos names r2+> okCataBadAna _ = lift (F.fusionarTau h1 ih1 h2 ih2) >>= mapFusionIndexes >>= wrapHylos names 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)@@ -249,16 +275,15 @@ > 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+> oksigma h1' r2@(m2,_,_)=+> do r1@(m1,_,_)<-F.fusionarSimple h1' ih1 h2 ih2 >>= mapFusionIndexes > if m1>=m2-> then wrapHylos names m1 hh1-> else wrapHylos names m2 hh2+> then wrapHylos names r1+> else wrapHylos names r2 > badCata _ = catchError (do h1''<- F.psiToSigma h1-> (m3,hh3)<-F.fusionarSigma h1'' ih1 ia h2 ih2-> wrapHylos names m3 hh3)+> F.fusionarSigma h1'' ih1 ia h2 ih2 >>= wrapHylos names) > error-> badsigma h1' _ = do (m3,hh3)<-F.fusionarSimple h1' ih1 h2 ih2; wrapHylos names m3 hh3+> badsigma h1' _ = F.fusionarSimple h1' ih1 h2 ih2 >>= mapFusionIndexes >>= wrapHylos names > error _ = throwError (Msg couldnt_Fuse_Hylos)
HFusion/Internal/HsPrec.hs view
@@ -4,7 +4,7 @@ Precedence, LeftParam, hpar, -- :: Bool -> Doc -> Doc- parentizar, -- ::Precedence -> LeftParam -> Precedence -> Bool+ parenthesize, -- ::Precedence -> LeftParam -> Precedence -> Bool Asoc(LeftAsoc,RightAsoc,None) ) where @@ -22,14 +22,12 @@ hpar paren d = if paren then char '(' <> d <> char ')' else d --- Decides if an expression E2, with outermost operador O2 having --- precedence given in the third parameter, needs parenthesis--- being the first parameter the precedence of operador O1 which--- contains E2 as one of its arguments, and the second parameter--- tells if E2 is left of 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)) +-- | Decides if a subexpression must be parenthesized. +parenthesize :: Precedence -- ^ Precendence of the containing operator+ -> LeftParam -- ^ Tells if the contained expression is left or right of the containing operator+ -> Precedence -- ^ Precedence of the contained operator+ -> Bool+parenthesize (p0,a0) left (p1,_) = p0>p1||+ p0==p1 && (if left then a0==RightAsoc+ else a0==LeftAsoc)
HFusion/Internal/HsPretty.hs view
@@ -4,9 +4,6 @@ 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,@@ -21,14 +18,15 @@ import HFusion.Internal.Utils import Control.Monad(mplus,msum)-import List((\\),transpose)-import Debug.Trace(trace)+import Control.Arrow((***))+import Data.List(transpose,intersperse)+import Data.Char(isLetter) import HFusion.Internal.Messages instance Show Prog where - show (Prog defs) = render.vcat.mapDocSeparator (text ""$$) $ defs+ show (Prog defs) = render.vcat$ intersperse (text "")$ map showDoc 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@@ -41,59 +39,32 @@ 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.+-- | A class for building 'Doc' values. 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 --- =================================================+ showDocPrec _ _ = showDoc --- 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 funcion 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+showTuple ls = char '('<> (hcat$ intersperse (char ',')$ map showDoc ls)<>char ')' --- Inserta parentesis o no, de acuerdo al valor del primer parametro,--- utilizando <> delante y ++ detras de la expresión en el segundo --- parametro. parlist:: Bool -> [Doc] -> Doc parlist paren content = if paren then char '(' <> - cat - (mapSeparator (text ""<+>) content- ++[char ')'])+ cat (intersperse (text " ") content++[char ')']) else sep content tab,stab::Int-tab=4 -- Indentacion grande-stab=2 -- Indentacion pequeña+-- | normal indentation+tab=4 +-- | small indentation+stab=2 --- Precedencias (ver HsPrec)+-- | Precedences for the constructors of 'Term' values. ttupleprec,tlambprec,tletprec,tcaseprec, tfappprec,thyloprec,tcappprec,tappprec,tsumprec::Precedence ttupleprec=(0,None)@@ -104,6 +75,7 @@ tsumprec =(1,None) tfappprec=(maxprec,LeftAsoc) tcappprec=(maxprec,LeftAsoc)+tinfixcappprec=(9,RightAsoc) tappprec=(maxprec,LeftAsoc) dec (p,a) = (p-1,a)@@ -111,13 +83,8 @@ 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 ')' @@ -129,8 +96,6 @@ 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@@ -176,13 +141,13 @@ -- 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@(Pas v' _)) | 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 _ p@(Pvar _) = p+removeSpuriousPas _ p@(Plit _) = p removeSpuriousPas vs (Ptuple ps) = Ptuple (map (removeSpuriousPas vs) ps) removeSpuriousPas vs (Pcons c ps) = Pcons c (map (removeSpuriousPas vs) ps) @@ -201,11 +166,11 @@ pss = transpose$ map patList ps removeCaseVars _ = Nothing findVarPattern i (Tvar v) ps | all (isPatternVar v) ps = Just i- findVarPattern i _ ps = Nothing+ findVarPattern _ _ _ = Nothing isPatternVar v (Pvar v') = v==v'- isPatternVar v _ = False+ isPatternVar _ _ = False removePattern i (Ptuple ps) = toPat$ del i ps- removePattern i _ = error "mergeCasePatterns': something that shouldn't had happened happened."+ removePattern _ _ = error "mergeCasePatterns': something that shouldn't had happened happened." listToTerm [t] = t listToTerm ts = Ttuple False ts termList (Ttuple _ ts) = ts@@ -232,8 +197,8 @@ 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),[])+ makeSustPair t _ v (Pvar v') | notElem v (varsB t) = ((v,Pvar v),[(v',Tvar v)])+ makeSustPair _ tsvs v p | p/=pany = ((v,Pas v p),[]) | elem v tsvs = ((v,Pvar v),[]) | otherwise = ((v,pany),[]) patList (Ptuple ps) = ps@@ -244,11 +209,11 @@ | otherwise = orderMatches lvp t0s orderMatches _ [] = True orderMatches _ _ = False-mergeCasePatterns'' _ t = Nothing+mergeCasePatterns'' _ _ = Nothing substitutePattern :: [(Variable,Pattern)] -> Pattern -> Pattern substitutePattern subst p@(Pvar v) = maybe p id $ lookup v subst -substitutePattern subst p@(Plit _) = p +substitutePattern _ 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 @@ -259,14 +224,14 @@ lastVars :: Pattern -> [Variable] lastVars (Pvar v) = [v]-lastVars (Pcons c ps) = lastVarsList ps+lastVars (Pcons _ 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+ where isPvar (Pvar _) = True isPvar _ = False @@ -274,7 +239,8 @@ showDoc v = text (show v) instance ShowDoc Term where- showDocPrec _ _ (Tvar name) = text (show name)+ showDocPrec _ _ (Tvar name) = text$ if not (null n) && not (isLetter (head n)) then "("++n++")" else n+ where n = show name showDocPrec _ _ (Tlit literal) = text (show literal) showDocPrec _ _ (Ttuple _ [Tvar name]) = text (show name)@@ -283,25 +249,15 @@ tdocs = map (showDocPrec ttupleprec False) terms in cat $ [char '(']- ++ map (nest 1) (mapSeparator (char ','<>) tdocs)+ ++ map (nest 1) (uncurry(++)$ (id *** map (char ','<>))$ splitAt 1 tdocs) ++ [char ')'] - -- La siguiente operacion esta comentada para ilustrar el - -- comportamiento general de cada definicion. 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.+ paren = parenthesize prec left tlambprec in parlist paren content showDocPrec prec left (Tlet variable term1 term2) =@@ -310,7 +266,7 @@ t2=showDocPrec tletprec False term2 content = [(text "let" <+> text (show variable) <+> equals <+> t1) $$ nest 1 (text "in" <+> t2)]- paren = parentizar prec left tletprec+ paren = parenthesize prec left tletprec in parlist paren content showDocPrec prec left (Tif term0 term1 term2) =@@ -320,10 +276,10 @@ 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+ paren = parenthesize prec left tletprec in parlist paren content - showDocPrec prec left (Tpar t) = char '(' <+> showDocPrec (0,None) False t <+> char ')'+ showDocPrec _ _ (Tpar t) = char '(' <+> showDocPrec (0,None) False t <+> char ')' showDocPrec prec left (Tcase term ps' ts') = let@@ -335,13 +291,13 @@ vcat [sep [p <+> text "->", nest tab t] | (p,t)<-zip ps ts] ]- paren = parentizar prec left tcaseprec+ paren = parenthesize prec left tcaseprec in parlist paren content - showDocPrec _ _ (Tfapp variable [] ) = text (show variable)+ showDocPrec p l (Tfapp variable [] ) = showDocPrec p l (Tvar variable) showDocPrec prec left (Tfapp variable terms) = let- tds@(td:tdocs)=map (flip (showDocPrec ((if infx then dec else id)$ op_precedence))) terms+ tds@(td:tdocs)=map (flip (showDocPrec op_precedence)) terms content | infx && length terms>1 = (td True <+> text (show variable)):@@ -349,45 +305,48 @@ | 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+ paren = infx && length terms<=1 || parenthesize 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+ where infx = isInfix variable+ isInfix (Vgen _ _) = False+ isInfix (Vuserdef ('@':'b':_)) = False+ isInfix (Vuserdef (c:_)) = not ((('a'<=c)&&(c<='z'))||(c=='_'))+ isInfix _ = 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 _ _ (Tcapp constructor []) = text$ if constructor/="[]" && not (null constructor) + && not (isLetter (head constructor)) + then "("++constructor++")"+ else constructor showDocPrec prec left (Tcapp constructor terms) = let- tds@(td:tdocs)=map (flip (showDocPrec ((if esinfijo then dec else id)$ op_precedence))) terms+ tds@(td:tdocs)=map (flip (showDocPrec op_precedence)) terms content - | esinfijo && length terms>1 = td True <+> text constructor <+>+ | isInfix && length terms>1 = td True <+> text constructor <+> hsep (map (\t->t False) tdocs)- | esinfijo = td True<>text constructor+ | isInfix = td True<>text constructor | otherwise = text constructor <+> hsep (map (\t->t False) tds)- paren = esinfijo && length terms<=1 || parentizar prec left op_precedence+ paren = isInfix && length terms<=1 || parenthesize prec left op_precedence in hpar paren content- where esinfijo = case constructor of + where isInfix = case constructor of "_" -> False (c:_)-> not (('A'<=c)&&(c<='Z')) && constructor/="[]" _ -> error infix_Constructor_Without_Characters_In_Name- op_precedence | esinfijo = (fst tcappprec,RightAsoc)+ op_precedence | isInfix = tinfixcappprec | otherwise = tcappprec showDocPrec prec left (Tapp term1 term2) = let t1=showDocPrec tappprec True term1 t2=showDocPrec tappprec False term2- paren = parentizar prec left tappprec+ paren = parenthesize prec left tappprec content = t1 <+> t2 in hpar paren content@@ -395,7 +354,6 @@ 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@@ -406,19 +364,19 @@ instance Show Pattern where show (Pvar name) = show name- show (Ptuple patterns) = "("++ mishowList "," patterns ++")"+ show (Ptuple patterns) = "("++ (concat$ intersperse ","$ map show 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) =+ showDocPrec _ _ (Pvar v) = text (show v) + showDocPrec _ _ (Pas v p) = text (show v)<>char '@'<>showDocPrec tcappprec False p+ showDocPrec _ _ (Ptuple patterns) = let ps=map (showDocPrec ttupleprec False) patterns in- (char '('<>hcat (mapSeparator (char ','<>) ps)<>char ')')+ (char '('<>hcat (uncurry(++)$ (id *** map (char ','<>))$ splitAt 1 ps)<>char ')') showDocPrec _ _ (Pcons name []) = text name showDocPrec prec left (Pcons name patterns) = let@@ -428,10 +386,10 @@ hsep (map (\t->t False) tdocs) | otherwise = text name <+> hsep (map (\t->t False) tds)- paren = parentizar prec left op_precedence+ paren = parenthesize prec left op_precedence in hpar paren content- where esinfijo (c:cs) = not (('A'<=c)&&(c<='Z'))+ where esinfijo (c:_) = not (('A'<=c)&&(c<='Z')) esinfijo _ = error infix_Constructor_Without_Characters_In_Name op_precedence | esinfijo name = (fst tcappprec,RightAsoc) | otherwise = tcappprec
HFusion/Internal/HsSyn.hs view
@@ -67,8 +67,9 @@ | 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 + | Thyloapp Variable Int [Term] (Maybe [Int]) Term -- ^ Hylo application, only used for inlining. In+ -- @Thyloapp name recargsCount non-recargs recarg@ the argument+ -- @recarg@ may be a tuple. deriving (Eq) @@ -76,16 +77,16 @@ 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)+thyloArgs 0 ts _ _ = insertElems (zip ts [0..]) []+thyloArgs _ 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+ where insert _ xs [] = map fst xs + insert _ [] 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@@ -174,9 +175,10 @@ 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))-+ vars (Thyloapp v _ ts _ t) = nub (v:(vars ts++vars t)) +instance Vars Def where+ vars (Defvalue v t) = filter (v/=)$ vars t -- | Operations for obtaining bound variables. @@ -199,7 +201,7 @@ 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+ varsB (Thyloapp _ _ ts _ t) = varsB ts++varsB t instance (VarsB a, VarsB b) => VarsB (Either a b) where varsB = either varsB varsB@@ -222,7 +224,8 @@ 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 _ _ t@(Tlit _) = t+ alphaConvert _ _ t@Tbottom = 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)@@ -232,7 +235,7 @@ 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"+ alphaConvert _ _ _ = 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)@@ -242,14 +245,14 @@ instance AlphaConvertible Pattern where- alphaConvert sc lvars t@(Pvar v) = maybe t Pvar $ lookup v lvars+ alphaConvert _ 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 _ _ t@(Plit _) = 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 _ 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
@@ -6,7 +6,21 @@ % Interfaces for manipulating hylomorphisms and its components. % ----------------------------------------------------------------------------- -> module HFusion.Internal.HyloFace where+> module HFusion.Internal.HyloFace(+> CHylo(..)+> , Algebra, Acomponent(..), Psi(..), Psii(..), Phii, OutF(..), InF(..), Etai(..), TupleTerm(..)+> , Tau(..), TauTerm(..), TermWrapper(..), Sigma(..), PatternS(..), WrappedCA(..)+> , ParaFunctor(..), EtaOp(..), HFunctor(..), HyloFunctor, Position, WrapTau(..)+> , unwrapA, foldTWM, foldTau, foldPF, foldPFM, foldTW, getRecIndex, mapStructure, getVars+> , getTerm, setTerm, getPosition, getPositions, rightCompose, leftCompose, compose+> , composeEta, idEta, expanded, mapTau, mapTW, mapTWacc, wrapA, isRec+> , runFusionState, FusionState, FusionError(..)+> , mapTWaccM, expandPositions, remapPositions, getArgIndexes, isIdEta, tupleterm+> , getTupletermsWithArgIndexes, makePosNR, OutFi(..)+> , CoalgebraTerm(..), HasComponents(..), Coalgebra, TermWrappable(..)+> , module HFusion.Internal.HsSyn+> ) where+> > import HFusion.Internal.HsSyn > import HFusion.Internal.Utils > import HFusion.Internal.HsPretty@@ -54,7 +68,7 @@ > -- | 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.+> -- | Returns the names of the constant arguments. > getContext :: hylo a ca -> Context > -- | Replaces the input variables of a grouping of a mutual hylo.@@ -144,9 +158,9 @@ > 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+> foldTau f1 _ _ (Tauphi t) = f1 t+> foldTau _ f2 _ (TauinF t) = f2 t+> foldTau _ _ f3 (Tautau t) = f3 t > -- | A sort of /map/ for 'Tau' values. > mapTau :: (Tau' Phii->Tau' Phii)->(Tau' InF->Tau' InF)->(Tau' Tau->Tau' Tau)->Tau->Tau@@ -206,9 +220,9 @@ > 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+> foldTW _ _ f3 _ _ (TWsimple a) = f3 a+> foldTW _ _ _ f4 _ (TWacomp a) = f4 a+> foldTW _ _ _ _ f5 TWbottom = f5 > -- | A monadic fold for TermWrapper values. > foldTWM :: Monad m => (Term->[Pattern]->[b]->m b)->(b->Etai->m b)->(a->m b)->(Acomponent a->m b)->m b->TermWrapper a->m b@@ -473,7 +487,7 @@ > -- | Positions in which the term references the given variable. > getPositions :: [TupleTerm] -> Variable -> [Position]-> getPositions [] v = []+> getPositions [] _ = [] > getPositions (tt:tts) v | elem v.vars.getTerm$ tt = getPosition tt:getPositions tts v > | otherwise = getPositions tts v @@ -481,7 +495,7 @@ > -- indexes where the variable appears. > getTupletermsWithArgIndexes :: [TupleTerm] -> Variable -> [(TupleTerm,[Int])]-> getTupletermsWithArgIndexes [] v = []+> getTupletermsWithArgIndexes [] _ = [] > getTupletermsWithArgIndexes (tt:tts) v = > let tsi = filter (elem v.vars.fst)$ zip (termToRecList (getTerm tt)) [0..] > in if null tsi then getTupletermsWithArgIndexes tts v@@ -522,15 +536,15 @@ > -- | 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 _ _ (PFid v) = f1 v+> foldPF _ f2 _ (PFcnt v) = f2 v > foldPF f1 f2 f3 (PFprod bvs) = f3 (map (foldPF f1 f2 f3) bvs) > -- | A monadic fold for ParaFunctor values. > foldPFM :: Monad m => (Variable->m b)->(Variable->m b)->([b]->m b)->ParaFunctor->m b-> foldPFM f1 f2 f3 (PFid v) = f1 v-> foldPFM f1 f2 f3 (PFcnt v) = f2 v+> foldPFM f1 _ _ (PFid v) = f1 v+> foldPFM _ f2 _ (PFcnt v) = f2 v > foldPFM f1 f2 f3 (PFprod bvs) = mapM (foldPFM f1 f2 f3) bvs >>= f3 > instance Vars ParaFunctor where@@ -572,7 +586,7 @@ > 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 [] = []+> mknr _ [] = [] > mknrbv ps p | elem p ps = PFcnt p > | otherwise = PFid p @@ -602,11 +616,11 @@ > remapPositions :: [(Position,Int)] -> HFunctor -> HFunctor > remapPositions idxs (HF vrs) = -> HF$ map (\o@(a,i,iss,b)->maybe o (\i'->(a,i',iss,b))$ +> HF$ map (\o@(a,_,iss,b)->maybe o (\i'->(a,i',iss,b))$ > maybe (foldPF (flip lookup idxs) (const Nothing) findJust b) Just$ > lookup a idxs) > vrs-> where findJust (Just a:as) = Just a+> where findJust (Just a:_) = Just a > findJust (_:as) = findJust as > findJust _ = Nothing @@ -618,7 +632,7 @@ > -- | An error monad with 'FusionError' errors and a state > -- monad carrying a generator of fresh variables. -> type FusionState a = ErrorT FusionError (State VarGen) a+> type FusionState a = ErrorT FusionError VarGenState a > -- | Runs a 'FusionState' computation using the given > -- variable generator. The result is either
HFusion/Internal/HyloRep.lhs view
@@ -2,14 +2,13 @@ >module HFusion.Internal.HyloRep( > module HFusion.Internal.HyloFace-> ,module HFusion.Internal.HsSyn,Hylo(..)) where+> ,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
HFusion/Internal/Inline.lhs view
@@ -11,16 +11,15 @@ > import List -> import HFusion.Internal.HyloRep-> import HFusion.Internal.Parsing.HyloContext-> import HFusion.Internal.RenVars+> import HFusion.Internal.HyloFace+> import HFusion.Internal.HyloRep() -- importing class instances only > 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,runState,evalState)+> import Control.Monad.State(get,put,State,runState,evalState) > import Control.Monad.Reader(Reader,runReader,ask,local) > import Control.Monad.Identity(Identity(..))+> import Control.Arrow((***)) > import qualified Data.Map as M(lookup) import Debug.Trace@@ -55,8 +54,6 @@ > | 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@@ -72,7 +69,7 @@ > splitList :: [a] -> [Int] -> [[a]] > splitList ls (i:is) = ls' : splitList lss is > where (ls',lss) = splitAt i ls-> splitList ls [] = []+> splitList _ [] = [] > insertRecvarCases :: [Term] -> [[PatternS]] -> Term -> Term > insertRecvarCases ts pss t = foldr insertCase t (zip ts (head pss))@@ -109,8 +106,8 @@ > | 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+> inlWCA ia _ sust t0 f = +> do let Just (_,inFs,etas,wca,_) = hss!!ia > k<-get > let (wca',i')=runState (renamePatternVars wca) (gi k) -- renombrar variables de patrones > put (k {gi=i'})@@ -124,7 +121,7 @@ > 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"+> lookupfapp _ _ = error "lookupfapp: unexpected case" > inlineTermS inlWCA fapp sust t = > case t of > TtermS t -> return t@@ -142,7 +139,7 @@ > put (gi k) > return res > TbottomS -> return$ Tbottom-> where conda TbottomS t1 t2 = [t1]+> where conda TbottomS t1 _ = [t1] > conda _ t1 t2 = [t1,t2] > inlS = inlineTermS inlWCA fapp sust > inlAlt' (c,vrs,ts) = (c,map (inlAlt vrs) ts)@@ -150,7 +147,7 @@ > 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 = +> inlTermS a (InF (c',_)) ts _ = > do k<-get > case lookup c' (fterms k) of > Just fts -> do k<-get@@ -158,7 +155,7 @@ > put (k {fterms=inlstupd c' (tail fts) (fterms k),gi=i'}) > return t > Nothing -> return a-> inlstupd c l [] = []+> inlstupd _ _ [] = [] > inlstupd c l (h@(c',_):as) | c==c' = (c,l):as > | otherwise = h: inlstupd c l as @@ -208,7 +205,7 @@ > 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+> toTermS _ [] _ = do ts<-get > put (tail ts) > return$ TtermS (head ts) > toTermS' :: Int -> PatternS -> State [Term] TermS -> TermS -> State [Term] TermS@@ -218,12 +215,12 @@ > 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' _ (PcaseR _ _ _ _ []) _ 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+> toTermS' _ (Ppattern v p) t tb = t >>= \t -> return$ TcaseS v p t tb+> toTermS' _ Pdone t _ = t > toTermSalts' ia t tb (t',recs) = toTermS' ia t' t tb >>= \r-> return (r,recs) @@ -251,8 +248,8 @@ > 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) =+> rs _ _ t@(TtermS _) = ([],t)+> rs ns ctx (TcaseS t0 p t _) | 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) =@@ -272,7 +269,7 @@ > 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) = +> rs ns ctx (TcaseSana ia ih t0 p t _) | 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) = @@ -296,7 +293,7 @@ > (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)+> rs _ _ TbottomS = ([],TbottomS) > recurse v ns ctx ps = let (addss,ps')=unzip $ map (rs' v ns ctx ps) ps > in (concat addss,ps')@@ -321,8 +318,8 @@ > matches (Pas _ p) p' = matches p p' > matches p (Pas _ p') = matches p p'-> matches _ (Pvar v) = True-> matches (Pvar v) _ = False+> matches _ (Pvar _) = True+> matches (Pvar _) _ = 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'@@ -333,24 +330,20 @@ 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 _ (Pas vp p) p' = matchingSubsts (Just vp) p p'+> matchingSubsts _ (Pvar vp) p = Just [(vp,p)] > matchingSubsts (Just v) _ p1@(Pvar _) = Just [(v,p1)]-> matchingSubsts v (Ptuple ps) (Ptuple ps') +> matchingSubsts _ (Ptuple ps) (Ptuple ps') > | length ps == length ps' = > sequence (zipWith (matchingSubsts Nothing) ps ps') >>= return . concat-> matchingSubsts v (Pcons c ps) (Pcons c' ps') +> matchingSubsts _ (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 _ (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) = @@ -366,7 +359,7 @@ > 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+> substituteTerms _ TbottomS = TbottomS @@ -377,11 +370,9 @@ > | 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"+> caGetInline _ _ (_,[],OutF _) = error$ "caGetInline: unexpected empty list of terms" @@ -392,7 +383,7 @@ > 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) =+> getInline terminosEntrada (Taucons _ ts phi etai) = > let tsinlines = map (getInline terminosEntrada) ts > (fts,newts) = reduceTrans tsinlines etai > in fts$ getInline newts phi@@ -427,7 +418,7 @@ [| TWcase t0 ps ts |] = case t0 of ps[i] -> [| ts[i] |] -> getInline terminosEntrada tw@(TWeta termWrapper etai) = +> getInline terminosEntrada (TWeta termWrapper etai) = > let (fts,resultadosEta) = reduceTrans terminosEntrada etai > in fts$ getInline resultadosEta termWrapper @@ -463,13 +454,12 @@ > 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+> (boundvar, _, 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@@ -501,7 +491,7 @@ > 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+> countArgs _ = 1 > instance Show EtaOp where@@ -517,6 +507,16 @@ > <>text "->case"<+>showTuple t0s<+>text "of"$$ > (showTuple ps<+>text "->"<>showTuple ts<>char ')') +> etaop2term (EOgeneral bvs tts) = Tlamb (bvtuple bvs) (ttuple tts)+> etaop2term EOid = Tfapp (Vuserdef "id") []+> etaop2term (EOsust vs ts vss) = Tlamb (bvtuple vss) (ttuple (map (sust$ zip vs ts) vss))+> where sust vts (Bvar v) = maybe (Tvar v) id$ lookup v vts+> sust vts (Bvtuple b vs) = Ttuple b$ map (sust vts) vs+> etaop2term (EOlet t0s ps vs ts) = Tlamb (bvtuple (map Bvar vs)) (Tcase (ttuple t0s) [ptuple ps] [ttuple ts])++> etai2term (Etai ([],[])) = etaop2term EOid+> etai2term (Etai (el,er)) = foldl1 (\t0 t1 -> Tfapp (Vuserdef ".") [t0, t1])$ map etaop2term$ el ++ reverse er+ > removeHyloApps :: Term -> Term > removeHyloApps = transformTerm remHApp > where remHApp _ (Thyloapp v i ts pos t) = Tfapp v (thyloArgs i ts pos t)@@ -581,7 +581,7 @@ > 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)+> where ok _ 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@@ -604,9 +604,9 @@ > 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+> alt2Term _ (t,_) = termS2Term f t > mkPattern (c,vrs,ts) = zipWith pf (replicate (length ts) (c,vrs)) [1..]-> mkTerm (c,vrs,ts) = map (alt2Term vrs) ts+> mkTerm (_,vrs,ts) = map (alt2Term vrs) ts > termS2Term _ (TtermS t) = t @@ -624,7 +624,7 @@ > showHylo :: (CHylo hylo,ShowDocA a,HasComponents ca,CoalgebraPrintable ca) => Bool -> VarGen -> hylo a ca -> String-> showHylo isTau i h =+> showHylo _ i h = > let s = text "--------------" > in render $ > text ("Hylo "++show (getContext h)) $$@@ -640,14 +640,14 @@ > where > (vsm,t0,coalg) = getCoalgebra h > tts=getComponentTerms coalg-> showFunctor ca fncs=+> showFunctor _ 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 [] _ = 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) =+> printDeltas (tts:ttss) (f:fncs) = > text "delta" $$ > nest 4 (vcat ( > (if isDeltaId tts f then text "id" else printDelta tts f)@@ -697,9 +697,9 @@ > showDocPF i (PFprod (p:ps)) = char '('<>hcat (showDocPF i p:map ((char 'x'<>).showDocPF i) ps)<>char ')'-> showDocPF i (PFprod _) = text "()"+> showDocPF _ (PFprod _) = text "()" > showDocPF i (PFid _) = text ("PI_"++show i)-> showDocPF i (PFcnt _) = char 'C'+> showDocPF _ (PFcnt _) = char 'C' > instance ShowDoc Psi where > showDoc (Psi alts) =@@ -716,12 +716,12 @@ > 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 ")"]) +> cat (text "(" : map (nest 2) (uncurry (++)$ (id *** map (text ","<+>))$ splitAt 1 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)) . +> termS2Term (\ia _ ->Tfapp (beta ia)) . > reorganizeSigma . weaveTermS (zipWith (zipWith mksum) > (splitList [1..] casemap) > (zipWith replicate casemap tts))$ pss )@@ -747,7 +747,7 @@ > 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 = get >>= \st-> maybe (put ((c,1):st) >> return 1) (\i->put (upd c st) >> return (i+1)) $ lookup c st-> upd c ((c',i):cs) = (c,i+1):cs+> upd c ((_,i):cs) = (c,i+1):cs > upd c [] = [(c,1)] > class ShowDocA a where@@ -761,10 +761,10 @@ > acomp2term :: Acomponent a -> Term > instance Acomp2Term InF where > acomp2term = a2term tinF-> where tinF (InF (c,_)) ts sust = Tcapp c ts+> where tinF (InF (c,_)) ts _ = Tcapp c ts > instance Acomp2Term Phii where > acomp2term = a2term tphii-> where tphii t ts sust = substitution sust t+> where tphii t _ sust = substitution sust t > instance Acomp2Term Tau where > acomp2term = a2term ttau > where ttau tau ts sust = let f tw=tw2term ts sust tterm tw@@ -772,7 +772,7 @@ > 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 -> +> Taucons _ 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]@@ -791,13 +791,13 @@ > 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) =+> hcase _ _ _ = return ()+> tc (Taucons c _ 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 (Taupair _ 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@@ -814,7 +814,7 @@ > 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)+> Taucons c taus _ _ -> 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 ->@@ -838,4 +838,4 @@ > instance ShowDoc Etai where > showDoc e@(Etai (l1,l2)) > | isIdEta e = text "id"-> | otherwise = sep (mapDocSeparator (char '.'<>) $ l1++reverse l2)+> | otherwise = sep$ uncurry (++)$ (id *** map (char '.'<>))$ splitAt 1$ map showDoc $ l1++reverse l2
HFusion/Internal/Messages.lhs view
@@ -83,7 +83,7 @@ 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."+> "does not exist 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
HFusion/Internal/Parsing/HyloContext.lhs view
@@ -10,12 +10,12 @@ > ,getCntArgPos -- :: Context -> Maybe [Int] > ,combineContexts -- :: Context -> Context -> Context > ) where+> import HFusion.Internal.HsPretty() > import HFusion.Internal.HsSyn-> import HFusion.Internal.HsPretty > import HFusion.Internal.Utils-> import List(intersect,find,(\\),delete)+> import List(intersect,(\\),delete) -A context contains the constant arguments with their recursive positions, if available.+A context contains the names of the constant arguments and the positions at which they appear. > data Context = Ctx [Variable] (Maybe [Int]) > deriving Show@@ -40,7 +40,7 @@ > extractContext :: [Def] -> [(Context,Def)] > extractContext dfs@(firstd:taild) = (ctx,removeArgsDef firstd) -> : map (\d -> (ctx,sustDef (zip vrs (getVars d))$ removeArgsDef d)) taild+> : map (\d -> (ctx,sustDef (zip (getVars d) vrs)$ removeArgsDef d)) taild > where idxs = findConstantArguments dfs > vrs = getVars firstd > ctx = Ctx vrs (Just idxs)@@ -63,13 +63,13 @@ > 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)+> removeFromCalls fs (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+> removeFromCalls _ _ 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.@@ -82,26 +82,27 @@ > 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)+> addToCalls fs (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+> addToCalls _ _ tr = tr -returns the indexes of the constant arguments of a mutually recursive definitions.+returns the indexes of the constant arguments of a set of 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 findConstantArgs' fs (Defvalue _ 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 _ -> []+> Tbottom -> [] > 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
HFusion/Internal/Parsing/HyloParser.lhs view
@@ -10,16 +10,14 @@ > 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)+> import List(partition,intersect,union,find,nubBy,(\\),deleteFirstsBy,sort) -- Posición de un token. Es utilizada por el parser y el -- lexer para resolver los problemas del layout.@@ -29,7 +27,7 @@ > parse :: String -> FusionState [HyloT] > parse inp = parseResult2FusionState (parseModule inp) >>= hsModule2HsSyn >>=-> lift . deriveHylos >>= \(errors,hs) -> if null errors then return hs+> lift . deriveHylos >>= \(errors,hs) -> if null errors then return (map snd hs) > else throwError (snd$ head errors) > -- | Obtains hylomorphisms representing functions in the original program.@@ -38,10 +36,10 @@ > -- 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 :: [Def] -> VarGenState ([([Def],FusionError)],[([Def],HyloT)]) > deriveHylos dfs = removeInputVar dfs >>= > handleRegularFunctions . getCycles >>= \ cdfs -> -> mapM (runErrorT . deriveHylo) cdfs >>= \ehs ->+> mapM (\cdf -> runErrorT$ fmap ((,) cdf)$ deriveHylo cdf) cdfs >>= \ehs -> > return (concat (zipWith (\df -> either ((:[]) . ((,) df)) (const [])) cdfs ehs) > ,concat (map (either (const []) (:[])) ehs)) @@ -67,8 +65,8 @@ 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+> catchParseState f _ (ParseOk p) = f p+> catchParseState _ h (ParseFailed loc err) = h loc err getCycles agrupa las definiciones de funciones mutuamente recursivas.@@ -84,8 +82,8 @@ > 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+> where dps ps (Defvalue _ t) = collect .map (flip lookup ps).vars$ t+> getV (Defvalue v _) = v > findCycles :: [[Int]] -> [[Int]] > findCycles g = joinCycles [] $ concat $ map (follow [] g) [0..length g-1]@@ -138,7 +136,7 @@ > 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 _ _ [] = return p > handleRegularFunctions' p calls dns ds = > do cs<-zipWithM (getCallDefs p calls) dns ds > let (dfs,nfs)=unzip cs@@ -147,7 +145,7 @@ > >>= 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+> where eq (_,d1,i1,_,t1) (_,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@@ -184,7 +182,7 @@ > | 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+> adaptr _ _ 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. @@ -200,7 +198,7 @@ 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+> getCalls ps calls ds (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)@@ -221,7 +219,7 @@ > 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)) = +> checkNoPattern (idxs,d@(Defvalue _ 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 @@ -236,7 +234,7 @@ > && 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 (_,Tvar _) = True > callIsOkToSpecialize _ = False > isVar (Tvar _) = True > isVar _ = False@@ -254,7 +252,7 @@ > 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)+> Just (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,[])
HFusion/Internal/Parsing/Translator.lhs view
@@ -13,7 +13,6 @@ > 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@@ -38,7 +37,7 @@ > 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 (HsPatBind _ (HsPVar _) _ _) = True > selectd _ = False > convertDecl2Def :: HsDecl -> FusionState Def@@ -83,8 +82,8 @@ > | 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 (Left _:_) = getFreshVar "v" >>= return . Left+> genVar (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])@@ -94,7 +93,7 @@ > 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+> susts' _ 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)@@ -123,13 +122,12 @@ > convertRhs2Term loc hsRhs = > case hsRhs of > HsUnGuardedRhs hsExp -> convertHsExp2Term loc hsExp [] >>= (return .fixInfixAssoc)-> HsGuardedRhss hsGuardedRhss -> throwError (ParserError loc "Guarded definitions are not supported.")+> 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+> let appArgs t args = foldl Tapp t args > in case exp of > HsVar hsQName -> return $ convertHsQName2Term hsQName args > HsCon hsQName -> return $ convertHsQName2Term hsQName args@@ -174,7 +172,7 @@ > converthsAlt2PatyTerm :: HsAlt -> FusionState (Pattern, Term)-> converthsAlt2PatyTerm (HsAlt loc hsPat hsGuardedAlts hsDecls) =+> converthsAlt2PatyTerm (HsAlt loc hsPat hsGuardedAlts _hsDecls) = > do pat <- convertPat2MyPat loc hsPat > term <- convertHsGuardedAlts2Term loc hsGuardedAlts > return (pat, term)@@ -183,7 +181,7 @@ > convertHsGuardedAlts2Term loc x = > case x of > HsUnGuardedAlt hsExp -> convertHsExp2Term loc hsExp []-> HsGuardedAlts hsGuardedAlt -> throwError (ParserError loc "Guarded alternatives are not supported.")+> HsGuardedAlts _hsGuardedAlt -> throwError (ParserError loc "Guarded alternatives are not supported.") > convertPat2MyPat :: SrcLoc -> HsPat -> FusionState Pattern@@ -221,11 +219,11 @@ > changeConsAssoc p = p > convertHsLetsDect2PatyTerm :: SrcLoc -> HsDecl -> FusionState (Pattern,Term)-> convertHsLetsDect2PatyTerm loc declaracion =+> convertHsLetsDect2PatyTerm _ declaracion = > case declaracion of-> HsPatBind loc hsPat hsRhs hsDecls -> do p <- convertPat2MyPat loc hsPat-> t <- convertRhs2Term loc hsRhs-> return (p,t)+> 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) @@ -247,7 +245,7 @@ > Special HsUnitCon -> Pcons "()" args > Special HsListCon -> foldr (\p -> Pcons ":" . (p:) . (:[])) (Pcons "[]" []) args > Special HsFunCon -> Pcons "->" args-> Special (HsTupleCon i) -> Ptuple args+> Special (HsTupleCon _) -> Ptuple args > Special HsCons -> Pcons ":" args > convertHsQName2Term :: HsQName -> [Term] -> Term@@ -258,7 +256,7 @@ > Special HsUnitCon -> Tcapp "()" args > Special HsListCon -> foldr (\p->Tcapp ":" .(p:) . (:[])) (Tcapp "[]" []) args > Special HsFunCon -> Tcapp "->" args-> Special (HsTupleCon i) -> Ttuple False args+> Special (HsTupleCon _) -> Ttuple False args > Special HsCons -> Tcapp ":" args > where cons s | isUpper (head s) = Tcapp s > | not (null args) = Tfapp (str2var s)@@ -303,4 +301,4 @@ > fixInfixAssoc (Tfapp v ts) = Tfapp v $ map fixInfixAssoc ts > fixInfixAssoc t@(Tvar _) = t > fixInfixAssoc t@(Tlit _) = t-> fixInfixAssoc t = error "fixInfixAssoc Term: not defined."+> fixInfixAssoc _ = error "fixInfixAssoc Term: not defined."
HFusion/Internal/RenVars.lhs view
@@ -8,7 +8,6 @@ > import List((\\),intersect,nub) > import HFusion.Internal.HyloFace > import HFusion.Internal.HsSyn-> import HFusion.Internal.Messages import Debug.Trace @@ -33,7 +32,7 @@ > ++ varsB (getAlgebra h) ++ vars (getContext h) > alphaConvert' ss h = > let constantArgs_h = getConstantArgs (getContext h)-> (bv,t0,c) = getCoalgebra 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) @@ -50,15 +49,15 @@ > 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 (PcaseS _ pat termS) = varsB termS ++ vars pat+> varsB (PcaseSana _ _ pat termS) = varsB termS ++ vars pat+> varsB (PcaseR _ _ _ _ ts) = concat (map (varsB.fst) ts)+> varsB (Ppattern _ p) = vars p > varsB Pdone = [] > instance VarsB Sigma where-> varsB (Sigma (_,listatps,pss,hss)) = concat (map varsB pss)+> varsB (Sigma (_,_,pss,_)) = concat (map varsB pss) > instance VarsB WrappedCA where > varsB (WCApsi (bv, t0, psi)) = varsB t0 ++ varsB psi ++ vars bv@@ -66,7 +65,7 @@ > varsB (WCAsigma (bv, t0, sigma)) = varsB t0 ++ varsB sigma ++ vars bv > instance VarsB InF where-> varsB (InF (cons,ts)) = varsB ts+> varsB (InF (_,ts)) = varsB ts > instance VarsB Tau where > varsB (Tauphi tauphii) = varsB tauphii@@ -77,22 +76,22 @@ > varsB = foldTW (\t0 pts vs -> varsB t0 ++ vars pts ++ concat vs) const varsB varsB [] > instance (VarsB a) => VarsB (TauTerm a) where-> varsB t = []+> varsB _ = [] > instance VarsB OutF where > varsB (OutF outfis) = varsB outfis > instance VarsB OutFi where-> varsB (OutFc (cons,vs,tps)) = vs+> varsB (OutFc (_,vs,_)) = vs > instance VarsB Psi where > varsB (Psi psis) = varsB psis > instance VarsB Psii where-> varsB (Psii (pat, tps)) = vars pat+> varsB (Psii (pat, _)) = vars pat > instance VarsB TupleTerm where-> varsB tt = []+> varsB _ = [] ======================================================================@@ -103,8 +102,8 @@ > 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+> vars (Sigma (_,listatps,_,hss)) = vars listatps ++ concat (map varshs hss)+> where varshs (Just (_,apcomsInf,_,wca,_)) = vars apcomsInf ++ vars wca > varshs _ = [] > instance Vars WrappedCA where@@ -113,7 +112,7 @@ > vars (WCAsigma (bv, t0, sigma)) = (vars t0 ++ vars sigma) \\ vars bv > instance Vars InF where-> vars (InF (cons,ts)) = vars ts+> vars (InF (_,ts)) = vars ts > instance Vars Tau where > vars (Tauphi tauphii) = vars tauphii@@ -124,16 +123,16 @@ > 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 (Taucons _ 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+> vars (Taucata _ tauterm) = vars tauterm > instance Vars OutF where > vars (OutF outfis) = vars outfis > instance Vars OutFi where-> vars (OutFc (cons,vs,tps)) = vars tps \\ vs+> vars (OutFc (_,vs,tps)) = vars tps \\ vs > instance Vars Psi where > vars (Psi psis) = vars psis@@ -147,7 +146,7 @@ > instance Vars EtaOp where > vars EOid = [] > vars (EOgeneral bvs ts) = vars ts \\ vars bvs-> vars (EOsust vs ts bvs) = vars ts \\ vars bvs+> vars (EOsust _ ts bvs) = vars ts \\ vars bvs > vars (EOlet ts ps vs ts1) = (vars ts ++ (vars ts1 \\ vars ps)) \\ vs > instance Vars Etai where@@ -159,7 +158,7 @@ > 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 _ _ 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) @@ -207,7 +206,7 @@ > 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)+> alphaConvert sc lvars (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@@ -224,7 +223,7 @@ > 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+> alphaConvert _ _ 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)
+ HFusion/Internal/ShowHyloRep.hs view
@@ -0,0 +1,106 @@+-- | Implementation of printing of the internal representation of hylomorphisms. +-- Currently intended only for debugging.+module HFusion.Internal.ShowHyloRep(showHyloRep) where++import HFusion.Internal.Inline()+import HFusion.Internal.HyloFace+import HFusion.Internal.HsPretty+import Control.Arrow((***))+import Data.List(intersperse)++showHyloRep :: (ShowRep a, ShowRep ca, CHylo hylo) => hylo a ca -> String+showHyloRep = render . showHyloRepDoc++showHyloRepDoc :: (ShowRep a, ShowRep ca, CHylo hylo) => hylo a ca -> Doc+showHyloRepDoc h = vcat+ [ text "Algebra:" <+> vcat (map showAcomponentRep (getAlgebra h))+ , text "Nat. Trans.:" <+> vcat (map showDoc$ getEta h)+ , text "Functor:" <+> vcat (map (text . show)$ getFunctor h)+ , text "Coalgebra:" <+> showCoalgebraRep (getCoalgebra h)+ , text "Context:" <+> (text$ show$ getContext h)+ ]+ ++showAcomponentRep :: ShowRep a => Acomponent a -> Doc+showAcomponentRep a = (text$ show$ getVars a) <+> text "->" <+> showTermWrapperRep (unwrapA a)++showTermWrapperRep :: ShowRep a => TermWrapper a -> Doc+showTermWrapperRep (TWsimple a) = showRep a+showTermWrapperRep (TWacomp a) = showAcomponentRep a+showTermWrapperRep TWbottom = text "_|_"+showTermWrapperRep (TWeta tw e) = sep [ parens (showTermWrapperRep tw) , char '.' <+> showDoc e ]+showTermWrapperRep (TWcase t0 ps tws) = text "case" <+> showDoc t0 <+> text "of"+ $$ nest 2 (vcat [ showDoc p <+> text "->" <+> showTermWrapperRep tw | (p,tw)<-zip ps tws ])++showCoalgebraRep :: ShowRep ca => Coalgebra ca -> Doc+showCoalgebraRep (bvs,ts,ca) = text (show bvs) <+> text "->" + <+> (text "case" <+> showDoc (ttuple ts) <+> text "of"+ $$ nest 2 (showRep ca))+++class ShowRep a where+ showRep :: a -> Doc++instance ShowRep Term where+ showRep = showDoc++instance ShowRep InF where+ showRep (InF (c,ts)) = parens$ text c <> char ',' <+> showDoc (ttuple ts)++instance ShowRep a => ShowRep (Acomponent a) where+ showRep = showAcomponentRep++instance ShowRep Tau where+ showRep (Tauphi tw) = showTermWrapperRep tw+ showRep (TauinF tw) = showTermWrapperRep tw+ showRep (Tautau tw) = showTermWrapperRep tw++instance ShowRep a => ShowRep (TauTerm a) where+ showRep (Tausimple t) = showRep t+ showRep (Taupair t tauterm) = parens$ showRep t <> char ',' <+> showRep tauterm+ showRep (Taucons c ts phi eta) = text ("Taucons_"++c)+ <+> parens (parens (showRep phi) <> char '$' + <+> parens (showDoc eta) + <+> parens (cat (uncurry (++)$ (id *** map (char ','<+>))$ splitAt 1$ + map showRep ts)))+ showRep (Taucata ft tauterm) = showDoc (Tlamb (Bvar$ Vuserdef "@u")$ ft (Tvar$ Vuserdef "@u")) <+> char '.' <+> showRep tauterm++instance ShowRep OutF where+ showRep = showDoc++instance ShowRep Psi where+ showRep = showDoc++instance ShowRep Sigma where+ showRep (Sigma (csm,tts,pss,_sigma_args)) = + vcat$ [ parens (hcat$ intersperse (char ',') ps) <+> text "->" <+> showTuple t + | (t,ps)<-zip (concat$ zipWith replicate csm tts) (map (map (text . show)) pss) + ]+++{-+> -- | 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.++-}++
HFusion/Internal/Utils.lhs view
@@ -13,11 +13,8 @@ > 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@@ -30,9 +27,14 @@ > -- with such a name as prefix. > type VarGen = M.Map String Int -> type VarGenState a = State VarGen a+> type VarGenState = State VarGen +> -- | Computes the value in the monad of the variable generator+> runVarGenState :: VarGenState a -> VarGen -> (a,VarGen)+> runVarGenState = runState+ > -- | Creates a variable generator +> newVarGen :: VarGen > newVarGen = M.empty > getFreshVar :: String -> VarGenState Variable@@ -48,7 +50,7 @@ > dfilter p (a:as) | (p a) = (a:r1,r2) > | otherwise = (r1,a:r2) > where (r1,r2)= dfilter p as-> dfilter p _ = ([],[])+> dfilter _ _ = ([],[]) Convierte una variable ligada en un termino. @@ -62,7 +64,7 @@ > 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 [] = []+> mapSel _ _ _ [] = [] substitutionPattern@@ -75,7 +77,7 @@ > _ -> pat > Ptuple tupla -> Ptuple (map (substitutionPattern sust) tupla) > Pcons cons pats -> Pcons cons (map (substitutionPattern sust) pats)-> Plit lit -> pat+> Plit _ -> pat > Pas v p -> case lookup v sust of > Just v' -> Pas v' (substitutionPattern sust p) > _ -> substitutionPattern sust p@@ -99,7 +101,7 @@ > substitution [] term = term > substitution ss t = > let-> except exp = let diff (v,val) = not (elem v (vars exp))+> except exp = let diff (v,_) = not (elem v (vars exp)) > in substitution (filter diff ss) > in > case t of@@ -163,9 +165,7 @@ > foldrM:: (Monad m) => (a -> b-> m b) -> b -> [a] -> m b-> foldrM f b0 [] =-> do-> return b0+> foldrM _f b0 [] = return b0 > foldrM f b0 (a:as) = > do > resTail <- foldrM f b0 as@@ -181,7 +181,7 @@ > | p == pany = t' > | countx == 0 = t' > | otherwise = case t0 of-> Tvar u -> substitution [(x,t0)] t'+> Tvar _ -> substitution [(x,t0)] t' > _ -> if isRecTuple t0 || countx == 1 > then substitution [(x,t0)] t' > else Tcase t0 [p] [t']@@ -196,7 +196,7 @@ > (Tcapp c [],Pcons c' []) | c==c' -> delCases t > | otherwise -> res > _ -> res-> where select (p@(Pvar v):_) (t:_) = ([p],[t])+> where select (p@(Pvar _):_) (t:_) = ([p],[t]) > select (p:ps) (t:ts) = let (ps',ts')=select ps ts > in (p:ps',t:ts') > select ps ts = (ps,ts)@@ -207,18 +207,18 @@ > countLinear :: Variable -> Term -> Int > countLinear v (Tvar v') = if v==v' then 1 else 0-> countLinear v (Tlit _) = 0+> countLinear _ (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 (Tcapp _ 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 (Thyloapp v' _ 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+> countLinear _ Tbottom = 0 extractVars (\v1 -> ... -> \vn -> t)@@ -245,7 +245,7 @@ > 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' (Thyloapp v _ 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@@ -337,7 +337,7 @@ deleteEvery > deleteEvery :: (Eq a) => a -> [a] -> [a]-> deleteEvery x [] = []+> deleteEvery _ [] = [] > deleteEvery x (l:ls) = if (x==l) then (deleteEvery x ls) else l : (deleteEvery x ls) deleteEverys@@ -361,7 +361,7 @@ > equalTerms :: [(Variable, Variable)] -> Term -> Term -> Maybe (Term,Term)-> equalTerms tbl (Tlit l) (Tlit l') | l==l' = Nothing+> equalTerms _ (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) = @@ -378,7 +378,7 @@ > 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)+> equalTerms _ t0 t1 = Just (t0,t1) > zipPatterns :: Pattern -> Pattern -> [(Variable, Variable)] -> [(Variable, Variable)] > zipPatterns (Pvar v0) (Pvar v1) tbl = (v0,v1):tbl@@ -390,10 +390,10 @@ Tells if two patterns have the same structure > equalPatterns :: Pattern -> Pattern -> Bool-> equalPatterns (Pvar v0) (Pvar v1) = True+> equalPatterns (Pvar _) (Pvar _) = 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 (Pas _ p0) (Pas _ p1) = equalPatterns p0 p1 > equalPatterns _ _ = False
hfusion.cabal view
@@ -1,5 +1,5 @@ name: hfusion-version: 0.0.4+version: 0.0.5 build-type: Simple cabal-version: >= 1.6 license: BSD3@@ -19,10 +19,11 @@ library build-depends: base<5, mtl, haskell-src, haskell98, containers, pretty exposed-modules:- HFusion.HFusion+ HFusion.HFusion, HFusion.CHANGELOG other-modules: HFusion.Internal.HyloFace ,HFusion.Internal.HyloRep+ ,HFusion.Internal.ShowHyloRep ,HFusion.Internal.FsDeriv ,HFusion.Internal.FunctorRep ,HFusion.Internal.FuseEnvironment@@ -45,5 +46,5 @@ source-repository this type: darcs location: http://www.fing.edu.uy/inco/proyectos/fusion/darcs/hfusion/- tag: 0.0.4+ tag: 0.0.5