{-# LANGUAGE TemplateHaskell, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeFamilies #-}

module Postdelay.TimeSpec.Units
  ( Time
  
  , 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
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

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 (boundedRational False $ 0 <=..< PosInf) <*> timeUnit <?> "Length of time"

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"
                                  ]
           , 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 <$ 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
           , Prefix Pico, Prefix Femto, Prefix Atto, Prefix Zepto, Prefix Yocto
           ]