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 ++++++++++++++++++++++++++---------------
 1 file changed, 27 insertions(+), 15 deletions(-)

(limited to 'lib/Postdelay/TimeSpec/Units.hs')

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
-- 
cgit v1.2.3