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
|
{- |
Module : Coalpit.Parsing
Description : Argument parsing facilities
Maintainer : defanor <defanor@uberspace.net>
Stability : unstable
Portability : non-portable (uses GHC extensions)
This module provides functions useful for argument parsing.
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Coalpit.Parsing ( Parser
, CLArg(..)
, pS
, readArg
, pTime
) where
import Text.Megaparsec
import Data.Proxy (Proxy(..))
import Data.Time.Format (TimeLocale, ParseTime, readSTime)
import Data.Void (Void)
import qualified Data.List.NonEmpty as NE
import Data.List (foldl')
import Data.Semigroup ((<>))
-- | Command-line argument wrapper, used to avoid orphan ShowToken
-- String and Stream [String] instances.
newtype CLArg = CLArg { unArg :: String }
deriving (Ord, Eq)
-- | Advances by one token.
advance :: Pos -> SourcePos -> t -> SourcePos
advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1)
-- | A list of strings (command-line arguments) stream.
instance Stream [CLArg] where
type Token [CLArg] = CLArg
type Tokens [CLArg] = [CLArg]
tokenToChunk Proxy = pure
tokensToChunk Proxy = id
chunkToTokens Proxy = id
chunkLength Proxy = length
chunkEmpty Proxy = null
advance1 Proxy = advance
advanceN Proxy w = foldl' (advance w)
take1_ [] = Nothing
take1_ (t:ts) = Just (t, ts)
takeN_ n s
| n <= 0 = Just ([], s)
| null s = Nothing
| otherwise = Just (splitAt n s)
takeWhile_ = span
instance ShowToken CLArg where
showTokens xs = concat $ NE.map unArg xs
-- | Command-line arguments parser.
type Parser = Parsec Void [CLArg]
-- | Applies a String parser to a single argument.
pS :: Parsec Void String a -> Parsec Void [CLArg] a
pS p = try $ do
x <- token (Right . unArg) Nothing
case parse p "argument" x of
Left e -> fail $ show e
Right x' -> pure x'
-- | Reads an argument using its 'Read' instance.
readArg :: Read a => Parser a
readArg = do
x <- token (Right . unArg) Nothing
case reads x of
[(n, "")] -> pure n
_ -> fail $ "Failed to read: " ++ x
-- | Parses a time argument.
pTime :: ParseTime a
=> TimeLocale
-- ^ Options, to read 'timeLocale' from.
-> String
-- ^ Time format to use.
-> Parser a
pTime tl tf = try $ do
x <- token (Right . unArg) Nothing
case readSTime False tl tf x of
[(t, "")] -> pure t
_ -> fail "Failed to parse time"
|
