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 TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Coalpit where
import Data.List
import GHC.Generics
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Maybe
type Parser = Parsec String String
args :: ToArgs a => a -> String
args = intercalate " " . toArgs
class ArgParser a where
argParser :: Parser a
default argParser :: (Generic a, GArgParser (Rep a)) => Parser a
argParser = to <$> gArgParser
class GArgParser f where
gArgParser :: Parser (f a)
class ToArgs a where
toArgs :: a -> [String]
default toArgs :: (Generic a, GToArgs (Rep a)) => a -> [String]
toArgs a = gToArgs (from a)
class GToArgs f where
gToArgs :: f a -> [String]
instance GArgParser U1 where
gArgParser = pure U1
instance GToArgs U1 where
gToArgs U1 = []
instance (GArgParser a, GArgParser b) => GArgParser (a :*: b) where
gArgParser = (:*:) <$> gArgParser <* space <*> gArgParser
instance (GToArgs a, GToArgs b) => GToArgs (a :*: b) where
gToArgs (a :*: b) = gToArgs a ++ gToArgs b
instance (GArgParser a, GArgParser b) => GArgParser (a :+: b) where
gArgParser = L1 <$> gArgParser <|> R1 <$> gArgParser
instance (GToArgs a, GToArgs b) => GToArgs (a :+: b) where
gToArgs c@(L1 x) = gToArgs x
gToArgs c@(R1 x) = gToArgs x
instance {-#OVERLAPPING#-}
(ArgParser a, Selector c) => GArgParser (S1 c (Rec0 (Maybe a))) where
gArgParser = do
case selName (undefined :: S1 c (Rec0 (Maybe a)) f) of
"" -> M1 <$> gArgParser
name -> do
x <- optional $ string ("--" ++ name) *> space *> argParser
pure $ M1 $ K1 x
instance (GArgParser a, Selector c) => GArgParser (S1 c a) where
gArgParser = M1 <$> do
let sname = case selName (undefined :: S1 c a f) of
"" -> pure ()
name -> string ("--" ++ name) *> space
sname *> gArgParser
-- record selectors
instance {-#OVERLAPPING#-}
(ToArgs a, Selector c) => GToArgs (S1 c (Rec0 (Maybe a))) where
gToArgs s@(M1 (K1 x)) = case (selName s, x) of
("", _) -> toArgs x
(_, Nothing) -> []
(name, Just x') -> ("--" ++ selName s) : toArgs x'
instance (GToArgs a, Selector c) => GToArgs (S1 c a) where
gToArgs s@(M1 x) = case selName s of
"" -> gToArgs x
name -> ("--" ++ selName s) : gToArgs x
instance (GArgParser a, Constructor c) => GArgParser (C1 c a) where
gArgParser = string (conName (undefined :: C1 c a f)) *> space *> (M1 <$> gArgParser)
instance (GToArgs a, Constructor c) => GToArgs (C1 c a) where
gToArgs c@(M1 x) = conName c : gToArgs x
instance (GArgParser a, Datatype c) => GArgParser (D1 c a) where
gArgParser = M1 <$> gArgParser
instance (GToArgs a, Datatype c) => GToArgs (D1 c a) where
gToArgs d@(M1 x) = gToArgs x
instance (ArgParser a) => GArgParser (K1 i a) where
gArgParser = K1 <$> argParser
instance (ToArgs a) => GToArgs (K1 i a) where
gToArgs (K1 x) = toArgs x
instance ArgParser Int where
argParser = read <$> some digitChar
instance ToArgs Int where
toArgs i = [show i]
instance ArgParser String where
argParser = char '"' *> manyTill anyChar (char '"')
instance ToArgs String where
toArgs i = [show i]
instance ArgParser Double where
argParser = read <$> some (digitChar <|> char '.')
instance ToArgs Double where
toArgs i = [show i]
instance ArgParser a => ArgParser (Maybe a)
instance ToArgs a => ToArgs (Maybe a)
|
