command parsing with optparse-applicative

4 files changed, 29 insertions, 15 deletions

diff --git a/sequence.cabal b/sequence.cabal
index 3d7ee92..f0e36c6 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -29,5 +29,6 @@ executable sequence
                      , xdg-basedir
                      , data-default-class
                      , haskeline
+                     , optparse-applicative
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index a66b771..700a6b4 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,6 +1,6 @@
 { mkDerivation, base, case-insensitive, containers
-, data-default-class, haskeline, mtl, pqueue, stdenv, text
-, transformers, xdg-basedir
+, data-default-class, haskeline, mtl, optparse-applicative, pqueue
+, stdenv, text, transformers, xdg-basedir
 }:
 mkDerivation {
   pname = "sequence";
@@ -10,7 +10,7 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [
     base case-insensitive containers data-default-class haskeline mtl
-    pqueue text transformers xdg-basedir
+    optparse-applicative pqueue text transformers xdg-basedir
   ];
   description = "A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)";
   license = stdenv.lib.licenses.gpl3;
diff --git a/src/Command.hs b/src/Command.hs
index 55f4466..4d85489 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -5,13 +5,19 @@ module Command
        , parseCmd
        ) where
 
+import Options.Applicative
+
 import Data.Char (isSpace)
 
 import Types
 
 data Cmd = PerformAlt Alteration
+         | ModifyTip SequenceValue
+         | OverrideTip SequenceValue
+         | ShowTip
+         | ShowHistory (Maybe Integer)
+         | Dump
          | Quit
-         | Step
          | UnknownCommand String
          | ParseError String
          | Empty
@@ -24,7 +30,7 @@ isQuote, isEscape :: Char -> Bool
 isQuote q = q `elem` quoteChars
 isEscape e = e `elem` escapeChars
 
-parseCmd :: SequenceM m => String -> m Cmd
+parseCmd :: String -> Cmd
 parseCmd = parseCmd' . split
   where
     split :: String -> [String]
@@ -57,6 +63,15 @@ parseCmd = parseCmd' . split
       , isEscape c          = split' ws w q (Just c) cs -- Set escaped flag at unescaped escape char
       | otherwise           = split' ws (c : w) q Nothing cs -- Append to word
 
-parseCmd' :: SequenceM m => [String] -> m Cmd
-parseCmd' [] = return Empty
-parseCmd' (cmd:args) = return $ UnknownCommand (show $ cmd:args) -- DEBUG
+parseCmd' :: [String] -> Cmd
+parseCmd' [] = Empty
+parseCmd' args = mapResult runParser
+  where
+    runParser = execParserPure (prefs $ showHelpOnError) (cmdParser `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
+    mapResult (Success a) = a
+    mapResult (Failure help) = UnknownCommand . fst $ renderFailure help ""
+    mapResult (CompletionInvoked _ ) = ParseError "Completion triggered" 
+
+cmdParser :: Parser Cmd
+cmdParser = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
+                                 ]
diff --git a/src/Main.hs b/src/Main.hs
index e6a3024..0088b7c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -35,18 +35,16 @@ main = do
 runCli :: (MonadIO m, MonadException m) => SequenceT m () 
 runCli = do
   input <- lift $ getInputLine "→ " 
-  cmnd <- maybe (return $ ParseError "Trying to parse EOF") parseCmd input
   case input of
     Nothing -> liftIO exitSuccess
-    Just _ -> do
-      case cmnd of
-        UnknownCommand cmd -> do
-          lift . outputStrLn $ "Unknown command: »" <> cmd <> "«"
+    Just input' -> do
+      case parseCmd input' of
+        UnknownCommand help -> do
+          lift . outputStrLn $ help
         ParseError err     -> do
           lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err
         Empty              -> return ()
 
         Quit           -> liftIO exitSuccess
-        PerformAlt alt -> apply' alt
-        Step           -> undefined
+        _              -> undefined
   runCli