{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns, TupleSections #-}

module Postdelay.TimeSpec.Utils
  ( StringParser
  , spaceConsumer, spaces
  , lexeme
  , signed, optSigned
  , sign
  , boundedNatural
  , boundedRational
  , module Data.Interval
  , fromDigit
  , mkGramSepBy
  ) where

import Control.Applicative
import Control.Monad
import Control.Lens

import Data.Time
import Data.Time.Lens
import Data.Time.Zones

import Data.Bool
import Data.Foldable
import Data.Functor
import Data.Function
import Data.AdditiveGroup
import Data.Interval (Interval, Extended(..), (<=..<=), (<=..<), (<..<=), (<..<), interval)
import qualified Data.Interval as I

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, spaces :: StringParser s m => m ()
spaceConsumer = L.space (void spaceChar) empty empty
spaces = void $ lexeme spaceChar

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 = label "sign" $ choice [ char '+' $> id
                             , char '-' $> negateV
                             ]

boundedNatural :: forall s n m. (Show n, Real n, StringParser s m)
               => Bool -- ^ Require number to be padded with zeroes?
               -> Interval n -> m n
boundedNatural padded (I.intersection (0 <=..< PosInf) -> bounds) = do
  n <- foldl' (\i l -> i * 10 + l) 0 <$> digitN (fromDigit <$> digitChar) <?> "Natural number cotained in: " ++ show bounds
  when (not $ n `I.member` bounds) $ fail "Natural number out of bounds"
  return n
  where
    digitN :: m n -> m [n]
    digitN p
      | PosInf <- maxDigits
      , Finite min <- minDigits = (++) <$> count min p <*> many p
      | Finite max <- maxDigits
      , Finite min <- minDigits
      , not padded = count' min max p
      | Finite max <- maxDigits
      , Finite _ <- minDigits
      , padded = count max p
      | otherwise = error "boundedNatural in undefined state"

    minDigits, maxDigits :: Extended Int
    (minDigits, maxDigits) = ( max 1 . fmap digits . I.lowerBound $ close bounds
                             , fmap digits . I.upperBound $ close bounds
                             )
      where
        close int
          | (Finite min, False) <- I.lowerBound' int = close $ interval (Finite $ min + 1, True) (I.upperBound' int)
          | (Finite max, False) <- I.upperBound' int = close $ interval (I.lowerBound' int) (Finite $ max - 1, True)
          | otherwise = int

    digits :: n -> Int
    digits = succ . floor . (logBase 10 :: Double -> Double) . realToFrac . abs

boundedRational :: forall s m n. (Show n, RealFrac n, StringParser s m)
                => Bool -- ^ Require number to be padded with zeroes
                -> Interval n -> m n
boundedRational padded (I.intersection (0 <=..< PosInf) -> bounds)
  = (+) <$> boundedNatural padded wholeBounds <*> fractional <?> "Nonnegative real contained in: " ++ show bounds
  where
    fractional :: m n
    fractional = reqFractional $ char '.' $> (/ 10) . foldr' (\h t -> h + t / 10) 0 <*> some (fromDigit <$> digitChar)
    
    reqFractional
      | contained = option 0
      | otherwise = id
      where (_, contained) = I.lowerBound' bounds
    wholeBounds
      | (Finite max, False) <- I.upperBound' bounds
      , max == (fromInteger $ round max) = interval (I.lowerBound' bounds) (Finite $ max - 1, True)
      | otherwise = bounds

fromDigit :: Num n => Char -> n
fromDigit c = fromIntegral $ fromEnum c - fromEnum '0'

mkGramSepBy :: MonadParsec e s m => m a -> [m b] -> m [b]
mkGramSepBy sep ps = map snd <$> mkGramSepBy' sep (zip [0..] ps)
  where
    mkGramSepBy' _ [] = empty
    mkGramSepBy' _ [(n, x)] = pure . (n, ) <$> x
    mkGramSepBy' sep ps = do
      head@(n, _) <- choice $ map (\(n, p) -> (n, ) <$> p) ps
      let ps' = filter (\(i, _) -> i /= n) ps
      tail <- option [] . try $ sep *> mkGramSepBy' sep ps'
      return $ insert head tail

    insert :: forall a. (Integer, a) -> [(Integer, a)] -> [(Integer, a)]
    insert x@(fst -> a) [] = [x]
    insert x@(fst -> a) (y@(fst -> b):ds)
      | a <= b = x:y:ds
      | otherwise = y:(insert x ds)