{-# LANGUAGE RankNTypes #-}
module Text.Cassette.Lead where

import Text.Cassette.Prim


-- | The type of binary leads, parameterized by the type of the left operand,
-- the right operand, and the type of the result.
type UnL a b =
  forall r r'. K7 (C (b -> r))  (C (a -> r))
                  (C (b -> r')) (C (a -> r'))

-- | The type of binary leads, parameterized by the type of the left operand,
-- the right operand, and the type of the result.
type BinL a b c =
  forall r r'. K7 (C (c -> r))  (C (b -> a -> r))
                  (C (c -> r')) (C (b -> a -> r'))

-- | Lift a pair of symmetric functions to a lead.
liftL :: Sym a b -> UnL a b
liftL (Sym (K7 f f')) =
  K7 (\k k' s x -> k (\s _ -> k' s x) s (f x))
     (\k k' s y -> k (\s _ -> k' s y) s (f' y))

-- | Iterates a one step construction function (resp. deconstruction)
-- function, i.e. a lead, thus obtaining a right fold (resp. unfold). The
-- resulting lead is a catamorphism on one side and an anamorpism on the
-- other, hence the name. The type of this function is the same as that of
-- 'foldr', lifted to cassettes.
catanar :: BinL a b b -> BinL b [a] b
catanar (K7 f f') = K7 g g' where
  g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z
  g k k' s xs@(x:xs') z =
    g (\k' s z -> f k (\s _ _ -> k' s z) s z x) (\s _ _ -> k' s xs z) s xs' z
  g' k k' s z =
    f' (\k' s z x -> g' (\k' s xs' z -> k k' s (x:xs') z) (\s _ -> k' s z x) s z)
       (\s _ -> k (\s _ _ -> k' s z) s [] z) s z

-- | Iterates a one step construction function (resp. deconstruction)
-- function, i.e. a lead, thus obtaining a left fold (resp. unfold). The
-- resulting lead is a catamorphism on one side and an anamorpism on the
-- other, hence the name. The type of this function is the same as that of
-- 'foldl', lifted to cassettes.
catanal :: BinL a b a -> BinL a [b] a
catanal (K7 f f') = K7 g (g' []) where
  g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z
  g k k' s xs@(x:xs') z =
    f (\k' s z -> g k (\s _ _ -> k' s z) s xs' z) (\s _ _ -> k' s xs z) s x z
  g' xs' k k' s z =
    f' (\k' s x z -> g' (x:xs') k (\s _ -> k' s x z) s z) (\s _ -> k (\s _ _ -> k' s z) s xs' z) s z

consL :: BinL a [a] [a]
consL = K7 (\k k' s xs' x -> k (\s _ -> k' s xs' x) s (x:xs'))
           (\k k' s xs -> case xs of
               x:xs' -> k (\s _ _ -> k' s xs) s xs' x
               _ -> k' s xs)

nilL :: PP [a]
nilL = shift [] nothing

justL :: UnL a (Maybe a)
justL = K7 (\k k' s x -> k (\s _ -> k' s x) s (Just x))
           (\k k' s mb -> maybe (k' s mb) (k (\s _ -> k' s mb) s) mb)

nothingL :: PP (Maybe a)
nothingL = shift Nothing nothing

pairL :: BinL a b (a, b)
pairL = K7 (\k k' s x2 x1 -> k (\s _ -> k' s x2 x1) s (x1, x2))
           (\k k' s t@(x1, x2) -> k (\s _ _ -> k' s t) s x2 x1)

tripleL :: K7 (C ((a,b,c) -> r))  (C (c -> b -> a -> r))
              (C ((a,b,c) -> r')) (C (c -> b -> a -> r'))
tripleL = K7 (\k k' s x3 x2 x1 -> k (\s _ -> k' s x3 x2 x1) s (x1, x2, x3))
             (\k k' s t@(x1, x2, x3) -> k (\s _ _ _ -> k' s t) s x3 x2 x1)

quadrupleL :: K7 (C ((a,b,c,d) -> r))  (C (d -> c -> b -> a -> r))
                 (C ((a,b,c,d) -> r')) (C (d -> c -> b -> a -> r'))
quadrupleL = K7 (\k k' s x4 x3 x2 x1 -> k (\s _ -> k' s x4 x3 x2 x1) s (x1, x2, x3, x4))
                (\k k' s t@(x1, x2, x3, x4) -> k (\s _ _ _ _ -> k' s t) s x4 x3 x2 x1)