{-# 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)