{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TypeFamilies #-}
module Matterhorn.Types.DirectionalSeq where
import Prelude ()
import Matterhorn.Prelude
import qualified Data.Sequence as Seq
data Chronological
data Retrograde
class SeqDirection a where
type ReverseDirection a
instance SeqDirection Chronological
where type ReverseDirection Chronological = Retrograde
instance SeqDirection Retrograde
where type ReverseDirection Retrograde = Chronological
data SeqDirection dir => DirectionalSeq dir a =
DSeq { dseq :: Seq a }
deriving (Show, Functor, Foldable, Traversable)
emptyDirSeq :: DirectionalSeq dir a
emptyDirSeq = DSeq mempty
appendDirSeq :: DirectionalSeq dir a -> DirectionalSeq dir a -> DirectionalSeq dir a
appendDirSeq a b = DSeq $ mappend (dseq a) (dseq b)
onDirectedSeq :: SeqDirection dir => (Seq a -> Seq b)
-> DirectionalSeq dir a -> DirectionalSeq dir b
onDirectedSeq f = DSeq . f . dseq
onDirSeqSubset :: SeqDirection dir =>
(e -> Bool) -> (e -> Bool)
-> (DirectionalSeq dir e -> (DirectionalSeq dir e, a))
-> DirectionalSeq dir e
-> (DirectionalSeq dir e, a)
onDirSeqSubset startPred endPred op entries =
let ml = dseq entries
(bl, ml1) = Seq.breakl startPred ml
(ml2, el) = Seq.breakl endPred ml1
(ml2', el') = if not (Seq.null el)
then (ml2 <> Seq.take 1 el, Seq.drop 1 el)
else (ml2, el)
(ml3, rval) = op $ DSeq ml2'
in (DSeq bl `appendDirSeq` ml3 `appendDirSeq` DSeq el', rval)
dirSeqBreakl :: SeqDirection dir =>
(e -> Bool) -> DirectionalSeq dir e
-> (DirectionalSeq dir e, DirectionalSeq dir e)
dirSeqBreakl isMatch entries =
let (removed, remaining) = Seq.breakl isMatch $ dseq entries
in (DSeq removed, DSeq remaining)
dirSeqPartition :: SeqDirection dir =>
(e -> Bool) -> DirectionalSeq dir e
-> (DirectionalSeq dir e, DirectionalSeq dir e)
dirSeqPartition isMatch entries =
let (match, nomatch) = Seq.partition isMatch $ dseq entries
in (DSeq match, DSeq nomatch)
withDirSeqHead :: SeqDirection dir => (e -> r) -> DirectionalSeq dir e -> Maybe r
withDirSeqHead op entries =
case Seq.viewl (dseq entries) of
Seq.EmptyL -> Nothing
e Seq.:< _ -> Just $ op e