{-# 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
           ]