symantic-cli/Language/Symantic/CLI/Read.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Language.Symantic.CLI.Read where
   6
   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(..))
  14 import Data.Bool
  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
  31
  32 import Language.Symantic.CLI.Sym as Sym
  33
  34 -- * Type 'Arg'
  35 newtype Arg = Arg { unArg :: String }
  36  deriving (Eq, Ord, Show)
  37
  38 -- * Type 'Args'
  39 newtype Args = Args { unArgs :: [Arg] }
  40  deriving (Eq, Ord, Show, Semigroup, Monoid)
  41 instance P.Stream Args where
  42         type Token  Args = Arg
  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
  51         take1_ as =
  52                 case unArgs as of
  53                  []   -> Nothing
  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
  60         showTokens toks =
  61                 List.intercalate ", " $ toList $ showArg <$> toks
  62                 where
  63                 showArg :: Arg -> String
  64                 showArg (Arg a@('-':_)) = a
  65                 showArg (Arg a) = "\""<>a<>"\""
  66
  67 -- * Type 'Reader'
  68 newtype Reader
  69  =      Reader
  70  {      reader_var :: Name
  71  }
  72
  73 defReader :: Reader
  74 defReader = Reader
  75  { reader_var = ""
  76  }
  77
  78 -- * Type 'Parser'
  79 newtype Parser e s 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)
  82
  83 coerceParser :: Parser e s a -> Parser e t a
  84 coerceParser = Parser . unParser
  85
  86 instance Sym_Fun Parser where
  87         f <$$> Parser a = Parser $ f <$> a
  88 instance Sym_App Parser where
  89         value = Parser . pure
  90         end = Parser P.eof
  91         Parser f <**> Parser a = Parser $ f <*> a
  92 instance Sym_Alt Parser where
  93         (<||>)   = (P.<|>)
  94         optional = P.optional
  95         option   = P.option
  96         choice   = P.choice
  97         try      = P.try
  98 instance Sym_AltApp Parser where
  99         many = P.many
 100         some = P.some
 101 type instance Perm (Parser e s) = P.PermParser Args (Parser e s)
 102 instance Sym_Interleaved Parser where
 103         interleaved = P.makePermParser
 104         (<<$>>)     = (P.<$$>)
 105         (<<|>>)     = (P.<||>)
 106         (<<$?>>)    = (P.<$?>)
 107         (<<|?>>)    = (P.<|?>)
 108         f <<$*>> a  = f P.<$?> ([],P.some a)
 109         f <<|*>> a  = f P.<|?> ([],P.some a)
 110 instance Sym_Command Parser where
 111         main = command
 112         command n p = P.token check (Just expected) *> coerceParser p
 113                 where
 114                 expected = Arg n
 115                 check a | a == expected = Right ()
 116                 check t = Left
 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
 121         string = do
 122                 name <- Parser $ R.asks reader_var
 123                 let check = Right
 124                 let expected | List.null name = Arg "<string>"
 125                              | otherwise      = Arg $ "<"<>name<>">"
 126                 unArg <$> P.token check (Just expected)
 127         tag n = do
 128                 let expected = Arg n
 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)
 133         opt n p =
 134                 (*> coerceParser p) $
 135                 case n of
 136                  OptionNameLong l ->
 137                         P.token (checkLong l) (Just $ expectedLong l)
 138                  OptionNameShort s ->
 139                         P.token (checkShort s) (Just $ expectedShort s)
 140                  OptionName s l ->
 141                         P.token (checkShort s) (Just $ expectedShort s) <|>
 142                         P.token (checkLong l)  (Just $ expectedLong l)
 143                 where
 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 ()
 151                 checkLong l t = Left
 152                  ( Just $ P.Tokens $ pure t
 153                  , Set.singleton $ P.Tokens $ pure $ expectedLong l)
 154 instance Sym_Help d Parser where
 155         help _msg p = p
 156 instance Sym_Rule Parser where
 157         rule _n = coerceParser
 158 instance Sym_Exit Parser where
 159         exit e =
 160                 Parser $
 161                         P.fancyFailure $ Set.singleton $
 162                                 P.ErrorCustom $ ErrorRead e
 163
 164 -- * Type 'ErrorRead'
 165 newtype ErrorRead e
 166  =      ErrorRead e
 167  deriving (Functor, Show)
 168 instance Eq (ErrorRead a) where
 169         _==_ = True
 170 instance Ord (ErrorRead a) where
 171         _`compare`_ = EQ
 172 instance Show e => P.ShowErrorComponent (ErrorRead e) where
 173         showErrorComponent = show
 174
 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) ""