Semigroup on subsets of heterogeneous lists.

gistfile1.hs

{-# LANGUAGE EmptyDataDecls    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}

module Sublist (S, L, R, Sublist, sublistHead, sublistTail, fromSublist) where

import           Control.Applicative ((<|>))
import qualified Control.Lens        as L
import           Data.Maybe          (fromMaybe)
import           Data.Monoid         (Monoid (..))
import           Data.Semigroup      (Semigroup (..))

data S; data L; data R

data Sublist ts as where
  -- | Terminator
  SubN :: Sublist () ()
  -- | Merge using a Semigroup instance
  SubS :: Semigroup a => Maybe a -> Sublist ts as -> Sublist (S, ts) (a, as)
  -- | Merge preferring the left value
  SubL :: Maybe a -> Sublist ts as -> Sublist (L, ts) (a, as)
  -- | Merge preferring the right value
  SubR :: Maybe a -> Sublist ts as -> Sublist (R, ts) (a, as)

instance Semigroup (Sublist ts as) where
  SubN      <> SubN      = SubN
  SubS x xs <> SubS y ys = SubS (x <> y)  (xs <> ys)
  SubL x xs <> SubL y ys = SubL (x <|> y) (xs <> ys)
  SubR x xs <> SubR y ys = SubR (y <|> x) (xs <> ys)
  _ <> _ = error "Semigroup (<>) on Sublist: impossible pattern match!"

instance Monoid (Sublist () ()) where
  mempty = SubN
  mappend = (<>)

instance (Monoid (Sublist t as), Semigroup a)
      => Monoid (Sublist (S, t) (a, as)) where
  mempty = SubS Nothing mempty
  mappend = (<>)

instance (Monoid (Sublist t as)) => Monoid (Sublist (L, t) (a, as)) where
  mempty = SubL Nothing mempty
  mappend = (<>)

instance (Monoid (Sublist t as)) => Monoid (Sublist (R, t) (a, as)) where
  mempty = SubR Nothing mempty
  mappend = (<>)

-- | Return all the values from a sublist, using a list of defaults for the case
-- any are missing from the sublist.
fromSublist :: Sublist t a -> a -> a
fromSublist SubN () = ()
fromSublist (SubS x xs) (y, ys) = (fromMaybe y x, fromSublist xs ys)
fromSublist (SubL x xs) (y, ys) = (fromMaybe y x, fromSublist xs ys)
fromSublist (SubR x xs) (y, ys) = (fromMaybe y x, fromSublist xs ys)

sublistHead :: L.Simple L.Lens (Sublist (t, ts) (a, as)) (Maybe a)
sublistHead = L.lens g s
  where
    g :: (Sublist (t, ts) (a, as)) -> Maybe a
    g (SubS x _) = x
    g (SubL x _) = x
    g (SubR x _) = x
    s :: (Sublist (t, ts) (a, as)) -> Maybe a -> (Sublist (t, ts) (a, as))
    s (SubS _ xs) y = SubS y xs
    s (SubL _ xs) y = SubL y xs
    s (SubR _ xs) y = SubR y xs

sublistTail :: L.Lens (Sublist (t, ts) (a, as)) (Sublist (t, us) (a, bs))
                      (Sublist ts as)           (Sublist us bs)
sublistTail = L.lens g s
  where
    g :: (Sublist (t, ts) (a, as)) -> (Sublist ts as)
    g (SubS _ xs) = xs
    g (SubL _ xs) = xs
    g (SubR _ xs) = xs
    s :: (Sublist (t, ts) (a, as))
      -> (Sublist ss bs)
      -> (Sublist (t, ss) (a, bs))
    s (SubS x _) ys = SubS x ys
    s (SubL x _) ys = SubL x ys
    s (SubR x _) ys = SubR x ys