repl-toolkit 1.0.0.1 → 1.0.1.0
raw patch · 11 files changed
+1792/−1771 lines, 11 filessetup-changed
Files
- LICENSE.md +201/−201
- Setup.hs +2/−2
- System/REPL.hs +22/−22
- System/REPL/Ask.hs +318/−317
- System/REPL/Command.hs +688/−685
- System/REPL/Config.hs +83/−83
- System/REPL/Prompt.hs +67/−67
- System/REPL/State.hs +102/−102
- System/REPL/Types.hs +242/−242
- changelog.txt +13/−11
- repl-toolkit.cabal +54/−39
LICENSE.md view
@@ -1,201 +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-2015 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.+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-2015 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
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
System/REPL.hs view
@@ -1,22 +1,22 @@--- |Contents:--- --- [/Ask/]--- Asking the user for input in a principled way.--- Reading, parsing errors, predicate checks are all handled.------ [/Command/]--- The main module of the package. Functions for creating--- commands, which can receive and ask for arguments.--- Commands are composable and can be built into a REPL.------ [/Config/]--- Read configuration files in various formats.-module System.REPL (- module System.REPL.Ask,- module System.REPL.Command,- module System.REPL.Config,- ) where--import System.REPL.Ask-import System.REPL.Command-import System.REPL.Config+-- |Contents: +-- +-- [/Ask/] +-- Asking the user for input in a principled way. +-- Reading, parsing errors, predicate checks are all handled. +-- +-- [/Command/] +-- The main module of the package. Functions for creating +-- commands, which can receive and ask for arguments. +-- Commands are composable and can be built into a REPL. +-- +-- [/Config/] +-- Read configuration files in various formats. +module System.REPL ( + module System.REPL.Ask, + module System.REPL.Command, + module System.REPL.Config, + ) where + +import System.REPL.Ask +import System.REPL.Command +import System.REPL.Config
System/REPL/Ask.hs view
@@ -1,317 +1,318 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}---- |Asking the user for input on the console.------ The main type is 'Asker', which takes care of parsing--- and verifying user input.-module System.REPL.Ask (- -- *Types- PromptMsg,- TypeError,- PredicateError,- Predicate,- Predicate',- Parser,- Asker(..),- Asker',- -- ** Exceptions- SomeREPLError(..),- SomeAskerError(..),- AskerTypeError(..),- AskerPredicateError(..),- GenericTypeError(..),- GenericPredicateError(..),- genericTypeError,- genericPredicateError,- -- * Creating askers- -- |These are all just convenience functions.- -- You can also create 'Asker's directly via the constructor.- --- -- For errors, you can supply a custom exception or use 'GenericTypeError',- -- 'GenericPredicateError'.- typeAskerP,- maybeAskerP,- -- **Creating askers via 'Read'- -- |These askers use 'Text.Read.readMaybe' as their parser.- --- -- It is possible to ask for Strings, but then quotes will be required- -- around them (per their Read-instance). To get the user's- -- input as-is, use the 'Verbatim' type or 'predAsker'.- Verbatim(..),- readParser,- asker,- lineAsker,- typeAsker,- predAsker,- maybeAsker,- -- *Running askers- -- |Created askers can be run via these functions.- -- Since the parsing depends on the Read-instance, the expected result type- -- must be explicitly given. E.g.:- --- -- @- -- intAsker :: Asker IO Int- -- intAsker = typeAsker "> " "Expected Int!"- -- @- --- -- or, for polymorphic askers,- --- -- @- -- genericAsk :: Read a => Asker IO a- -- genericAsk = typeAsker "> " "Couldn't parse value!"- -- ...- -- do (x :: Int) <- genericAsk- -- (y :: Int) <- genericAsk- -- putStrLn $ "The sum is: " ++ show (x+y)- -- @- ask,- ask',- askEither,- untilValid,- -- *Creating predicates- boolPredicate,- -- *Example askers- -- |A few askers for convenience.- PathRootDoesNotExist(..),- PathIsNotWritable(..),- filepathAsker,- writablefilepathAsker,- ) where--import Prelude hiding (putStrLn, putStr, getLine, reverse)--import Control.Arrow (right, (|||))-import Control.Monad.Catch-import Control.Monad.IO.Class (MonadIO(liftIO))-import Data.Char (isSpace)-import Data.Functor.Monadic-import qualified Data.List as L-import qualified Data.Text as T-import qualified System.Directory as D-import qualified System.FilePath as FP-import qualified System.IO.Error as ERR-import System.REPL.Prompt-import System.REPL.Types-import Text.Read (readMaybe)---- Askers------------------------------------------------------------------------------------ |Creates an 'Asker' which only cares about the type of the input.-typeAskerP :: Applicative m- => PromptMsg- -> Parser a- -> Asker' m a-typeAskerP pr parse = Asker pr parse (pure . Right)---- |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'.-maybeAskerP :: Applicative m- => PromptMsg- -> Parser a- -> Predicate m a b- -> Asker m (Maybe a) (Maybe b)-maybeAskerP pr parse pred = Asker pr parse' check- where- parse' t = if T.all isSpace t then Right Nothing- else right Just $ parse t-- check Nothing = pure $ Right Nothing- check (Just t) = pred t >$> (\case Right t -> Right (Just t)- Left err -> Left err)---- Parsers based on Read------------------------------------------------------------------------------------ |A parser based on 'Text.Read.readMaybe'. This suffices for the parsing of--- most data types.-readParser :: Read a- => (T.Text -> TypeError)- -> Parser a-readParser errT t = maybe (Left $ errT t) Right . readMaybe . T.unpack $ t---- |Creates a general 'Asker' with 'Text.Read.readMaybe' as its parser.--- Using 'Data.Read.readMaybe' is perfectly fine for most values, keep in mind--- that the input Text has to be unpacked into a string. This can be costly--- on very large inputs.------ __NOTE:__ Instances of String/Text have to be surrounded with quotes (\").--- You practically never want this when asking for input.--- If you want to get the user input as-is, restrict the return type to--- @Asker m Verbatim@ or use 'predAsker'/'lineAsker'.-asker :: (Functor m, Read a)- => PromptMsg- -> (T.Text -> TypeError)- -> Predicate' m a- -> Asker' m a-asker pr errT pred = Asker pr (readParser errT) pred---- |Creates an 'Asker' based on Read which just cares about the type of the input.-typeAsker :: (Applicative m, Read a)- => PromptMsg- -> (T.Text -> TypeError)- -> Asker' m a-typeAsker p errT = asker p errT (pure . Right)---- |Creates an 'Asker' which takes its input verbatim as 'Text'.--- Quotes around the input are not required.--- The input thus only has to pass a predicate, not any parsing.-predAsker :: (Functor m)- => PromptMsg- -> Predicate m T.Text b- -> Asker m T.Text b-predAsker pr f = Asker pr Right f---- |A wrapper aroung 'getLine'. Prints no prompt and returns the user input as-is.-lineAsker :: Applicative m- => Asker' m T.Text-lineAsker = predAsker "" (pure . Right)---- |An asker based on Read which asks for an optional value.-maybeAsker :: (Applicative m, Read a)- => PromptMsg- -> (T.Text -> TypeError)- -> Predicate' m a- -> Asker' m (Maybe a)-maybeAsker pr errT pred = maybeAskerP pr (readParser errT) pred---- Running askers------------------------------------------------------------------------------------- |Executes an Asker. A 'SomeAskerError' is thrown if the inpout can't be--- parsing into a value of the correct type, if the input fails the 'Asker''s--- predicate, or if the escape key is pressed.-ask :: (MonadIO m, MonadCatch m)- => Asker m a b- -> Maybe T.Text- -> m b-ask a v = askEither a v >>= either throwM return---- |See 'ask'. Always reads the input from stdin.------ @--- ask' a = ask a Nothing--- @-ask' :: (MonadIO m, MonadCatch m)- => Asker m a b- -> m b-ask' a = ask a Nothing---- |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.--- --- Pressing the escape key returns a 'AskerInputAborterError' (if supported).-askEither :: (MonadIO m, MonadCatch m)- => Asker m a b- -> Maybe T.Text- -> m (Either SomeAskerError b)-askEither a = maybe getInput check- where- getInput = (promptAbort '\ESC' (askerPrompt a) >>= check)- `catch` (return . Left)-- check inp = case askerParser a inp of- Left err -> return . Left . SomeAskerError . AskerTypeError $ err- Right t -> askerPredicate a t- >>= return . (Left . SomeAskerError . AskerPredicateError ||| Right)---- |Repeatedly executes an ask action until the user enters a valid value.--- Error messages are printed each time.-untilValid :: forall m a.(MonadIO m, MonadCatch m, Read a)- => m a- -> m a-untilValid m = m `catch` handler- where- handler :: SomeAskerError -> m a- handler l = liftIO (putStrLn $ show l) >> untilValid m---- Creating predicates------------------------------------------------------------------------------------ |Creates a predicate from a boolean function and an error message.-boolPredicate :: Functor m- => (a -> m Bool)- -> (a -> PredicateError)- -> Predicate' m a-boolPredicate f errP t = (\case {True -> Right t; False -> Left (errP t)}) <$> f t---- Example askers------------------------------------------------------------------------------------ |Asks the user for a file or a directory.--- --- Parsing checks for basic validity via 'System.FilePath.isValid'. Invalid paths are rejected.------ After that, the asker determines whether the target exists and what type--- it has. You can run a predicate on that information.-filepathAsker :: MonadIO m- => PromptMsg- -> (FilePath -> TypeError)- -> Predicate m (PathExistenceType, FilePath) b- -> Asker m FilePath b-filepathAsker pr errT pred = Asker pr parse pred'- where- parse = (\fp -> if FP.isValid fp then Right fp else Left $ errT fp) . T.unpack-- pred' fp = do- exType <- liftIO $ getExistenceType fp- pred (exType, fp)- --return $ if ok then Right (exType, fp)- -- else Left $ errP (exType, fp)-- getExistenceType :: FilePath -> IO PathExistenceType- getExistenceType fp = do- isDir <- D.doesDirectoryExist fp- if isDir then return IsDirectory- else do isFile <- D.doesFileExist fp- return $ if isFile then IsFile- else DoesNotExist---- |See 'filepathAsker'. This 'Asker' also ensures that the given path--- is writeable in the following sense:------ * at least some initial part of the path exists and--- * the last existing part of the path is writeable.------ 'PathRootDoesNotExist' and 'PathIsNotWritable' exceptions are thrown if the--- first or second of these conditions is violated.------ For relative paths, we only check that the current directory is writable.------ Handled exceptions:------ * 'System.IO.Error.isPermissionError'--- * 'System.IO.Error.isDoesNotExistError'-writablefilepathAsker- :: MonadIO m- => PromptMsg- -> (FilePath -> TypeError)- -> Predicate m (PathExistenceType, FilePath) b- -> Asker m FilePath b-writablefilepathAsker pr errT pred = filepathAsker pr errT pred'- where- permError e = if ERR.isPermissionErrorType (ERR.ioeGetErrorType e) ||- ERR.isDoesNotExistErrorType (ERR.ioeGetErrorType e)- then Just () else Nothing- conc :: [FilePath] -> FilePath- conc = L.foldl' (FP.</>) ""- doesExist fp = (||) <$> D.doesDirectoryExist (conc fp) <*> D.doesFileExist (conc fp)-- isWritable fp = catchJust permError (fp >>= D.getPermissions >$> D.writable) (const $ return False)-- -- A utility function which gets a bool and returns the second argument if its value is false,- -- and the third if its true.- boolEither :: (Monad m, Exception a) => (m Bool) -> a -> m (Either SomeException b) -> m (Either SomeException b)- boolEither x falseCase trueCase = x >>= (\case{True -> trueCase; False -> return $ Left $ SomeException falseCase})-- pred' args@(_, fp) = - if FP.isRelative fp then boolEither (liftIO $ isWritable D.getCurrentDirectory) (PathIsNotWritable fp) (pred args)- else do- existingRoot <- liftIO $ takeWhile snd <$> mapM (\x -> (x,) <$> doesExist x) (L.inits $ FP.splitDirectories fp)- if null existingRoot then return (Left $ SomeException $ PathRootDoesNotExist fp)- else boolEither (liftIO $ isWritable (return . conc . fst . last $ existingRoot)) (PathIsNotWritable fp) (pred args)+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- |Asking the user for input on the console. +-- +-- The main type is 'Asker', which takes care of parsing +-- and verifying user input. +module System.REPL.Ask ( + -- *Types + PromptMsg, + TypeError, + PredicateError, + Predicate, + Predicate', + Parser, + Asker(..), + Asker', + -- ** Exceptions + SomeREPLError(..), + SomeAskerError(..), + AskerTypeError(..), + AskerPredicateError(..), + GenericTypeError(..), + GenericPredicateError(..), + genericTypeError, + genericPredicateError, + -- * Creating askers + -- |These are all just convenience functions. + -- You can also create 'Asker's directly via the constructor. + -- + -- For errors, you can supply a custom exception or use 'GenericTypeError', + -- 'GenericPredicateError'. + typeAskerP, + maybeAskerP, + -- **Creating askers via 'Read' + -- |These askers use 'Text.Read.readMaybe' as their parser. + -- + -- It is possible to ask for Strings, but then quotes will be required + -- around them (per their Read-instance). To get the user's + -- input as-is, use the 'Verbatim' type or 'predAsker'. + Verbatim(..), + readParser, + asker, + lineAsker, + typeAsker, + predAsker, + maybeAsker, + -- *Running askers + -- |Created askers can be run via these functions. + -- Since the parsing depends on the Read-instance, the expected result type + -- must be explicitly given. E.g.: + -- + -- @ + -- intAsker :: Asker IO Int + -- intAsker = typeAsker "> " "Expected Int!" + -- @ + -- + -- or, for polymorphic askers, + -- + -- @ + -- genericAsk :: Read a => Asker IO a + -- genericAsk = typeAsker "> " "Couldn't parse value!" + -- ... + -- do (x :: Int) <- genericAsk + -- (y :: Int) <- genericAsk + -- putStrLn $ "The sum is: " ++ show (x+y) + -- @ + ask, + ask', + askEither, + untilValid, + -- *Creating predicates + boolPredicate, + -- *Example askers + -- |A few askers for convenience. + PathRootDoesNotExist(..), + PathIsNotWritable(..), + PathExistenceType(..), + filepathAsker, + writableFilepathAsker, + ) where + +import Prelude hiding (putStrLn, putStr, getLine, reverse) + +import Control.Arrow (right, (|||)) +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Char (isSpace) +import Data.Functor.Monadic +import qualified Data.List as L +import qualified Data.Text as T +import qualified System.Directory as D +import qualified System.FilePath as FP +import qualified System.IO.Error as ERR +import System.REPL.Prompt +import System.REPL.Types +import Text.Read (readMaybe) + +-- Askers +------------------------------------------------------------------------------- + +-- |Creates an 'Asker' which only cares about the type of the input. +typeAskerP :: Applicative m + => PromptMsg + -> Parser a + -> Asker' m a +typeAskerP pr parse = Asker pr parse (pure . Right) + +-- |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'. +maybeAskerP :: Applicative m + => PromptMsg + -> Parser a + -> Predicate m a b + -> Asker m (Maybe a) (Maybe b) +maybeAskerP pr parse pred = Asker pr parse' check + where + parse' t = if T.all isSpace t then Right Nothing + else right Just $ parse t + + check Nothing = pure $ Right Nothing + check (Just t) = pred t >$> (\case Right t -> Right (Just t) + Left err -> Left err) + +-- Parsers based on Read +------------------------------------------------------------------------------- + +-- |A parser based on 'Text.Read.readMaybe'. This suffices for the parsing of +-- most data types. +readParser :: Read a + => (T.Text -> TypeError) + -> Parser a +readParser errT t = maybe (Left $ errT t) Right . readMaybe . T.unpack $ t + +-- |Creates a general 'Asker' with 'Text.Read.readMaybe' as its parser. +-- Using 'Data.Read.readMaybe' is perfectly fine for most values, keep in mind +-- that the input Text has to be unpacked into a string. This can be costly +-- on very large inputs. +-- +-- __NOTE:__ Instances of String/Text have to be surrounded with quotes (\"). +-- You practically never want this when asking for input. +-- If you want to get the user input as-is, restrict the return type to +-- @Asker m Verbatim@ or use 'predAsker'/'lineAsker'. +asker :: (Functor m, Read a) + => PromptMsg + -> (T.Text -> TypeError) + -> Predicate' m a + -> Asker' m a +asker pr errT pred = Asker pr (readParser errT) pred + +-- |Creates an 'Asker' based on Read which just cares about the type of the input. +typeAsker :: (Applicative m, Read a) + => PromptMsg + -> (T.Text -> TypeError) + -> Asker' m a +typeAsker p errT = asker p errT (pure . Right) + +-- |Creates an 'Asker' which takes its input verbatim as 'Text'. +-- Quotes around the input are not required. +-- The input thus only has to pass a predicate, not any parsing. +predAsker :: (Functor m) + => PromptMsg + -> Predicate m T.Text b + -> Asker m T.Text b +predAsker pr f = Asker pr Right f + +-- |A wrapper around 'getLine'. Prints no prompt and returns the user input as-is. +lineAsker :: Applicative m + => Asker' m T.Text +lineAsker = predAsker "" (pure . Right) + +-- |An asker based on Read which asks for an optional value. +maybeAsker :: (Applicative m, Read a) + => PromptMsg + -> (T.Text -> TypeError) + -> Predicate' m a + -> Asker' m (Maybe a) +maybeAsker pr errT pred = maybeAskerP pr (readParser errT) pred + +-- Running askers +-------------------------------------------------------------------------------- + +-- |Executes an Asker. A 'SomeAskerError' is thrown if the inpout can't be +-- parsing into a value of the correct type, if the input fails the 'Asker''s +-- predicate, or if the escape key is pressed. +ask :: (MonadIO m, MonadCatch m) + => Asker m a b + -> Maybe T.Text + -> m b +ask a v = askEither a v >>= either throwM return + +-- |See 'ask'. Always reads the input from stdin. +-- +-- @ +-- ask' a = ask a Nothing +-- @ +ask' :: (MonadIO m, MonadCatch m) + => Asker m a b + -> m b +ask' a = ask a Nothing + +-- |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. +-- +-- Pressing the escape key returns a 'AskerInputAborterError' (if supported). +askEither :: (MonadIO m, MonadCatch m) + => Asker m a b + -> Maybe T.Text + -> m (Either SomeAskerError b) +askEither a = maybe getInput check + where + getInput = (promptAbort '\ESC' (askerPrompt a) >>= check) + `catch` (return . Left) + + check inp = case askerParser a inp of + Left err -> return . Left . SomeAskerError . AskerTypeError $ err + Right t -> askerPredicate a t + >>= return . (Left . SomeAskerError . AskerPredicateError ||| Right) + +-- |Repeatedly executes an ask action until the user enters a valid value. +-- Error messages are printed each time. +untilValid :: forall m a.(MonadIO m, MonadCatch m, Read a) + => m a + -> m a +untilValid m = m `catch` handler + where + handler :: SomeAskerError -> m a + handler l = liftIO (putStrLn $ show l) >> untilValid m + +-- Creating predicates +------------------------------------------------------------------------------- + +-- |Creates a predicate from a boolean function and an error message. +boolPredicate :: Functor m + => (a -> m Bool) + -> (a -> PredicateError) + -> Predicate' m a +boolPredicate f errP t = (\case {True -> Right t; False -> Left (errP t)}) <$> f t + +-- Example askers +------------------------------------------------------------------------------- + +-- |Asks the user for a file or a directory. +-- +-- Parsing checks for basic validity via 'System.FilePath.isValid'. Invalid paths are rejected. +-- +-- After that, the asker determines whether the target exists and what type +-- it has. You can run a predicate on that information. +filepathAsker :: MonadIO m + => PromptMsg + -> (FilePath -> TypeError) + -> Predicate m (PathExistenceType, FilePath) b + -> Asker m FilePath b +filepathAsker pr errT pred = Asker pr parse pred' + where + parse = (\fp -> if FP.isValid fp then Right fp else Left $ errT fp) . T.unpack + + pred' fp = do + exType <- liftIO $ getExistenceType fp + pred (exType, fp) + --return $ if ok then Right (exType, fp) + -- else Left $ errP (exType, fp) + + getExistenceType :: FilePath -> IO PathExistenceType + getExistenceType fp = do + isDir <- D.doesDirectoryExist fp + if isDir then return IsDirectory + else do isFile <- D.doesFileExist fp + return $ if isFile then IsFile + else DoesNotExist + +-- |See 'filepathAsker'. This 'Asker' also ensures that the given path +-- is writeable in the following sense: +-- +-- * at least some initial part of the path exists and +-- * the last existing part of the path is writeable. +-- +-- 'PathRootDoesNotExist' and 'PathIsNotWritable' exceptions are thrown if the +-- first or second of these conditions is violated. +-- +-- For relative paths, we only check that the current directory is writable. +-- +-- Handled exceptions: +-- +-- * 'System.IO.Error.isPermissionError' +-- * 'System.IO.Error.isDoesNotExistError' +writableFilepathAsker + :: MonadIO m + => PromptMsg + -> (FilePath -> TypeError) + -> Predicate m (PathExistenceType, FilePath) b + -> Asker m FilePath b +writableFilepathAsker pr errT pred = filepathAsker pr errT pred' + where + permError e = if ERR.isPermissionErrorType (ERR.ioeGetErrorType e) || + ERR.isDoesNotExistErrorType (ERR.ioeGetErrorType e) + then Just () else Nothing + conc :: [FilePath] -> FilePath + conc = L.foldl' (FP.</>) "" + doesExist fp = (||) <$> D.doesDirectoryExist (conc fp) <*> D.doesFileExist (conc fp) + + isWritable fp = catchJust permError (fp >>= D.getPermissions >$> D.writable) (const $ return False) + + -- A utility function which gets a bool and returns the second argument if its value is false, + -- and the third if its true. + boolEither :: (Monad m, Exception a) => (m Bool) -> a -> m (Either SomeException b) -> m (Either SomeException b) + boolEither x falseCase trueCase = x >>= (\case{True -> trueCase; False -> return $ Left $ SomeException falseCase}) + + pred' args@(_, fp) = + if FP.isRelative fp then boolEither (liftIO $ isWritable D.getCurrentDirectory) (PathIsNotWritable fp) (pred args) + else do + existingRoot <- liftIO $ takeWhile snd <$> mapM (\x -> (x,) <$> doesExist x) (L.inits $ FP.splitDirectories fp) + if null existingRoot then return (Left $ SomeException $ PathRootDoesNotExist fp) + else boolEither (liftIO $ isWritable (return . conc . fst . last $ existingRoot)) (PathIsNotWritable fp) (pred args)
System/REPL/Command.hs view
@@ -1,685 +1,688 @@-{-# LANGUAGE OverloadedStrings #-}---- |Provides Commands for REPLs. Commands are there to provide high-level--- handling of user input and to offer functionality in a standard, composable--- way.------ Whereas an 'Asker' is good for getting a single value, a 'Command' can get--- multiple inputs and be composed with other commands.------ Use cases:------ 1. Getting specific numbers of arguments or optional arguments from the user. E.g.------ @--- \{\-\# LANGUAGE OverloadedStrings \#\-\}--- --- import Data.Text (unpack)------ asker :: Asker' IO String--- asker = Asker "Enter argument: " (Right . unpack) (return . Right)------ cmd = makeCommand3 "command" ("command"==) "description" True [asker,asker,asker] (\t x y z -> putStrLn "yay!")--- @--- --- This is a command with 3 arguments. The user can enter the arguments--- in the same line or give them one by one:------ >>> command arg1 arg2 arg3--- yay!------ >>> command--- Enter argument:--- >>> arg1--- Enter argument:--- >>> arg2--- Enter argument:--- >>> arg3--- yay!--- --- Had we set the bool above to @False@, only the first form would have been allowed.------ Arguments can contain whitespace if they are surrounded with quotes:------ >>> command "arg1 with spaces" arg2 arg3--- yay!------ Optional arguments are also possible:------ @--- cmd = makeCommandN "command" ("command"==) "description" True [asker] [optAsker]--- (\t (x:xs) -> do putStrLn ("Required argument: " ++ x)--- if null xs then putStrLn "No optional argument."--- else putStrLn ("Optional argument: " ++ head xs))--- @------ >>> command arg1--- Required argument: arg1--- --- >>> command arg1 arg2--- Required argument: arg1--- Optional argument: arg2------ 2. Creating command hierarchies, e.g.------ @--- commit = makeCommand 1 "commit" ...--- sendEmail = makeCommand "send-email"--- sendTweet = makeCommand "send-tweet"------ commit' = subcommand commit [sendEmail, sendTweet]------ main = makeREPLSimple [commit']--- @--- --- >>> myVersionControl commit "my first commit" send-email------ Here, @commit@ is the root command and @sendEmail@, @sendTweet@ its two--- possible sub-commands. The sub-commands get executed after their root command.------ 3. Making a REPL out of some commands.------ As above, one can use 'makeREPL' or 'makeREPLSimple' to create a --- REPL out of a list of commands and use it as the @main@ function instead--- of going through the chore of writing a loop it by hand.-module System.REPL.Command (- -- *Command class- Command(..),- oneOf,- subcommand,- -- **Running commands- -- |You can use 'runPartialCommand' to run a command as well, but one generally doesn't want left-over input.- runCommand,- runSingleCommand,- runSingleCommandIf,- -- **Making REPLs- makeREPL,- makeREPLSimple,- -- *Exceptions- -- |These are the exceptions that can be thrown during the course of command- -- invocation (in addition to those that you throw yourself, of course).- --- -- SomeCommandError is an abstract exception and all others are its concrete- -- subclasses. See the example in "Control.Exception" for details.- SomeREPLError(..),- SomeCommandError(..),- MalformedParamsError(..),- TooFewParamsError(..),- TooManyParamsError(..),- -- * Dealing with arguments- readArgs,- getName,- defCommandTest,- quoteArg,- -- * Helpers- summarizeCommands,- -- * Making commands- -- |Ignore the "a0"-type parameters in the Askers.- makeCommand,- makeCommand1,- makeCommand2,- makeCommand3,- makeCommand4,- makeCommand5,- makeCommand6,- makeCommand7,- makeCommand8,- makeCommandN,- -- * Example commands.- -- |A few commands for convenience.- noOpCmd,- defExitCmd,- defHelpCmd,- defErrorHandler,- ) where--import Prelude hiding (putStrLn, putStr, (++), length, replicate)-import qualified Prelude as P--import Control.Monad-import Control.Monad.Catch-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Loops (unfoldrM, iterateUntil)-import Data.Char (isSpace)-import qualified Data.Functor.Bind as Bi-import Data.Functor.Monadic-import qualified Data.List as LU-import qualified Data.List.Safe as L-import Data.ListLike(ListLike(..))-import Data.ListLike.IO (ListLikeIO(..))-import Data.Maybe (fromJust, isJust, fromMaybe)-import Data.Ord-import qualified Data.Text as T-import System.REPL.Ask-import System.REPL.Types-import qualified System.REPL.Prompt as PR-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---- |Runs the command with the input text as parameter, discarding any left-over--- input. The command test is disregarded.--- --- Can throw:--- --- * 'MalformedParamsError'-runCommand :: (MonadThrow m) => Command m T.Text a -> T.Text -> m a-runCommand c = fmap fst . runPartialCommand c <=< readArgs---- |Runs the command with the input text as parameter.--- The command test is disregarded.------ Can throw:--- --- * 'MalformedParamsError'--- * 'TooManyParamsError', if any input is left unconsumed.------ __Note:__ 'TooManyParamsError' will only be thrown after the command's execution--- is attempted. This is because of the subcommand mechanism, which prevents the--- static determination of the number of required arguments.-runSingleCommand :: (MonadThrow m) => Command m T.Text a -> T.Text -> m a-runSingleCommand c t = fromJust <$> runSingleCommandIf (c{commandTest = const True}) t---- |Runs the command with the input text as parameter. If the input doesn't--- pass the command test, @Nothing@ is returned.------ Can throw:--- --- * 'MalformedParamsError'--- * 'TooManyParamsError', if any input is left unconsumed.-runSingleCommandIf :: MonadThrow m => Command m T.Text a -> T.Text -> m (Maybe a)-runSingleCommandIf c t = do- t' <- readArgs t- if L.null t' || not (commandTest c $ LU.head t') then return Nothing- else do- (res, output) <- runPartialCommand c t'- let act = length t'- mx = act - length output- when (not . L.null $ output) (throwM $ TooManyParamsError mx act)- return $ Just res----- |Takes a list @xs@ and executes the first command in a list whose--- 'commandTest' matches the input.------ Note that the resultant command @c@'s' 'runPartialCommand' should only be--- executed with an input @t@ if 'commandTest c t' == True', where @t'@ is either--- @head (readArgs t)@ or @mempty@ if @t@ is empty.--- Otherwise, the result is undefined.-oneOf :: Monoid i- => T.Text- -- ^Command name.- -> T.Text- -- ^Command description.- -> [Command m i a]- -> Command m i a-oneOf n d xs = Command n test d cmd- where- test t = L.any (($ t) . commandTest) xs- -- because of @test@, the list is guaranteed to be non-empty- cmd input = (`runPartialCommand` input)- . LU.head- . L.dropWhile (not . ($ fromMaybe mempty (L.head input)) . commandTest) $ xs---- |Adds a list of possible subcommands after a command (that should leave--- some input unconsumed). Ignoring all the required parameters for a moment,------ > subcommand x xs = x >>- oneOf xs-subcommand :: (Monad m, Monoid i)- => Command m i a- -- ^The root command.- -> [a -> Command m i b]- -- ^The subcommands that may follow it. This list must be finite.- -> Command m i b-subcommand x xs = x Bi.>>- \y -> oneOf "" "" (L.map ($ y) xs)---- |Splits and trims the input of a command. If the input cannot be parsed, a--- 'MalformedParamsError' exception is thrown.------ === Format------ 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).------ Arguments are parsed using parsec's @stringLiteral@ (haskell-style),--- meaning that escape sequences and unicode characters are handled automatically.-readArgs :: MonadThrow m => T.Text -> m [T.Text]-readArgs = either err return . P.parse parser "" . T.unpack- where- err = throwM . MalformedParamsError . T.pack . show- -- 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)---- |Gets the first part of a command string. Returns Nothing--- if the string is empty of if 'readArgs' throws a 'MalformedParamsError'.-getName :: T.Text -> Maybe T.Text-getName = readArgs >=> L.head---- |The "default" command test for making commands.--- This function uses 'getName' to extract the first part of the user input,--- stripping whitespace and also checking whether the entire input is well-formed.-defCommandTest :: [T.Text] -- ^Command names, including permissible aliases.- -> T.Text -- ^User input.- -> Bool-defCommandTest xs = maybe False (`L.elem` xs) . getName---- |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 is empty or contains--- whitespace.-quoteArg :: T.Text -> T.Text-quoteArg x = if T.null x || T.any isSpace x then '\"' `T.cons` x `T.snoc` '\"'- else x---- |Creates a command without parameters.-makeCommand :: (MonadIO m, MonadCatch m, Monoid i)- => T.Text -- ^Command name.- -> (i -> Bool) -- ^Command test.- -> T.Text -- ^Command description.- -> (i -> m z)- -- ^Command function. It will receive the first part of the input- -- (customarily the command name), or the empty string if the- -- input only contained whitespace.- -> Command m i z-makeCommand n t d f = Command n t d f'- where- f' args = do res <- f $ fromMaybe mempty $ L.head args- return (res, L.drop 1 args)----- |Creates a command with one parameter.-makeCommand1 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -- If True, running the command will run the Asker's- -- IO action if not enough input is provided. If False- -- a 'TooFewParamsError' will be thrown.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> (T.Text -> a -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand1 n t d canAsk p1 f = Command n t d f'- where- mx = 1- f' args = do let x0 = fromMaybe mempty $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- res <- f x0 x1- return (res, L.drop (mx+1) args)---- |Creates a command with two parameters.-makeCommand2 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> (T.Text -> a -> b -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand2 n t d canAsk p1 p2 f = Command n t d f'- where- mx = 2- f' args = do let x0 = fromMaybe mempty $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- res <- f x0 x1 x2- return (res, L.drop (mx+1) args)---- |Creates a command with three parameters.-makeCommand3 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> (T.Text -> a -> b -> c -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand3 n t d canAsk p1 p2 p3 f = Command n t d f'- where- mx = 3- f' args = do let x0 = fromMaybe "" $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- res <- f x0 x1 x2 x3- return (res, L.drop (mx+1) args)---- |Creates a command with four parameters.-makeCommand4 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> Asker m d0 d -- ^'Asker' for the fourth parameter.- -> (T.Text -> a -> b -> c -> d -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand4 n t d canAsk p1 p2 p3 p4 f = Command n t d f'- where- mx = 4- f' args = do let x0 = fromMaybe "" $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- x4 <- askC p4 args 4- res <- f x0 x1 x2 x3 x4- return (res, L.drop (mx+1) args)---- |Creates a command with five parameters.-makeCommand5 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> Asker m d0 d -- ^'Asker' for the fourth parameter.- -> Asker m e0 e -- ^'Asker' for the fifth parameter.- -> (T.Text -> a -> b -> c -> d -> e -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand5 n t d canAsk p1 p2 p3 p4 p5 f = Command n t d f'- where- mx = 5- f' args = do let x0 = fromMaybe "" $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- x4 <- askC p4 args 4- x5 <- askC p5 args 5- res <- f x0 x1 x2 x3 x4 x5- return (res, L.drop (mx+1) args)---- |Creates a command with six parameters.-makeCommand6 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> Asker m d0 d -- ^'Asker' for the fourth parameter.- -> Asker m e0 e -- ^'Asker' for the fifth parameter.- -> Asker m f0 f -- ^'Asker' for the sixth parameter.- -> (T.Text -> a -> b -> c -> d -> e -> f -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand6 n t d canAsk p1 p2 p3 p4 p5 p6 f = Command n t d f'- where- mx = 6- f' args = do let x0 = fromMaybe mempty $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- x4 <- askC p4 args 4- x5 <- askC p5 args 5- x6 <- askC p6 args 6- res <- f x0 x1 x2 x3 x4 x5 x6- return (res, L.drop (mx+1) args)---- |Creates a command with seven parameters.-makeCommand7 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> Asker m d0 d -- ^'Asker' for the fourth parameter.- -> Asker m e0 e -- ^'Asker' for the fifth parameter.- -> Asker m f0 f -- ^'Asker' for the sixth parameter.- -> Asker m g0 g -- ^'Asker' for the seventh parameter.- -> (T.Text -> a -> b -> c -> d -> e -> f -> g -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand7 n t d canAsk p1 p2 p3 p4 p5 p6 p7 f = Command n t d f'- where- mx = 7- f' args = do let x0 = fromMaybe "" $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- x4 <- askC p4 args 4- x5 <- askC p5 args 5- x6 <- askC p6 args 6- x7 <- askC p7 args 7- res <- f x0 x1 x2 x3 x4 x5 x6 x7- return (res, L.drop (mx+1) args)---- |Creates a command with eight parameters.-makeCommand8 :: (MonadIO m, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input.- -> Asker m a0 a -- ^'Asker' for the first parameter.- -> Asker m b0 b -- ^'Asker' for the second parameter.- -> Asker m c0 c -- ^'Asker' for the third parameter.- -> Asker m d0 d -- ^'Asker' for the fourth parameter.- -> Asker m e0 e -- ^'Asker' for the fifth parameter.- -> Asker m f0 f -- ^'Asker' for the sixth parameter.- -> Asker m g0 g -- ^'Asker' for the seventh parameter.- -> Asker m h0 h -- ^'Asker' for the eighth parameter.- -> (T.Text -> a -> b -> c -> d -> e -> f -> g -> h -> m z) -- ^Command function.- -> Command m T.Text z-makeCommand8 n t d canAsk p1 p2 p3 p4 p5 p6 p7 p8 f = Command n t d f'- where- mx = 8- f' args = do let x0 = fromMaybe "" $ L.head args- when (not canAsk) $ checkParamNum args mx- x1 <- askC p1 args 1- x2 <- askC p2 args 2- x3 <- askC p3 args 3- x4 <- askC p4 args 4- x5 <- askC p5 args 5- x6 <- askC p6 args 6- x7 <- askC p7 args 7- x8 <- askC p8 args 8- res <- f x0 x1 x2 x3 x4 x5 x6 x7 x8- return (res, L.drop (mx+1) args)----- |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, MonadCatch m)- => T.Text -- ^Command name.- -> (T.Text -> Bool) -- ^Command test.- -> T.Text -- ^Command description- -> Bool -- ^Whether the command can ask for input. This only- -- affects the necessary parameters.- -> [Asker m a0 a] -- ^'Asker's for the necessary parameters.- -> [Asker m b0 a] -- ^'Asker's for the optional parameters.- -> (T.Text -> [a] -> m z)- -> Command m T.Text z-makeCommandN n t d canAsk necc opt f = Command n t d f'- where- min = P.length necc-- f' args = do when (not canAsk) $ checkParamNum args min- neccParams <- unfoldrM (comb args) (necc,1, Nothing)- let x0 = maybe "" id (L.head args)- from = L.length neccParams + 1- to = Just $ L.length args - 1- optParams <- unfoldrM (comb args) (opt, from, to)- let params = neccParams L.++ optParams- res <- f x0 params- return (res, L.drop (length params + 1) args)-- -- |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 askC x inp i >$> args xs >$> Just- where- args ys y = (y,(ys,i+1,j))---- |Prints out a list of command names, with their descriptions.-summarizeCommands :: MonadIO m- => [Command m2 i 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---- |Throws a 'TooFewParamsError' if the length of the list is smaller than the second argument.-checkParamNum :: MonadThrow m => [a] -> Int -> m ()-checkParamNum xs need = if have < need then throwM $ TooFewParamsError need have else return ()- where have = length xs - 1 ---- |Wrapper for 'ask'.-askC :: (MonadIO m, MonadCatch m)- => Asker m a0 a -> [T.Text] -> Int -> m a-askC f xs i = ask f (xs L.!! i)----askC False f xs j i = maybe (throwM $ TooFewParamsError j (length xs - 1)) (ask f . Just) (xs L.!! i)---- |Runs a REPL based on a set of commands.--- For a line of input, the commands are tried in following order:------ * the "exit" command,--- * all regular commands, and then--- * the "unknown" command.-makeREPL :: (MonadIO m, MonadCatch m)- => [Command m T.Text a]- -- ^The regular commands.- -> Command m T.Text b- -- ^The "exit" command which terminates the loop.- -> Command m T.Text c- -- ^The command that is called when none of the others match.- -- This one's 'commandTest' is replaced with @const True@.- -> m T.Text- -- ^The asker to execute before each command (i.e. the prompt).- -> [Handler m ()]- -- ^List of Handlers for any exceptions that may arise.- -- The exception hierchy is rooted in 'SomeREPLError'.- -- See "System.REPL.Types".- -> m ()- -- ^Asks the user repeatedly for input, until the input matches- -- the command test of the "exit" command.-makeREPL regular exit unknown prompt handlers = void $ iterateUntil id iter- where- iter = (prompt >>= runSingleCommand allCommands)- `catches` handlers'-- handlers' = fmap (\(Handler f) -> Handler (\e -> f e >> return False)) handlers- exit' = fmap (const True) exit- regular' = L.map (fmap (const False)) regular- unknown' = fmap (const False) $ unknown{commandTest = const True}-- allCommands = oneOf "" "" (exit' : regular' ++ [unknown'])---- |A variant of 'makeREPL' with some default settings:------ * The "exit" command is 'defExitCmd'.--- * The "unknown" command prints "Unknown command: <user input>".--- * The prompt is "> ".--- * The error handler is 'defErrorHandler'.-makeREPLSimple :: (MonadIO m, MonadCatch m)- => [Command m T.Text a]- -> m ()-makeREPLSimple regular = makeREPL regular defExitCmd unknownCmd PR.prompt defErrorHandler- where- unknownCmd = makeCommandN "" (const True) "" False [] (repeat lineAsker)- (\t _ -> liftIO $ PR.putStrLn $ "Unknown command: " ++ t)---- Example commands------------------------------------------------------------------------------------ |A command that takes no arguments and does nothing.-noOpCmd :: (MonadIO m, MonadCatch m)- => T.Text- -- ^Command name.- -> [T.Text]- -- ^Alternative names for the command. The user can either- -- the command name or any of the alternative names.- --- -- E.g. "exit" with alternative names ":e", ":quit".- -> Command m T.Text ()-noOpCmd n ns = makeCommand n ((`L.elem` (n:ns)) . T.strip) "" (const $ return ())---- |A command with the name ":exit" and the description--- "Exits the program." Otherwise, it does nothing.------ You can use this as the exit-command for 'makeREPL',--- if no special clean-up is needed upon quitting.-defExitCmd :: (MonadIO m, MonadCatch m)- => Command m T.Text ()-defExitCmd = makeCommand n ((n==) . T.strip) "Exits the program." (const $ return ())- where- n = ":exit"---- |A help-command with the name ":help" and the--- description "Prints this help text."------ It goes through the given list of commands and prints--- the name and description of each one.-defHelpCmd :: (MonadIO m, MonadCatch m, Foldable f)- => f (Command m0 a b)- -> Command m T.Text ()-defHelpCmd cmds = makeCommand n ((n==) . T.strip) "Prints this help text." help- where- n = ":help"- help _ = liftIO $ mapM_ (\x -> putStrLn $ commandName x ++ " - " ++ commandDesc x) cmds---- |A default error handler that catches 'SomeREPLError' and prints it to stdout.------ Useful in combination with 'makeREPL'.-defErrorHandler :: MonadIO m- => [Handler m ()]-defErrorHandler = [Handler h]- where- h :: MonadIO m => SomeREPLError -> m ()- h = liftIO . print+{-# LANGUAGE OverloadedStrings #-} + +-- |Provides Commands for REPLs. Commands are there to provide high-level +-- handling of user input and to offer functionality in a standard, composable +-- way. +-- +-- Whereas an 'Asker' is good for getting a single value, a 'Command' can get +-- multiple inputs and be composed with other commands. +-- +-- Use cases: +-- +-- 1. Getting specific numbers of arguments or optional arguments from the user. E.g. +-- +-- @ +-- \{\-\# LANGUAGE OverloadedStrings \#\-\} +-- +-- import Data.Text (unpack) +-- +-- asker :: Asker' IO String +-- asker = Asker "Enter argument: " (Right . unpack) (return . Right) +-- +-- cmd = makeCommand3 "command" ("command"==) "description" True [asker,asker,asker] (\t x y z -> putStrLn "yay!") +-- @ +-- +-- This is a command with 3 arguments. The user can enter the arguments +-- in the same line or give them one by one: +-- +-- >>> command arg1 arg2 arg3 +-- yay! +-- +-- >>> command +-- Enter argument: +-- >>> arg1 +-- Enter argument: +-- >>> arg2 +-- Enter argument: +-- >>> arg3 +-- yay! +-- +-- Had we set the bool above to @False@, only the first form would have been allowed. +-- +-- Arguments can contain whitespace if they are surrounded with quotes: +-- +-- >>> command "arg1 with spaces" arg2 arg3 +-- yay! +-- +-- Optional arguments are also possible: +-- +-- @ +-- cmd = makeCommandN "command" ("command"==) "description" True [asker] [optAsker] +-- (\t (x:xs) -> do putStrLn ("Required argument: " ++ x) +-- if null xs then putStrLn "No optional argument." +-- else putStrLn ("Optional argument: " ++ head xs)) +-- @ +-- +-- >>> command arg1 +-- Required argument: arg1 +-- +-- >>> command arg1 arg2 +-- Required argument: arg1 +-- Optional argument: arg2 +-- +-- 2. Creating command hierarchies, e.g. +-- +-- @ +-- commit = makeCommand 1 "commit" ... +-- sendEmail = makeCommand "send-email" +-- sendTweet = makeCommand "send-tweet" +-- +-- commit' = subcommand commit [sendEmail, sendTweet] +-- +-- main = makeREPLSimple [commit'] +-- @ +-- +-- >>> myVersionControl commit "my first commit" send-email +-- +-- Here, @commit@ is the root command and @sendEmail@, @sendTweet@ its two +-- possible sub-commands. The sub-commands get executed after their root command. +-- +-- 3. Making a REPL out of some commands. +-- +-- As above, one can use 'makeREPL' or 'makeREPLSimple' to create a +-- REPL out of a list of commands and use it as the @main@ function instead +-- of going through the chore of writing a loop it by hand. +module System.REPL.Command ( + -- *Command class + Command(..), + oneOf, + subcommand, + -- **Running commands + -- |You can use 'runPartialCommand' to run a command as well, but one generally doesn't want left-over input. + runCommand, + runSingleCommand, + runSingleCommandIf, + -- **Making REPLs + makeREPL, + makeREPLSimple, + -- *Exceptions + -- |These are the exceptions that can be thrown during the course of command + -- invocation (in addition to those that you throw yourself, of course). + -- + -- SomeCommandError is an abstract exception and all others are its concrete + -- subclasses. See the example in "Control.Exception" for details. + SomeREPLError(..), + SomeCommandError(..), + MalformedParamsError(..), + TooFewParamsError(..), + TooManyParamsError(..), + -- * Dealing with arguments + readArgs, + getName, + defCommandTest, + quoteArg, + -- * Helpers + summarizeCommands, + -- * Making commands + -- |Ignore the "a0"-type parameters in the Askers. + makeCommand, + makeCommand1, + makeCommand2, + makeCommand3, + makeCommand4, + makeCommand5, + makeCommand6, + makeCommand7, + makeCommand8, + makeCommandN, + -- * Example commands. + -- |A few commands for convenience. + noOpCmd, + defExitCmd, + defHelpCmd, + defErrorHandler, + ) where + +import Prelude hiding (putStrLn, putStr, (++), length, replicate) +import qualified Prelude as P + +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Loops (unfoldrM, iterateUntil) +import Data.Char (isSpace) +import qualified Data.Functor.Bind as Bi +import Data.Functor.Monadic +import qualified Data.List as LU +import qualified Data.List.Safe as L +import Data.ListLike(ListLike(..)) +import Data.ListLike.IO (ListLikeIO(..)) +import Data.Maybe (fromJust, isJust, fromMaybe) +import Data.Ord +import qualified Data.Text as T +import System.REPL.Ask +import System.REPL.Types +import qualified System.REPL.Prompt as PR +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 + +-- |Runs the command with the input text as parameter, discarding any left-over +-- input. The command test is disregarded. +-- +-- Can throw: +-- +-- * 'MalformedParamsError' +runCommand :: (MonadThrow m) => Command m T.Text a -> T.Text -> m a +runCommand c = fmap fst . runPartialCommand c <=< readArgs + +-- |Runs the command with the input text as parameter. +-- The command test is disregarded. +-- +-- Can throw: +-- +-- * 'MalformedParamsError' +-- * 'TooManyParamsError', if any input is left unconsumed. +-- +-- __Note:__ 'TooManyParamsError' will only be thrown after the command's execution +-- is attempted. This is because of the subcommand mechanism, which prevents the +-- static determination of the number of required arguments. +runSingleCommand :: (MonadThrow m) => Command m T.Text a -> T.Text -> m a +runSingleCommand c t = fromJust <$> runSingleCommandIf (c{commandTest = const True}) t + +-- |Runs the command with the input text as parameter. If the input doesn't +-- pass the command test, @Nothing@ is returned. +-- +-- Can throw: +-- +-- * 'MalformedParamsError' +-- * 'TooManyParamsError', if any input is left unconsumed. +runSingleCommandIf :: MonadThrow m => Command m T.Text a -> T.Text -> m (Maybe a) +runSingleCommandIf c t = do + t' <- readArgs t + if L.null t' || not (commandTest c $ LU.head t') then return Nothing + else do + (res, output) <- runPartialCommand c t' + let act = length t' + mx = act - length output + when (not . L.null $ output) (throwM $ TooManyParamsError mx act) + return $ Just res + + +-- |Takes a list @xs@ and executes the first command in a list whose +-- 'commandTest' matches the input. +-- +-- Note that the resultant command @c@'s' 'runPartialCommand' should only be +-- executed with an input @t@ if 'commandTest c t' == True', where @t'@ is either +-- @head (readArgs t)@ or @mempty@ if @t@ is empty. +-- Otherwise, the result is undefined. +oneOf :: Monoid i + => T.Text + -- ^Command name. + -> T.Text + -- ^Command description. + -> [Command m i a] + -> Command m i a +oneOf n d xs = Command n test d cmd + where + test t = L.any (($ t) . commandTest) xs + -- because of @test@, the list is guaranteed to be non-empty + cmd input = (`runPartialCommand` input) + . LU.head + . L.dropWhile (not . ($ fromMaybe mempty (L.head input)) . commandTest) $ xs + +-- |Adds a list of possible subcommands after a command (that should leave +-- some input unconsumed). Ignoring all the required parameters for a moment, +-- +-- > subcommand x xs = x >>- oneOf xs +subcommand :: (Monad m, Monoid i) + => Command m i a + -- ^The root command. + -> [a -> Command m i b] + -- ^The subcommands that may follow it. This list must be finite. + -> Command m i b +subcommand x xs = x Bi.>>- \y -> oneOf "" "" (L.map ($ y) xs) + +-- |Splits and trims the input of a command. If the input cannot be parsed, a +-- 'MalformedParamsError' exception is thrown. +-- +-- === Format +-- +-- 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). +-- +-- Arguments are parsed using parsec's @stringLiteral@ (haskell-style), +-- meaning that escape sequences and unicode characters are handled automatically. +readArgs :: MonadThrow m => T.Text -> m [T.Text] +readArgs = either err return . P.parse parser "" . T.unpack + where + err = throwM . MalformedParamsError . T.pack . show + -- 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) + +-- |Gets the first part of a command string. Returns Nothing +-- if the string is empty or if 'readArgs' throws a 'MalformedParamsError'. +getName :: T.Text -> Maybe T.Text +getName = readArgs >=> L.head + +-- |The "default" command test for making commands. +-- This function uses 'getName' to extract the first part of the user input, +-- stripping whitespace and also checking whether the entire input is well-formed. +defCommandTest :: [T.Text] -- ^Command names, including permissible aliases. + -> T.Text -- ^User input. + -> Bool +defCommandTest xs = maybe False (`L.elem` xs) . getName + +-- |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 is empty or contains +-- whitespace. +quoteArg :: T.Text -> T.Text +quoteArg x = if T.null x || T.any isSpace x then '\"' `T.cons` x `T.snoc` '\"' + else x + +-- |Creates a command without parameters. +makeCommand :: (MonadIO m, MonadCatch m, Monoid i) + => T.Text -- ^Command name. + -> (i -> Bool) -- ^Command test. + -> T.Text -- ^Command description. + -> (i -> m z) + -- ^Command function. It will receive the first part of the input + -- (customarily the command name), or the empty string if the + -- input only contained whitespace. + -> Command m i z +makeCommand n t d f = Command n t d f' + where + f' args = do res <- f $ fromMaybe mempty $ L.head args + return (res, L.drop 1 args) + + +-- |Creates a command with one parameter. +makeCommand1 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -- If True, running the command will run the Asker's + -- IO action if not enough input is provided. If False + -- a 'TooFewParamsError' will be thrown. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> (T.Text -> a -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand1 n t d canAsk p1 f = Command n t d f' + where + mx = 1 + f' args = do let x0 = fromMaybe mempty $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + res <- f x0 x1 + return (res, L.drop (mx+1) args) + +-- |Creates a command with two parameters. +makeCommand2 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> (T.Text -> a -> b -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand2 n t d canAsk p1 p2 f = Command n t d f' + where + mx = 2 + f' args = do let x0 = fromMaybe mempty $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + res <- f x0 x1 x2 + return (res, L.drop (mx+1) args) + +-- |Creates a command with three parameters. +makeCommand3 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> (T.Text -> a -> b -> c -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand3 n t d canAsk p1 p2 p3 f = Command n t d f' + where + mx = 3 + f' args = do let x0 = fromMaybe "" $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + res <- f x0 x1 x2 x3 + return (res, L.drop (mx+1) args) + +-- |Creates a command with four parameters. +makeCommand4 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> Asker m d0 d -- ^'Asker' for the fourth parameter. + -> (T.Text -> a -> b -> c -> d -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand4 n t d canAsk p1 p2 p3 p4 f = Command n t d f' + where + mx = 4 + f' args = do let x0 = fromMaybe "" $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + x4 <- askC p4 args 4 + res <- f x0 x1 x2 x3 x4 + return (res, L.drop (mx+1) args) + +-- |Creates a command with five parameters. +makeCommand5 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> Asker m d0 d -- ^'Asker' for the fourth parameter. + -> Asker m e0 e -- ^'Asker' for the fifth parameter. + -> (T.Text -> a -> b -> c -> d -> e -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand5 n t d canAsk p1 p2 p3 p4 p5 f = Command n t d f' + where + mx = 5 + f' args = do let x0 = fromMaybe "" $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + x4 <- askC p4 args 4 + x5 <- askC p5 args 5 + res <- f x0 x1 x2 x3 x4 x5 + return (res, L.drop (mx+1) args) + +-- |Creates a command with six parameters. +makeCommand6 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> Asker m d0 d -- ^'Asker' for the fourth parameter. + -> Asker m e0 e -- ^'Asker' for the fifth parameter. + -> Asker m f0 f -- ^'Asker' for the sixth parameter. + -> (T.Text -> a -> b -> c -> d -> e -> f -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand6 n t d canAsk p1 p2 p3 p4 p5 p6 f = Command n t d f' + where + mx = 6 + f' args = do let x0 = fromMaybe mempty $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + x4 <- askC p4 args 4 + x5 <- askC p5 args 5 + x6 <- askC p6 args 6 + res <- f x0 x1 x2 x3 x4 x5 x6 + return (res, L.drop (mx+1) args) + +-- |Creates a command with seven parameters. +makeCommand7 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> Asker m d0 d -- ^'Asker' for the fourth parameter. + -> Asker m e0 e -- ^'Asker' for the fifth parameter. + -> Asker m f0 f -- ^'Asker' for the sixth parameter. + -> Asker m g0 g -- ^'Asker' for the seventh parameter. + -> (T.Text -> a -> b -> c -> d -> e -> f -> g -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand7 n t d canAsk p1 p2 p3 p4 p5 p6 p7 f = Command n t d f' + where + mx = 7 + f' args = do let x0 = fromMaybe "" $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + x4 <- askC p4 args 4 + x5 <- askC p5 args 5 + x6 <- askC p6 args 6 + x7 <- askC p7 args 7 + res <- f x0 x1 x2 x3 x4 x5 x6 x7 + return (res, L.drop (mx+1) args) + +-- |Creates a command with eight parameters. +makeCommand8 :: (MonadIO m, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. + -> Asker m a0 a -- ^'Asker' for the first parameter. + -> Asker m b0 b -- ^'Asker' for the second parameter. + -> Asker m c0 c -- ^'Asker' for the third parameter. + -> Asker m d0 d -- ^'Asker' for the fourth parameter. + -> Asker m e0 e -- ^'Asker' for the fifth parameter. + -> Asker m f0 f -- ^'Asker' for the sixth parameter. + -> Asker m g0 g -- ^'Asker' for the seventh parameter. + -> Asker m h0 h -- ^'Asker' for the eighth parameter. + -> (T.Text -> a -> b -> c -> d -> e -> f -> g -> h -> m z) -- ^Command function. + -> Command m T.Text z +makeCommand8 n t d canAsk p1 p2 p3 p4 p5 p6 p7 p8 f = Command n t d f' + where + mx = 8 + f' args = do let x0 = fromMaybe "" $ L.head args + when (not canAsk) $ checkParamNum args mx + x1 <- askC p1 args 1 + x2 <- askC p2 args 2 + x3 <- askC p3 args 3 + x4 <- askC p4 args 4 + x5 <- askC p5 args 5 + x6 <- askC p6 args 6 + x7 <- askC p7 args 7 + x8 <- askC p8 args 8 + res <- f x0 x1 x2 x3 x4 x5 x6 x7 x8 + return (res, L.drop (mx+1) args) + + +-- |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, MonadCatch m) + => T.Text -- ^Command name. + -> (T.Text -> Bool) -- ^Command test. + -> T.Text -- ^Command description + -> Bool -- ^Whether the command can ask for input. This only + -- affects the necessary parameters. + -> [Asker m a0 a] -- ^'Asker's for the necessary parameters. + -> [Asker m b0 a] -- ^'Asker's for the optional parameters. + -> (T.Text -> [a] -> m z) + -> Command m T.Text z +makeCommandN n t d canAsk necc opt f = Command n t d f' + where + min = P.length necc + + f' args = do when (not canAsk) $ checkParamNum args min + neccParams <- unfoldrM (comb args) (necc,1, Nothing) + let x0 = maybe "" id (L.head args) + from = L.length neccParams + 1 + to = Just $ L.length args - 1 + optParams <- unfoldrM (comb args) (opt, from, to) + let params = neccParams L.++ optParams + res <- f x0 params + return (res, L.drop (length params + 1) args) + + -- |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 askC x inp i >$> args xs >$> Just + where + args ys y = (y,(ys,i+1,j)) + +-- |Prints out a list of command names, with their descriptions. +summarizeCommands :: MonadIO m + => [Command m2 i 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 + +-- |Throws a 'TooFewParamsError' if the length of the list is smaller than the second argument. +checkParamNum :: MonadThrow m => [a] -> Int -> m () +checkParamNum xs need = if have < need then throwM $ TooFewParamsError need have else return () + where have = length xs - 1 + +-- |Wrapper for 'ask'. +askC :: (MonadIO m, MonadCatch m) + => Asker m a0 a -> [T.Text] -> Int -> m a +askC f xs i = ask f (xs L.!! i) + +--askC False f xs j i = maybe (throwM $ TooFewParamsError j (length xs - 1)) (ask f . Just) (xs L.!! i) + +-- |Runs a REPL based on a set of commands. +-- For a line of input, the commands are tried in following order: +-- +-- * the "exit" command, +-- * all regular commands, and then +-- * the "unknown" command. +makeREPL :: (MonadIO m, MonadCatch m) + => [Command m T.Text a] + -- ^The regular commands. + -> Command m T.Text b + -- ^The "exit" command which terminates the loop. + -> Command m T.Text c + -- ^The command that is called when none of the others match. + -- This one's 'commandTest' is replaced with @const True@. + -> m T.Text + -- ^The asker to execute before each command (i.e. the prompt). + -> [Handler m ()] + -- ^List of Handlers for any exceptions that may arise. + -- The exception hierchy is rooted in 'SomeREPLError'. + -- See "System.REPL.Types". + -> m () + -- ^Asks the user repeatedly for input, until the input matches + -- the command test of the "exit" command. +makeREPL regular exit unknown prompt handlers = void $ iterateUntil id iter + where + iter = (prompt >>= runSingleCommand allCommands) + `catches` handlers' + + handlers' = fmap (\(Handler f) -> Handler (\e -> f e >> return False)) handlers + exit' = fmap (const True) exit + regular' = L.map (fmap (const False)) regular + unknown' = fmap (const False) $ unknown{commandTest = const True} + + allCommands = oneOf "" "" (exit' : regular' ++ [unknown']) + +-- |A variant of 'makeREPL' with some default settings: +-- +-- * The "exit" command is 'defExitCmd'. +-- * The "unknown" command prints "Unknown command: <user input>". +-- * The prompt is "> ". +-- * The error handler is 'defErrorHandler'. +makeREPLSimple :: (MonadIO m, MonadCatch m) + => [Command m T.Text a] + -> m () +makeREPLSimple regular = makeREPL regular defExitCmd unknownCmd PR.prompt defErrorHandler + where + unknownCmd = makeCommandN "" (const True) "" False [] (repeat lineAsker) + (\t _ -> liftIO $ PR.putStrLn $ "Unknown command: " ++ t) + +-- Example commands +------------------------------------------------------------------------------- + +-- |A command that takes no arguments and does nothing. +noOpCmd :: (MonadIO m, MonadCatch m) + => T.Text + -- ^Command name. + -> [T.Text] + -- ^Alternative names for the command. The user can either + -- the command name or any of the alternative names. + -- + -- E.g. "exit" with alternative names ":e", ":quit". + -> Command m T.Text () +noOpCmd n ns = makeCommand n ((`L.elem` (n:ns)) . T.strip) "" (const $ return ()) + +-- |A command with the name ":exit" and the description +-- "Exits the program." Otherwise, it does nothing. +-- +-- You can use this as the exit-command for 'makeREPL', +-- if no special clean-up is needed upon quitting. +defExitCmd :: (MonadIO m, MonadCatch m) + => Command m T.Text () +defExitCmd = makeCommand n ((n==) . T.strip) "Exits the program." (const $ return ()) + where + n = ":exit" + +-- |A help-command with the name ":help" and the +-- description "Prints this help text." +-- +-- It goes through the given list of commands and prints +-- the name and description of each one. +defHelpCmd :: (MonadIO m, MonadCatch m, Foldable f) + => f (Command m0 a b) + -> Command m T.Text () +defHelpCmd cmds = makeCommand n ((n==) . T.strip) "Prints this help text." help + where + n = ":help" + help _ = liftIO $ mapM_ (\x -> putStrLn $ commandName x ++ " - " ++ commandDesc x) cmds + +-- |A default error handler that catches 'SomeREPLError' and prints it to stdout. +-- +-- Since all the sub-types of 'SomeREPLError' just wrap a 'SomeException', we +-- use the 'Show'-instance of that inner exception. +-- +-- Useful in combination with 'makeREPL'. +defErrorHandler :: MonadIO m + => [Handler m ()] +defErrorHandler = [Handler h] + where + h :: MonadIO m => SomeREPLError -> m () + h = liftIO . print
System/REPL/Config.hs view
@@ -1,83 +1,83 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}---- |Contains logic for reading configuration files.-module System.REPL.Config (- readConfigFile,- readConfigJSON,- readConfigShow,- -- *Exceptions- -- |A NoConfigFileParseError gets thrown whenever a config file can't be parsed.- NoConfigFileParseError(..),- ) where--import Prelude hiding ((++), FilePath)--import Control.Monad.Catch-import Control.Monad.IO.Class-import Data.Aeson-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Default-import Data.Functor.Monadic-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import qualified Data.Text as T-import qualified System.FilePath as Fp-import System.Directory-import System.REPL.Types-import Text.Read (readMaybe)---- |Creates a NoParseError out of a 'Fp.FilePath'.-noParseError :: Fp.FilePath -> NoConfigFileParseError-noParseError = NoConfigFileParseError . T.pack---- |Variant of 'readConfigFile' that uses 'Show' and 'Read' for (de)serialization.------ If the file's content's can't be parsed, a 'NoParseError' will be thrown.-readConfigShow :: forall m a.- (MonadThrow m, Functor m, MonadIO m, Default a, Show a,- Read a)- => Fp.FilePath- -> m a-readConfigShow path = readConfigFile path readEither showBS- where- showBS = encodeUtf8 . T.pack . show- readEither = maybe (Left $ noParseError path) Right . readMaybe . T.unpack . decodeUtf8---- |Variant of 'readConfigFile' that uses JSON for (de)serialization.------ If the file's content's can't be parsed, a 'NoParseError' will be thrown.-readConfigJSON :: forall m a.- (MonadThrow m, Functor m, MonadIO m, Default a, ToJSON a,- FromJSON a)- => Fp.FilePath- -> m a-readConfigJSON path = readConfigFile path decodeEither (BL.toStrict . encode)- where- decodeEither = maybe (Left $ noParseError path) Right . decode . BL.fromStrict---- |Tries to read a configuration from file. If the file is missing,--- a default instance is written to file and returned. The following--- exceptions may be thrown:------ * @IOException@, if the IO operations associated with reading or creating the--- configuration file fail, and--- * An exception of type @e@ if the configuration file is present, but its--- contents can't be parsed.-readConfigFile :: forall e m a.- (MonadThrow m, Functor m, MonadIO m, Default a, Exception e)- => Fp.FilePath -- ^Path of the configuration file.- -> (B.ByteString -> Either e a)- -- ^Parser for the file's contents.- -> (a -> B.ByteString)- -- ^Encoder for the default value. If the given configuration- -- file does not exist, a default value will be serialized- -- using this function.- -> m a-readConfigFile path parser writer = do- liftIO $ createDirectoryIfMissing True $ Fp.takeDirectory path- exists <- liftIO $ doesFileExist path- content <- if not exists then do liftIO $ B.writeFile path (writer (def :: a))- return $ Right def- else liftIO (B.readFile path) >$> parser- either throwM return content+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- |Contains logic for reading configuration files. +module System.REPL.Config ( + readConfigFile, + readConfigJSON, + readConfigShow, + -- *Exceptions + -- |A NoConfigFileParseError gets thrown whenever a config file can't be parsed. + NoConfigFileParseError(..), + ) where + +import Prelude hiding ((++), FilePath) + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Default +import Data.Functor.Monadic +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text as T +import qualified System.FilePath as Fp +import System.Directory +import System.REPL.Types +import Text.Read (readMaybe) + +-- |Creates a NoParseError out of a 'Fp.FilePath'. +noParseError :: Fp.FilePath -> NoConfigFileParseError +noParseError = NoConfigFileParseError . T.pack + +-- |Variant of 'readConfigFile' that uses 'Show' and 'Read' for (de)serialization. +-- +-- If the file's content's can't be parsed, a 'NoParseError' will be thrown. +readConfigShow :: forall m a. + (MonadThrow m, Functor m, MonadIO m, Default a, Show a, + Read a) + => Fp.FilePath + -> m a +readConfigShow path = readConfigFile path readEither showBS + where + showBS = encodeUtf8 . T.pack . show + readEither = maybe (Left $ noParseError path) Right . readMaybe . T.unpack . decodeUtf8 + +-- |Variant of 'readConfigFile' that uses JSON for (de)serialization. +-- +-- If the file's content's can't be parsed, a 'NoParseError' will be thrown. +readConfigJSON :: forall m a. + (MonadThrow m, Functor m, MonadIO m, Default a, ToJSON a, + FromJSON a) + => Fp.FilePath + -> m a +readConfigJSON path = readConfigFile path decodeEither (BL.toStrict . encode) + where + decodeEither = maybe (Left $ noParseError path) Right . decode . BL.fromStrict + +-- |Tries to read a configuration from file. If the file is missing, +-- a default instance is written to file and returned. The following +-- exceptions may be thrown: +-- +-- * @IOException@, if the IO operations associated with reading or creating the +-- configuration file fail, and +-- * An exception of type @e@ if the configuration file is present, but its +-- contents can't be parsed. +readConfigFile :: forall e m a. + (MonadThrow m, Functor m, MonadIO m, Default a, Exception e) + => Fp.FilePath -- ^Path of the configuration file. + -> (B.ByteString -> Either e a) + -- ^Parser for the file's contents. + -> (a -> B.ByteString) + -- ^Encoder for the default value. If the given configuration + -- file does not exist, a default value will be serialized + -- using this function. + -> m a +readConfigFile path parser writer = do + liftIO $ createDirectoryIfMissing True $ Fp.takeDirectory path + exists <- liftIO $ doesFileExist path + content <- if not exists then do liftIO $ B.writeFile path (writer (def :: a)) + return $ Right def + else liftIO (B.readFile path) >$> parser + either throwM return content
System/REPL/Prompt.hs view
@@ -1,67 +1,67 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |Little helper functions for getting and putting lines.--- --- This module re-exports part of "Data.ListLike.IO", which contains names that clash with Prelude.-module System.REPL.Prompt (- -- *String-generic versions of Prelude Functions- module Data.ListLike.IO,- putErr,- putErrLn,- prompt,- -- * Prompts- prompt',- promptAbort,- ) where--import Prelude hiding (putStrLn, putStr, getLine, reverse)--import Control.Monad.Catch-import Control.Monad.IO.Class (MonadIO(liftIO))-import Data.ListLike(ListLike(empty, cons, reverse))-import Data.ListLike.IO (ListLikeIO(..))-import qualified System.IO as IO-import System.REPL.Types---- |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, 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, ListLikeIO full item, ListLikeIO full' item')- => full -> m full'-prompt' s = liftIO (putStr s >> IO.hFlush IO.stdout >> getLine)---- |The same as prompt, but aborts as soon as the user presses a given key--- (commonly @'\ESC'@). This function temporarily tries to set the buffering mode--- to NoBuffering via 'System.IO.hSetBuffering', which may not be supported.--- See the documentation of 'System.IO.hSetBuffering' for details.-promptAbort :: (MonadIO m, ListLikeIO full item, ListLikeIO full' Char,- MonadCatch m)- => Char -> full -> m full'-promptAbort abortChar s = do- liftIO $ putStr s- liftIO $ IO.hFlush IO.stdout- bufMode <- liftIO $ IO.hGetBuffering IO.stdin- liftIO $ IO.hSetBuffering IO.stdin IO.NoBuffering- input <- getUntil empty- `catch` (\(e :: SomeAskerError) ->- liftIO (IO.hSetBuffering IO.stdin bufMode) >> throwM e)- liftIO $ IO.hSetBuffering IO.stdin bufMode- return $ reverse input- where- getUntil acc = do c <- liftIO $ getChar- if c == abortChar then throwM AskerInputAbortedError- else if c == '\n' then return acc- else getUntil (cons c acc)+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Little helper functions for getting and putting lines. +-- +-- This module re-exports part of "Data.ListLike.IO", which contains names that clash with Prelude. +module System.REPL.Prompt ( + -- *String-generic versions of Prelude Functions + module Data.ListLike.IO, + putErr, + putErrLn, + prompt, + -- * Prompts + prompt', + promptAbort, + ) where + +import Prelude hiding (putStrLn, putStr, getLine, reverse) + +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.ListLike(ListLike(empty, cons, reverse)) +import Data.ListLike.IO (ListLikeIO(..)) +import qualified System.IO as IO +import System.REPL.Types + +-- |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, 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, ListLikeIO full item, ListLikeIO full' item') + => full -> m full' +prompt' s = liftIO (putStr s >> IO.hFlush IO.stdout >> getLine) + +-- |The same as prompt, but aborts as soon as the user presses a given key +-- (commonly @'\ESC'@). This function temporarily tries to set the buffering mode +-- to NoBuffering via 'System.IO.hSetBuffering', which may not be supported. +-- See the documentation of 'System.IO.hSetBuffering' for details. +promptAbort :: (MonadIO m, ListLikeIO full item, ListLikeIO full' Char, + MonadCatch m) + => Char -> full -> m full' +promptAbort abortChar s = do + liftIO $ putStr s + liftIO $ IO.hFlush IO.stdout + bufMode <- liftIO $ IO.hGetBuffering IO.stdin + liftIO $ IO.hSetBuffering IO.stdin IO.NoBuffering + input <- getUntil empty + `catch` (\(e :: SomeAskerError) -> + liftIO (IO.hSetBuffering IO.stdin bufMode) >> throwM e) + liftIO $ IO.hSetBuffering IO.stdin bufMode + return $ reverse input + where + getUntil acc = do c <- liftIO $ getChar + if c == abortChar then throwM AskerInputAbortedError + else if c == '\n' then return acc + else getUntil (cons c acc)
System/REPL/State.hs view
@@ -1,102 +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-+-- |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 +
System/REPL/Types.hs view
@@ -1,242 +1,242 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}---- |Types used by other modules in the package.------ The module contains the following exception hierarchy:------ * 'SomeREPLError'------ * 'SomeAskerError'------ * 'AskerTypeError'--- * 'AskerPredicateError'--- * 'AskerInputAbortedError'------ * 'SomeCommandError'------ * 'MalformedParamsError'--- * 'TooFewParamsError'--- * 'TooManyParamsError'------ * 'NoConfigFileParseError'----module System.REPL.Types where--import Control.Exception-import qualified Data.Functor.Apply as Ap-import qualified Data.Functor.Bind as Bi-import qualified Data.Text as T-import Data.Typeable---- Asker types------------------------------------------------------------------------------------ |An error message indicating that a value wasn't able to be parsed.-type TypeError = SomeException--- |An error message indicating that a value failied a predicate.-type PredicateError = SomeException--- |A prompt.-type PromptMsg = T.Text---- |A predicate which a value has to fulfil.-type Predicate m a b = a -> m (Either PredicateError b)---- |A predicate which does not change the type of its input.-type Predicate' m a = Predicate m a a---- |A parser which either returns a parsed value or an error message.-type Parser a = T.Text -> Either TypeError a---- |The description of an \'ask for user input\'-action.--- The type parameters are the used monad (typically 'IO' or 'ExceptT'),--- the type of the read value and the type of the error that is thrown--- in case of failures.------ The components are a prompt, a parser, and a predicate that--- the parsed value must fulfil. The the predicate------ * is monadic and--- * can change the returned type (useful for adjoining additional information)-data Asker m a b = Asker{ -- |The prompt to be displayed to the user.- askerPrompt::T.Text,- -- |The parser for the input value.- askerParser::Parser a,- -- |The predicate which the input, once read,- -- must fulfill. The Left side is an error message.- askerPredicate::Predicate m a b}---- |An Asker which does not convert its argument into different type after parsing.-type Asker' m a = Asker m a a---- |Root of the exception hierarchy.-data SomeREPLError = forall e.Exception e => SomeREPLError e deriving (Typeable)-instance Show SomeREPLError where show (SomeREPLError e) = show e-instance Exception SomeREPLError--replErrorUpcast :: (Exception a) => a -> SomeException-replErrorUpcast = toException . SomeREPLError-replErrorDowncast :: (Exception a) => SomeException -> Maybe a-replErrorDowncast x = do {SomeREPLError y <- fromException x; cast y}---- |Generic error related to 'Asker's. Either the input was incorrect--- in some way, or the process was aborted by the user.-data SomeAskerError = forall e.Exception e => SomeAskerError e deriving (Typeable)-instance Show SomeAskerError where show (SomeAskerError e) = show e-instance Exception SomeAskerError where- toException = replErrorUpcast- fromException = replErrorDowncast--askerErrorUpcast :: (Exception a) => a -> SomeException-askerErrorUpcast = toException . SomeAskerError-askerErrorDowncast :: (Exception a) => SomeException -> Maybe a-askerErrorDowncast x = do {SomeAskerError y <- fromException x; cast y}---- |The input wasn't able to be parsed.-data AskerTypeError = AskerTypeError SomeException deriving (Show, Typeable)-instance Exception AskerTypeError where- toException = askerErrorUpcast- fromException = askerErrorDowncast---- |The parsed value failed a predicate.-data AskerPredicateError = AskerPredicateError SomeException deriving (Show, Typeable)-instance Exception AskerPredicateError where- toException = askerErrorUpcast- fromException = askerErrorDowncast---- |The input for an Asker was aborted by the user.-data AskerInputAbortedError = AskerInputAbortedError deriving (Show, Typeable)-instance Exception AskerInputAbortedError where- toException = askerErrorUpcast- fromException = askerErrorDowncast---- |A generic type failure for use with Askers.-data GenericTypeError = GenericTypeError T.Text deriving (Show, Typeable, Eq)-instance Exception GenericTypeError---- |Constructor for 'GenericTypeError' which wraps the value into a 'SomeException'.-genericTypeError :: T.Text -> SomeException-genericTypeError = SomeException . GenericTypeError---- |A generic predicate failure for use with Askers.-data GenericPredicateError = GenericPredicateError T.Text deriving (Show, Typeable, Eq)-instance Exception GenericPredicateError---- |Constructor for 'GenericTypeError' which wraps the value into a 'SomeException'.-genericPredicateError :: T.Text -> SomeException-genericPredicateError = SomeException . GenericPredicateError---- |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::T.Text}---- |Read-instance for 'Verbatim'. Wraps the given value into quotes and--- reads it a a 'T.Text'.-instance Read Verbatim where- readsPrec _ s = [(Verbatim $ T.pack s,"")]---- Types for example askers------------------------------------------------------------------------------------ |Indicates whether the target of a path exists and what form it has.-data PathExistenceType = IsDirectory | IsFile | DoesNotExist deriving (Eq, Show, Ord, Read, Enum, Bounded)---- |Indicates that no part of a path exists.-data PathRootDoesNotExist = PathRootDoesNotExist FilePath deriving (Typeable, Eq, Show)-instance Exception PathRootDoesNotExist---- |Indicatres that the last existing portion of a path is not writable.-data PathIsNotWritable = PathIsNotWritable FilePath deriving (Typeable, Eq, Show)-instance Exception PathIsNotWritable---- Command types------------------------------------------------------------------------------------ Exceptions------------------------------------------------------------------------------------ |Generic error related to command execution.-data SomeCommandError = forall e.Exception e => SomeCommandError e deriving (Typeable)-instance Show SomeCommandError where show (SomeCommandError e) = show e-instance Exception SomeCommandError where- toException = replErrorUpcast- fromException = replErrorDowncast--commandErrorUpcast :: (Exception a) => a -> SomeException-commandErrorUpcast = toException . SomeCommandError-commandErrorDowncast :: (Exception a) => SomeException -> Maybe a-commandErrorDowncast x = do {SomeCommandError y <- fromException x; cast y}---- |The input of a command was malformed and could not interpreted. I.e.--- the input contained inadmissible characters, or quotes were mismatched.--- The 'Text' argument contains the parser error.-data MalformedParamsError = MalformedParamsError T.Text deriving (Show, Eq, Typeable, Ord)-instance Exception MalformedParamsError where- toException = commandErrorUpcast- fromException = commandErrorDowncast---- |Too many parameters were given to a command. The first value is the maximum,--- the second the actual number.-data TooManyParamsError = TooManyParamsError Int Int deriving (Show, Eq, Typeable, Ord)-instance Exception TooManyParamsError where- toException = commandErrorUpcast- fromException = commandErrorDowncast---- |Too few parameters were given to a command. The first value is the minium,--- the second the actual number.-data TooFewParamsError = TooFewParamsError Int Int deriving (Show, Eq, Typeable, Ord)-instance Exception TooFewParamsError where- toException = commandErrorUpcast- fromException = commandErrorDowncast---- Command type------------------------------------------------------------------------------------ |A REPL command, possibly with parameters.-data Command m i a = Command{- -- |The short name of the command. Purely informative.- commandName :: T.Text,- -- |Returns whether the first part of an input- -- (the command name) matches- -- a the command. 'defCommandTest' is appropriate for most cases.- commandTest :: i -> Bool,- -- |A description of the command.- commandDesc :: T.Text,- -- |Runs the command with the input text as parameter,- -- returning the unconsumed input.- runPartialCommand :: [i] -> m (a, [i])}--instance Functor m => Functor (Command m i) where- fmap f c@Command{runPartialCommand=run} = c{runPartialCommand=(fmap (\(x,y) -> (f x, y)) . run)}--instance (Monad m) => Ap.Apply (Command m i) where- -- |Runs the first command, then the second with the left-over input.- -- The result of the first command is applied to that of the second.- --- -- All other fields (name, description,...) of the second command are- -- ignored.- f <.> g = f{runPartialCommand = h}- where- h input = do (func, output) <- runPartialCommand f input- (arg, output') <- runPartialCommand g output- return (func arg, output')---instance (Monad m) => Bi.Bind (Command m i) where- -- |The same as 'Ap.<.>', but the second argument can read the result of the- -- first.- f >>- g = f{runPartialCommand = h}- where- h input = do (res, output) <- runPartialCommand f input- (res', output') <- runPartialCommand (g res) output- return (res', output')----- Config file types------------------------------------------------------------------------------------ |Indicates that some string was not able to be parsed.-data NoConfigFileParseError = NoConfigFileParseError T.Text deriving (Show, Eq, Read, Typeable)--instance Exception NoConfigFileParseError+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- |Types used by other modules in the package. +-- +-- The module contains the following exception hierarchy: +-- +-- * 'SomeREPLError' +-- +-- * 'SomeAskerError' +-- +-- * 'AskerTypeError' +-- * 'AskerPredicateError' +-- * 'AskerInputAbortedError' +-- +-- * 'SomeCommandError' +-- +-- * 'MalformedParamsError' +-- * 'TooFewParamsError' +-- * 'TooManyParamsError' +-- +-- * 'NoConfigFileParseError' +-- +module System.REPL.Types where + +import Control.Exception (SomeException(..), Exception(..)) +import qualified Data.Functor.Apply as Ap +import qualified Data.Functor.Bind as Bi +import qualified Data.Text as T +import Data.Typeable + +-- Asker types +------------------------------------------------------------------------------- + +-- |An error message indicating that a value wasn't able to be parsed. +type TypeError = SomeException +-- |An error message indicating that a value failed a predicate. +type PredicateError = SomeException +-- |A prompt. +type PromptMsg = T.Text + +-- |A predicate which a value has to fulfil. +type Predicate m a b = a -> m (Either PredicateError b) + +-- |A predicate which does not change the type of its input. +type Predicate' m a = Predicate m a a + +-- |A parser which either returns a parsed value or an error message. +type Parser a = T.Text -> Either TypeError a + +-- |The description of an \'ask for user input\'-action. +-- The type parameters are the used monad (typically 'IO' or 'ExceptT'), +-- the type of the read value and the type of the error that is thrown +-- in case of failures. +-- +-- The components are a prompt, a parser, and a predicate that +-- the parsed value must fulfil. The predicate +-- +-- * is monadic and +-- * can change the returned type (useful for adjoining additional information) +data Asker m a b = Asker{ -- |The prompt to be displayed to the user. + askerPrompt::T.Text, + -- |The parser for the input value. + askerParser::Parser a, + -- |The predicate which the input, once read, + -- must fulfill. The Left side is an error message. + askerPredicate::Predicate m a b} + +-- |An Asker which does not convert its argument into a different type after parsing. +type Asker' m a = Asker m a a + +-- |Root of the exception hierarchy. +data SomeREPLError = forall e.Exception e => SomeREPLError e deriving (Typeable) +instance Show SomeREPLError where show (SomeREPLError e) = show e +instance Exception SomeREPLError + +replErrorUpcast :: (Exception a) => a -> SomeException +replErrorUpcast = toException . SomeREPLError +replErrorDowncast :: (Exception a) => SomeException -> Maybe a +replErrorDowncast x = do {SomeREPLError y <- fromException x; cast y} + +-- |Generic error related to 'Asker's. Either the input was incorrect +-- in some way, or the process was aborted by the user. +data SomeAskerError = forall e.Exception e => SomeAskerError e deriving (Typeable) +instance Show SomeAskerError where show (SomeAskerError e) = show e +instance Exception SomeAskerError where + toException = replErrorUpcast + fromException = replErrorDowncast + +askerErrorUpcast :: (Exception a) => a -> SomeException +askerErrorUpcast = toException . SomeAskerError +askerErrorDowncast :: (Exception a) => SomeException -> Maybe a +askerErrorDowncast x = do {SomeAskerError y <- fromException x; cast y} + +-- |The input could not be parsed. +data AskerTypeError = AskerTypeError SomeException deriving (Show, Typeable) +instance Exception AskerTypeError where + toException = askerErrorUpcast + fromException = askerErrorDowncast + +-- |The parsed value failed a predicate. +data AskerPredicateError = AskerPredicateError SomeException deriving (Show, Typeable) +instance Exception AskerPredicateError where + toException = askerErrorUpcast + fromException = askerErrorDowncast + +-- |The input for an Asker was aborted by the user. +data AskerInputAbortedError = AskerInputAbortedError deriving (Show, Typeable) +instance Exception AskerInputAbortedError where + toException = askerErrorUpcast + fromException = askerErrorDowncast + +-- |A generic type failure for use with Askers. +data GenericTypeError = GenericTypeError T.Text deriving (Show, Typeable, Eq) +instance Exception GenericTypeError + +-- |Constructor for 'GenericTypeError' which wraps the value into a 'SomeException'. +genericTypeError :: T.Text -> SomeException +genericTypeError = SomeException . GenericTypeError + +-- |A generic predicate failure for use with Askers. +data GenericPredicateError = GenericPredicateError T.Text deriving (Show, Typeable, Eq) +instance Exception GenericPredicateError + +-- |Constructor for 'GenericTypeError' which wraps the value into a 'SomeException'. +genericPredicateError :: T.Text -> SomeException +genericPredicateError = SomeException . GenericPredicateError + +-- |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::T.Text} + +-- |Read-instance for 'Verbatim'. Wraps the given value into quotes and +-- reads it a a 'T.Text'. +instance Read Verbatim where + readsPrec _ s = [(Verbatim $ T.pack s,"")] + +-- Types for example askers +------------------------------------------------------------------------------- + +-- |Indicates whether the target of a path exists and what form it has. +data PathExistenceType = IsDirectory | IsFile | DoesNotExist deriving (Eq, Show, Ord, Read, Enum, Bounded) + +-- |Indicates that no part of a path exists. +data PathRootDoesNotExist = PathRootDoesNotExist FilePath deriving (Typeable, Eq, Show) +instance Exception PathRootDoesNotExist + +-- |Indicates that the last existing portion of a path is not writable. +data PathIsNotWritable = PathIsNotWritable FilePath deriving (Typeable, Eq, Show) +instance Exception PathIsNotWritable + +-- Command types +------------------------------------------------------------------------------- + +-- Exceptions +------------------------------------------------------------------------------- + +-- |Generic error related to command execution. +data SomeCommandError = forall e.Exception e => SomeCommandError e deriving (Typeable) +instance Show SomeCommandError where show (SomeCommandError e) = show e +instance Exception SomeCommandError where + toException = replErrorUpcast + fromException = replErrorDowncast + +commandErrorUpcast :: (Exception a) => a -> SomeException +commandErrorUpcast = toException . SomeCommandError +commandErrorDowncast :: (Exception a) => SomeException -> Maybe a +commandErrorDowncast x = do {SomeCommandError y <- fromException x; cast y} + +-- |The input of a command was malformed and could not be interpreted. I.e. +-- the input contained inadmissible characters, or quotes were mismatched. +-- The 'Text' argument contains the parser error. +data MalformedParamsError = MalformedParamsError T.Text deriving (Show, Eq, Typeable, Ord) +instance Exception MalformedParamsError where + toException = commandErrorUpcast + fromException = commandErrorDowncast + +-- |Too many parameters were given to a command. The first value is the maximum, +-- the second the actual number. +data TooManyParamsError = TooManyParamsError Int Int deriving (Show, Eq, Typeable, Ord) +instance Exception TooManyParamsError where + toException = commandErrorUpcast + fromException = commandErrorDowncast + +-- |Too few parameters were given to a command. The first value is the minium, +-- the second the actual number. +data TooFewParamsError = TooFewParamsError Int Int deriving (Show, Eq, Typeable, Ord) +instance Exception TooFewParamsError where + toException = commandErrorUpcast + fromException = commandErrorDowncast + +-- Command type +------------------------------------------------------------------------------- + +-- |A REPL command, possibly with parameters. +data Command m i a = Command{ + -- |The short name of the command. Purely informative. + commandName :: T.Text, + -- |Returns whether the first part of an input + -- (the command name) matches + -- a the command. 'defCommandTest' is appropriate for most cases. + commandTest :: i -> Bool, + -- |A description of the command. + commandDesc :: T.Text, + -- |Runs the command with the input text as parameter, + -- returning the unconsumed input. + runPartialCommand :: [i] -> m (a, [i])} + +instance Functor m => Functor (Command m i) where + fmap f c@Command{runPartialCommand=run} = c{runPartialCommand=(fmap (\(x,y) -> (f x, y)) . run)} + +instance (Monad m) => Ap.Apply (Command m i) where + -- |Runs the first command, then the second with the left-over input. + -- The result of the first command is applied to that of the second. + -- + -- All other fields (name, description,...) of the second command are + -- ignored. + f <.> g = f{runPartialCommand = h} + where + h input = do (func, output) <- runPartialCommand f input + (arg, output') <- runPartialCommand g output + return (func arg, output') + + +instance (Monad m) => Bi.Bind (Command m i) where + -- |The same as 'Ap.<.>', but the second argument can read the result of the + -- first. + f >>- g = f{runPartialCommand = h} + where + h input = do (res, output) <- runPartialCommand f input + (res', output') <- runPartialCommand (g res) output + return (res', output') + + +-- Config file types +------------------------------------------------------------------------------- + +-- |Indicates that some string was not able to be parsed. +data NoConfigFileParseError = NoConfigFileParseError T.Text deriving (Show, Eq, Read, Typeable) + +instance Exception NoConfigFileParseError
changelog.txt view
@@ -1,11 +1,13 @@-1.0.0.1 Updated aeson dependency's upper bound.--1.0 Refactored the package. Switched from lazy to strict text. Changed the types. Added user input as parameter for Asker error messages.--0.5 Replaced system-filepath with filepath, as system-filepath has become deprecated. This is a minor, but breaking, change.--0.4 Completely overhauled the command system. It is now possible to chain commands together and make subcommands.--0.3.1 Added functionality for reading configuration files.--0.3 Ditched MonadError in favour of MonadThrow. This should make the functions much easier to use.+1.0.1.0 Fixed name clashes with base, added new exports, fixed typos. + +1.0.0.1 Updated aeson dependency's upper bound. + +1.0 Refactored the package. Switched from lazy to strict text. Changed the types. Added user input as parameter for Asker error messages. + +0.5 Replaced system-filepath with filepath, as system-filepath has become deprecated. This is a minor, but breaking, change. + +0.4 Completely overhauled the command system. It is now possible to chain commands together and make subcommands. + +0.3.1 Added functionality for reading configuration files. + +0.3 Ditched MonadError in favour of MonadThrow. This should make the functions much easier to use.
repl-toolkit.cabal view
@@ -1,39 +1,54 @@--- Initial repl-toolkit.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/--name: repl-toolkit-version: 1.0.0.1-synopsis: Toolkit for quickly whipping up config files and 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-extra-source-files: changelog.txt--source-repository head- type: git- location: git://github.com/ombocomp/repl-toolkit.git--library- exposed-modules: System.REPL,- System.REPL.Ask,- System.REPL.Command,- System.REPL.Config,- System.REPL.Prompt,- System.REPL.State,- System.REPL.Types- other-extensions: OverloadedStrings,- DeriveDataTypeable,- FlexibleContexts,- LambdaCase,- ScopedTypeVariables,- ExistentialQuantification,- TupleSections- build-depends: base >=4.8 && <5, functor-monadic >=0.1, text >=1.1, ListLike >=4.1, exceptions >=0.8 && <1, parsec >=3.1 && <4, listsafe >= 0.1, monad-loops >= 0.3 && <0.6, mtl >= 2.2 && <3, transformers >= 0.3 && <0.7, directory >= 1.2.1 && <2, filepath >= 1.3 && <2, bytestring >= 0.10 && <0.20, data-default >= 0.5.3, aeson >=0.8.0.2 && <2, semigroupoids >= 4 && <6- default-language: Haskell2010-+-- Initial repl-toolkit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: repl-toolkit +version: 1.0.1.0 +synopsis: Toolkit for quickly whipping up config files and 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 +extra-source-files: changelog.txt + +source-repository head + type: git + location: git://github.com/ombocomp/repl-toolkit.git + +library + exposed-modules: System.REPL, + System.REPL.Ask, + System.REPL.Command, + System.REPL.Config, + System.REPL.Prompt, + System.REPL.State, + System.REPL.Types + other-extensions: OverloadedStrings, + DeriveDataTypeable, + FlexibleContexts, + LambdaCase, + ScopedTypeVariables, + ExistentialQuantification, + TupleSections + build-depends: base >=4.8 && <5, + aeson >=0.8.0.2 && <2, + bytestring >= 0.10 && <0.20, + data-default >= 0.5.3, + directory >= 1.2.1 && <2, + exceptions >=0.8 && <1, + filepath >= 1.3 && <2, + functor-monadic >=0.1, + ListLike >=4.1, + listsafe >= 0.1, + monad-loops >= 0.3 && <0.6, + mtl >= 2.2 && <3, + parsec >=3.1 && <4, + semigroupoids >= 4 && <6, + transformers >= 0.3 && <0.7, + text >=1.1 + default-language: Haskell2010 +