1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 module Symantic.CLI.Read where
7 import Control.Applicative (Applicative(..), Alternative(..))
8 import Control.Applicative.Permutations as P
9 import Control.Arrow ((***))
10 import Control.Monad (Monad(..), MonadPlus(..))
12 import Data.Either (Either(..))
13 import Data.Eq (Eq(..))
14 import Data.Foldable (Foldable(..))
15 import Data.Function (($), (.), const)
16 import Data.Functor (Functor(..), (<$>))
17 import Data.Maybe (Maybe(..))
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ord(..), Ordering(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.String (String)
22 import Prelude (error)
23 import Text.Show (Show(..))
24 import qualified Data.List as List
25 import qualified Data.Sequence as Seq
26 import qualified Data.Set as Set
27 import qualified Text.Megaparsec as P
29 import Symantic.CLI.Sym as Sym
32 newtype Arg = Arg { unArg :: String }
33 deriving (Eq, Ord, Show)
34 -- TODO: first pass separating options from non-options.
37 newtype Args = Args { unArgs :: [Arg] }
38 deriving (Eq, Ord, Show, Semigroup, Monoid)
39 instance P.Stream Args where
41 type Tokens Args = Args
42 tokenToChunk _s = Args . pure
43 tokensToChunk _s = Args
44 chunkToTokens _s = unArgs
45 chunkLength _s = List.length . unArgs
46 chunkEmpty _s = List.null . unArgs
50 t:ts -> Just (t, Args ts)
51 takeN_ n as | n <= 0 = Just (Args [], as)
52 | null (unArgs as) = Nothing
53 | otherwise = Just $ (Args *** Args) $ List.splitAt n $ unArgs as
54 takeWhile_ f = (Args *** Args) . List.span f . unArgs
55 reachOffset = error "[BUG] P.Stream Args: reachOffset is useless here and must not be used"
56 reachOffsetNoLine = error "[BUG] P.Stream Args: reachOffsetNoLine is useless here and must not be used"
58 List.intercalate ", " $ toList $ showArg <$> toks
60 showArg :: Arg -> String
61 showArg (Arg a@('-':_)) = a
62 showArg (Arg a) = "\""<>a<>"\""
66 = Parser { unParser :: P.Parsec (ErrorRead e) Args a }
67 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
68 , P.MonadParsec (ErrorRead e) Args )
70 coerceParser :: Parser e s a -> Parser e t a
71 coerceParser = Parser . unParser
73 instance Sym_Fun Parser where
74 f <$$> Parser a = Parser $ f <$> a
75 instance Sym_App Parser where
78 Parser f <**> Parser a = Parser $ f <*> a
79 instance Sym_Alt Parser where
84 try = P.try -- FIXME: use P.observing to not catch exit
85 instance Sym_AltApp Parser where
88 instance Sym_Permutation Parser where
89 runPermutation = P.runPermutation
90 toPermutation = P.toPermutation
91 toPermutationWithDefault = P.toPermutationWithDefault
93 f <<$>> x = f <$> P.toPermutation x
94 (<<$) = (<<$>>) . const
95 f <<$?>> (d,x) = f <$> P.toPermutationWithDefault d x
96 a <<$? b = const a <<$?>> b
97 f <<$*>> x = f <$> P.toPermutationWithDefault [] (P.some x)
98 f <<$:>> x = f . Seq.fromList <$> P.toPermutationWithDefault [] (P.some x)
99 {-# INLINE (<<$>>) #-}
101 {-# INLINE (<<$?>>) #-}
102 {-# INLINE (<<$?) #-}
103 {-# INLINE (<<$*>>) #-}
104 {-# INLINE (<<$:>>) #-}
106 f <<|>> x = f <*> P.toPermutation x
107 f <<| x = f <* P.toPermutation x
108 f <<|?>> (d,x) = f <*> P.toPermutationWithDefault d x
109 f <<|? (d,x) = f <* P.toPermutationWithDefault d x
110 f <<|*>> x = f <*> P.toPermutationWithDefault [] (P.some x)
111 f <<|:>> x = f <*> P.toPermutationWithDefault Seq.empty (Seq.fromList <$$> P.some x)
112 {-# INLINE (<<|>>) #-}
114 {-# INLINE (<<|?>>) #-}
115 {-# INLINE (<<|?) #-}
116 {-# INLINE (<<|*>>) #-}
117 {-# INLINE (<<|:>>) #-}
118 type instance Sym.Permutation (Parser e s) = P.Permutation (Parser e s)
119 instance Sym_Command Parser where
121 command n p = P.token check exps *> coerceParser p
123 exps = Set.singleton $ P.Tokens $ pure exp
125 check t | t == exp = Just ()
126 | otherwise = Nothing
127 instance Sym_Option Parser where
129 Arg arg <- P.token check exps
132 Left err -> P.customFailure $ ErrorRead err
134 exps = Set.singleton $ P.Tokens $ pure exp
135 exp | List.null n = Arg "<string>"
136 | otherwise = Arg $ "<"<>n<>">"
138 tag n = P.token check exps
140 exps = Set.singleton $ P.Tokens $ pure exp
142 check t | t == exp = Just ()
143 | otherwise = Nothing
145 (*> coerceParser p) $
147 OptionNameLong l -> P.token (check expLong l) (exps $ expLong l)
148 OptionNameShort s -> P.token (check expShort s) (exps $ expShort s)
150 P.token (check expShort s) (exps $ expShort s) <|>
151 P.token (check expLong l) (exps $ expLong l)
153 exps = Set.singleton . P.Tokens . pure
154 expShort s = Arg ['-', s]
155 expLong l = Arg $ "--"<>l
156 check exp t a | a == exp t = Just ()
157 | otherwise = Nothing
158 instance Sym_Help d Parser where
160 instance Sym_Rule Parser where
161 rule _n = coerceParser
162 instance Sym_Exit Parser where
165 P.fancyFailure $ Set.singleton $
166 P.ErrorCustom $ ErrorRead e
168 -- * Type 'ErrorRead'
172 instance Show e => Show (ErrorRead e) where
173 showsPrec p (ErrorRead e) = showsPrec p e
174 instance Eq (ErrorRead a) where
176 instance Ord (ErrorRead a) where
178 instance Show e => P.ShowErrorComponent (ErrorRead e) where
179 showErrorComponent = show
182 Parser e s a -> Args ->
183 Either (P.ParseErrorBundle Args (ErrorRead e)) a
184 readArgs p = P.runParser (unParser $ p <* end) ""