{-# 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.Maybe
import Data.List
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

import Debug.Trace


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, Ord n, Num n, StringParser s m)
               => Bool -- ^ Require number to be padded with zeroes?
               -> Interval n -> m n
boundedNatural padded (I.intersection (0 <=..< PosInf) -> bounds)
  | I.null bounds = empty
  | otherwise = 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) = {- traceShowId -} ( 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 0 = 1
    digits n = succ . fromJust $ findIndex (\(min, max) -> min <= n && n < max) [ (10^i, 10^(succ i)) | i <- ([0..] :: [Int]) ]

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)
  | I.null bounds = empty
  | otherwise = (+) <$> boundedNatural padded wholeBounds <*> fractional <?> "Nonnegative rational 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)