From 2e662e12f5fd6d26eee9e74b06b9cf3d176df07e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 7 May 2016 20:29:51 +0200 Subject: First prototype --- src/Main.hs | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Types.hs | 57 +++++++++++++++++++++++++++ 2 files changed, 184 insertions(+) create mode 100644 src/Main.hs create mode 100644 src/Types.hs 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 [ […]]" + | 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 + } -- cgit v1.2.3