2 files changed, 146 insertions, 0 deletions

diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs
new file mode 100644
index 0000000..330997a
--- /dev/null
+++ b/lib/Postdelay/TimeSpec/Units.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-}
+
+module Postdelay.TimeSpec.Units
+  ( Time
+  
+  , Second, Minute, Hour
+  , Day, Week, Month, Year
+
+  , timeLength
+
+  , module Data.Units.SI.Prefixes
+  ) where
+
+import Postdelay.TimeSpec.Utils
+
+import Control.Applicative
+
+import Data.Metrology
+import Data.Metrology.TH
+import Data.Metrology.SI.Mono ()
+
+import Data.Units.SI
+import Data.Units.SI.Prefixes
+import Data.Units.SI.Parser
+import qualified Data.Dimensions.SI as D
+
+import Data.Foldable
+import Data.Function
+import Data.VectorSpace
+
+import Data.Fixed (Fixed, HasResolution)
+import qualified Data.Fixed as Fixed
+
+
+import Text.Megaparsec
+  
+
+declareDerivedUnit "Day"   [t| Hour |] 24     Nothing
+declareDerivedUnit "Week"  [t| Day  |] 7      Nothing
+declareDerivedUnit "Month" [t| Day  |] 30     Nothing
+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
+  (^+^) = (+)
+  negateV = negate
+  (^-^) = (-)
+
+instance HasResolution p => VectorSpace (Fixed p) where
+  type Scalar (Fixed p) = Fixed p
+  (*^) = (*)
+
+
+timeLength :: StringParser s m => m Time
+timeLength = (*^) <$> lexeme rational <*> timeUnit
+
+rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n
+rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar)
+  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'
+
+timeUnit :: StringParser s m => m Time
+timeUnit = label "Unit of time" . choice $
+           [ 1 % Second <$ choice [ string' "seconds"
+                                  , string' "second"
+                                  , string' "secs"
+                                  , string' "sec"
+                                  ]
+           , 1 % Minute <$ choice [ string' "minutes"
+                                  , string' "minute"
+                                  , string' "mins"
+                                  , string' "min"
+                                  ]
+           , 1 % Hour   <$ choice [ string' "hours"
+                                  , string' "hour"
+                                  ]
+           , 1 % Day    <$ choice [ string' "days"
+                                  , string' "day"
+                                  ]
+           , 1 % Week   <$ choice [ string' "weeks"
+                                  , string' "week"
+                                  ]
+           , 1 % Month  <$ choice [ string' "months"
+                                  , string' "month"
+                                  ]
+           , 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" ]
+           ]
+
+siPrefix :: (StringParser s m, Fractional n) => m n
+siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show 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
+           , Prefix Pico, Prefix Femto, Prefix Atto, Prefix Zepto, Prefix Yocto
+           ]
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
new file mode 100644
index 0000000..e4ba732
--- /dev/null
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns #-}
+
+module Postdelay.TimeSpec.Utils where
+
+import Control.Applicative
+import Control.Monad
+import Control.Lens
+
+import Data.Time
+import Data.Time.Zones
+
+import Data.AdditiveGroup
+
+import Text.Megaparsec
+import Text.Megaparsec.Prim (MonadParsec)
+import qualified Text.Megaparsec.Lexer as L
+
+
+type StringParser s m = (MonadParsec Dec s m, Token s ~ Char)
+
+  
+spaceConsumer :: StringParser s m => m ()
+spaceConsumer = L.space (void spaceChar) empty empty
+
+lexeme :: StringParser s m => m a -> m a
+lexeme = L.lexeme spaceConsumer
+
+signed, optSigned :: (StringParser s m, AdditiveGroup n) => m n -> m n
+signed = (<*>) (lexeme sign)
+optSigned = (<*>) (option id $ lexeme sign)
+
+sign :: (StringParser s m, AdditiveGroup n) => m (n -> n)
+sign = choice [ id <$ char '+'
+              , negateV <$ char '-'
+              ]