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

module Postdelay.TimeSpec.Utils where

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

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

import Data.Functor
import Data.AdditiveGroup

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
                             ]

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)