First prototype

2 files changed, 184 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..eff9a92
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,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
diff --git a/src/Types.hs b/src/Types.hs
new file mode 100644
index 0000000..2dff0f0
--- /dev/null
+++ b/src/Types.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module Types
+       ( Entity(..)
+       , showEntity
+       , Comment
+       , Alteration(..)
+       , SequenceState, queue, history
+       ) where
+
+import           Data.PQueue.Prio.Max (MaxPQueue)
+import qualified Data.PQueue.Prio.Max as MaxPQueue
+
+import           Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import           Data.Monoid (Monoid(..), (<>))
+
+import           Control.Monad.State.Lazy (MonadState)
+import           Control.Monad.IO.Class (MonadIO)
+
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+import           Control.Lens.TH
+
+import           Data.Default.Class
+
+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 Comment = Text
+
+data Alteration = Modify Entity Integer
+                | Override Entity Integer
+                | Drop Entity
+                | Insert Entity Integer
+                | 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
+        }