haskeline based framework

6 files changed, 123 insertions, 152 deletions

diff --git a/sequence.cabal b/sequence.cabal
index 948b8b1..3d7ee92 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -22,12 +22,12 @@ executable sequence
   build-depends:       base >=4.8 && <5
                      , mtl
                      , transformers
-                     , readline
                      , pqueue
                      , text
                      , case-insensitive
                      , containers
-                     , lens
+                     , xdg-basedir
                      , data-default-class
+                     , haskeline
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index ead4f98..a66b771 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,6 +1,6 @@
 { mkDerivation, base, case-insensitive, containers
-, data-default-class, lens, mtl, pqueue, readline, stdenv, text
-, transformers
+, data-default-class, haskeline, mtl, pqueue, stdenv, text
+, transformers, xdg-basedir
 }:
 mkDerivation {
   pname = "sequence";
@@ -9,8 +9,8 @@ mkDerivation {
   isLibrary = false;
   isExecutable = true;
   executableHaskellDepends = [
-    base case-insensitive containers data-default-class lens mtl pqueue
-    readline text transformers
+    base case-insensitive containers data-default-class haskeline mtl
+    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
new file mode 100644
index 0000000..fd21087
--- /dev/null
+++ b/src/Command.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Command
+       ( Cmd(..)
+       , parseCmd
+       ) where
+
+import Types
+
+data Cmd = PerformAlt Alteration
+         | Quit
+         | Step
+         | UnknownCommand String
+         | ParseError String
+
+parseCmd :: SequenceM m => String -> m Cmd
+parseCmd input = return $ UnknownCommand input
diff --git a/src/Main.hs b/src/Main.hs
index eff9a92..834cefd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, ConstraintKinds, ViewPatterns, OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-}
 
 import           Data.PQueue.Prio.Max (MaxPQueue)
 import qualified Data.PQueue.Prio.Max as MaxPQueue
@@ -6,122 +6,46 @@ import qualified Data.PQueue.Prio.Max as MaxPQueue
 import           Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..))
 import qualified Data.Sequence as Seq
 
-import           Data.List (delete)
-import           Data.Bool
+import Data.Default.Class
+import Data.Maybe (fromMaybe)
 
-import           Data.Monoid (Monoid(..), (<>))
-
-import           Data.Default.Class
-
-import           System.Console.Readline (readline)
-
-import           Control.Monad.State.Lazy (MonadState(..), runStateT, modify)
-import           Control.Monad.IO.Class (MonadIO(..))
-
-import           Control.Monad (void, join)
-
-import           Control.Lens hiding ((|>), (:<))
-
-import           Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
-
-import           Text.Read (readMaybe)
-
-import           Data.CaseInsensitive  ( CI )
-import qualified Data.CaseInsensitive as CI
-
-import System.Exit (exitSuccess)
+import System.Environment.XDG.BaseDir (getUserCacheFile)
+import System.Environment (getProgName)
+import System.Exit
 
+import System.Console.Haskeline
 
+import Control.Monad.State.Strict
+import Control.Monad.Writer.Strict
+import Control.Monad.IO.Class
+  
 import Types
+import Utils
+import Command
 
-type SequenceM m = (MonadIO m, MonadState SequenceState m)
-
-prompt :: String
-prompt = "→ "
+type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a
 
 main :: IO ()
