1 {-# LANGUAGE OverloadedStrings, DataKinds, DeriveDataTypeable #-} 2 {-# OPTIONS_GHC -fno-warn-orphans #-} 3 module Databrary.Model.Segment 4 ( Segment(..) 5 , lowerBound, upperBound 6 , showSegmentWith 7 , segmentLength 8 , fullSegment 9 , emptySegment 10 , segmentFull 11 , segmentEmpty 12 , segmentContains 13 , segmentOverlaps 14 , segmentIntersect 15 , segmentInterp 16 , segmentJSON 17 , segmentSetDuration 18 ) where 19 20 import Control.Applicative ((<|>), optional, Alternative, empty) 21 import Control.Monad (guard, liftM2) 22 import Data.Maybe (fromMaybe, isNothing) 23 import qualified Data.Text as T 24 import Data.Typeable (Typeable) 25 import Database.PostgreSQL.Typed.Types (PGType, PGParameter(..), PGColumn(..)) 26 import Database.PostgreSQL.Typed.Array (PGArrayType) 27 import qualified Database.PostgreSQL.Typed.Range as Range 28 import qualified Text.ParserCombinators.ReadP as RP 29 import qualified Text.ParserCombinators.ReadPrec as RP (lift, readPrec_to_P, minPrec) 30 import Text.Read (readMaybe, readPrec) 31 import qualified Web.Route.Invertible as R 32 33 import qualified Databrary.JSON as JSON 34 import Databrary.Model.Offset 35 36 lowerBound, upperBound :: Range.Range a -> Maybe a 37 lowerBound = Range.bound . Range.lowerBound 38 upperBound = Range.bound . Range.upperBound 39 40 newtype Segment = Segment { segmentRange :: Range.Range Offset } deriving (Eq, Ord, Typeable) 41 42 instance PGType "segment" 43 instance Range.PGRangeType "segment" "interval" 44 instance PGType "segment[]" 45 instance PGArrayType "segment[]" "segment" 46 47 instance PGParameter "segment" Segment where 48 pgEncode t (Segment r) = pgEncode t r 49 instance PGColumn "segment" Segment where 50 pgDecode t = Segment . pgDecode t 51 52 segmentLength :: Segment -> Maybe Offset 53 segmentLength (Segment r) = 54 liftM2 (-) (upperBound r) (lowerBound r) 55 56 showSegmentWith :: (Offset -> ShowS) -> Segment -> ShowS 57 showSegmentWith _ (Segment Range.Empty) = showString "empty" 58 showSegmentWith sf (Segment r) 59 | Just x <- Range.getPoint r = sf x 60 | otherwise = 61 maybe id (((if Range.lowerClosed r then id else showChar '(') .) . sf) (lowerBound r) 62 . showChar ',' . maybe id sf (upperBound r) 63 . (if Range.upperClosed r then showChar ']' else id) 64 65 instance Show Segment where 66 showsPrec = showSegmentWith . showsPrec 67 68 readP :: Read a => RP.ReadP a 69 readP = RP.readPrec_to_P readPrec RP.minPrec 70 71 instance Read Segment where 72 readPrec = RP.lift $ Segment <$> re RP.+++ rf RP.+++ rr where 73 re = do 74 RP.optional (RP.string "empty") 75 return Range.Empty 76 rf = do 77 _ <- RP.char '-' 78 return Range.full 79 rr :: RP.ReadP (Range.Range Offset) 80 rr = do 81 lb <- optional $ ('[' ==) <$> RP.satisfy (`elem` ['(','[']) 82 l <- optional readP 83 (guard (isNothing lb) >> Range.point <$> maybeA l) RP.+++ do 84 _ <- if isNothing lb && isNothing l then RP.char ',' else RP.satisfy (`elem` [',','-']) 85 u <- optional readP 86 ub <- optional $ ('[' ==) <$> RP.satisfy (`elem` [')',']']) 87 return $ Range.range (mb True lb l) (mb False ub u) 88 -- more liberal than Range.makeBound: 89 mb :: Bool -> Maybe Bool -> Maybe Offset -> Range.Bound Offset 90 mb d = maybe Range.Unbounded . Range.Bounded . fromMaybe d 91 92 maybeA :: Alternative m => Maybe a -> m a 93 maybeA (Just x) = pure x 94 maybeA Nothing = empty 95 96 instance JSON.ToJSON Segment where 97 toJSON (Segment r) 98 | Range.isEmpty r = JSON.Null 99 | Just o <- Range.getPoint r = JSON.toJSON o 100 | otherwise = JSON.toJSON $ map Range.bound [Range.lowerBound r, Range.upperBound r] 101 102 instance JSON.FromJSON Segment where 103 parseJSON (JSON.String s) = maybe (fail "Invalid segment string") return $ readMaybe $ T.unpack s 104 parseJSON j = do 105 a <- JSON.parseJSON j <|> return <$> JSON.parseJSON j 106 Segment <$> case a of 107 [] -> return Range.empty 108 [p] -> return $ maybe Range.empty Range.point p 109 [l, u] -> return $ Range.normal l u 110 _ -> fail "Segment array too long" 111 112 instance R.Parameter T.Text Segment where 113 renderParameter s = T.pack $ showSegmentWith (shows . offsetMillis) s "" 114 115 fullSegment :: Segment 116 fullSegment = Segment Range.full 117 118 emptySegment :: Segment 119 emptySegment = Segment Range.empty 120 121 segmentFull :: Segment -> Bool 122 segmentFull = Range.isFull . segmentRange 123 124 segmentEmpty :: Segment -> Bool 125 segmentEmpty = Range.isEmpty . segmentRange 126 127 segmentContains :: Segment -> Segment -> Bool 128 segmentContains (Segment a) (Segment b) = a Range.@> b 129 130 segmentOverlaps :: Segment -> Segment -> Bool 131 segmentOverlaps (Segment a) (Segment b) = Range.overlaps a b 132 133 segmentIntersect :: Segment -> Segment -> Segment 134 segmentIntersect (Segment a) (Segment b) = Segment (Range.intersect a b) 135 136 segmentInterp :: Float -> Segment -> Segment 137 segmentInterp f (Segment r) 138 | Just u <- upperBound r = Segment (Range.point (l + realToFrac f * (u - l))) 139 | otherwise = Segment (Range.point 0) 140 where l = fromMaybe 0 $ lowerBound r 141 142 segmentJSON :: JSON.ToObject o => Segment -> o 143 segmentJSON s = "segment" `JSON.kvObjectOrEmpty` (if segmentFull s then empty else pure s) 144 145 segmentSetDuration :: Offset -> Segment -> Segment 146 segmentSetDuration o (Segment (Range.Range lb@(Range.Lower (Range.Bounded _ l)) (Range.Upper ub))) = 147 Segment (Range.Range lb (Range.Upper (Range.Bounded (Range.boundClosed ub) (l + o)))) 148 segmentSetDuration _ s = s