1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 module Language.Symantic.CLI.Read where
7 -- import Control.Monad.Trans.Class (MonadTrans(..))
8 -- import Data.Char (Char)
9 -- import Data.Default.Class (Default(..))
10 -- import qualified Control.Monad.Trans.State as S
11 import Control.Applicative (Applicative(..), Alternative(..))
12 import Control.Arrow ((***))
13 import Control.Monad (Monad(..), MonadPlus(..))
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Foldable (Foldable(..))
18 import Data.Function (($), (.))
19 import Data.Functor (Functor(..), (<$>))
20 import Data.Maybe (Maybe(..))
21 import Data.Monoid (Monoid(..))
22 import Data.Ord (Ord(..), Ordering(..))
23 import Data.Semigroup (Semigroup(..))
24 import Data.String (String)
25 import Text.Show (Show(..))
26 import qualified Control.Monad.Trans.Reader as R
27 import qualified Data.List as List
28 import qualified Data.Set as Set
29 import qualified Text.Megaparsec as P
30 import qualified Text.Megaparsec.Perm as P
32 import Language.Symantic.CLI.Sym as Sym
35 newtype Arg = Arg { unArg :: String }
36 deriving (Eq, Ord, Show)
39 newtype Args = Args { unArgs :: [Arg] }
40 deriving (Eq, Ord, Show, Semigroup, Monoid)
41 instance P.Stream Args where
43 type Tokens Args = Args
44 tokenToChunk _s = Args . pure
45 tokensToChunk _s = Args
46 chunkToTokens _s = unArgs
47 chunkLength _s = List.length . unArgs
48 chunkEmpty _s = List.null . unArgs
49 advance1 _s _ind (P.SourcePos n l c) _ = P.SourcePos n l (c <> P.pos1)
50 advanceN s ind pos = foldl' (P.advance1 s ind) pos . unArgs
54 t:ts -> Just (t, Args ts)
55 takeN_ n as | n <= 0 = Just (Args [], as)
56 | null (unArgs as) = Nothing
57 | otherwise = Just $ (Args *** Args) $ List.splitAt n $ unArgs as
58 takeWhile_ f = (Args *** Args) . List.span f . unArgs
59 instance P.ShowToken Arg where
61 List.intercalate ", " $ toList $ showArg <$> toks
63 showArg :: Arg -> String
64 showArg (Arg a@('-':_)) = a
65 showArg (Arg a) = "\""<>a<>"\""
80 = Parser { unParser :: R.ReaderT Reader (P.Parsec (ErrorRead e) Args) a }
81 deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec (ErrorRead e) Args)
83 coerceParser :: Parser e s a -> Parser e t a
84 coerceParser = Parser . unParser
86 instance Sym_Fun Parser where
87 f <$$> Parser a = Parser $ f <$> a
88 instance Sym_App Parser where
91 Parser f <**> Parser a = Parser $ f <*> a
92 instance Sym_Alt Parser where
98 instance Sym_AltApp Parser where
101 type instance Perm (Parser e s) = P.PermParser Args (Parser e s)
102 instance Sym_Interleaved Parser where
103 interleaved = P.makePermParser
108 f <<$*>> a = f P.<$?> ([],P.some a)
109 f <<|*>> a = f P.<|?> ([],P.some a)
110 instance Sym_Command Parser where
112 command n p = P.token check (Just expected) *> coerceParser p
115 check a | a == expected = Right ()
117 ( Just $ P.Tokens $ pure t
118 , Set.singleton $ P.Tokens $ pure expected )
119 instance Sym_Option Parser where
120 var n (Parser p) = Parser $ R.local (\ro -> ro{reader_var = n}) p
122 name <- Parser $ R.asks reader_var
124 let expected | List.null name = Arg "<string>"
125 | otherwise = Arg $ "<"<>name<>">"
126 unArg <$> P.token check (Just expected)
129 let check t | t == expected = Right ()
130 | otherwise = Left ( Just $ P.Tokens $ pure t
131 , Set.singleton $ P.Tokens $ pure expected )
132 P.token check (Just expected)
134 (*> coerceParser p) $
137 P.token (checkLong l) (Just $ expectedLong l)
139 P.token (checkShort s) (Just $ expectedShort s)
141 P.token (checkShort s) (Just $ expectedShort s) <|>
142 P.token (checkLong l) (Just $ expectedLong l)
144 expectedShort s = Arg ['-', s]
145 checkShort s a | a == expectedShort s = Right ()
146 checkShort s t = Left
147 ( Just $ P.Tokens $ pure t
148 , Set.singleton $ P.Tokens $ pure $ expectedShort s)
149 expectedLong l = Arg $ "--"<>l
150 checkLong l a | a == expectedLong l = Right ()
152 ( Just $ P.Tokens $ pure t
153 , Set.singleton $ P.Tokens $ pure $ expectedLong l)
154 instance Sym_Help d Parser where
156 instance Sym_Rule Parser where
157 rule _n = coerceParser
158 instance Sym_Exit Parser where
161 P.fancyFailure $ Set.singleton $
162 P.ErrorCustom $ ErrorRead e
164 -- * Type 'ErrorRead'
167 deriving (Functor, Show)
168 instance Eq (ErrorRead a) where
170 instance Ord (ErrorRead a) where
172 instance Show e => P.ShowErrorComponent (ErrorRead e) where
173 showErrorComponent = show
175 readArgs :: Parser e s a -> Args -> Either (P.ParseError (P.Token Args) (ErrorRead e)) a
176 readArgs p = P.runParser ((`R.runReaderT` defReader) $ unParser $ p <* end) ""