From 3df1de8111f8efa853ed73161a28cb69612322d3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 7 May 2016 21:43:23 +0200 Subject: haskeline based framework --- src/Command.hs | 17 +++++++ src/Main.hs | 150 ++++++++++++++------------------------------------------- src/Types.hs | 66 ++++++++++++------------- src/Utils.hs | 30 ++++++++++++ 4 files changed, 117 insertions(+), 146 deletions(-) create mode 100644 src/Command.hs create mode 100644 src/Utils.hs (limited to 'src') 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 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Command + ( Cmd(..) + , parseCmd + ) where + +import Types + +data Cmd = PerformAlt Alteration + | Quit + | Step + | UnknownCommand String + | ParseError String + +parseCmd :: SequenceM m => String -> m Cmd +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 @@ -{-# LANGUAGE FlexibleContexts, ConstraintKinds, ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-} import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as MaxPQueue @@ -6,122 +6,46 @@ 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.Default.Class +import Data.Maybe (fromMaybe) -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 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 -type SequenceM m = (MonadIO m, MonadState SequenceState m) - -prompt :: String -prompt = "→ " +type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a 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 +main = do + historyFile <- flip getUserCacheFile "history" =<< getProgName + let + settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings + void . flip runStateT def . runInputT settings . runWriterT $ runCli + +runCli :: (MonadIO m, MonadException m) => SequenceT m () +runCli = do + input <- lift $ getInputLine "→ " + cmnd <- maybe (return undefined) parseCmd input + case input of + Nothing -> liftIO exitSuccess + Just _ -> do + case cmnd of + UnknownCommand cmd -> do + lift . outputStrLn $ "Unknown command: »" <> cmd <> "«" + ParseError err -> do + lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err + + Quit -> liftIO exitSuccess + PerformAlt alt -> apply' alt + Step -> undefined + runCli 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 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, OverloadedStrings, ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-} module Types ( Entity(..) - , showEntity + , SequenceValue , Comment , Alteration(..) - , SequenceState, queue, history + , Sequence + , History + , SequenceM ) where -import Data.PQueue.Prio.Max (MaxPQueue) -import qualified Data.PQueue.Prio.Max as MaxPQueue +import Data.PQueue.Prio.Max (MaxPQueue) +import qualified Data.PQueue.Prio.Max as MaxPQueue (empty) -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq +import Data.Sequence (Seq) -import Data.Monoid (Monoid(..), (<>)) +import Data.Text (Text) -import Control.Monad.State.Lazy (MonadState) -import Control.Monad.IO.Class (MonadIO) +import Data.Default.Class -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Control.Monad.State.Strict (MonadState(..), MonadTrans(..)) +import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..)) -import Control.Lens.TH +import Control.Monad.IO.Class (MonadIO) -import Data.Default.Class +import System.Console.Haskeline (InputT) + 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 SequenceValue = Integer type Comment = Text -data Alteration = Modify Entity Integer - | Override Entity Integer +data Alteration = Modify Entity SequenceValue + | Override Entity SequenceValue | Drop Entity - | Insert Entity Integer + | Insert Entity SequenceValue | 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 - } +type Sequence = MaxPQueue SequenceValue Entity + +type History = Seq (Alteration, Comment) + +type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m) + +instance MonadState s m => MonadState s (InputT m) where + get = lift get + put = lift . put + state = lift . state + +instance Default (MaxPQueue k v) where + 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 @@ +{-# LANGUAGE ViewPatterns, OverloadedStrings, FlexibleContexts #-} + +module Utils + ( showEntity + , apply, apply' + ) where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Monoid (Monoid(..), (<>)) + +import Control.Monad.State.Class +import Control.Monad.Writer.Class + +import Types + +showEntity :: Entity -> Text +showEntity (Entity name number) + | (Just (show -> n)) <- number = name <> " № " <> Text.pack n + | otherwise = name + +apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m () +apply' alteration = do + (newSt, hist) <- apply alteration <$> get + tell hist + put newSt + +apply :: Alteration -> Sequence -> (Sequence, History) +apply alteration seq = undefined -- cgit v1.2.3