-- Please, see the file LICENSE for copyright and license information.

% -----------------------------------------------------------------------------
% $Id: FuseFace.lhs,v 1.32 2006/06/21 17:04:41 fdomin Exp $
%
%  Se presenta aqui la interfaz del tipo HyloT que representa hilomorfimos de
% cualquier tipo.
%
% -----------------------------------------------------------------------------

> module HFusion.Internal.FuseFace(
>       fusionar, 
>       fusionar', 
>       fusionarTau, 
>       fusionarSigma, 
>       getCata, 
>       getAna, 
>       HyloT,
>       showHT, 
>       showHTRep, 
>       deriveHylo,
>       inline,
>       getConstantArgCount,
>       getConstantArgPos,
>       getNames,
>       renameHT,
>       WrapHT(..),WrapHA(..)
>      )
>    where

> import HFusion.Internal.HyloRep
> import HFusion.Internal.Parsing.HyloContext
> import qualified HFusion.Internal.FunctorRep as F
> import qualified HFusion.Internal.Inline as I
> import 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
> import HFusion.Internal.Utils
> import HFusion.Internal.Messages

 import Debug.Trace

 sss s v = trace (s++": "++show v) v

> data HyloT = HTp (HA Phii)
>            | HTi (HA InF)
>            | HTt (HA Tau)

