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.Applicative (Applicative(..), Alternative(..))
   8 import Control.Arrow ((***))
   9 import Control.Monad (Monad(..), MonadPlus(..))
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor (Functor(..), (<$>))
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..), Ordering(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.String (String)
  21 import Text.Show (Show(..))
  22 import qualified Data.List as List
  23 import qualified Data.Set as Set
  24 import qualified Text.Megaparsec as P
  25 import qualified Text.Megaparsec.Perm as P
  26
  27 import Language.Symantic.CLI.Sym as Sym
  28
  29 -- * Type 'Arg'
  30 newtype Arg = Arg { unArg :: String }
  31  deriving (Eq, Ord, Show)
  32
  33 -- * Type 'Args'
  34 newtype Args = Args { unArgs :: [Arg] }
  35  deriving (Eq, Ord, Show, Semigroup, Monoid)
  36 instance P.Stream Args where
  37         type Token  Args = Arg
  38         type Tokens Args = Args
  39         tokenToChunk _s  = Args . pure
  40         tokensToChunk _s = Args
  41         chunkToTokens _s = unArgs
  42         chunkLength _s   = List.length . unArgs
  43         chunkEmpty _s    = List.null . unArgs
  44         advance1 _s _ind (P.SourcePos n l c) _ = P.SourcePos n l (c <> P.pos1)
  45         advanceN s ind pos = foldl' (P.advance1 s ind) pos . unArgs
  46         take1_ as =
  47                 case unArgs as of
  48                  []   -> Nothing
  49                  t:ts -> Just (t, Args ts)
  50         takeN_ n as | n <= 0    = Just (Args [], as)
  51                     | null (unArgs as) = Nothing
  52                     | otherwise = Just $ (Args *** Args) $ List.splitAt n $ unArgs as
  53         takeWhile_ f = (Args *** Args) . List.span f . unArgs
  54 instance P.ShowToken Arg where
  55         showTokens toks =
  56                 List.intercalate ", " $ toList $ showArg <$> toks
  57                 where
  58                 showArg :: Arg -> String
  59                 showArg (Arg a@('-':_)) = a
  60                 showArg (Arg a) = "\""<>a<>"\""
  61
  62 -- * Type 'Parser'
  63 newtype Parser e s a
  64  =      Parser { unParser :: P.Parsec (ErrorRead e) Args a }
  65  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec (ErrorRead e) Args)
  66
  67 coerceParser :: Parser e s a -> Parser e t a
  68 coerceParser = Parser . unParser
  69
  70 instance Sym_Fun Parser where
  71         f <$$> Parser a = Parser $ f <$> a
  72 instance Sym_App Parser where
  73         value = Parser . pure
  74         end = Parser P.eof
  75         Parser f <**> Parser a = Parser $ f <*> a
  76 instance Sym_Alt Parser where
  77         (<||>)   = (P.<|>)
  78         optional = P.optional
  79         option   = P.option
  80         choice   = P.choice
  81         try      = P.try
  82 instance Sym_AltApp Parser where
  83         many = P.many
  84         some = P.some
  85 type instance Perm (Parser e s) = P.PermParser Args (Parser e s)
  86 instance Sym_Interleaved Parser where
  87         interleaved = P.makePermParser
  88         (<<$>>)     = (P.<$$>)
  89         (<<|>>)     = (P.<||>)
  90         (<<$?>>)    = (P.<$?>)
  91         (<<|?>>)    = (P.<|?>)
  92         f <<$*>> a  = f P.<$?> ([],P.some a)
  93         f <<|*>> a  = f P.<|?> ([],P.some a)
  94 instance Sym_Command Parser where
  95         main = command
  96         command n p = P.token check (Just expected) *> coerceParser p
  97                 where
  98                 expected = Arg n
  99                 check a | a == expected = Right ()
 100                 check t = Left
 101                  ( Just $ P.Tokens $ pure t
 102                  , Set.singleton $ P.Tokens $ pure expected )
 103 instance Sym_Option Parser where
 104         var n f = do
 105                 let check = Right
 106                 let expected | List.null n = Arg "<string>"
 107                              | otherwise   = Arg $ "<"<>n<>">"
 108                 Arg arg <- P.token check (Just expected)
 109                 case f arg of
 110                  Right a -> return a
 111                  Left err -> P.customFailure $ ErrorRead err
 112         tag n = do
 113                 let expected = Arg n
 114                 let check t | t == expected = Right ()
 115                             | otherwise     = Left ( Just $ P.Tokens $ pure t
 116                                                    , Set.singleton $ P.Tokens $ pure expected )
 117                 P.token check (Just expected)
 118         opt n p =
 119                 (*> coerceParser p) $
 120                 case n of
 121                  OptionNameLong l ->
 122                         P.token (checkLong l) (Just $ expectedLong l)
 123                  OptionNameShort s ->
 124                         P.token (checkShort s) (Just $ expectedShort s)
 125                  OptionName s l ->
 126                         P.token (checkShort s) (Just $ expectedShort s) <|>
 127                         P.token (checkLong l)  (Just $ expectedLong l)
 128                 where
 129                 expectedShort s = Arg ['-', s]
 130                 checkShort s a | a == expectedShort s = Right ()
 131                 checkShort s t = Left
 132                  ( Just $ P.Tokens $ pure t
 133                  , Set.singleton $ P.Tokens $ pure $ expectedShort s)
 134                 expectedLong l = Arg $ "--"<>l
 135                 checkLong l a | a == expectedLong l = Right ()
 136                 checkLong l t = Left
 137                  ( Just $ P.Tokens $ pure t
 138                  , Set.singleton $ P.Tokens $ pure $ expectedLong l)
 139 instance Sym_Help d Parser where
 140         help _msg p = p
 141 instance Sym_Rule Parser where
 142         rule _n = coerceParser
 143 instance Sym_Exit Parser where
 144         exit e =
 145                 Parser $
 146                         P.fancyFailure $ Set.singleton $
 147                                 P.ErrorCustom $ ErrorRead e
 148
 149 -- * Type 'ErrorRead'
 150 newtype ErrorRead e
 151  =      ErrorRead e
 152  deriving (Functor)
 153 instance Show e => Show (ErrorRead e) where
 154         showsPrec p (ErrorRead e) = showsPrec p e
 155 instance Eq (ErrorRead a) where
 156         _==_ = True
 157 instance Ord (ErrorRead a) where
 158         _`compare`_ = EQ
 159 instance Show e => P.ShowErrorComponent (ErrorRead e) where
 160         showErrorComponent = show
 161
 162 readArgs :: Parser e s a -> Args -> Either (P.ParseError (P.Token Args) (ErrorRead e)) a
 163 readArgs p = P.runParser (unParser $ p <* end) ""