1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
{-# 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)
|
