summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sequence.cabal4
-rw-r--r--sequence.nix8
-rw-r--r--src/Command.hs17
-rw-r--r--src/Main.hs150
-rw-r--r--src/Types.hs66
-rw-r--r--src/Utils.hs30
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
22 build-depends: base >=4.8 && <5 22 build-depends: base >=4.8 && <5
23 , mtl 23 , mtl
24 , transformers 24 , transformers
25 , readline
26 , pqueue 25 , pqueue
27 , text 26 , text
28 , case-insensitive 27 , case-insensitive
29 , containers 28 , containers
30 , lens 29 , xdg-basedir
31 , data-default-class 30 , data-default-class
31 , haskeline
32 hs-source-dirs: src 32 hs-source-dirs: src
33 default-language: Haskell2010 \ No newline at end of file 33 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 @@
1{ mkDerivation, base, case-insensitive, containers 1{ mkDerivation, base, case-insensitive, containers
2, data-default-class, lens, mtl, pqueue, readline, stdenv, text 2, data-default-class, haskeline, mtl, pqueue, stdenv, text
3, transformers 3, transformers, xdg-basedir
4}: 4}:
5mkDerivation { 5mkDerivation {
6 pname = "sequence"; 6 pname = "sequence";
@@ -9,8 +9,8 @@ mkDerivation {
9 isLibrary = false; 9 isLibrary = false;
10 isExecutable = true; 10 isExecutable = true;
11 executableHaskellDepends = [ 11 executableHaskellDepends = [
12 base case-insensitive containers data-default-class lens mtl pqueue 12 base case-insensitive containers data-default-class haskeline mtl
13 readline text transformers 13 pqueue text transformers xdg-basedir
14 ]; 14 ];
15 description = "A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)"; 15 description = "A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)";
16 license = stdenv.lib.licenses.gpl3; 16 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 @@
1{-# LANGUAGE FlexibleContexts #-}
2
3module Command
4 ( Cmd(..)
5 , parseCmd
6 ) where
7
8import Types
9
10data Cmd = PerformAlt Alteration
11 | Quit
12 | Step
13 | UnknownCommand String
14 | ParseError String
15
16parseCmd :: SequenceM m => String -> m Cmd
17parseCmd 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 @@
1{-# LANGUAGE FlexibleContexts, ConstraintKinds, ViewPatterns, OverloadedStrings #-} 1{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-}
2 2
3import Data.PQueue.Prio.Max (MaxPQueue) 3import Data.PQueue.Prio.Max (MaxPQueue)
4import qualified Data.PQueue.Prio.Max as MaxPQueue 4import qualified Data.PQueue.Prio.Max as MaxPQueue
@@ -6,122 +6,46 @@ import qualified Data.PQueue.Prio.Max as MaxPQueue
6import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..)) 6import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..))
7import qualified Data.Sequence as Seq 7import qualified Data.Sequence as Seq
8 8
9import Data.List (delete) 9import Data.Default.Class
10import Data.Bool 10import Data.Maybe (fromMaybe)
11 11
12import Data.Monoid (Monoid(..), (<>)) 12import System.Environment.XDG.BaseDir (getUserCacheFile)
13 13import System.Environment (getProgName)
14import Data.Default.Class 14import System.Exit
15
16import System.Console.Readline (readline)
17
18import Control.Monad.State.Lazy (MonadState(..), runStateT, modify)
19import Control.Monad.IO.Class (MonadIO(..))
20
21import Control.Monad (void, join)
22
23import Control.Lens hiding ((|>), (:<))
24
25import Data.Text (Text)
26import qualified Data.Text as Text
27import qualified Data.Text.IO as Text
28
29import Text.Read (readMaybe)
30
31import Data.CaseInsensitive ( CI )
32import qualified Data.CaseInsensitive as CI
33
34import System.Exit (exitSuccess)
35 15
16import System.Console.Haskeline
36 17
18import Control.Monad.State.Strict
19import Control.Monad.Writer.Strict
20import Control.Monad.IO.Class
21
37import Types 22import Types
23import Utils
24import Command
38 25
39type SequenceM m = (MonadIO m, MonadState SequenceState m) 26type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a
40
41prompt :: String
42prompt = "→ "
43 27
44main :: IO () 28main :: IO ()
45main = void $ runStateT acceptCmd def 29main = do
46 30 historyFile <- flip getUserCacheFile "history" =<< getProgName
47acceptCmd :: SequenceM m => m () 31 let
48acceptCmd = join $ liftIO (readline prompt) >>= handleCmd 32 settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings
49 33 void . flip runStateT def . runInputT settings . runWriterT $ runCli
50terminate :: MonadIO m => m a 34
51terminate = liftIO exitSuccess 35runCli :: (MonadIO m, MonadException m) => SequenceT m ()
52 36runCli = do
53handleCmd :: SequenceM m => Maybe String -> m (m ()) 37 input <- lift $ getInputLine "→ "
54handleCmd Nothing = return terminate -- EOF 38 cmnd <- maybe (return undefined) parseCmd input
55handleCmd (Just "") = return acceptCmd -- Empty input 39 case input of
56handleCmd (Just (Text.words . Text.pack -> (CI.mk -> cmd) : args)) -- Input containing at least one word 40 Nothing -> liftIO exitSuccess
57 | cmd `elem` ["exit", "quit"] = return $ return () 41 Just _ -> do
58 | cmd `elem` ["insert", "add"] = acceptCmd <$ case args of 42 case cmnd of
59 (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 43 UnknownCommand cmd -> do
60 _ -> liftIO . Text.putStrLn $ "Malformed arguments to insert.\nExpecting: insert <name> <sequence value> [<comment> […]]" 44 lift . outputStrLn $ "Unknown command: »" <> cmd <> "«"
61 | cmd == "dump" = acceptCmd <$ (get >>= liftIO . print) 45 ParseError err -> do
62 | otherwise = acceptCmd <$ do 46 lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err
63 liftIO $ Text.putStrLn ("No such command known: " <> CI.original cmd) 47
64handleCmd _ = error "Could not parse input String to Text" 48 Quit -> liftIO exitSuccess
65 49 PerformAlt alt -> apply' alt
66askBool :: MonadIO m => Text -> m Bool 50 Step -> undefined
67askBool question = do 51 runCli
68 str <- liftIO $ readline (Text.unpack question <> " (Yes/No)?\n" <> prompt)
69 case str of
70 Nothing -> terminate
71 Just (CI.mk -> "yes") -> return True
72 Just (CI.mk -> "y") -> return True
73 Just (CI.mk -> "no") -> return False
74 Just (CI.mk -> "n") -> return False
75 _ -> askBool question
76
77withNewName :: SequenceM m => (Entity -> m ()) -> Text -> m Bool
78withNewName callback name = do
79 -- names <- getNames <$> use history
80 entity <- getEntity
81 maybe False (const True) <$> maybe (return Nothing) (\e -> Just <$> callback e) entity
82 where
83 number :: MaxPQueue Integer Entity -> MaxPQueue Integer Entity
84 number = fst . MaxPQueue.foldrWithKey accum (MaxPQueue.empty, 0)
85 accum key val o@(queue, maxNmbr)
86 | (Entity (CI.mk -> val') _) <- val
87 , val' == CI.mk name = (MaxPQueue.insert key (Entity (CI.original val') (Just $ succ maxNmbr)) queue, succ maxNmbr)
88 | otherwise = o
89 getEntity = do
90 names <- MaxPQueue.elems <$> use queue -- we have semantic guarantees that names is a set
91 let
92 takenNumbers = map (\(Entity _ n) -> n) $ filter (\(Entity (CI.mk -> id) _) -> id == CI.mk name) names
93 case takenNumbers of
94 [] -> return . Just $ Entity name Nothing
95 [Nothing] -> do
96 liftIO $ Text.putStrLn ("Name »" <> name <> "« is already taken.")
97 useNumber <- liftIO $ askBool "Introduce a numbering scheme"
98 if useNumber
99 then queue <~ (number) >> getEntity
100 else return Nothing
101 (maximum -> (Just maxNmbr)) -> do
102 let
103 entity = Entity name (Just $ succ maxNmbr)
104 liftIO $ Text.putStrLn ("Changed name to »" <> showEntity entity <> "«")
105 return $ Just entity
106
107parseComment :: [Text] -> Maybe Comment
108parseComment (Text.unwords -> c)
109 | c == "" = Nothing
110 | otherwise = Just c
111
112update :: (Alteration, Maybe Comment) -> SequenceState -> SequenceState
113update loggable@(alt, _) = affect alt . over history (|> loggable)
114
115affect :: Alteration -> SequenceState -> SequenceState
116affect (Modify id by) = over queue $ affect' (\(k, v) -> if v == id then Just (k + by, id) else Just (k, v))
117affect (Override id new) = over queue $ affect' (\(k, v) -> if v == id then Just (new, id) else Just (k, v))
118affect (Drop id) = over queue $ MaxPQueue.filter (/= id)
119affect (Insert id v) = over queue $ MaxPQueue.insert v id
120affect _ = error "Modification not implemented yet"
121
122affect' :: ((Integer, Entity) -> Maybe (Integer, Entity)) -> MaxPQueue Integer Entity -> MaxPQueue Integer Entity
123affect' f = MaxPQueue.foldrWithKey accum MaxPQueue.empty
124 where
125 accum key val
126 | (Just (key', val')) <- f (key, val) = MaxPQueue.insert key' val'
127 | otherwise = id
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 @@
1{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} 1{-# LANGUAGE TemplateHaskell, OverloadedStrings, ConstraintKinds, FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}
2 3
3module Types 4module Types
4 ( Entity(..) 5 ( Entity(..)
5 , showEntity 6 , SequenceValue
6 , Comment 7 , Comment
7 , Alteration(..) 8 , Alteration(..)
8 , SequenceState, queue, history 9 , Sequence
10 , History
11 , SequenceM
9 ) where 12 ) where
10 13
11import Data.PQueue.Prio.Max (MaxPQueue) 14import Data.PQueue.Prio.Max (MaxPQueue)
12import qualified Data.PQueue.Prio.Max as MaxPQueue 15import qualified Data.PQueue.Prio.Max as MaxPQueue (empty)
13 16
14import Data.Sequence (Seq) 17import Data.Sequence (Seq)
15import qualified Data.Sequence as Seq
16 18
17import Data.Monoid (Monoid(..), (<>)) 19import Data.Text (Text)
18 20
19import Control.Monad.State.Lazy (MonadState) 21import Data.Default.Class
20import Control.Monad.IO.Class (MonadIO)
21 22
22import Data.Text (Text) 23import Control.Monad.State.Strict (MonadState(..), MonadTrans(..))
23import qualified Data.Text as Text 24import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..))
24import qualified Data.Text.IO as Text
25 25
26import Control.Lens.TH 26import Control.Monad.IO.Class (MonadIO)
27 27
28import Data.Default.Class 28import System.Console.Haskeline (InputT)
29 29
30
30data Entity = Entity Text (Maybe Integer) 31data Entity = Entity Text (Maybe Integer)
31 deriving (Eq, Ord, Show) 32 deriving (Eq, Ord, Show)
32 33
33showEntity :: Entity -> Text 34type SequenceValue = Integer
34showEntity (Entity t Nothing) = t
35showEntity (Entity t (Just n)) = t <> " " <> (Text.pack $ show n)
36 35
37type Comment = Text 36type Comment = Text
38 37
39data Alteration = Modify Entity Integer 38data Alteration = Modify Entity SequenceValue
40 | Override Entity Integer 39 | Override Entity SequenceValue
41 | Drop Entity 40 | Drop Entity
42 | Insert Entity Integer 41 | Insert Entity SequenceValue
43 | Rename Entity Entity 42 | Rename Entity Entity
44 deriving (Show) 43 deriving (Show)
45 44
46data SequenceState = SequenceState 45type Sequence = MaxPQueue SequenceValue Entity
47 { _queue :: MaxPQueue Integer Entity -- Current state 46
48 , _history :: Seq (Alteration, Maybe Comment) -- Most recent last 47type History = Seq (Alteration, Comment)
49 } 48
50 deriving (Show) 49type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m)
51makeLenses ''SequenceState 50
52 51instance MonadState s m => MonadState s (InputT m) where
53instance Default SequenceState where 52 get = lift get
54 def = SequenceState 53 put = lift . put
55 { _queue = MaxPQueue.empty 54 state = lift . state
56 , _history = Seq.empty 55
57 } 56instance Default (MaxPQueue k v) where
57 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 @@
1{-# LANGUAGE ViewPatterns, OverloadedStrings, FlexibleContexts #-}
2
3module Utils
4 ( showEntity
5 , apply, apply'
6 ) where
7
8import Data.Text (Text)
9import qualified Data.Text as Text
10
11import Data.Monoid (Monoid(..), (<>))
12
13import Control.Monad.State.Class
14import Control.Monad.Writer.Class
15
16import Types
17
18showEntity :: Entity -> Text
19showEntity (Entity name number)
20 | (Just (show -> n)) <- number = name <> " № " <> Text.pack n
21 | otherwise = name
22
23apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m ()
24apply' alteration = do
25 (newSt, hist) <- apply alteration <$> get
26 tell hist
27 put newSt
28
29apply :: Alteration -> Sequence -> (Sequence, History)
30apply alteration seq = undefined