Is it possible to make GHC optimize (deforest) generic functions such as catamorphisms?

Main.dump-simpl

Result size = 325

Main.$fFunctorTreeT_$cfmap
  :: forall a_ajJ b_ajK.
     (a_ajJ -> b_ajK) -> Main.TreeT a_ajJ -> Main.TreeT b_ajK
[GblId,
 Arity=2,
 Caf=NoCafRefs,
 Str=DmdType LS,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [120 30] 70 130}]
Main.$fFunctorTreeT_$cfmap =
  \ (@ a_axE)
    (@ b_axF)
    (f_aam :: a_axE -> b_axF)
    (ds_dyQ :: Main.TreeT a_axE) ->
    case ds_dyQ of _ {
      Main.Leaf -> Main.Leaf @ b_axF;
      Main.Tree l_aao r_aap ->
        Main.Tree @ b_axF (f_aam l_aao) (f_aam r_aap)
    }

Main.$fFunctorTreeT_$c<$
  :: forall a_ayF b_ayG.
     a_ayF -> Main.TreeT b_ayG -> Main.TreeT a_ayF
[GblId,
 Arity=2,
 Caf=NoCafRefs,
 Str=DmdType LS,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.$fFunctorTreeT_$c<$ =
  \ (@ a_az9)
    (@ b_aza)
    (x_azb :: a_az9)
    (eta_B1 :: Main.TreeT b_aza) ->
    case eta_B1 of _ {
      Main.Leaf -> Main.Leaf @ a_az9;
      Main.Tree l_aao r_aap -> Main.Tree @ a_az9 x_azb x_azb
    }

Main.$fFunctorTreeT [InlPrag=[ALWAYS] CONLIKE]
  :: GHC.Base.Functor Main.TreeT
[GblId[DFunId],
 Caf=NoCafRefs,
 Str=DmdType m,
 Unf=DFun(arity=0) GHC.Base.D:Functor [Main.$fFunctorTreeT_$cfmap,
                                       Main.$fFunctorTreeT_$c<$]]
Main.$fFunctorTreeT =
  GHC.Base.D:Functor
    @ Main.TreeT Main.$fFunctorTreeT_$cfmap Main.$fFunctorTreeT_$c<$

Main.unfix1
  :: forall (f_aay :: * -> *). Main.Fix f_aay -> Main.Fix f_aay
[GblId,
 Arity=1,
 Caf=NoCafRefs,
 Str=DmdType S,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.unfix1 =
  \ (@ f_aay::* -> *) (ds_dyO :: Main.Fix f_aay) -> ds_dyO

Main.unfix
  :: forall (f_aab :: * -> *).
     Main.Fix f_aab -> f_aab (Main.Fix f_aab)
[GblId[[RecSel]],
 Arity=1,
 Caf=NoCafRefs,
 Str=DmdType S,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.unfix =
  Main.unfix1
  `cast` (forall (f_aay :: * -> *).
          <Main.Fix f_aay> -> Main.NTCo:Fix <f_aay>
          :: (forall (f_aay :: * -> *). Main.Fix f_aay -> Main.Fix f_aay)
               ~#
             (forall (f_aay :: * -> *).
              Main.Fix f_aay -> f_aay (Main.Fix f_aay)))

Main.catam_$scatam [InlPrag=INLINE (sat-args=1)]
  :: forall a_ajC.
     (Main.TreeT a_ajC -> a_ajC) -> Main.Fix Main.TreeT -> a_ajC
[GblId,
 Arity=2,
 Caf=NoCafRefs,
 Str=DmdType C(S)L,
 Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
         Tmpl= \ (@ a_ajC)
                 (eta_B1 [Occ=OnceL!] :: Main.TreeT a_ajC -> a_ajC) ->
                 letrec {
                   g_sAi [Occ=LoopBreaker] :: Main.Fix Main.TreeT -> a_ajC
                   [LclId, Arity=1]
                   g_sAi =
                     \ (x_az2 [Occ=Once] :: Main.Fix Main.TreeT) ->
                       eta_B1
                         (Main.$fFunctorTreeT_$cfmap
                            @ (Main.Fix Main.TreeT)
                            @ a_ajC
                            g_sAi
                            (Main.unfix @ Main.TreeT x_az2)); } in
                 g_sAi}]
Main.catam_$scatam =
  \ (@ a_ajC)
    (eta_B1 :: Main.TreeT a_ajC -> a_ajC)
    (eta1_X2 :: Main.Fix Main.TreeT) ->
    eta_B1
      (letrec {
         a_sAg [Occ=LoopBreaker]
           :: Main.TreeT (Main.Fix Main.TreeT) -> Main.TreeT a_ajC
         [LclId, Arity=1, Str=DmdType S]
         a_sAg =
           \ (ds_dyQ :: Main.TreeT (Main.Fix Main.TreeT)) ->
             case ds_dyQ of _ {
               Main.Leaf -> Main.Leaf @ a_ajC;
               Main.Tree l_aao r_aap ->
                 Main.Tree
                   @ a_ajC
                   (eta_B1
                      (a_sAg
                         (l_aao
                          `cast` (Main.NTCo:Fix <Main.TreeT>
                                  :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)))))
                   (eta_B1
                      (a_sAg
                         (r_aap
                          `cast` (Main.NTCo:Fix <Main.TreeT>
                                  :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)))))
             }; } in
       a_sAg
         (eta1_X2
          `cast` (Main.NTCo:Fix <Main.TreeT>
                  :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))))

