Skip to content

Commit 9d1cec0

Browse files
drlkfdrlkf
committed
style: format using fourmolu
1 parent 62784bf commit 9d1cec0

File tree

7 files changed

+360
-252
lines changed

7 files changed

+360
-252
lines changed

‎README.md

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,3 +11,7 @@ Commits](https://www.conventionalcommits.org/en/v1.0.0/) to generate versions
1111
with [Semantic Release](https://github.com/semantic-release/semantic-release),
1212
so make sure your commits are compliant. Pull requests are rebased, not
1313
squashed, so make sure your commits make sense as well.
14+
15+
It is preferrable that you format code using
16+
[fourmolu](https://github.com/fourmolu/fourmolu), a configuration is available
17+
at the root of the repository.

‎fourmolu.yaml

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
---
2+
column-limit: 90
3+
comma-style: leading
4+
function-arrows: leading
5+
haddock-style: single-line
6+
haddock-style-module: single-line
7+
import-export-style: diff-friendly
8+
indentation: 2
9+
let-style: inline
10+
respectful: false
11+
single-constraint-parens: never
12+
single-deriving-parens: never
13+
sort-constraints: true
14+
sort-derived-classes: true
15+
sort-deriving-clauses: true
16+
...

‎src/Text/Megaparsec/Time.hs

Lines changed: 76 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -1,43 +1,50 @@
11
{-# LANGUAGE FlexibleContexts #-}
22

3-
{- |
4-
Module : Text.Megaparsec.Time
5-
Description : Various parsers for types related to time.
6-
Copyright : (c) drlkf, 2024
7-
License : GPL-3
8-
Maintainer : [email protected]
9-
Stability : experimental
10-
-}
11-
12-
module Text.Megaparsec.Time
13-
( DayResult
14-
15-
, dateParser
16-
, dayParser
17-
, durationParser
18-
, gregorianDayParser
19-
, hoursParser
20-
, minutesParser
21-
, secondsParser
22-
, timeParser
23-
) where
24-
25-
import Control.Applicative (optional, (<|>))
26-
import Control.Monad (replicateM)
27-
import Control.Monad.Combinators (choice, some)
28-
import Data.Char (toLower)
29-
import Data.Functor (($>))
30-
import Data.Maybe (fromMaybe)
31-
import Data.Time (Day, DayOfWeek (..),
32-
NominalDiffTime, TimeOfDay (..),
33-
defaultTimeLocale,
34-
makeTimeOfDayValid, parseTimeM,
35-
secondsToNominalDiffTime)
36-
import Text.Megaparsec (Parsec, takeRest, try)
37-
import Text.Megaparsec.Char (char, digitChar, space, space1,
38-
string')
39-
import Text.Megaparsec.Utils (posNumParser)
40-
import Text.Printf (printf)
3+
-- |
4+
-- Module : Text.Megaparsec.Time
5+
-- Description : Various parsers for types related to time.
6+
-- Copyright : (c) drlkf, 2024
7+
-- License : GPL-3
8+
-- Maintainer : [email protected]
9+
-- Stability : experimental
10+
module Text.Megaparsec.Time (
11+
DayResult,
12+
dateParser,
13+
dayParser,
14+
durationParser,
15+
gregorianDayParser,
16+
hoursParser,
17+
minutesParser,
18+
secondsParser,
19+
timeParser,
20+
) where
21+
22+
import Control.Applicative (optional, (<|>))
23+
import Control.Monad (replicateM)
24+
import Control.Monad.Combinators (choice, some)
25+
import Data.Char (toLower)
26+
import Data.Functor (($>))
27+
import Data.Maybe (fromMaybe)
28+
import Data.Time (
29+
Day,
30+
DayOfWeek (..),
31+
NominalDiffTime,
32+
TimeOfDay (..),
33+
defaultTimeLocale,
34+
makeTimeOfDayValid,
35+
parseTimeM,
36+
secondsToNominalDiffTime,
37+
)
38+
import Text.Megaparsec (Parsec, takeRest, try)
39+
import Text.Megaparsec.Char (
40+
char,
41+
digitChar,
42+
space,
43+
space1,
44+
string',
45+
)
46+
import Text.Megaparsec.Utils (posNumParser)
47+
import Text.Printf (printf)
4148

4249
-- | Representation of a parser result with either a number of days relative to
4350
-- the current day, or a 'DayOfWeek'.
@@ -58,48 +65,54 @@ dateParser = (,) <$> optional (try (dayParser <* space1)) <*> timeParser
5865
dayParser
5966
:: Ord e
6067
=> Parsec e String DayResult
61-
dayParser = choice
62-
[ Right <$> longDay
63-
, Right <$> shortDay
64-
, Left <$> (string' "yesterday" $> -1)
65-
, Left <$> (string' "tomorrow" $> 1)
66-
, Right <$> absoluteDay
67-
, Left <$> relativeDay
68-
] where shortDay = choice $ map (ciString (fmap toLower . take 3 . show)) weekDays
69-
longDay = choice $ map (ciString (fmap toLower . show)) weekDays
70-
ciString f d = try (string' (f d)) $> d
71-
weekDays = [Monday .. Friday]
72-
sign = (char '-' $> negate) <|> (char '+' $> id)
73-
absoluteDay = toEnum . read <$> some digitChar
74-
relativeDay = ($) <$> sign <*> (read <$> some digitChar)
68+
dayParser =
69+
choice
70+
[ Right <$> longDay
71+
, Right <$> shortDay
72+
, Left <$> (string' "yesterday" $> -1)
73+
, Left <$> (string' "tomorrow" $> 1)
74+
, Right <$> absoluteDay
75+
, Left <$> relativeDay
76+
]
77+
where
78+
shortDay = choice $ map (ciString (fmap toLower . take 3 . show)) weekDays
79+
longDay = choice $ map (ciString (fmap toLower . show)) weekDays
80+
ciString f d = try (string' (f d)) $> d
81+
weekDays = [Monday .. Friday]
82+
sign = (char '-' $> negate) <|> (char '+' $> id)
83+
absoluteDay = toEnum . read <$> some digitChar
84+
relativeDay = ($) <$> sign <*> (read <$> some digitChar)
7585

7686
-- | Parse a 'NominalDiffTime' using strings like @1h23m45s@, with all
7787
-- components being optional as long as one is present.
7888
durationParser
7989
:: Ord e
8090
=> Parsec e String NominalDiffTime
8191
durationParser = try hours <|> try minutes <|> secondsParser
82-
where hours = do
83-
h <- hoursParser <* space
84-
m <- fromMaybe zero <$> optional (try minutes)
85-
s <- fromMaybe zero <$> optional secondsParser
92+
where
93+
hours = do
94+
h <- hoursParser <* space
95+
m <- fromMaybe zero <$> optional (try minutes)
96+
s <- fromMaybe zero <$> optional secondsParser
8697

87-
return (h + m + s)
98+
return (h + m + s)
8899

89-
minutes = do
90-
m <- minutesParser <* space
91-
s <- fromMaybe zero <$> optional secondsParser
100+
minutes = do
101+
m <- minutesParser <* space
102+
s <- fromMaybe zero <$> optional secondsParser
92103

93-
return (m + s)
104+
return (m + s)
94105

95106
-- | Parse a Gregorian 'Day' from a @%d\/%m\/%Y@ format.
96107
gregorianDayParser
97108
:: Ord e
98109
=> Parsec e String Day
99110
gregorianDayParser = do
100111
s <- takeRest
101-
parseTimeM False defaultTimeLocale "%F" s <|>
102-
parseTimeM False defaultTimeLocale "%d/%m/%Y" s
112+
113+
let parseTime = flip (parseTimeM False defaultTimeLocale) s
114+
115+
parseTime "%F" <|> parseTime "%d/%m/%Y"
103116

104117
-- | Parse a 'NominalDiffTime' from a number of hours from a string like @1h@.
105118
hoursParser

‎src/Text/Megaparsec/Utils.hs

Lines changed: 63 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -1,68 +1,78 @@
1-
{-# LANGUAGE FlexibleContexts #-}
1+
{-# LANGUAGE FlexibleContexts #-}
22
{-# LANGUAGE ScopedTypeVariables #-}
3-
{-# LANGUAGE TypeFamilies #-}
4-
5-
{- |
6-
Module : Text.Megaparsec.Utils
7-
Description : Various generic parsers and combinators.
8-
Copyright : (c) drlkf, 2024
9-
License : GPL-3
10-
Maintainer : [email protected]
11-
Stability : experimental
12-
-}
13-
14-
module Text.Megaparsec.Utils
15-
( boolParser
16-
, boundedEnumShowParser
17-
, commaSeparated
18-
, numParser
19-
, occurrence
20-
, occurrences
21-
, parsecToJSONParser
22-
, parsecToReadsPrec
23-
, posDecNumParser
24-
, posNumParser
25-
, uuidParser
26-
) where
27-
28-
import Control.Applicative (many, some, (<|>))
29-
import Control.Applicative.Combinators (choice)
30-
import Control.Monad (replicateM)
31-
import Control.Monad.Combinators (optional)
32-
import Data.Aeson.Types (Parser, Value, withText)
33-
import Data.Functor (($>))
34-
import Data.List (intercalate, sortOn)
35-
import Data.List.NonEmpty (NonEmpty ((:|)))
36-
import Data.Maybe (fromJust)
37-
import qualified Data.Text as T (unpack)
38-
import Data.UUID (UUID)
39-
import qualified Data.UUID as U (fromString)
40-
import Text.Megaparsec (Parsec, ShowErrorComponent,
41-
anySingle, errorBundlePretty,
42-
runParser, try)
43-
import Text.Megaparsec.Char (char, digitChar, hexDigitChar,
44-
string')
3+
{-# LANGUAGE TypeFamilies #-}
4+
5+
-- |
6+
-- Module : Text.Megaparsec.Utils
7+
-- Description : Various generic parsers and combinators.
8+
-- Copyright : (c) drlkf, 2024
9+
-- License : GPL-3
10+
-- Maintainer : [email protected]
11+
-- Stability : experimental
12+
module Text.Megaparsec.Utils (
13+
boolParser,
14+
boundedEnumShowParser,
15+
commaSeparated,
16+
numParser,
17+
occurrence,
18+
occurrences,
19+
parsecToJSONParser,
20+
parsecToReadsPrec,
21+
posDecNumParser,
22+
posNumParser,
23+
uuidParser,
24+
) where
25+
26+
import Control.Applicative (many, some, (<|>))
27+
import Control.Applicative.Combinators (choice)
28+
import Control.Monad (replicateM)
29+
import Control.Monad.Combinators (optional)
30+
import Data.Aeson.Types (Parser, Value, withText)
31+
import Data.Functor (($>))
32+
import Data.List (intercalate, sortOn)
33+
import Data.List.NonEmpty (NonEmpty ((:|)))
34+
import Data.Maybe (fromJust)
35+
import qualified Data.Text as T (unpack)
36+
import Data.UUID (UUID)
37+
import qualified Data.UUID as U (fromString)
38+
import Text.Megaparsec (
39+
Parsec,
40+
ShowErrorComponent,
41+
anySingle,
42+
errorBundlePretty,
43+
runParser,
44+
try,
45+
)
46+
import Text.Megaparsec.Char (
47+
char,
48+
digitChar,
49+
hexDigitChar,
50+
string',
51+
)
4552

4653
-- | Parse a case-insensitive human-readable boolean, including C-style numbers
4754
-- and English yes-no.
4855
boolParser
4956
:: Ord e
5057
=> Parsec e String Bool
5158
boolParser = true <|> false
52-
where true = True <$ choice (map string' ["true", "y", "yes", "1"])
53-
false = False <$ choice (map string' ["false", "n", "no", "0"])
59+
where
60+
true = True <$ choice (map string' ["true", "y", "yes", "1"])
61+
false = False <$ choice (map string' ["false", "n", "no", "0"])
5462

5563
-- | Parse a 'Bounded' 'Enum' type that has a 'Show' instance, trying all
5664
-- possibilities, case-insensitive, in the 'Enum' order.
5765
boundedEnumShowParser
58-
:: forall a e. Ord e
66+
:: forall a e
67+
. Ord e
5968
=> Bounded a
6069
=> Enum a
6170
=> Show a
6271
=> Parsec e String a
6372
boundedEnumShowParser =
6473
choice . map parseShow $ sortOn (negate . length . show) [(minBound :: a) ..]
65-
where parseShow a = string' (show a) $> a
74+
where
75+
parseShow a = string' (show a) $> a
6676

6777
-- | Parse a comma-separated list of items.
6878
commaSeparated
@@ -77,7 +87,8 @@ occurrence
7787
=> Parsec e String a
7888
-> Parsec e String a
7989
occurrence p = go
80-
where go = p <|> (anySingle >> go)
90+
where
91+
go = p <|> (anySingle >> go)
8192

8293
-- | Parse all occurrences of a given parser.
8394
occurrences
@@ -113,8 +124,10 @@ numParser = (char '-' >> negate <$> posNumParser) <|> posNumParser
113124
-- instances.
114125
parsecToJSONParser
115126
:: ShowErrorComponent e
116-
=> String -- ^ Parser name.
117-
-> Parsec e String a -- ^ Parser.
127+
=> String
128+
-- ^ Parser name.
129+
-> Parsec e String a
130+
-- ^ Parser.
118131
-> (Value -> Parser a)
119132
parsecToJSONParser n p =
120133
withText n $ either (fail . errorBundlePretty) pure . runParser p n . T.unpack

‎test/Spec.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,2 @@
1-
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
21
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2+
{-# OPTIONS_GHC -Wno-missing-export-lists #-}

0 commit comments

Comments
 (0)