1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
{-# LANGUAGE FlexibleContexts, ConstraintKinds, ViewPatterns, OverloadedStrings #-}
import Data.PQueue.Prio.Max (MaxPQueue)
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.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 Types
type SequenceM m = (MonadIO m, MonadState SequenceState m)
prompt :: String
prompt = "→ "
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
|
