repl-toolkit (empty) → 0.1.0.0
raw patch · 6 files changed
+975/−0 lines, 6 filesdep +ListLikedep +basedep +functor-monadicsetup-changed
Dependencies added: ListLike, base, functor-monadic, listsafe, monad-loops, mtl, numericpeano, parsec, text
Files
- LICENSE.md +201/−0
- Setup.hs +2/−0
- System/REPL.hs +223/−0
- System/REPL/Command.hs +426/−0
- System/REPL/State.hs +102/−0
- repl-toolkit.cabal +21/−0
+ LICENSE.md view
@@ -0,0 +1,201 @@+Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2014 Janos Tapolczai + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ System/REPL.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +-- |Functions to expedite the building of REPLs. +module System.REPL ( + -- *String-generic versions of Prelude Functions + module Data.ListLike.IO, + putErr, + putErrLn, + -- *Feture-rich reading of user-input + -- |These functions automate parsing and validating command-line + -- input via the 'Asker' type. + -- + -- It is possible to ask for Strings, but then quotes will be required + -- around them (per their Read-instance). If you want to get the user's + -- input as-is, use the 'Verbatim' type. + Asker(..), + Success(..), + AskFailure(..), + asker, + typeAsker, + predAsker, + maybeAsker, + prompt, + prompt', + Verbatim(..), + -- **Asking for input + ask, + ask', + untilValid, + ) where + +import Prelude hiding (putStrLn, putStr, getLine) + +import Control.Arrow (right, (|||)) +import Control.Exception +import Control.Monad.Except +import Data.Char (isSpace) +import Data.Functor.Monadic +import Data.ListLike() +import Data.ListLike.IO (ListLikeIO(..)) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Typeable +import qualified System.IO as IO +import Text.Read (readMaybe) + +-- Stdio +------------------------------------------------------------------------------- + +-- |Prints a string to stderr. +putErr :: ListLikeIO full item => full -> IO () +putErr = hPutStr IO.stderr + +-- |Prints a string, followed by a newline character, to stderr. +putErrLn :: ListLikeIO full item => full -> IO () +putErrLn = hPutStrLn IO.stderr + +-- |Prints @> @ and asks the user to input a line. +prompt :: (MonadIO m, Functor m, ListLikeIO full item) => m full +prompt = prompt' ("> " :: String) + +-- |Prints its first argument and, in the same line, asks the user +-- to input a line. +prompt' :: (MonadIO m, Functor m, ListLikeIO full item, ListLikeIO full' item') + => full -> m full' +prompt' s = liftIO (putStr s >> IO.hFlush IO.stdout >> getLine) + +-- Askers +------------------------------------------------------------------------------- + +-- |The description of an \'ask for user input\'-action. +-- The type parameters are the used monad (typically @IO@), +-- the type of the read value and the type of the error that is thrown +-- in case of failures. +data Asker m a = Asker{ -- |The prompt to be displayed to the user. + askerPrompt::Text, + -- |The parser for the input value, which + -- either delivers a value of type @a@ or + -- an error message. + askerParser::Text -> Either Text a, + -- |The predicate which the input, once read, + -- must fulfill. It either delivers 'Success' + -- or an error message. + askerPredicate::a -> m (Either Text Success)} + +-- |Singleton type representing success. +data Success = Success deriving (Eq, Show, Read) + +-- |Represents a failure of an ask function. +-- It can either be a type failure (failure to interpret the +-- user input as a value of the required type) or a predicate +-- failure (the user input could be interpreter as a value +-- of the required type, but it failed some user-supplied test). +data AskFailure = TypeFailure Text -- ^Indicates that the parsing as the + -- required type failed. + | PredicateFailure Text -- ^Indiciates that the parsed + -- value failed a predicate. + | ParamFailure Text + -- ^Indicates that an incorrect number of + -- parameters was passed. + | NothingFoundFailure -- ^Indicates that no action was + -- appropriate to the given input. + deriving (Typeable, Eq) + +instance Exception AskFailure + +instance Show AskFailure where + show (ParamFailure t) = T.unpack t + show NothingFoundFailure = "No appropriate action found!" + show (PredicateFailure t) = T.unpack t + show (TypeFailure t) = T.unpack t + +-- |A verbatim Text whose Read instance simply returns the read +-- string, as-is. +-- This is useful for askers which ask for strings without quotes. +newtype Verbatim = Verbatim{fromVerbatim::Text -- ^Extracts a 'Verbatim''s 'Text'. + } + +-- |Read-instance for 'Verbatim'. Wraps the given value into quotes and +-- reads it a a 'Text'. +instance Read Verbatim where + readsPrec _ s = [(Verbatim $ T.pack s,"")] + +-- |Creates a general 'Asker' with 'Data.Read.readMaybe' as its parser. +-- This suffices for most simple values. +-- The main drawback of using 'Data.Read.readMaybe' is that the input +-- 'Text' is unpacked into a String, which incurs a performance hit. +-- For short (one-line) input. this isn't important, but if large ones +-- are expected, it's better to pass a custom, 'Text'-compatible parsing +-- function, such as a parsec-parser. +asker :: (Monad m, Functor m, Read a) + => Text -- ^The prompt. + -> Text -- ^Type error message. + -> Text -- ^Predicate error message. + -> (a -> m Bool) -- ^Predicate. + -> Asker m a +asker pr errT errP pred = Asker pr parse check + where + parse = maybe (Left errT) Right . readMaybe . T.unpack + check = pred >=$> (\case True -> Right Success + False -> Left errP) + +-- |Creates an 'Asker' which just cares about the type of the input. +typeAsker :: (Monad m, Functor m, Read a) + => Text -- ^The prompt. + -> Text -- ^Type error message. + -> Asker m a +typeAsker p errT = asker p errT undefined (const $ return True) + +-- |Creates an 'Asker' which takes its input verbatim as 'Text'. +predAsker :: (Monad m, Functor m) + => Text -- ^The prompt. + -> Text -- ^Predicate error message. + -> (Text -> m Bool) -- ^The predicate. + -> Asker m Verbatim +predAsker p errP f = asker p (error "Type error in predAsker. This is a bug.") + errP (f . fromVerbatim) + +-- |An asker which asks for an optional value. If only whitespace +-- is entered (according to 'Data.Char.isSpace'), it returns 'Nothing' +-- without further parsing or checking; otherwise, it behaves identically +-- to 'asker'. +maybeAsker :: (Monad m, Functor m, Read a) + => Text -- ^The prompt. + -> Text -- ^Type error message. + -> Text -- ^Predicate error message. + -> (a -> m Bool) -- ^Predicate. + -> Asker m (Maybe a) +maybeAsker pr errT errP pred = Asker pr parse check + where + parse t = if T.all isSpace t then Right Nothing + else right Just + $ maybe (Left errT) Right + $ readMaybe + $ T.unpack t + + check Nothing = return $ Right Success + check (Just t) = pred t >$> (\case True -> Right Success + False -> Left errP) + +-- Running askers +-------------------------------------------------------------------------------- + +-- |Executes an 'Asker'. If the Text argument is Nothing, the user is asked +-- to enter a line on stdin. If it is @Just x@, @x@ is taken to be input. +-- If the input is of the wrong type, an error-message is printed +-- and the user is asked again. +-- In addition to the condition that the input must be of the correct +-- type, it must also fulfill a predicate. +-- +-- Since the predicate is of monadic, arbitrarily complex +-- tests can be performed: checking whether an item is in a database, +-- whether a date was less than x years ago, etc. +ask :: (MonadIO m, MonadError SomeException m, Functor m, Read a) + => Asker m a + -> Maybe Text + -> m a +ask a v = maybe ((liftIO . prompt' . askerPrompt $ a) >>= check) + check + v + where + check inp = + case askerParser a inp of + Left err -> throwError $ SomeException $ TypeFailure err + Right t -> askerPredicate a t + >>= (throwError . SomeException . PredicateFailure ||| return . const t) + +-- |See 'ask'. Always reads the input from stdin. +-- @ask' a = ask a Nothing@. +ask' :: (MonadIO m, MonadError SomeException m, Functor m, Read a) + => Asker m a + -> m a +ask' a = ask a Nothing + +-- |Repeatedly executes an ask action until the user enters a valid value. +-- Error messages are printed each time. +untilValid :: (MonadIO m, MonadError SomeException m, Functor m, Read a) + => m a + -> m a +untilValid m = m `catchError` (\l -> liftIO (putStrLn (show l)) >> untilValid m)
+ System/REPL/Command.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- |Provides Commands for REPLs. Commands take care of input +-- and parameter-handling, and allow parameters to be supplied +-- in the same line as the command's name (e.g. ":cmd param1 param2" on stdin). +-- Provided parameters can be parsed and checked (say, against databases) +-- before they are passed to the actual command function. +-- They are relatively large units of abstraction, but they allow the easy +-- creation of relatively sophisticated command loops, and have the advantage +-- that one doesn't need to fiddle around with input handling in the middle +-- of the actual command code. +module System.REPL.Command ( + -- *Command dispatch + -- |Using the 'Command' class is not necessary, but it makes dealing with + -- user input considerably easier. When a command is run with a line of + -- input, it automatically segments it by whitespace, tries to interpret + -- each part as one of its arguments and passes them to the actual command + -- function. If any arguments haven't been supplies, it asks for them on + -- stdin. If too many arguments have been supplied, or if any argument' + -- parsing returns an error, the command is aborted. + -- + -- Example: + -- + -- > cd = makeCommand1 ... + -- + -- >>> :cd ../ + -- Directory changed! + -- >>> :cd + -- Enter new directory: + -- >>> ../ + -- Directory changed! + Command(..), + commandInfo, + runOnce, + commandDispatch, + summarizeCommands, + readArgs, + quoteArg, + -- ** Making commands. + makeCommand, + makeCommand1, + makeCommand2, + makeCommand3, + makeCommand4, + makeCommand5, + makeCommand6, + makeCommandN, + ) where + +import Prelude hiding (putStrLn, putStr, getLine, unwords, words, (!!), (++), + length, replicate) +import qualified Prelude as P + +import Control.Arrow (left) +import Control.Exception +import Control.Monad +import Control.Monad.Except +import Control.Monad.Loops (unfoldrM) +import Data.Char (isSpace) +import Data.Functor.Monadic +import qualified Data.List as LU +import qualified Data.List.Safe as L +import Data.ListLike(ListLike(..)) +import Data.Maybe (fromJust, isNothing, isJust) +import Data.Ord +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Typeable +import Numeric.Peano +import System.REPL +import qualified Text.Parsec as P +import qualified Text.Parsec.Language as P +import qualified Text.Parsec.Token as P + +-- alias for Data.ListLike.append +(++) :: (ListLike full item) => full -> full -> full +(++) = append + +-- |A REPL command, possibly with parameters. +data Command m a = Command{ + -- |The short name of the command. Purely informative. + commandName :: Text, + -- |Returns whether a string matches + -- a command name. The simplest form is + -- @s==@ for some string s, but more liberal + -- matchings are possible. + commandTest :: Text -> Bool, + -- |A description of the command. + commandDesc :: Text, + -- |The number of parameters, if fixed. + numParameters :: Maybe Int, + -- |Runs the command with the input text as parameter. + runCommand :: Text -> m a} + +instance Functor m => Functor (Command m) where + fmap f c@Command{runCommand=run} = c{runCommand=(fmap f . run)} + +data ParamNumError = NoParams | ExactParams | TooManyParams + deriving (Enum, Show, Eq, Read, Typeable, Ord) + +-- |Prints information (the command name, description and, if given, +-- the number of parameters) about a command to the console. +commandInfo :: MonadIO m => Command m a -> m () +commandInfo c = liftIO $ do + putStr $ commandName c + putStrLn $ maybe "" ((" Parameters: " P.++) . show) (numParameters c) + putStrLn $ commandDesc c + +-- |Splits and trims the input of a command. +-- Any non-whitespace sequence of characters is interpreted as +-- one argument, unless double quotes (") are used, in which case +-- they demarcate an argument. Each argument is parsed as a haskell +-- string literal (quote-less arguments have quotes inserted around them). +-- If the number of quotes in the input is not even, the operating will fail. +-- +-- Arguments are parsed using parsec's @stringLiteral@ (haskell-style), +-- meaning that escape sequences and unicode characters are handled automatically. +readArgs :: Text -> Either Text [Text] +readArgs = (left $ T.pack . show) . P.parse parser "" . T.unpack + where + -- Main parser. + parser = P.many (stringLiteral P.<|> unquotedLiteral) + + stringLiteral = P.stringLiteral P.haskell >$> T.pack + + -- The parser for string literals without quotes around them. + -- + -- First we read a bunch of characters and then we pass the result, + -- wrapped in quotes, to the stringLiteral parser AGAIN. + -- This might seem strange, but this way, escape sequences are correctly + -- handled. The alternative would have been to copy the (private) logic + -- found in Text.Parsec.Token's source. + unquotedLiteral = + do raw <- P.many1 $ P.satisfy $ not . isSpace + P.eof P.<|> (P.many1 P.space >> return ()) + let lit = stringLiteral + res = P.parse lit "" ("\"" ++ raw ++ "\"") + case res of (Right r) -> return r + (Left l) -> fail (show l) + +-- |Takes a line of text and a command. +-- If the text matches the given command's 'commandTest', +-- the command is run with it. If not, 'Nothing' is returned. +runOnce :: MonadIO m => Text -> Command m a -> m (Maybe a) +runOnce l c = if commandTest c l then liftM Just (runCommand c l) + else return Nothing + + +-- |Returns an error message if an unexpected number of parameters have been +-- supplied. +paramErr :: Text -- ^The command name. + -> [Text] -- ^The given input. + -> Int -- ^The minimum number of parameters. + -> Nat -- ^The maximum number of parameters. May be infinite if there + -- is no upper bound. + -> ParamNumError -- ^The kind of error that occurred. + -> Text +paramErr c inp minNum maxNum errType = + "The following " ++ T.pack (show num) ++ " parameters were given to " ++ c ++ ":\n" + ++ T.intercalate " " (maybe [] (L.map wrap) $ L.tail inp) ++ ".\n" + ++ (numErr LU.!! fromEnum errType) + where + -- wraps the argument in quotation marks if it contains a space + wrap t = if T.any isSpace t then "\"" ++ t ++ "\"" else t + -- number of arguments (excluding the command name) + num = L.length inp - 1 + -- error message regarding how many parameters the command takes + numErr = [c ++ " takes no parameters.", + c ++ " takes " ++ T.pack (show minNum) ++ " parameters.", + c ++ " takes at most " ++ T.pack (show (fromPeano maxNum :: Integer)) ++ " parameters."] + +-- |Checks the number of parameters before executing a monadic function. +-- For compatibility (with the IO monad, mainly), the nominal type +-- of the thrown exception is 'SomeException', but only AskFailures will +-- actually be thrown in this function (other IO exceptions may occur). +checkParams :: (MonadIO m, MonadError SomeException m, Functor m) + => Text -- ^The command name. + -> Text -- ^The raw input (including the command name). + -> Int -- ^The minimal number of parameters, excluding the command's name. + -> Nat -- ^The maximal number of parameters, excluding the command's name. + -- This may be infinity if there is no upper bound. + -> ([Text] -> m a) -- ^The command. + -> m a -- ^Result. If too many parameters were + -- passed, this will be a 'ParamNumFailure'. +checkParams n inp minNum maxNum m = + case readArgs inp of + Left l -> throwError (SomeException $ ParamFailure l) + Right r -> + if natLength r > maxNum + 1 then + throwError $ SomeException $ ParamFailure + $ paramErr n r minNum maxNum (errKind $ natLength r) + else m r + where + errKind len = if minNum == 0 && 0 == maxNum then NoParams + else if maxNum < len then TooManyParams + else ExactParams + +-- |Surrounds an argument in quote marks, if necessary. +-- This is useful when arguments were extracted via 'readArgs', which deletes +-- quote marks. Quotes are placed around the input iff it doesn't begin with +-- a quote mark (\"). +-- 'readArgs' and 'quoteArg' are inverse up to suitable isomorphism, i.e. +-- if 'readArgs orig = (Right res)', then it holds that +-- @readArgs orig = readArgs $ intercalate " " $ map quoteArg res@ +quoteArg :: Text -> Text +quoteArg x = if T.null x || T.head x /= '\"' + then '\"' `T.cons` x `T.snoc` '\"' + else x + +-- |Creates a command without parameters. +makeCommand :: (MonadIO m, MonadError SomeException m, + Functor m) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description. + -> (Text -> m a) -- ^The actual command. + -> Command m a +makeCommand n t d f = + Command n t d (Just 0) (\inp -> checkParams n inp 0 0 c) + where + c inp = do let li = maybe "" id (L.head inp) + f li + +-- |Creates a command with one parameter. +makeCommand1 :: (MonadIO m, MonadError SomeException m, Functor m, Read a) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> (Text -> a -> m z) + -> Command m z +makeCommand1 n t d p1 f = + Command n t d (Just 1) (\inp -> checkParams n inp 1 1 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + f li x1 + +-- |Creates a command with two parameters. +makeCommand2 :: (MonadIO m, MonadError SomeException m, Functor m, Read a, + Read b) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> Asker m b -- ^'Asker' for the second perameter. + -> (Text -> a -> b -> m z) + -> Command m z +makeCommand2 n t d p1 p2 f = + Command n t d (Just 2) (\inp -> checkParams n inp 2 2 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + x2 <- ask p2 (inp L.!! 2) + f li x1 x2 + +-- |Creates a command with three parameters. +makeCommand3 :: (MonadIO m, MonadError SomeException m, Functor m, Read a, + Read b, Read c) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> Asker m b -- ^'Asker' for the second perameter. + -> Asker m c -- ^'Asker' for the third parameter. + -> (Text -> a -> b -> c -> m z) + -> Command m z +makeCommand3 n t d p1 p2 p3 f = + Command n t d (Just 3) (\inp -> checkParams n inp 3 3 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + x2 <- ask p2 (inp L.!! 2) + x3 <- ask p3 (inp L.!! 3) + f li x1 x2 x3 + +-- |Creates a command with four parameters. +makeCommand4 :: (MonadIO m, MonadError SomeException m, Functor m, Read a, + Read b, Read c, Read d) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> Asker m b -- ^'Asker' for the second perameter. + -> Asker m c -- ^'Asker' for the third parameter. + -> Asker m d -- ^'Asker' for the fourth parameter. + -> (Text -> a -> b -> c -> d -> m z) + -> Command m z +makeCommand4 n t d p1 p2 p3 p4 f = + Command n t d (Just 4) (\inp -> checkParams n inp 4 4 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + x2 <- ask p2 (inp L.!! 2) + x3 <- ask p3 (inp L.!! 3) + x4 <- ask p4 (inp L.!! 4) + f li x1 x2 x3 x4 + +-- |Creates a command with five parameters. +makeCommand5 :: (MonadIO m, MonadError SomeException m, Functor m, Read a, + Read b, Read c, Read d, Read e) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> Asker m b -- ^'Asker' for the second perameter. + -> Asker m c -- ^'Asker' for the third parameter. + -> Asker m d -- ^'Asker' for the fourth parameter. + -> Asker m e -- ^'Asker' for the fifth parameter. + -> (Text -> a -> b -> c -> d -> e -> m z) + -> Command m z +makeCommand5 n t d p1 p2 p3 p4 p5 f = + Command n t d (Just 4) (\inp -> checkParams n inp 5 5 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + x2 <- ask p2 (inp L.!! 2) + x3 <- ask p3 (inp L.!! 3) + x4 <- ask p4 (inp L.!! 4) + x5 <- ask p5 (inp L.!! 5) + f li x1 x2 x3 x4 x5 + +-- |Creates a command with four parameters. +makeCommand6 :: (MonadIO m, MonadError SomeException m, Functor m, Read a, + Read b, Read c, Read d, Read e, Read f) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> Asker m a -- ^'Asker' for the first parameter. + -> Asker m b -- ^'Asker' for the second perameter. + -> Asker m c -- ^'Asker' for the third parameter. + -> Asker m d -- ^'Asker' for the fourth parameter. + -> Asker m e -- ^'Asker' for the fifth parameter. + -> Asker m f -- ^'Asker' for the sixth parameter. + -> (Text -> a -> b -> c -> d -> e -> f -> m z) + -> Command m z +makeCommand6 n t d p1 p2 p3 p4 p5 p6 f = + Command n t d (Just 4) (\inp -> checkParams n inp 6 6 c) + where + c inp = do let li = maybe "" id (L.head inp) + x1 <- ask p1 (inp L.!! 1) + x2 <- ask p2 (inp L.!! 2) + x3 <- ask p3 (inp L.!! 3) + x4 <- ask p4 (inp L.!! 4) + x5 <- ask p5 (inp L.!! 5) + x6 <- ask p6 (inp L.!! 6) + f li x1 x2 x3 x4 x5 x6 + +-- |Creates a command with a list of parameters. +-- The first list @necc@ of 'Asker's indicates the necessary parameters; +-- the user must at least provide this many. The second list @opt@ contains +-- 'Asker's for additional, optional parameters, and may be infinite. +-- If the number of passed parameters exceeds +-- @length necc + length opt@, or if any 'Asker' fails, +-- the command returns an 'AskFailure'. +makeCommandN :: (MonadIO m, MonadError SomeException m, Functor m, Read a) + => Text -- ^Command name. + -> (Text -> Bool) -- ^Command test. + -> Text -- ^Command description + -> [Asker m a] -- ^'Asker's for the necessary parameters. + -> [Asker m a] -- ^'Asker's for the optional parameters. + -> (Text -> [a] -> m z) + -> Command m z +makeCommandN n t d necc opt f = Command n t d Nothing (\inp -> checkParams n inp min max c) + where + min = P.length necc + max = natLength necc + natLength opt + + c inp = do let li = maybe "" id (L.head inp) + neccParams <- unfoldrM (comb inp) (necc,1, Nothing) + let from = L.length neccParams + 1 + to = Just $ L.length inp - 1 + + optParams <- unfoldrM (comb inp) (opt, from, to) + f li (neccParams L.++ optParams) + + -- |Goes through the list of askers until all are done or until the first + -- AskFailure occurs. The results are of type @Either (AskFailure e) z@, + -- the state is of type @([Asker m a e], Int)@. The second component @i@ + -- indicates that the @i@th parameter is to be read. + comb _ ([],_,_) = return Nothing + comb inp (x:xs, i, j) = + if isJust j && fromJust j < i then return Nothing + else ask x (inp L.!! i) >$> args xs >$> Just + + where args ys y = (y,(ys,i+1,j)) + +-- |Takes an input and tries to run it against a list of commands, +-- trying the out in sequence. The first command whose 'commandTest' +-- returns True is executed. If none of the commands match, +-- @NothingFoundFailure@ is thrown. +commandDispatch :: (MonadIO m, MonadError SomeException m, Functor m) + => Text -- ^The user's input. + -> [Command m z] -- ^The command library. + -> m z +commandDispatch input cs = + case readArgs input of + Left l -> throwError (SomeException $ ParamFailure l) + Right input' -> if noMatch input' + then throwError (SomeException NothingFoundFailure) + else do runCommand (fromJust $ first input') input + where + noMatch = isNothing . first + firstArg = maybe "" id . L.head + first r = L.head $ P.dropWhile (not . flip commandTest (firstArg r)) cs + + +-- |Prints out a list of command names, with their descriptions. +summarizeCommands :: MonadIO m + => [Command m2 z] + -> m () +summarizeCommands [] = return () +summarizeCommands xs = liftIO $ mapM_ (\c -> prName c >> prDesc c) xs + where + maxLen :: Int + maxLen = fromIntegral + $ T.length + $ commandName + $ fromJust + $ L.minimumBy (comparing $ (* (-1)) . T.length . commandName) xs + prName = putStr . padRight ' ' maxLen . commandName + prDesc = putStrLn . (" - " ++) . commandDesc + + padRight c i cs = cs ++ replicate (i - length cs) c
+ System/REPL/State.hs view
@@ -0,0 +1,102 @@+-- |Helper functions relating to State. +module System.REPL.State ( + -- *Convenience functions for handling state + -- |These can be convenient when one wishes to + -- to extract a number of elements from the current state via pattern + -- -matching, e.g. + -- + -- @ data State = State{f::a,g::b,h::c} + -- ... + -- do (x,z) <- get2 f h + -- ...do something with x and z... @ + get1, + get2, + get3, + get4, + get5, + get6, + get7, + get8, + )where + +import Control.Arrow +import Control.Monad +import Control.Monad.State + +-- |Extracts a result from the current state. +-- Defined as @get1 f = liftM f get@. +get1 :: Monad m + => (s -> a) + -> StateT s m a +get1 f1 = liftM f1 get + +-- |Extracts two results from the current state. +get2 :: Monad m + => (s -> a) + -> (s -> b) + -> StateT s m (a,b) +get2 f1 f2 = liftM (f1 &&& f2) get + +-- |Extracts three results from the current state. +get3 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> StateT s m (a,b,c) +get3 f1 f2 f3 = liftM (\x -> (f1 x,f2 x, f3 x)) get + +-- |Extracts four results from the current state. +get4 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> (s -> d) + -> StateT s m (a,b,c,d) +get4 f1 f2 f3 f4 = liftM (\x -> (f1 x,f2 x, f3 x, f4 x)) get + +-- |Extracts five results from the current state. +get5 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> (s -> d) + -> (s -> e) + -> StateT s m (a,b,c,d,e) +get5 f1 f2 f3 f4 f5 = liftM (\x -> (f1 x,f2 x, f3 x, f4 x, f5 x)) get + +-- |Extracts six results from the current state. +get6 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> (s -> d) + -> (s -> e) + -> (s -> f) + -> StateT s m (a,b,c,d,e,f) +get6 f1 f2 f3 f4 f5 f6 = liftM (\x -> (f1 x,f2 x, f3 x, f4 x, f5 x, f6 x)) get + +-- |Extracts seven results from the current state. +get7 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> (s -> d) + -> (s -> e) + -> (s -> f) + -> (s -> g) + -> StateT s m (a,b,c,d,e,f,g) +get7 f1 f2 f3 f4 f5 f6 f7 = liftM (\x -> (f1 x,f2 x, f3 x, f4 x, f5 x, f6 x, f7 x)) get + +-- |Extracts eight results from the current state. +get8 :: Monad m + => (s -> a) + -> (s -> b) + -> (s -> c) + -> (s -> d) + -> (s -> e) + -> (s -> f) + -> (s -> g) + -> (s -> h) + -> StateT s m (a,b,c,d,e,f,g,h) +get8 f1 f2 f3 f4 f5 f6 f7 f8 = liftM (\x -> (f1 x,f2 x, f3 x, f4 x, f5 x, f6 x, f7 x, f8 x)) get +
+ repl-toolkit.cabal view
@@ -0,0 +1,21 @@+-- Initial repl-toolkit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: repl-toolkit +version: 0.1.0.0 +synopsis: Toolkit for quickly whipping up command-line interfaces. +description: A simple toolkit for quickly whipping up REPLs, input validation and sets of commands included. +homepage: https://github.com/ombocomp/repl-toolkit +license: Apache-2.0 +license-file: LICENSE.md +author: Janos Tapolczai +maintainer: janos.tapolczai@gmail.com +category: System, REPL +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: System.REPL, System.REPL.State, System.REPL.Command + other-extensions: OverloadedStrings, DeriveDataTypeable, FlexibleContexts, LambdaCase + build-depends: base >=4.7 && <5, functor-monadic >=0.1, text >=1.1, ListLike >=4.1, mtl >=2.2, parsec >=3.1, numericpeano >= 0.1, listsafe >= 0.1, monad-loops >= 0.3 + default-language: Haskell2010