From 5b09b096e38ed231b62df57736e87c989b481b5d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 15 Feb 2017 18:17:26 +0100 Subject: Purely relative time specifications --- lib/Postdelay/TimeSpec.hs | 28 ++++++++++++++++++++++++--- lib/Postdelay/TimeSpec/Units.hs | 42 ++++++++++++++++++++++++++--------------- lib/Postdelay/TimeSpec/Utils.hs | 8 +++++--- 3 files changed, 57 insertions(+), 21 deletions(-) (limited to 'lib') diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index 5c41180..03baf85 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -14,16 +14,38 @@ import Text.Megaparsec import Control.Monad.IO.Class import Control.Applicative +import Control.Lens hiding ((#)) -import Data.Semigroup +import Data.Bool +import Data.Semigroup hiding (option) import Data.Monoid (Endo(..)) +import Data.Foldable +import Data.VectorSpace import Data.Time +import Data.Time.Lens import Data.Time.Zones +seconds' :: Timeable t => Lens' t Time +seconds' = seconds . iso (% Second) (# Second) + + pTimeSpec :: StringParser s m => m (Endo LocalTime) -pTimeSpec = empty +pTimeSpec = label "Relative time specification" $ + choice [ pOffsets False + ] + +pOffsets :: forall s m. StringParser s m + => Bool -- ^ Require sign on first offset? + -> m (Endo LocalTime) +pOffsets (bool optSigned signed -> reqSgn) = fmap fold $ (:) <$> offset reqSgn <*> many (offset optSigned) + where + asOffset :: Time -> Endo LocalTime + asOffset by = Endo $ flexDT.seconds' %~ (^+^ by) + offset :: (m Time -> m Time) -> m (Endo LocalTime) + offset sgn = asOffset <$> lexeme (sgn timeLength) "Time offset" pTimeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ) -pTimeZone = empty +pTimeZone = label "Timezone" $ + empty diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs index 330997a..0062460 100644 --- a/lib/Postdelay/TimeSpec/Units.hs +++ b/lib/Postdelay/TimeSpec/Units.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeFamilies #-} module Postdelay.TimeSpec.Units ( Time - , Second, Minute, Hour - , Day, Week, Month, Year + , Second(..), Minute(..), Hour(..) + , Day(..), Week(..), Month(..), Year(..) , timeLength + , module Data.Metrology , module Data.Units.SI.Prefixes ) where import Postdelay.TimeSpec.Utils import Control.Applicative +import Control.Monad import Data.Metrology import Data.Metrology.TH @@ -42,9 +44,6 @@ declareDerivedUnit "Year" [t| Day |] 365.25 Nothing type Time = MkQu_DLN D.Time DefaultLCSU Fixed.Pico -data Prefix where - Prefix :: forall p. (UnitPrefix p, Show p) => p -> Prefix - instance HasResolution p => AdditiveGroup (Fixed p) where zeroV = 0 (^+^) = (+) @@ -57,16 +56,16 @@ instance HasResolution p => VectorSpace (Fixed p) where timeLength :: StringParser s m => m Time -timeLength = (*^) <$> lexeme rational <*> timeUnit +timeLength = (*^) <$> lexeme rational <*> timeUnit "Length of time" rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n -rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar) +rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar) "Decimal number" where combine :: [Char] -> [Char] -> n combine (map asN -> whole) (map asN -> fractional) = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10 asN :: Char -> n - asN c = fromIntegral $ ((-) `on` fromEnum) c '0' + asN c = fromIntegral $ fromEnum c - fromEnum '0' timeUnit :: StringParser s m => m Time timeUnit = label "Unit of time" . choice $ @@ -95,15 +94,28 @@ timeUnit = label "Unit of time" . choice $ , 1 % Year <$ choice [ string' "years" , string' "year" ] - ] ++ - [ (% Second) <$> option 1 siPrefix <* string "s" - , (% Hour) <$> option 1 siPrefix <* string "h" - , (% Day) <$> option 1 siPrefix <* string "d" - , (% Year) <$> option 1 siPrefix <* choice [ string "a", string "yr", string "yrs" ] + , option 1 siPrefix <**> choice [ (% Second) <$ string "s" + , (% Hour ) <$ string "h" + , (% Day ) <$ string "d" + , (% Year ) <$ choice [ string "a", string' "yr", string' "yrs" ] + ] ] + +data Prefix where + Prefix :: forall p. ParseablePrefix p => p -> Prefix + +class UnitPrefix a => ParseablePrefix a where + parser :: StringParser s m => a -> m () + +instance {-# OVERLAPPABLE #-} (UnitPrefix a, Show a) => ParseablePrefix a where + parser = void . string . show + +instance ParseablePrefix Micro where + parser _ = void $ choice [ string "ยต", string "u" ] + siPrefix :: (StringParser s m, Fractional n) => m n -siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show p)) +siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ parser p) [ Prefix Deca, Prefix Hecto, Prefix Kilo, Prefix Mega, Prefix Giga , Prefix Tera, Prefix Peta, Prefix Exa, Prefix Zetta, Prefix Yotta , Prefix Deci, Prefix Centi, Prefix Milli, Prefix Micro, Prefix Nano diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs index e4ba732..85ac299 100644 --- a/lib/Postdelay/TimeSpec/Utils.hs +++ b/lib/Postdelay/TimeSpec/Utils.hs @@ -7,8 +7,10 @@ import Control.Monad import Control.Lens import Data.Time +import Data.Time.Lens import Data.Time.Zones +import Data.Functor import Data.AdditiveGroup import Text.Megaparsec @@ -30,6 +32,6 @@ signed = (<*>) (lexeme sign) optSigned = (<*>) (option id $ lexeme sign) sign :: (StringParser s m, AdditiveGroup n) => m (n -> n) -sign = choice [ id <$ char '+' - , negateV <$ char '-' - ] +sign = label "sign" $ choice [ char '+' $> id + , char '-' $> negateV + ] -- cgit v1.2.3