1{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE TypeFamilies #-}
5
6{- | These declarations allow the use of a DirectionalSeq, which is a
7   Seq that uses a phantom type to identify the ordering of the
8   elements in the sequence (Forward or Reverse).  The constructors
9   are not exported from this module so that a DirectionalSeq can only
10   be constructed by the functions in this module.
11-}
12
13module Matterhorn.Types.DirectionalSeq where
14
15import           Prelude ()
16import           Matterhorn.Prelude
17
18import qualified Data.Sequence as Seq
19
20
21data Chronological
22data Retrograde
23class SeqDirection a where
24  type ReverseDirection a
25instance SeqDirection Chronological
26  where type ReverseDirection Chronological = Retrograde
27instance SeqDirection Retrograde
28  where type ReverseDirection Retrograde = Chronological
29
30data SeqDirection dir => DirectionalSeq dir a =
31    DSeq { dseq :: Seq a }
32         deriving (Show, Functor, Foldable, Traversable)
33
34emptyDirSeq :: DirectionalSeq dir a
35emptyDirSeq = DSeq mempty
36
37appendDirSeq :: DirectionalSeq dir a -> DirectionalSeq dir a -> DirectionalSeq dir a
38appendDirSeq a b = DSeq $ mappend (dseq a) (dseq b)
39
40onDirectedSeq :: SeqDirection dir => (Seq a -> Seq b)
41              -> DirectionalSeq dir a -> DirectionalSeq dir b
42onDirectedSeq f = DSeq . f . dseq
43
44-- | Uses a start-predicate and and end-predicate to
45-- identify (the first matching) subset that is delineated by
46-- start-predicate and end-predicate (inclusive).  It will then call
47-- the passed operation function on the subset messages to get back a
48-- (possibly modified) set of messages, along with an extracted value.
49-- The 'onDirSeqSubset' function will replace the original subset of
50-- messages with the set returned by the operation function and return
51-- the resulting message list along with the extracted value.
52
53onDirSeqSubset :: SeqDirection dir =>
54                 (e -> Bool) -> (e -> Bool)
55               -> (DirectionalSeq dir e -> (DirectionalSeq dir e, a))
56               -> DirectionalSeq dir e
57               -> (DirectionalSeq dir e, a)
58onDirSeqSubset startPred endPred op entries =
59    let ml = dseq entries
60        (bl, ml1) = Seq.breakl startPred ml
61        (ml2, el) = Seq.breakl endPred ml1
62        -- move match from start of el to end of ml2
63        (ml2', el') = if not (Seq.null el)
64                      then (ml2 <> Seq.take 1 el, Seq.drop 1 el)
65                      else (ml2, el)
66        (ml3, rval) = op $ DSeq ml2'
67    in (DSeq bl `appendDirSeq` ml3 `appendDirSeq` DSeq el', rval)
68
69-- | dirSeqBreakl splits the DirectionalSeq into a tuple where the
70-- first element is the (possibly empty) DirectionalSeq of all
71-- elements from the start for which the predicate returns false; the
72-- second tuple element is the remainder of the list, starting with
73-- the first element for which the predicate matched.
74dirSeqBreakl :: SeqDirection dir =>
75               (e -> Bool) -> DirectionalSeq dir e
76             -> (DirectionalSeq dir e, DirectionalSeq dir e)
77dirSeqBreakl isMatch entries =
78    let (removed, remaining) = Seq.breakl isMatch $ dseq entries
79    in (DSeq removed, DSeq remaining)
80
81-- | dirSeqPartition splits the DirectionalSeq into a tuple of two
82-- DirectionalSeq elements: the first contains all elements for which
83-- the predicate is true and the second contains all elements for
84-- which the predicate is false.
85dirSeqPartition :: SeqDirection dir =>
86                  (e -> Bool) -> DirectionalSeq dir e
87                -> (DirectionalSeq dir e, DirectionalSeq dir e)
88dirSeqPartition isMatch entries =
89    let (match, nomatch) = Seq.partition isMatch $ dseq entries
90    in (DSeq match, DSeq nomatch)
91
92
93withDirSeqHead :: SeqDirection dir => (e -> r) -> DirectionalSeq dir e -> Maybe r
94withDirSeqHead op entries =
95    case Seq.viewl (dseq entries) of
96      Seq.EmptyL -> Nothing
97      e Seq.:< _ -> Just $ op e
98