> showHT :: HyloT -> VarGenState String
> showHT h = do i<-get;return$ foldHT (show' i False) (show' i False) (show' i True) h
>   where show' i t h=foldHA (show'' i t) (show'' i t) (show'' i t) h
>         show'' i t hss@(h:hs) = (names ++)$ concat $ (I.showHylo t i h :) $ 
>                                 map ("\n------------------------------\n"++)$ map (I.showHylo t i) hs
>            where names=tuple (map getName hss)
>                  tuple [] = "()"
>                  tuple (n:ns) = '(': show n ++ concat (map ((',':).show) ns) ++ ") =\n"
>         show'' _ _ _ = ""

> 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 _ _ (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 _ _ (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
> instance WrapHA Psi where
>  wrapHA h = HAp h
> instance WrapHA OutF where
>  wrapHA h = HAo h
> instance WrapHA Sigma where
>  wrapHA h = HAs h
> class WrapHT a where
>  wrapHT ::  HA a -> HyloT
> instance WrapHT Term where
>  wrapHT = HTp
> instance WrapHT InF where
>  wrapHT = HTi
> instance WrapHT Tau where
>  wrapHT = HTt


> getNames :: HyloT -> [Variable]
> getNames = foldHT gn gn gn
>  where gn = foldHA (map getName) (map getName) (map getName)

> getConstantArgCount :: HyloT -> Int
> getConstantArgCount = length . foldHT gn gn gn
>  where gn = head . foldHA (map (getConstantArgs.getContext)) (map (getConstantArgs.getContext)) (map (getConstantArgs.getContext))

> getRecArgCount :: HyloT -> Int -> Int
> getRecArgCount h i = foldHT gn gn gn h
>  where gn = (!!i) . foldHA (map getRecArgs) (map getRecArgs) (map getRecArgs)
>        getRecArgs = (\(bvs,_,_)->length bvs) . getCoalgebra

> getConstantArgPos :: HyloT -> Maybe [Int]
> getConstantArgPos = foldHT gn gn gn
>  where gn = head . foldHA (map (getCntArgPos.getContext)) (map (getCntArgPos.getContext)) (map (getCntArgPos.getContext))


> renameHT ::  HyloT -> HyloT -> FusionState (HyloT,HyloT)
> renameHT h1 h2 = foldHT (renh1 h2) (renh1 h2) (renh1 h2) h1
>   where renh1 h2 h1 = foldHA (ren h2) (ren h2) (ren h2) h1
>         ren h2 h1 = foldHT (renh2 h1) (renh2 h1) (renh2 h1) h2
>         renh2 h1 h2 = foldHA (ren' h1) (ren' h1) (ren' h1) h2
>         ren' [h1] [h2] = do (h1',h2')<-lift (renameVariables h1 h2 [])
>                             return (wrapHT.wrapHA$ [h1'],wrapHT.wrapHA$ [h2'])
>         ren' _ _ = error "Mutual recursion not handled."

> deriveHylo :: [Def] -> FusionState HyloT
> deriveHylo dfs = let (ctxs,vs,ts)=unzip3$ map (\(ctx,Defvalue v t)-> (ctx,v,t))$ extractContext$ dfs
>                   in buildHylo vs ts >>= (return.wrapHT.wrapHA.zipWith setContext ctxs)


> fusionar :: [Variable] -> HyloT -> Int -> Int -> HyloT -> Int -> FusionState (Int,[(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
>             h2' <- lift (inline h2) >>= deriveHylo
>             fusionar' names h1' ih1 (ia h1' ih1) h2' ih2 
>   where ia'' = maybe (ia'-getConstantArgCount h1) (length.([0..ia'-1]\\))$ getConstantArgPos h1
>         ia h1 ih1 = max 0 (min (getRecArgCount h1 ih1-1) ia'')

> -- | 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
>        errorTau _ = throwError NotTau
>        fuseCata h2 h1 = foldHT (fuseCataHylo h1) (fuseCataAna h1) errorTau h2
>        fusePsi h2 h1 = foldHT (fusePsiPhii h1) (fuseHyloAna h1) errorTau h2
>        fuseSigma h2 h1 = foldHT (fuseSigmaPhii h1) (fuseSigmaAna h1) errorTau h2
>        fuseCataHylo h1 h2 = let f h2 i2 = fusionarOutF names h1 ih1 h2 i2
>                              in foldHA f f f h2 ih2
>        fuseCataAna h1 h2 = let f h2 i2 = F.fusionarSimple h1 ih1 h2 i2
>                                            >>=  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
>        fuseHyloAna h1 h2 = let f h1=fusionarInF names h1 ih1 ia
>                             in foldHA (f h1) (f h1) (f h1) h2 ih2
>        fuseSigmaAna h1 h2 = let f h1 h2=F.fusionarSigma h1 ih1 ia h2 ih2 >>= wrapHylos
>                              in foldHA (f h1) (f h1) (f h1) h2
>        fuseSigmaPhii h1 h2 = let f h1 h2 = do h2' <- mapM (F.getAna h2) h2
>                                               F.fusionarSigma h1 ih1 ia h2' ih2 >>= wrapHylos
>                              in foldHA (f h1) (f h1) (f h1) h2 
>        wrapHylos (m,r,h) = do vs<-sequence $ replicate (length h-length names) (lift (getFreshVar "v"))
>                               return (m,r,wrapHT.wrapHA.zipWith setName (names++vs)$ h)

> 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= lift (F.fusionarTau h1 ih1 h2 ih2) >>= mapFusionIndexes >>= wrapHylos
>                              in foldHA (f h1) (f h1) (f h1) h2
>        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,[(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
>        errorh1 _ = throwError (Msg first_Hylo_Not_Psi_Form)
>        errorh2 _ = throwError (Msg second_Hylo_Not_InF_Form)
>        fuseAna h2 h1 = foldHT errorh2 (fuseHyloAna h1) errorh2 h2
>        fuseSigma h2 h1 = foldHT errorh2 (fuseSigmaAna h1) errorh2 h2
>        fuseSigmaAna h1 h2 = let f h1 = F.fusionarSigma h1 ih1 ia
>                             in wrapHylos$ foldHA (f h1) (f h1) (f h1) h2 ih2
>        fuseHyloAna h1 h2 = let f h1 h2 ih2 = do h1'<-F.psiToSigma h1
>                                                 F.fusionarSigma h1' ih1 ia h2 ih2
>                             in wrapHylos$ foldHA (f h1) (f h1) (f h1) h2 ih2
>        wrapHylos res = do (m,r,h)<-res
>                           vs<-sequence $ replicate (length h-length names) (lift$ getFreshVar "v")
>                           return (m,r,wrapHT.wrapHA.zipWith setName (names++vs)$ h)


> getCata :: HyloT -> FusionState HyloT
> getCata h = foldHT f f f h
>  where f h=foldHA f' (return.wrapHT.wrapHA) (\_->throwError NotInF) h
>        f' h = do h'<-mapM (F.getCata h) h
>                  return.wrapHT.wrapHA$ h'

> getAna :: HyloT -> FusionState HyloT
> getAna h = foldHT f (return.wrapHT) (\_->throwError NotInF) h
>  where f h=foldHA f' f' f' h
>        f' h = do h'<-mapM (F.getAna h) h
>                  return.wrapHT.wrapHA$ h'

> wrapHylos :: (WrapHT a,WrapHA b) => [Variable] 
>                                     -> (Int,[(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)

> fusionarAmbos names h1 ih1 ia h2 ih2 = catchError (mapM (F.getCata h1) h1 >>= okCata)  badCata
>  where
>    okCata h1' = catchError (mapM (F.getAna h2) h2 >>= okcataana h1') (okCataBadAna h1')
>    badCata _ = catchError (mapM (F.getAna h2) h2 >>= badCataOkAna ) badCataBadAna 
>    okcataana h1' h2'= catchError (do h1''<-F.psiToSigma h1
>                                      res<-F.fusionarSigma h1'' ih1 ia h2' ih2
>                                      oksigma h1' h2' res)
>                                  (badsigma h1' h2')
>    oksigma h1' h2' 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 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
>                          F.fusionarSigma h1'' ih1 ia h2' ih2 >>= wrapHylos names
>    badCataBadAna _ = throwError (Msg couldnt_Fuse_Hylos)
>    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 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,[(Int,[(Int,Int)])],HyloT)
> fusionarOutF names h1 ih1 h2 ih2 = catchError (mapM (F.getAna h2) h2 >>= okcataana) okCataBadAna
>  where
>    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 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)

> fusionarInF names h1 ih1 ia h2 ih2 = catchError (mapM (F.getCata h1) h1 >>= okCata) badCata
>  where
>    okCata h1' = catchError (do h1''<-F.psiToSigma h1
>                                res<-F.fusionarSigma h1'' ih1 ia h2 ih2
>                                oksigma h1' res)
>                            (badsigma h1')
>    oksigma h1' r2@(m2,_,_)=
>                  do r1@(m1,_,_)<-F.fusionarSimple h1' ih1 h2 ih2 >>= mapFusionIndexes
>                     if m1>=m2
>                       then wrapHylos names r1
>                       else wrapHylos names r2
>    badCata _ = catchError (do h1''<- F.psiToSigma h1
>                               F.fusionarSigma h1'' ih1 ia h2 ih2 >>= wrapHylos names)
>                           error
>    badsigma h1' _ = F.fusionarSimple h1' ih1 h2 ih2 >>= mapFusionIndexes >>= wrapHylos names
>    error _ = throwError (Msg couldnt_Fuse_Hylos)


===================================================================================================================================
inline
===================================================================================================================================

> inline :: HyloT -> VarGenState [Def]
> inline hylo =
>       foldHT f f f hylo
>  where f h = foldHA g g g h
>        g h = do dfs<-mapM (I.inline h) h
>                 return (mergeContext (zip (map getContext h) dfs))

 inline :: HyloT -> VarGenState [Def]
 inline hylo =
       foldHT (trace "phi" f) (trace "inf" f) (trace "tau" f) hylo
  where f h = foldHA (trace "psi" g) (trace "outF" g) (trace "sigma" g) h
        g h = do dfs<-mapM (I.inline h) h
                 return (mergeContext (zip (map getContext h) dfs))