SepList.hs

{-# LANGUAGE DeriveFoldable #-}
module Textual.SepList
    (
     SepList,
     sepList,
     slItems
    ) where

import Lawless
import Data.Textual
import Text.Printer (hsep)
import Data.Binary
import Data.List.NonEmpty
import Data.Foldable (Foldable)
import Data.Binary.Get
import Control.Monad.Fail

type SepList a = SepList' (NonEmpty a)

sepList ∷ ∀ a. (Ord a, Eq a, Binary a, Printable a) ⇒ a → SepList a
sepList a = SepList' $ a :| []

-- | A serializable printable separated list.
data SepList' a where
  SepList' ∷ ∀ a. (Ord a, Eq a, Binary a, Printable a) ⇒ NonEmpty a → SepList' (NonEmpty a)

deriving instance Foldable SepList'
deriving instance Eq (SepList a)
deriving instance Ord (SepList a)

slItems ∷ Lens' (SepList' (NonEmpty a)) (NonEmpty a)
slItems = lens (\(SepList' i) → i) (\(SepList' _) j → SepList' j)

instance (Ord a) ⇒ Semigroup (SepList' (NonEmpty a)) where
  a <> b = a & slItems .~ ((a ^. slItems) <> (b ^. slItems))

instance (Ord a, Binary a, Printable a) ⇒ Binary (SepList' (NonEmpty a)) where
  put = putList ∘ toList ∘ view slItems
  get = label "SepList'" $ do
    (nonEmpty <$> get) >>= \case
      Nothing → fail "Encountered an empty SepList'"
      Just l → return ∘ SepList' $ l

instance (Printable a) ⇒ Printable (SepList' (NonEmpty a)) where
  print = hsep ∘ over traversed print ∘ view slItems

instance (Printable a)⇒ Show (SepList a) where
  show = toString