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