Symantic/CLI/Read.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Symantic.CLI.Read where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Applicative.Permutations as P
   9 import Control.Arrow ((***))
  10 import Control.Monad (Monad(..), MonadPlus(..))
  11 import Data.Bool
  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
  28
  29 import Symantic.CLI.Sym as Sym
  30
  31 -- * Type 'Arg'
  32 newtype Arg = Arg { unArg :: String }
  33  deriving (Eq, Ord, Show)
  34 -- TODO: first pass separating options from non-options.
  35
  36 -- * Type 'Args'
  37 newtype Args = Args { unArgs :: [Arg] }
  38  deriving (Eq, Ord, Show, Semigroup, Monoid)
  39 instance P.Stream Args where
  40         type Token  Args = Arg
  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
  47         take1_ as =
  48                 case unArgs as of
  49                  []   -> Nothing
  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"
  57         showTokens _s toks =
  58                 List.intercalate ", " $ toList $ showArg <$> toks
  59                 where
  60                 showArg :: Arg -> String
  61                 showArg (Arg a@('-':_)) = a
  62                 showArg (Arg a) = "\""<>a<>"\""
  63
  64 -- * Type 'Parser'
  65 newtype Parser e s a
  66  =      Parser { unParser :: P.Parsec (ErrorRead e) Args a }
  67  deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
  68           , P.MonadParsec (ErrorRead e) Args )
  69
  70 coerceParser :: Parser e s a -> Parser e t a
  71 coerceParser = Parser . unParser
  72
  73 instance Sym_Fun Parser where
  74         f <$$> Parser a = Parser $ f <$> a
  75 instance Sym_App Parser where
  76         value = Parser . pure
  77         end = Parser P.eof
  78         Parser f <**> Parser a = Parser $ f <*> a
  79 instance Sym_Alt Parser where
  80         (<||>)   = (P.<|>)
  81         optional = P.optional
  82         option   = P.option
  83         choice   = P.choice
  84         try      = P.try -- FIXME: use P.observing to not catch exit
  85 instance Sym_AltApp Parser where
  86         many = P.many
  87         some = P.some
  88 instance Sym_Permutation Parser where
  89         runPermutation           = P.runPermutation
  90         toPermutation            = P.toPermutation
  91         toPermutationWithDefault = P.toPermutationWithDefault
  92
  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 (<<$>>) #-}
 100         {-# INLINE (<<$) #-}
 101         {-# INLINE (<<$?>>) #-}
 102         {-# INLINE (<<$?) #-}
 103         {-# INLINE (<<$*>>) #-}
 104         {-# INLINE (<<$:>>) #-}
 105
 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 (<<|>>) #-}
 113         {-# 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
 120         main = command
 121         command n p = P.token check exps *> coerceParser p
 122                 where
 123                 exps = Set.singleton $ P.Tokens $ pure exp
 124                 exp = Arg n
 125                 check t | t == exp  = Just ()
 126                         | otherwise = Nothing
 127 instance Sym_Option Parser where
 128         var n f = do
 129                 Arg arg <- P.token check exps
 130                 case f arg of
 131                  Right a -> return a
 132                  Left err -> P.customFailure $ ErrorRead err
 133                 where
 134                 exps = Set.singleton $ P.Tokens $ pure exp
 135                 exp | List.null n = Arg "<string>"
 136                     | otherwise   = Arg $ "<"<>n<>">"
 137                 check = Just
 138         tag n = P.token check exps
 139                 where
 140                 exps = Set.singleton $ P.Tokens $ pure exp
 141                 exp = Arg n
 142                 check t | t == exp  = Just ()
 143                         | otherwise = Nothing
 144         opt n p =
 145                 (*> coerceParser p) $
 146                 case n of
 147                  OptionNameLong  l -> P.token (check expLong  l) (exps $ expLong l)
 148                  OptionNameShort s -> P.token (check expShort s) (exps $ expShort s)
 149                  OptionName s l ->
 150                         P.token (check expShort s) (exps $ expShort s) <|>
 151                         P.token (check expLong l)  (exps $ expLong l)
 152                 where
 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
 159         help _msg p = p
 160 instance Sym_Rule Parser where
 161         rule _n = coerceParser
 162 instance Sym_Exit Parser where
 163         exit e =
 164                 Parser $
 165                         P.fancyFailure $ Set.singleton $
 166                                 P.ErrorCustom $ ErrorRead e
 167
 168 -- * Type 'ErrorRead'
 169 newtype ErrorRead e
 170  =      ErrorRead e
 171  deriving (Functor)
 172 instance Show e => Show (ErrorRead e) where
 173         showsPrec p (ErrorRead e) = showsPrec p e
 174 instance Eq (ErrorRead a) where
 175         _==_ = True
 176 instance Ord (ErrorRead a) where
 177         _`compare`_ = EQ
 178 instance Show e => P.ShowErrorComponent (ErrorRead e) where
 179         showErrorComponent = show
 180
 181 readArgs ::
 182  Parser e s a -> Args ->
 183  Either (P.ParseErrorBundle Args (ErrorRead e)) a
 184 readArgs p = P.runParser (unParser $ p <* end) ""