From 5b09b096e38ed231b62df57736e87c989b481b5d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <aethoago@141.li>
Date: Wed, 15 Feb 2017 18:17:26 +0100
Subject: Purely relative time specifications
---
lib/Postdelay/TimeSpec/Units.hs | 42 ++++++++++++++++++++++++++---------------
lib/Postdelay/TimeSpec/Utils.hs | 8 +++++---
2 files changed, 32 insertions(+), 18 deletions(-)
(limited to 'lib/Postdelay/TimeSpec')
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