diff --git a/HFusion/CHANGELOG.hs b/HFusion/CHANGELOG.hs new file mode 100644 --- /dev/null +++ b/HFusion/CHANGELOG.hs @@ -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 + diff --git a/HFusion/HFusion.hs b/HFusion/HFusion.hs --- a/HFusion/HFusion.hs +++ b/HFusion/HFusion.hs @@ -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 . 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) diff --git a/HFusion/Internal/FsDeriv.lhs b/HFusion/Internal/FsDeriv.lhs --- a/HFusion/Internal/FsDeriv.lhs +++ b/HFusion/Internal/FsDeriv.lhs @@ -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 diff --git a/HFusion/Internal/FunctorRep.lhs b/HFusion/Internal/FunctorRep.lhs --- a/HFusion/Internal/FunctorRep.lhs +++ b/HFusion/Internal/FunctorRep.lhs @@ -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 = [] diff --git a/HFusion/Internal/FuseEnvironment.lhs b/HFusion/Internal/FuseEnvironment.lhs --- a/HFusion/Internal/FuseEnvironment.lhs +++ b/HFusion/Internal/FuseEnvironment.lhs @@ -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)] diff --git a/HFusion/Internal/FuseFace.lhs b/HFusion/Internal/FuseFace.lhs --- a/HFusion/Internal/FuseFace.lhs +++ b/HFusion/Internal/FuseFace.lhs @@ -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) diff --git a/HFusion/Internal/HsPrec.hs b/HFusion/Internal/HsPrec.hs --- a/HFusion/Internal/HsPrec.hs +++ b/HFusion/Internal/HsPrec.hs @@ -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) diff --git a/HFusion/Internal/HsPretty.hs b/HFusion/Internal/HsPretty.hs --- a/HFusion/Internal/HsPretty.hs +++ b/HFusion/Internal/HsPretty.hs @@ -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 diff --git a/HFusion/Internal/HsSyn.hs b/HFusion/Internal/HsSyn.hs --- a/HFusion/Internal/HsSyn.hs +++ b/HFusion/Internal/HsSyn.hs @@ -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 diff --git a/HFusion/Internal/HyloFace.lhs b/HFusion/Internal/HyloFace.lhs --- a/HFusion/Internal/HyloFace.lhs +++ b/HFusion/Internal/HyloFace.lhs @@ -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 diff --git a/HFusion/Internal/HyloRep.lhs b/HFusion/Internal/HyloRep.lhs --- a/HFusion/Internal/HyloRep.lhs +++ b/HFusion/Internal/HyloRep.lhs @@ -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 diff --git a/HFusion/Internal/Inline.lhs b/HFusion/Internal/Inline.lhs --- a/HFusion/Internal/Inline.lhs +++ b/HFusion/Internal/Inline.lhs @@ -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 diff --git a/HFusion/Internal/Messages.lhs b/HFusion/Internal/Messages.lhs --- a/HFusion/Internal/Messages.lhs +++ b/HFusion/Internal/Messages.lhs @@ -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 diff --git a/HFusion/Internal/Parsing/HyloContext.lhs b/HFusion/Internal/Parsing/HyloContext.lhs --- a/HFusion/Internal/Parsing/HyloContext.lhs +++ b/HFusion/Internal/Parsing/HyloContext.lhs @@ -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 diff --git a/HFusion/Internal/Parsing/HyloParser.lhs b/HFusion/Internal/Parsing/HyloParser.lhs --- a/HFusion/Internal/Parsing/HyloParser.lhs +++ b/HFusion/Internal/Parsing/HyloParser.lhs @@ -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,[]) diff --git a/HFusion/Internal/Parsing/Translator.lhs b/HFusion/Internal/Parsing/Translator.lhs --- a/HFusion/Internal/Parsing/Translator.lhs +++ b/HFusion/Internal/Parsing/Translator.lhs @@ -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." diff --git a/HFusion/Internal/RenVars.lhs b/HFusion/Internal/RenVars.lhs --- a/HFusion/Internal/RenVars.lhs +++ b/HFusion/Internal/RenVars.lhs @@ -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) diff --git a/HFusion/Internal/ShowHyloRep.hs b/HFusion/Internal/ShowHyloRep.hs new file mode 100644 --- /dev/null +++ b/HFusion/Internal/ShowHyloRep.hs @@ -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. + +-} + + diff --git a/HFusion/Internal/Utils.lhs b/HFusion/Internal/Utils.lhs --- a/HFusion/Internal/Utils.lhs +++ b/HFusion/Internal/Utils.lhs @@ -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 diff --git a/hfusion.cabal b/hfusion.cabal --- a/hfusion.cabal +++ b/hfusion.cabal @@ -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