-main = void $ runStateT acceptCmd def
-       
-acceptCmd :: SequenceM m => m ()
-acceptCmd = join $ liftIO (readline prompt) >>= handleCmd
-
-terminate :: MonadIO m => m a
-terminate = liftIO exitSuccess
-
-handleCmd :: SequenceM m => Maybe String -> m (m ())
-handleCmd Nothing = return terminate -- EOF
-handleCmd (Just "") = return acceptCmd -- Empty input
-handleCmd (Just (Text.words . Text.pack -> (CI.mk -> cmd) : args)) -- Input containing at least one word
-  | cmd `elem` ["exit", "quit"] = return $ return ()
-  | cmd `elem` ["insert", "add"] = acceptCmd <$ case args of
-    (name : (readMaybe . Text.unpack -> Just val) : comment) -> bool (liftIO $ Text.putStrLn "Did not insert new entity") (return ()) =<< withNewName (\e -> modify $ update (Insert e val, parseComment comment)) name
-    _ -> liftIO . Text.putStrLn $ "Malformed arguments to insert.\nExpecting: insert <name> <sequence value> [<comment> […]]"
-  | cmd == "dump" = acceptCmd <$ (get >>= liftIO . print)
-  | otherwise = acceptCmd <$ do
-      liftIO $ Text.putStrLn ("No such command known: " <> CI.original cmd)
-handleCmd _ = error "Could not parse input String to Text"
-
-askBool :: MonadIO m => Text -> m Bool
-askBool question = do
-  str <- liftIO $ readline (Text.unpack question <> " (Yes/No)?\n" <> prompt)
-  case str of
-    Nothing -> terminate
-    Just (CI.mk -> "yes") -> return True
-    Just (CI.mk -> "y") -> return True
-    Just (CI.mk -> "no") -> return False
-    Just (CI.mk -> "n") -> return False
-    _ -> askBool question
-
-withNewName :: SequenceM m => (Entity -> m ()) -> Text -> m Bool
-withNewName callback name = do
-  -- names <- getNames <$> use history
-  entity <- getEntity 
-  maybe False (const True) <$> maybe (return Nothing) (\e -> Just <$> callback e) entity
-  where
-    number :: MaxPQueue Integer Entity -> MaxPQueue Integer Entity
-    number = fst . MaxPQueue.foldrWithKey accum (MaxPQueue.empty, 0)
-    accum key val o@(queue, maxNmbr)
-      | (Entity (CI.mk -> val') _) <- val
-      , val' == CI.mk name = (MaxPQueue.insert key (Entity (CI.original val') (Just $ succ maxNmbr)) queue, succ maxNmbr)
-      | otherwise = o
-    getEntity = do
-      names <- MaxPQueue.elems <$> use queue -- we have semantic guarantees that names is a set
-      let
-        takenNumbers = map (\(Entity _ n) -> n) $ filter (\(Entity (CI.mk -> id) _) -> id == CI.mk name) names
-      case takenNumbers of
-        [] -> return . Just $ Entity name Nothing
-        [Nothing] -> do
-          liftIO $ Text.putStrLn ("Name »" <> name <> "« is already taken.")
-          useNumber <- liftIO $ askBool "Introduce a numbering scheme"
-          if useNumber
-            then queue <~ (number) >> getEntity
-            else return Nothing
-        (maximum -> (Just maxNmbr)) -> do
-          let
-            entity = Entity name (Just $ succ maxNmbr)
-          liftIO $ Text.putStrLn ("Changed name to »" <> showEntity entity <> "«")
-          return $ Just entity
-
-parseComment :: [Text] -> Maybe Comment
-parseComment (Text.unwords -> c)
-  | c == ""   = Nothing
-  | otherwise = Just c
-
-update :: (Alteration, Maybe Comment) -> SequenceState -> SequenceState
-update loggable@(alt, _) = affect alt . over history (|> loggable)
-
-affect :: Alteration -> SequenceState -> SequenceState
-affect (Modify id by)    = over queue $ affect' (\(k, v) -> if v == id then Just (k + by, id) else Just (k, v))
-affect (Override id new) = over queue $ affect' (\(k, v) -> if v == id then Just (new, id) else Just (k, v))
-affect (Drop id)         = over queue $ MaxPQueue.filter (/= id)
-affect (Insert id v)     = over queue $ MaxPQueue.insert v id
-affect _                 = error "Modification not implemented yet"
-
-affect' :: ((Integer, Entity) -> Maybe (Integer, Entity)) -> MaxPQueue Integer Entity -> MaxPQueue Integer Entity
-affect' f = MaxPQueue.foldrWithKey accum MaxPQueue.empty
-  where
-    accum key val
-      | (Just (key', val')) <- f (key, val) = MaxPQueue.insert key' val'
-      | otherwise = id
+main = do
+  historyFile <- flip getUserCacheFile "history" =<< getProgName
+  let
+    settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings
+  void . flip runStateT def . runInputT settings . runWriterT $ runCli
+
+runCli :: (MonadIO m, MonadException m) => SequenceT m () 
+runCli = do
+  input <- lift $ getInputLine "→ " 
+  cmnd <- maybe (return undefined) parseCmd input
+  case input of
+    Nothing -> liftIO exitSuccess
+    Just _ -> do
+      case cmnd of
+        UnknownCommand cmd -> do
+          lift . outputStrLn $ "Unknown command: »" <> cmd <> "«"
+        ParseError err     -> do
+          lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err
+
+        Quit           -> liftIO exitSuccess
+        PerformAlt alt -> apply' alt
+        Step           -> undefined
+  runCli
diff --git a/src/Types.hs b/src/Types.hs
index 2dff0f0..10cea7a 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -1,57 +1,57 @@
-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell, OverloadedStrings, ConstraintKinds, FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}
 
 module Types
        ( Entity(..)
-       , showEntity
+       , SequenceValue
        , Comment
        , Alteration(..)
-       , SequenceState, queue, history
+       , Sequence
+       , History
+       , SequenceM
        ) where
 