Main.catam [InlPrag=INLINE (sat-args=1)]
  :: forall (f_aad :: * -> *) a_aae.
     GHC.Base.Functor f_aad =>
     (f_aad a_aae -> a_aae) -> Main.Fix f_aad -> a_aae
[GblId,
 Arity=2,
 Caf=NoCafRefs,
 Str=DmdType LL,
 Unf=Unf{Src=InlineStable, TopLvl=True, Arity=2, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
         Tmpl= \ (@ f_ajB::* -> *)
                 (@ a_ajC)
                 ($dFunctor_ajD [Occ=Once] :: GHC.Base.Functor f_ajB)
                 (f_aaf [Occ=OnceL!] :: f_ajB a_ajC -> a_ajC) ->
                 letrec {
                   f1_Xzl [Occ=OnceL!] :: f_ajB (Main.Fix f_ajB) -> f_ajB a_ajC
                   [LclId]
                   f1_Xzl =
                     GHC.Base.fmap
                       @ f_ajB $dFunctor_ajD @ (Main.Fix f_ajB) @ a_ajC g_Xk8;
                   g_Xk8 [Occ=LoopBreaker] :: Main.Fix f_ajB -> a_ajC
                   [LclId, Arity=1]
                   g_Xk8 =
                     \ (x_Xzr [Occ=Once] :: Main.Fix f_ajB) ->
                       f_aaf (f1_Xzl (Main.unfix @ f_ajB x_Xzr)); } in
                 g_Xk8}]
