{-# LANGUAGE MultiParamTypeClasses, GADTs, DeriveFunctor, ScopedTypeVariables #-}

--------------------------------------------------------------------------------
-- Left join implemented for lists

class HOrd a b where
  hcmp :: a -> b -> Ordering

instance Ord a => HOrd (a, b) (a, c) where
  hcmp (x, _) (y, _) = compare x y

leftJoin :: HOrd a b => [a] -> [b] -> [(a, Maybe b)]
leftJoin []     _  = []
leftJoin (x:xs) ys = (x, y'):leftJoin xs ys' where
  (y', ys')          = findLEQ ys
  findLEQ []         = (Nothing, [])
  findLEQ (y:ys)
    | hcmp x y == GT = findLEQ ys
    | hcmp x y == LT = (Nothing, y:ys)
    | hcmp x y == EQ = (Just y,  y:ys)

leftJoinWith :: HOrd a b => (a -> Maybe b -> c) -> [a] -> [b] -> [c]
leftJoinWith f xs ys = uncurry f <$> leftJoin xs ys

--------------------------------------------------------------------------------
-- "Unfold" based streams

data ListF r a = NilF | ConsF a r deriving(Functor)
type Step s a = s -> ListF s a

data Stream a where
  Stream :: Step s a -> s -> Stream a

instance Functor Stream where
  fmap g (Stream f s0) = Stream (\s -> g <$> f s) s0

list :: [a] -> Stream a
list = Stream f where
  f []     = NilF
  f (x:xs) = ConsF x xs

stream :: Stream a -> [a]
stream (Stream f s0) = go s0 where
  go s = case f s of
    NilF       -> []
    ConsF x s' -> x:go s'

--------------------------------------------------------------------------------
-- Left join implemented for streams

leftJoinStep :: HOrd a b => Step l a -> Step r b -> Step (l, r) (a, Maybe b)
leftJoinStep lstep rstep = \(l, r0) -> case lstep l of
  NilF       -> NilF
  ConsF x l' ->
    let
      (y', r')  = findLEQ r0
      findLEQ r = case rstep r of
        NilF               -> (Nothing, r)
        ConsF y r'
          | hcmp x y == GT -> findLEQ r'
          | hcmp x y == LT -> (Nothing, r)
          | hcmp x y == EQ -> (Just y,  r)
    in
      ConsF (x, y') (l', r')

leftJoinS :: HOrd a b => Stream a -> Stream b -> Stream (a, Maybe b)
leftJoinS (Stream lf l0) (Stream rf r0) = Stream (leftJoinStep lf rf) (l0, r0)

leftJoinWith' :: HOrd a b => (a -> Maybe b -> c) -> [a] -> [b] -> [c]
leftJoinWith' f xs ys = stream (uncurry f <$> leftJoinS (list xs) (list ys))

--------------------------------------------------------------------------------
-- Expected output:
-- ["Aa","Bb","B'b","C","Dd"]

main :: IO ()
main = do print $ leftJoinWith combine xs ys
          print $ leftJoinWith combine xs ys
  where
    xs :: [(Int, String)]
    ys :: [(Int, Char)]

    xs = [(0,"A"), (1,"B"), (1,"B'"), (2,"C"), (3,"D")         ]
    ys = [(0,'a'), (1,'b'),                    (3,'d'), (4,'e')]

    combine (_, l) Nothing       = l
    combine (_, l) (Just (_, r)) = l ++ [r]