-import           Data.PQueue.Prio.Max (MaxPQueue)
-import qualified Data.PQueue.Prio.Max as MaxPQueue
+import Data.PQueue.Prio.Max (MaxPQueue)
+import qualified Data.PQueue.Prio.Max as MaxPQueue (empty)
 
-import           Data.Sequence (Seq)
-import qualified Data.Sequence as Seq
+import Data.Sequence (Seq)
 
-import           Data.Monoid (Monoid(..), (<>))
+import Data.Text (Text)
 
-import           Control.Monad.State.Lazy (MonadState)
-import           Control.Monad.IO.Class (MonadIO)
+import Data.Default.Class
 
-import           Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
+import Control.Monad.State.Strict (MonadState(..), MonadTrans(..))
+import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..))
 
-import           Control.Lens.TH
+import Control.Monad.IO.Class (MonadIO)
 
-import           Data.Default.Class
+import System.Console.Haskeline (InputT)
 
+  
 data Entity = Entity Text (Maybe Integer)
             deriving (Eq, Ord, Show)
 
-showEntity :: Entity -> Text
-showEntity (Entity t Nothing) = t
-showEntity (Entity t (Just n)) = t <> " " <> (Text.pack $ show n)
+type SequenceValue = Integer
 
 type Comment = Text
 
-data Alteration = Modify Entity Integer
-                | Override Entity Integer
+data Alteration = Modify Entity SequenceValue
+                | Override Entity SequenceValue
                 | Drop Entity
-                | Insert Entity Integer
+                | Insert Entity SequenceValue
                 | Rename Entity Entity
                 deriving (Show)
 
-data SequenceState = SequenceState
-                     { _queue   :: MaxPQueue Integer Entity -- Current state
-                     , _history :: Seq (Alteration, Maybe Comment) -- Most recent last
-                     }
-                   deriving (Show)
-makeLenses ''SequenceState
-
-instance Default SequenceState where
-  def = SequenceState
-        { _queue   = MaxPQueue.empty
-        , _history = Seq.empty
-        }
+type Sequence = MaxPQueue SequenceValue Entity
+
+type History = Seq (Alteration, Comment)
+
+type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m)
+
+instance MonadState s m => MonadState s (InputT m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+
+instance Default (MaxPQueue k v) where
+  def = MaxPQueue.empty
diff --git a/src/Utils.hs b/src/Utils.hs
new file mode 100644
index 0000000..2254fde
--- /dev/null
+++ b/src/Utils.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE ViewPatterns, OverloadedStrings, FlexibleContexts #-}
+
+module Utils
+       ( showEntity
+       , apply, apply'
+       ) where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import Data.Monoid (Monoid(..), (<>))
+
+import Control.Monad.State.Class
+import Control.Monad.Writer.Class
+
+import Types
+
+showEntity :: Entity -> Text
+showEntity (Entity name number)
+  | (Just (show -> n)) <- number = name <> " № " <> Text.pack n
+  | otherwise = name
+
+apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m ()
+apply' alteration = do
+  (newSt, hist) <- apply alteration <$> get
+  tell hist
+  put newSt
+
+apply :: Alteration -> Sequence -> (Sequence, History)
+apply alteration seq = undefined