content: {-# language LambdaCase #-}
  {-# language TypeFamilies #-}
  {-# language PatternSynonyms #-}
  {-# language FlexibleContexts #-}
  {-# language FlexibleInstances #-}
  {-# language MultiParamTypeClasses #-}
  
  ---------------------------------------------------------------------------------
  -- |
  -- Copyright :  (c) Edward Kmett 2017-2018
  -- License   :  BSD-2-Clause OR Apache-2.0
  -- Maintainer:  Edward Kmett <ekmett@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable
  --
  ---------------------------------------------------------------------------------
  
  module Cat
    ( Cat
    , snocCat
    , singleton
    , null
    ) where
  
  import Control.Lens
  import Data.Default
  import Data.Function (on)
  import Data.List (unfoldr)
  import Data.Semigroup
  import GHC.Exts as Exts
  import Text.Read
  import Prelude hiding (null)
  
  import Relative
  import Queue (Queue, snocQ)
  import qualified Queue
  
  -- invariant, all recursive cat's are non-empty
  data Cat a = E | C a (Queue (Cat a))
  
  -- {-# complete E, (:<) #-}
  
  instance Default (Cat a) where
    def = E
  
  instance Relative a => Relative (Cat a) where
    rel _ E = E
    rel 0 xs = xs
    rel d (C a as) = C (rel d a) (rel d as)
    {-# inline rel #-}
  
  null :: Cat a -> Bool
  null E = True
  null _ = False
  {-# inline null #-}
  
  instance Relative a => Semigroup (Cat a) where
    xs <> E = xs
    E <> xs = xs
    C x xs <> ys = link x xs ys
    {-# inline (<>) #-}
  
  instance Relative a => Monoid (Cat a) where
    mempty = E
    mappend = (<>)
  
  link :: Relative a => a -> Queue (Cat a) -> Cat a -> Cat a
  link x q ys = C x (snocQ q ys)
  {-# inline link #-}
  
  -- O(1 + e) where e is the # of empty nodes in the queue
  linkAll :: Relative a => Queue (Cat a) -> Cat a
  linkAll q = case uncons q of
    Just (cat@(C a t), q')
      | Queue.null q' -> cat
      | otherwise -> link a t (linkAll q')
    Just (E, q') -> linkAll q' -- recursive case
    Nothing -> E
  
  instance AsEmpty (Cat a) where
    _Empty = prism (const E) $ \case
      E -> Right ()
      xs -> Left xs
  
  instance (Relative a, Relative b) => Cons (Cat a) (Cat b) a b where
    _Cons = prism kons unkons where
      kons (a, E) = C a def
      kons (a, ys) = link a def ys
      {-# inline conlike kons #-}
      unkons E = Left E
      unkons (C a q) = Right (a, linkAll q)
      {-# inline unkons #-}
  
  instance Relative a => IsList (Cat a) where
    type Item (Cat a) = a
    fromList = foldr cons E
    {-# inline fromList #-}
    toList = unfoldr uncons
    {-# inline toList #-}
  
  singleton :: a -> Cat a
  singleton a = C a def
  {-# inline conlike singleton #-}
  
  snocCat :: Relative a => Cat a -> a -> Cat a
  snocCat xs a = xs <> singleton a
  {-# inline snocCat #-}
  
  instance (Show a, Relative a) => Show (Cat a) where
    showsPrec d = showsPrec d . Exts.toList
  
  instance (Read a, Relative a) => Read (Cat a) where
    readPrec = Exts.fromList <$> readPrec
  
  instance (Eq a, Relative a) => Eq (Cat a) where
    (==) = (==) `on` Exts.toList
    {-# inline (==) #-}
  
  instance (Ord a, Relative a) => Ord (Cat a) where
    compare = compare `on` Exts.toList
    {-# inline compare #-}
  
  