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
|
{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings, TupleSections #-}
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.Text (Text)
import qualified Data.Text as Text
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Default.Class
import Data.Maybe (fromMaybe, isNothing, fromJust)
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
main :: IO ()
main = do
historyFile <- flip getUserCacheFile "history" =<< getProgName
let
settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings
void . flip runStateT def . runInputT settings $ runCli
-- data Cmd = PerformAlt Alteration (Maybe Comment)
-- | ShowTip
-- | ShowHistory (Maybe Integer)
-- | Dump
runCli :: (MonadIO m, MonadException m, SequenceM m) => InputT m ()
runCli = do
input <- getInputLine "→ "
case input of
Nothing -> liftIO exitSuccess
Just input' -> do
cmd <- parseCmd input'
case cmd of
UnknownCommand help -> do
outputStrLn $ help
ParseError err -> do
outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err
Empty -> return ()
Quit -> liftIO exitSuccess
Dump -> gets ctxSequence >>= mapM_ (outputStrLn . showAssoc) . MaxPQueue.toDescList
ShowTip -> do
tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
case tip of
Just entity -> outputStrLn . Text.unpack $ showEntity entity
Nothing -> outputStrLn "Queue is currently empty"
ShowHistory ns -> do
let sel = maybe id takeR ns
mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory
PerformAlt alt comment -> apply alt comment
_ -> undefined
runCli
showAssoc :: (SequenceValue, Entity) -> String
showAssoc (val, entity) = show val <> "\t" <> (Text.unpack $ showEntity entity)
apply :: SequenceM m => Alteration -> Comment -> InputT m ()
apply alteration comment = alter alteration >> modify (\ctx -> ctx { ctxHistory = ctxHistory ctx |> (alteration, comment) })
alter :: SequenceM m => Alteration -> InputT m ()
alter (Modify entity ((+) -> mod)) = alterMatching entity mod
alter (Override entity (const -> mod)) = alterMatching entity mod
alter (Rename old new) = do
[(k, _)] <- filter (\(_, v) -> v == old) <$> gets (MaxPQueue.assocsU . ctxSequence)
alter (Drop old)
alter (Insert new k)
alter (Drop entity) = do
(matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
modify $ \ctx -> ctx { ctxSequence = notMatching }
when (MaxPQueue.null matching) warnEmpty
alter (Insert entity val) = do
modify $ \ctx -> ctx { ctxSequence = MaxPQueue.insert val entity $ ctxSequence ctx }
introduceNumbering entity
alterMatching :: SequenceM m => Entity -> (SequenceValue -> SequenceValue) -> InputT m ()
alterMatching entity mod = do
(matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
modify $ \ctx -> ctx { ctxSequence = notMatching `MaxPQueue.union` MaxPQueue.mapKeys mod matching }
when (MaxPQueue.null matching) warnEmpty
introduceNumbering :: SequenceM m => Entity -> InputT m ()
introduceNumbering entity = do
let
matches (Entity name _) (Entity name' _) = name == name'
(matching, notMatching) <- MaxPQueue.partition (matches entity) <$> gets ctxSequence
if MaxPQueue.size matching <= 1
then return ()
else do
let
(matching', notMatching') = MaxPQueue.partition (\(Entity _ n) -> isNothing n) matching
maxN = MaxPQueue.foldrU (\(Entity _ n) -> max n) (Just 0) notMatching'
modify $ \ctx -> ctx { ctxSequence = snd $ MaxPQueue.foldrWithKey accum (fromJust maxN, MaxPQueue.union notMatching notMatching') matching' }
if MaxPQueue.null notMatching'
then outputStrLn $ "Had to introduce a numbering scheme to differentiate multiple entities called »" <> (Text.unpack $ showEntity entity) <> "«"
else outputStrLn $ "Inserted new entity called »" <> (Text.unpack $ showEntity entity) <> "« into existing numbering scheme"
where
accum key (Entity val _) (n, queue) = (succ n, MaxPQueue.insert key (Entity val $ Just (succ n)) queue)
warnEmpty :: MonadIO m => InputT m ()
warnEmpty = outputStrLn "Selection did not match any entities"
|
