From 99b12580b0ef0592dbfb5da04070114314e9b7f8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 8 May 2016 00:00:20 +0200
Subject: framework for command parsing

---
 src/Command.hs | 55 ++++++++++++++++++++++++++++++++++++++++++++-----------
 src/Utils.hs   | 10 ++++++++++
 2 files changed, 54 insertions(+), 11 deletions(-)

(limited to 'src')

diff --git a/src/Command.hs b/src/Command.hs
index 4d85489..79893a5 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -5,15 +5,16 @@ module Command
        , parseCmd
        ) where
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Options.Applicative
 
 import Data.Char (isSpace)
 
 import Types
 
-data Cmd = PerformAlt Alteration
-         | ModifyTip SequenceValue
-         | OverrideTip SequenceValue
+data Cmd = PerformAlt Alteration (Maybe Comment)
          | ShowTip
          | ShowHistory (Maybe Integer)
          | Dump
@@ -30,7 +31,7 @@ isQuote, isEscape :: Char -> Bool
 isQuote q = q `elem` quoteChars
 isEscape e = e `elem` escapeChars
 
-parseCmd :: String -> Cmd
+parseCmd :: SequenceM m => String -> m Cmd
 parseCmd = parseCmd' . split
   where
     split :: String -> [String]
@@ -63,15 +64,47 @@ 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' :: [String] -> Cmd
-parseCmd' [] = Empty
-parseCmd' args = mapResult runParser
+parseCmd' :: SequenceM m => [String] -> m Cmd
+parseCmd' [] = return Empty
+parseCmd' args = do
+  knownEntities <- entities
+  tip <- snd <$> gets getMax
+  return $ 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
+    runParser = execParserPure (prefs $ showHelpOnError) (cmdParser knownEntities tip `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"
-                                 ]
+-- data Cmd = PerformAlt Alteration (Maybe Comment)
+--          | ShowTip
+--          | ShowHistory (Maybe Integer)
+--          | Dump
+--          | Quit
+-- data Alteration = Modify Entity SequenceValue
+--                 | Override Entity SequenceValue
+--                 | Drop Entity
+--                 | Insert Entity SequenceValue
+--                 | Rename Entity Entity
+
+cmdParser :: Set Entity -> Entity -> Parser Cmd
+cmdParser knownEntities tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
+                                                   , command "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable"
+                                                   , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history"
+                                                   , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?"
+                                                   , command "set" $ parseOverride `info` progDesc "Set an entities sequence value"
+                                                   , command "modify" $ parseModify `info` progDesc "Modify an entities sequence value"
+                                                   , command "drop" $ parseDrop `info` progDesc "Stop tracking an entity"
+                                                   , command "add" $ parseAdd `info` progDesc "Start tracking an entity"
+                                                   , command "rename" $ parseRename `info` progDesc "Rename an entity"
+                                                   ]
+  where
+    parseHistory = ShowHistory <$> optional (argument natural (help "How many entries to display" <> metavar "NATURAL"))
+    parseOverride = PerformAlt <$> (Override <$> entity <*> sequenceValue) <*> comment
+
+    natural = do
+      int <- auto
+      if int < 0
+        then readerError "Natural number (0 ≤ n) required"
+        else return int
+    entity = Entity <$> 
diff --git a/src/Utils.hs b/src/Utils.hs
index 2254fde..945c6b7 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -3,16 +3,23 @@
 module Utils
        ( showEntity
        , apply, apply'
+       , entities
        ) where
 
 import Data.Text (Text)
 import qualified Data.Text as Text
 
+import Data.PQueue.Prio.Max (MaxPQueue)
+import qualified Data.PQueue.Prio.Max as MaxPQueue
+
 import Data.Monoid (Monoid(..), (<>))
 
 import Control.Monad.State.Class
 import Control.Monad.Writer.Class
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Types
 
 showEntity :: Entity -> Text
@@ -28,3 +35,6 @@ apply' alteration = do
 
 apply :: Alteration -> Sequence -> (Sequence, History)
 apply alteration seq = undefined
+
+entities :: MonadState Sequence m => m (Set Entity)
+entities = Set.fromList . MaxPQueue.keys <$> get
-- 
cgit v1.2.3