diff options
-rw-r--r-- | sequence.cabal | 4 | ||||
-rw-r--r-- | sequence.nix | 8 | ||||
-rw-r--r-- | src/Command.hs | 17 | ||||
-rw-r--r-- | src/Main.hs | 150 | ||||
-rw-r--r-- | src/Types.hs | 66 | ||||
-rw-r--r-- | src/Utils.hs | 30 |
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 | }: |
5 | mkDerivation { | 5 | mkDerivation { |
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 | |||
3 | module Command | ||
4 | ( Cmd(..) | ||
5 | , parseCmd | ||
6 | ) where | ||
7 | |||
8 | import Types | ||
9 | |||
10 | data Cmd = PerformAlt Alteration | ||
11 | | Quit | ||
12 | | Step | ||
13 | | UnknownCommand String | ||
14 | | ParseError String | ||
15 | |||
16 | parseCmd :: SequenceM m => String -> m Cmd | ||
17 | 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 @@ | |||
1 | {-# LANGUAGE FlexibleContexts, ConstraintKinds, ViewPatterns, OverloadedStrings #-} | 1 | {-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-} |
2 | 2 | ||
3 | import Data.PQueue.Prio.Max (MaxPQueue) | 3 | import Data.PQueue.Prio.Max (MaxPQueue) |
4 | import qualified Data.PQueue.Prio.Max as MaxPQueue | 4 | import qualified Data.PQueue.Prio.Max as MaxPQueue |
@@ -6,122 +6,46 @@ import qualified Data.PQueue.Prio.Max as MaxPQueue | |||
6 | import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..)) | 6 | import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..)) |
7 | import qualified Data.Sequence as Seq | 7 | import qualified Data.Sequence as Seq |
8 | 8 | ||
9 | import Data.List (delete) | 9 | import Data.Default.Class |
10 | import Data.Bool | 10 | import Data.Maybe (fromMaybe) |
11 | 11 | ||
12 | import Data.Monoid (Monoid(..), (<>)) | 12 | import System.Environment.XDG.BaseDir (getUserCacheFile) |
13 | 13 | import System.Environment (getProgName) | |
14 | import Data.Default.Class | 14 | import System.Exit |
15 | |||
16 | import System.Console.Readline (readline) | ||
17 | |||
18 | import Control.Monad.State.Lazy (MonadState(..), runStateT, modify) | ||
19 | import Control.Monad.IO.Class (MonadIO(..)) | ||
20 | |||
21 | import Control.Monad (void, join) | ||
22 | |||
23 | import Control.Lens hiding ((|>), (:<)) | ||
24 | |||
25 | import Data.Text (Text) | ||
26 | import qualified Data.Text as Text | ||
27 | import qualified Data.Text.IO as Text | ||
28 | |||
29 | import Text.Read (readMaybe) | ||
30 | |||
31 | import Data.CaseInsensitive ( CI ) | ||
32 | import qualified Data.CaseInsensitive as CI | ||
33 | |||
34 | import System.Exit (exitSuccess) | ||
35 | 15 | ||
16 | import System.Console.Haskeline | ||
36 | 17 | ||
18 | import Control.Monad.State.Strict | ||
19 | import Control.Monad.Writer.Strict | ||
20 | import Control.Monad.IO.Class | ||
21 | |||
37 | import Types | 22 | import Types |
23 | import Utils | ||
24 | import Command | ||
38 | 25 | ||
39 | type SequenceM m = (MonadIO m, MonadState SequenceState m) | 26 | type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a |
40 | |||
41 | prompt :: String | ||
42 | prompt = "→ " | ||
43 | 27 | ||
44 | main :: IO () | 28 | main :: IO () |
45 | main = void $ runStateT acceptCmd def | 29 | main = do |
46 | 30 | historyFile <- flip getUserCacheFile "history" =<< getProgName | |
47 | acceptCmd :: SequenceM m => m () | 31 | let |
48 | acceptCmd = 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 | |
50 | terminate :: MonadIO m => m a | 34 | |
51 | terminate = liftIO exitSuccess | 35 | runCli :: (MonadIO m, MonadException m) => SequenceT m () |
52 | 36 | runCli = do | |
53 | handleCmd :: SequenceM m => Maybe String -> m (m ()) | 37 | input <- lift $ getInputLine "→ " |
54 | handleCmd Nothing = return terminate -- EOF | 38 | cmnd <- maybe (return undefined) parseCmd input |
55 | handleCmd (Just "") = return acceptCmd -- Empty input | 39 | case input of |
56 | handleCmd (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 | |
64 | handleCmd _ = error "Could not parse input String to Text" | 48 | Quit -> liftIO exitSuccess |
65 | 49 | PerformAlt alt -> apply' alt | |
66 | askBool :: MonadIO m => Text -> m Bool | 50 | Step -> undefined |
67 | askBool 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 | |||
77 | withNewName :: SequenceM m => (Entity -> m ()) -> Text -> m Bool | ||
78 | withNewName 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 | |||
107 | parseComment :: [Text] -> Maybe Comment | ||
108 | parseComment (Text.unwords -> c) | ||
109 | | c == "" = Nothing | ||
110 | | otherwise = Just c | ||
111 | |||
112 | update :: (Alteration, Maybe Comment) -> SequenceState -> SequenceState | ||
113 | update loggable@(alt, _) = affect alt . over history (|> loggable) | ||
114 | |||
115 | affect :: Alteration -> SequenceState -> SequenceState | ||
116 | affect (Modify id by) = over queue $ affect' (\(k, v) -> if v == id then Just (k + by, id) else Just (k, v)) | ||
117 | affect (Override id new) = over queue $ affect' (\(k, v) -> if v == id then Just (new, id) else Just (k, v)) | ||
118 | affect (Drop id) = over queue $ MaxPQueue.filter (/= id) | ||
119 | affect (Insert id v) = over queue $ MaxPQueue.insert v id | ||
120 | affect _ = error "Modification not implemented yet" | ||
121 | |||
122 | affect' :: ((Integer, Entity) -> Maybe (Integer, Entity)) -> MaxPQueue Integer Entity -> MaxPQueue Integer Entity | ||
123 | affect' 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 | ||
3 | module Types | 4 | module 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 | ||
11 | import Data.PQueue.Prio.Max (MaxPQueue) | 14 | import Data.PQueue.Prio.Max (MaxPQueue) |
12 | import qualified Data.PQueue.Prio.Max as MaxPQueue | 15 | import qualified Data.PQueue.Prio.Max as MaxPQueue (empty) |
13 | 16 | ||
14 | import Data.Sequence (Seq) | 17 | import Data.Sequence (Seq) |
15 | import qualified Data.Sequence as Seq | ||
16 | 18 | ||
17 | import Data.Monoid (Monoid(..), (<>)) | 19 | import Data.Text (Text) |
18 | 20 | ||
19 | import Control.Monad.State.Lazy (MonadState) | 21 | import Data.Default.Class |
20 | import Control.Monad.IO.Class (MonadIO) | ||
21 | 22 | ||
22 | import Data.Text (Text) | 23 | import Control.Monad.State.Strict (MonadState(..), MonadTrans(..)) |
23 | import qualified Data.Text as Text | 24 | import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..)) |
24 | import qualified Data.Text.IO as Text | ||
25 | 25 | ||
26 | import Control.Lens.TH | 26 | import Control.Monad.IO.Class (MonadIO) |
27 | 27 | ||
28 | import Data.Default.Class | 28 | import System.Console.Haskeline (InputT) |
29 | 29 | ||
30 | |||
30 | data Entity = Entity Text (Maybe Integer) | 31 | data Entity = Entity Text (Maybe Integer) |
31 | deriving (Eq, Ord, Show) | 32 | deriving (Eq, Ord, Show) |
32 | 33 | ||
33 | showEntity :: Entity -> Text | 34 | type SequenceValue = Integer |
34 | showEntity (Entity t Nothing) = t | ||
35 | showEntity (Entity t (Just n)) = t <> " " <> (Text.pack $ show n) | ||
36 | 35 | ||
37 | type Comment = Text | 36 | type Comment = Text |
38 | 37 | ||
39 | data Alteration = Modify Entity Integer | 38 | data 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 | ||
46 | data SequenceState = SequenceState | 45 | type Sequence = MaxPQueue SequenceValue Entity |
47 | { _queue :: MaxPQueue Integer Entity -- Current state | 46 | |
48 | , _history :: Seq (Alteration, Maybe Comment) -- Most recent last | 47 | type History = Seq (Alteration, Comment) |
49 | } | 48 | |
50 | deriving (Show) | 49 | type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m) |
51 | makeLenses ''SequenceState | 50 | |
52 | 51 | instance MonadState s m => MonadState s (InputT m) where | |
53 | instance 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 | } | 56 | instance 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 | |||
3 | module Utils | ||
4 | ( showEntity | ||
5 | , apply, apply' | ||
6 | ) where | ||
7 | |||
8 | import Data.Text (Text) | ||
9 | import qualified Data.Text as Text | ||
10 | |||
11 | import Data.Monoid (Monoid(..), (<>)) | ||
12 | |||
13 | import Control.Monad.State.Class | ||
14 | import Control.Monad.Writer.Class | ||
15 | |||
16 | import Types | ||
17 | |||
18 | showEntity :: Entity -> Text | ||
19 | showEntity (Entity name number) | ||
20 | | (Just (show -> n)) <- number = name <> " № " <> Text.pack n | ||
21 | | otherwise = name | ||
22 | |||
23 | apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m () | ||
24 | apply' alteration = do | ||
25 | (newSt, hist) <- apply alteration <$> get | ||
26 | tell hist | ||
27 | put newSt | ||
28 | |||
29 | apply :: Alteration -> Sequence -> (Sequence, History) | ||
30 | apply alteration seq = undefined | ||