Main.catam =
  \ (@ f_ajB::* -> *)
    (@ a_ajC)
    ($dFunctor_ajD :: GHC.Base.Functor f_ajB)
    (eta_B1 :: f_ajB a_ajC -> a_ajC) ->
    letrec {
      a_sAa :: f_ajB (Main.Fix f_ajB) -> f_ajB a_ajC
      [LclId, Str=DmdType]
      a_sAa =
        GHC.Base.fmap
          @ f_ajB $dFunctor_ajD @ (Main.Fix f_ajB) @ a_ajC g_sAc;
      g_sAc [Occ=LoopBreaker] :: Main.Fix f_ajB -> a_ajC
      [LclId, Arity=1, Str=DmdType L]
      g_sAc =
        \ (x_az2 :: Main.Fix f_ajB) ->
          eta_B1
            (a_sAa
               (x_az2
                `cast` (Main.NTCo:Fix <f_ajB>
                        :: Main.Fix f_ajB ~# f_ajB (Main.Fix f_ajB)))); } in
    g_sAc

Rec {
Main.$wdepth1 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth1 =
  \ (w_s1RI :: Main.Tree) ->
    case w_s1RI
         `cast` (Main.NTCo:Fix <Main.TreeT>
                 :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
    of _ {
      Main.Leaf -> 0;
      Main.Tree l_aao r_aap ->
        case Main.$wdepth1 l_aao of ww_s1RL { __DEFAULT ->
        case Main.$wdepth1 r_aap of ww1_X1Sn { __DEFAULT ->
        case GHC.Prim.<=# ww_s1RL ww1_X1Sn of _ {
          GHC.Types.False -> ww_s1RL;
          GHC.Types.True -> ww1_X1Sn
        }
        }
        }
    }
end Rec }

Main.depth1 [InlPrag=INLINE[0]] :: Main.Tree -> GHC.Types.Int
[GblId,
 Arity=1,
 Caf=NoCafRefs,
 Str=DmdType Sm,
 Unf=Unf{Src=Worker=Main.$wdepth1, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
         Tmpl= \ (w_s1RI [Occ=Once] :: Main.Tree) ->
                 case Main.$wdepth1 w_s1RI of ww_s1RL { __DEFAULT ->
                 GHC.Types.I# ww_s1RL
                 }}]
Main.depth1 =
  \ (w_s1RI :: Main.Tree) ->
    case Main.$wdepth1 w_s1RI of ww_s1RL { __DEFAULT ->
    GHC.Types.I# ww_s1RL
    }

Rec {
Main.$wdepth2 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth2 =
  \ (w_s1RO :: Main.Tree) ->
    case w_s1RO
         `cast` (Main.NTCo:Fix <Main.TreeT>
                 :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
    of _ {
      Main.Leaf -> 0;
      Main.Tree l_aak r_aal ->
        case Main.$wdepth2 l_aak of ww_s1RR { __DEFAULT ->
        case Main.$wdepth2 r_aal of ww1_X1Sw { __DEFAULT ->
        case GHC.Prim.<=# ww_s1RR ww1_X1Sw of _ {
          GHC.Types.False -> ww_s1RR;
          GHC.Types.True -> ww1_X1Sw
        }
        }
        }
    }
end Rec }

Main.depth2 [InlPrag=INLINE[0]] :: Main.Tree -> GHC.Types.Int
[GblId,
 Arity=1,
 Caf=NoCafRefs,
 Str=DmdType Sm,
 Unf=Unf{Src=Worker=Main.$wdepth2, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
         Tmpl= \ (w_s1RO [Occ=Once] :: Main.Tree) ->
                 case Main.$wdepth2 w_s1RO of ww_s1RR { __DEFAULT ->
                 GHC.Types.I# ww_s1RR
                 }}]
Main.depth2 =
  \ (w_s1RO :: Main.Tree) ->
    case Main.$wdepth2 w_s1RO of ww_s1RR { __DEFAULT ->
    GHC.Types.I# ww_s1RR
    }

Main.main2 :: GHC.Base.String
[GblId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, Cheap=False, Expandable=False,
         Guidance=IF_ARGS [] 415 480}]
Main.main2 =
  case Main.$wdepth2
         ((Main.Leaf @ (Main.Fix Main.TreeT))
          `cast` (Sym (Main.NTCo:Fix <Main.TreeT>)
                  :: Main.TreeT (Main.Fix Main.TreeT) ~# Main.Fix Main.TreeT))
  of ww_s1RR { __DEFAULT ->
  case GHC.Prim.<# ww_s1RR 0 of _ {
    GHC.Types.False ->
      case GHC.Prim.<# ww_s1RR 0 of _ {
        GHC.Types.False ->
          GHC.Show.shows_itos' ww_s1RR (GHC.Types.[] @ GHC.Types.Char);
        GHC.Types.True ->
          case ww_s1RR of wild2_a1S9 {
            __DEFAULT ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   (GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
            (-2147483648) ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
          }
      };
    GHC.Types.True ->
      case GHC.Prim.<# ww_s1RR 0 of _ {
        GHC.Types.False ->
          GHC.Show.shows_itos' ww_s1RR (GHC.Types.[] @ GHC.Types.Char);
        GHC.Types.True ->
          case ww_s1RR of wild2_a1S9 {
            __DEFAULT ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   (GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
            (-2147483648) ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
          }
      }
  }
  }

Main.main3 :: GHC.Base.String
[GblId,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
         ConLike=False, Cheap=False, Expandable=False,
         Guidance=IF_ARGS [] 415 480}]
Main.main3 =
  case Main.$wdepth1
         ((Main.Leaf @ (Main.Fix Main.TreeT))
          `cast` (Sym (Main.NTCo:Fix <Main.TreeT>)
                  :: Main.TreeT (Main.Fix Main.TreeT) ~# Main.Fix Main.TreeT))
  of ww_s1RL { __DEFAULT ->
  case GHC.Prim.<# ww_s1RL 0 of _ {
    GHC.Types.False ->
      case GHC.Prim.<# ww_s1RL 0 of _ {
        GHC.Types.False ->
          GHC.Show.shows_itos' ww_s1RL (GHC.Types.[] @ GHC.Types.Char);
        GHC.Types.True ->
          case ww_s1RL of wild2_a1S9 {
            __DEFAULT ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   (GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
            (-2147483648) ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
          }
      };
    GHC.Types.True ->
      case GHC.Prim.<# ww_s1RL 0 of _ {
        GHC.Types.False ->
          GHC.Show.shows_itos' ww_s1RL (GHC.Types.[] @ GHC.Types.Char);
        GHC.Types.True ->
          case ww_s1RL of wild2_a1S9 {
            __DEFAULT ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   (GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
            (-2147483648) ->
              GHC.Types.:
                @ GHC.Types.Char
                GHC.Show.shows3
                (GHC.Show.shows_itos'
                   214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
          }
      }
  }
  }

Main.main1
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [0] 110 0}]
Main.main1 =
  \ (eta_B1 :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    case GHC.IO.Handle.Text.hPutStr2
           GHC.IO.Handle.FD.stdout Main.main3 GHC.Types.True eta_B1
    of _ { (# new_s_aUc, _ #) ->
    GHC.IO.Handle.Text.hPutStr2
      GHC.IO.Handle.FD.stdout Main.main2 GHC.Types.True new_s_aUc
    }

Main.main :: GHC.Types.IO ()
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.main =
  Main.main1
  `cast` (Sym (GHC.Types.NTCo:IO <()>)
          :: (GHC.Prim.State# GHC.Prim.RealWorld
              -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
               ~#
             GHC.Types.IO ())

Main.main4
  :: GHC.Prim.State# GHC.Prim.RealWorld
     -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=IF_ARGS [0] 30 0}]
Main.main4 =
  \ (eta_Xr :: GHC.Prim.State# GHC.Prim.RealWorld) ->
    GHC.TopHandler.runMainIO1
      @ ()
      (Main.main1
       `cast` (Sym (GHC.Types.NTCo:IO <()>)
               :: (GHC.Prim.State# GHC.Prim.RealWorld
                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
                    ~#
                  GHC.Types.IO ()))
      eta_Xr

:Main.main :: GHC.Types.IO ()
[GblId,
 Arity=1,
 Str=DmdType L,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
         ConLike=True, Cheap=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
:Main.main =
  Main.main4
  `cast` (Sym (GHC.Types.NTCo:IO <()>)
          :: (GHC.Prim.State# GHC.Prim.RealWorld
              -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
               ~#
             GHC.Types.IO ())


------ Local rules for imported ids --------
"SPEC Main.catam [Main.TreeT]" [ALWAYS]
    forall (@ a_ajC) ($dFunctor_sAv :: GHC.Base.Functor Main.TreeT).
      Main.catam @ Main.TreeT @ a_ajC $dFunctor_sAv
      = Main.catam_$scatam @ a_ajC

Main.hs

-- Is it possible to make GHC optimize (deforest) generic functions such as catamorphisms?
-- http://stackoverflow.com/q/13099203/1333025

module Main where

data TreeT r = Leaf | Tree r r
instance Functor TreeT where
    fmap f Leaf         = Leaf
    fmap f (Tree l r)   = Tree (f l) (f r)

newtype Fix f = Fix { unfix :: f (Fix f) }

type Tree = Fix TreeT

{-# INLINE catam #-}
catam :: (Functor f) => (f a -> a) -> (Fix f -> a)
catam f = let g = f . fmap g . unfix
          in g

depth1 :: Tree -> Int
depth1 = catam g
  where
    g Leaf       = 0
    g (Tree l r) = max l r

depth2 :: Tree -> Int
depth2 (Fix Leaf) = 0
depth2 (Fix (Tree l r)) = max (depth2 l) (depth2 r)

main :: IO ()
main = do
    print $ depth1 (Fix Leaf)
    print $ depth2 (Fix Leaf)