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
|
{-# 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) = ( 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 = ceiling . (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)
|
