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