How to extract common form...?

JoinList.hs

module JoinList where

import Sized
import Data.Monoid ((<>))

data JoinList m a = Empty
                  | Single m a
                  | Append m (JoinList m a) (JoinList m a)
                  deriving (Eq, Show)

(+++) :: Monoid m => JoinList m a -> JoinList m a -> JoinList m a
j +++ k = Append (tag j <> tag k) j k

tag :: Monoid m => JoinList m a -> m
tag Empty          = mempty
tag (Single t _)   = t
tag (Append t _ _) = t

foldJ :: c -> (b -> a -> c) -> (b -> c -> c -> c) -> JoinList b a -> c
foldJ e _ _ Empty          = e
foldJ _ s _ (Single t x)   = s t x
foldJ e s a (Append t l r) = a t (foldJ e s a l) (foldJ e s a r)

indexJ :: (Sized b, Monoid b) => Int -> JoinList b a -> Maybe a
indexJ _  Empty         = Nothing
indexJ i (Single _ x)
   | i >  0             = Nothing
   | i == 0             = Just x
   | otherwise          = Nothing
indexJ i (Append t l r)
   | i >= wholeSize     = Nothing
   | i >  leftSize      = indexJ (i - leftSize) r
   | i == leftSize      = indexJ 0 r
   | i >  0             = indexJ i l
   | i == 0             = indexJ 0 l
   | otherwise          = Nothing
  where wholeSize = getSize . size $ t
        leftSize  = getSize . size $ tag l

dropJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
dropJ _  Empty            = Empty
dropJ i jl@(Single _ _)
   | i >  0               = Empty
   | i == 0               = jl
   | otherwise            = jl
dropJ i jl@(Append t l r)
   | i >= wholeSize       = Empty
   | i >  leftSize        = dropJ (i - leftSize) r
   | i == leftSize        = r
   | i >  0               = dropJ i l +++ r
   | i == 0               = jl
   | otherwise            = jl
  where wholeSize = getSize . size $ t
        leftSize  = getSize . size $ tag l

takeJ :: (Sized b, Monoid b) => Int -> JoinList b a -> JoinList b a
takeJ _ Empty             = Empty
takeJ i jl@(Single _ _)
   | i >  0               = jl
   | i == 0               = Empty
   | otherwise            = Empty
takeJ i jl@(Append t l r)
   | i >= wholeSize       = jl
   | i >  leftSize        = l +++ takeJ (i - leftSize) r
   | i == leftSize        = l
   | i >  0               = takeJ i l
   | i == 0               = Empty
   | otherwise            = Empty
  where wholeSize = getSize . size $ t
        leftSize  = getSize . size $ tag l

Half-brained attempt:

foldJ :: (Sized b, Monoid b) => c ->
         (a -> c) -> (a -> c) -> (a -> c) ->
         (Int -> JoinList b a -> c) ->
         (Int -> JoinList b a -> c) ->
         (Int -> JoinList b a -> c) ->
         (Int -> JoinList b a -> c) ->
         (Int -> JoinList b a -> c) ->
         (Int -> JoinList b a -> c) ->
         Int -> JoinList b a -> c
foldJ e _  _  _  _  _  _  _  _  _  _ Empty = e
foldJ _ sP s0 sN _  _  _  _  _  _  i (Single _ x)
 | i >  0    = sP x
 | i == 0    = s0 x
 | otherwise = sN x
foldJ _ _  _  _  a6 a5 a4 a3 a2 a1 i jl@(Append t l _)
   | i >= wholeSize = a6 i jl
   | i >  leftSize  = a5 i jl
   | i == leftSize  = a4 i jl
   | i >  0         = a3 i jl
   | i == 0         = a2 i jl
   | otherwise      = a1 i jl
  where wholeSize = getSize . size $ t
        leftSize  = getSize . size $ tag l