module Language.Explorer.Tools.REPL where import Control.Monad.IO.Class (MonadIO(..)) import Language.Explorer.Monadic (Explorer(config), execute, revert, jump, toTree) import qualified System.Console.Haskeline as Hl import Data.Tree (drawTree) import Data.Maybe (fromJust, isNothing) import Data.Char (isSpace) import Data.List (find, isPrefixOf) import Text.Read (readMaybe) import Control.Arrow (Arrow(first)) import Control.Monad.Trans import Control.Monad.Catch type MetaTable p m c o = [(String, String -> Explorer p m c o -> m (Explorer p m c o))] type RParser p c = String -> c -> Maybe p type Prompt p m c o = Explorer p m c o -> String type MetaHandler p m c o = String -> Explorer p m c o -> m (Explorer p m c o) type OutputHandler m o = o -> m () type Repl p m c o = Prompt p m c o -> RParser p c -> String -> MetaTable p m c o -> MetaHandler p m c o -> OutputHandler m o -> Explorer p m c o -> m () handleJump :: MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o) handleJump :: String -> Explorer p m c o -> m (Explorer p m c o) handleJump String input Explorer p m c o ex = case String -> Maybe Ref forall a. Read a => String -> Maybe a readMaybe ((Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace String input) of (Just Ref ref_id) -> case Ref -> Explorer p m c o -> Maybe (Explorer p m c o) forall p (m :: * -> *) c o. Ref -> Explorer p m c o -> Maybe (Explorer p m c o) jump Ref ref_id Explorer p m c o ex of (Just Explorer p m c o ex') -> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex' Maybe (Explorer p m c o) Nothing -> IO (Explorer p m c o) -> m (Explorer p m c o) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Explorer p m c o) -> m (Explorer p m c o)) -> IO (Explorer p m c o) -> m (Explorer p m c o) forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn String "Given reference is not in the exploration tree." IO () -> IO (Explorer p m c o) -> IO (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Explorer p m c o -> IO (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex Maybe Ref Nothing -> IO (Explorer p m c o) -> m (Explorer p m c o) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Explorer p m c o) -> m (Explorer p m c o)) -> IO (Explorer p m c o) -> m (Explorer p m c o) forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn String "the jump command requires an integer argument." IO () -> IO (Explorer p m c o) -> IO (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Explorer p m c o -> IO (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex handleRevert :: MonadIO m => MetaHandler p m c o handleRevert :: MetaHandler p m c o handleRevert String input Explorer p m c o ex = case String -> Maybe Ref forall a. Read a => String -> Maybe a readMaybe ((Char -> Bool) -> String -> String forall a. (a -> Bool) -> [a] -> [a] dropWhile Char -> Bool isSpace String input) of (Just Ref ref_id) -> case Ref -> Explorer p m c o -> Maybe (Explorer p m c o) forall p (m :: * -> *) c o. Ref -> Explorer p m c o -> Maybe (Explorer p m c o) revert Ref ref_id Explorer p m c o ex of (Just Explorer p m c o ex') -> do IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn String "reverting" Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex' Maybe (Explorer p m c o) Nothing -> IO (Explorer p m c o) -> m (Explorer p m c o) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Explorer p m c o) -> m (Explorer p m c o)) -> IO (Explorer p m c o) -> m (Explorer p m c o) forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn String "Given reference is not valid for reverting." IO () -> IO (Explorer p m c o) -> IO (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Explorer p m c o -> IO (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex Maybe Ref Nothing -> IO (Explorer p m c o) -> m (Explorer p m c o) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Explorer p m c o) -> m (Explorer p m c o)) -> IO (Explorer p m c o) -> m (Explorer p m c o) forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn String "the jump command requires an integer argument." IO () -> IO (Explorer p m c o) -> IO (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Explorer p m c o -> IO (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex handleTree :: MonadIO m => MetaHandler p m c o handleTree :: MetaHandler p m c o handleTree String input Explorer p m c o ex = do IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ String -> IO () putStrLn (String -> IO ()) -> (Tree String -> String) -> Tree String -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Tree String -> String drawTree (Tree String -> IO ()) -> Tree String -> IO () forall a b. (a -> b) -> a -> b $ ((Ref, c) -> String) -> Tree (Ref, c) -> Tree String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Ref -> String forall a. Show a => a -> String show (Ref -> String) -> ((Ref, c) -> Ref) -> (Ref, c) -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . (Ref, c) -> Ref forall a b. (a, b) -> a fst) (Explorer p m c o -> Tree (Ref, c) forall p (m :: * -> *) c o. Explorer p m c o -> Tree (Ref, c) toTree Explorer p m c o ex) Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex metaTable :: MonadIO m => [(String, String -> Explorer p m c o -> m (Explorer p m c o))] metaTable :: [(String, String -> Explorer p m c o -> m (Explorer p m c o))] metaTable = [ (String "jump", String -> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) p c o. MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o) handleJump), (String "revert", String -> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) p c o. MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o) handleRevert), (String "tree", String -> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) p c o. MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o) handleTree)] constructMetaTable :: MonadIO m => String -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))] constructMetaTable :: String -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))] constructMetaTable String prefix = ((String, String -> Explorer p m c o -> m (Explorer p m c o)) -> (String, String -> Explorer p m c o -> m (Explorer p m c o))) -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))] -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))] forall a b. (a -> b) -> [a] -> [b] map ((String -> String) -> (String, String -> Explorer p m c o -> m (Explorer p m c o)) -> (String, String -> Explorer p m c o -> m (Explorer p m c o)) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first (String prefix String -> String -> String forall a. [a] -> [a] -> [a] ++ )) [(String, String -> Explorer p m c o -> m (Explorer p m c o))] forall (m :: * -> *) p c o. MonadIO m => [(String, String -> Explorer p m c o -> m (Explorer p m c o))] metaTable repl :: (Eq p, Eq o, Monoid o, MonadIO m, MonadMask m) => Repl p m c o repl :: Repl p m c o repl Prompt p m c o prompt RParser p c parser String metaPrefix MetaTable p m c o metaTable MetaHandler p m c o metaHandler OutputHandler m o outputHandler Explorer p m c o ex = Settings m -> InputT m () -> m () forall (m :: * -> *) a. (MonadIO m, MonadMask m) => Settings m -> InputT m a -> m a Hl.runInputT Settings m forall (m :: * -> *). MonadIO m => Settings m Hl.defaultSettings (Explorer p m c o -> InputT m () loop Explorer p m c o ex) where loop :: Explorer p m c o -> InputT m () loop Explorer p m c o ex = do Maybe String minput <- String -> InputT m (Maybe String) forall (m :: * -> *). (MonadIO m, MonadMask m) => String -> InputT m (Maybe String) Hl.getInputLine (String -> InputT m (Maybe String)) -> Prompt p m c o -> Explorer p m c o -> InputT m (Maybe String) forall b c a. (b -> c) -> (a -> b) -> a -> c . Prompt p m c o prompt (Explorer p m c o -> InputT m (Maybe String)) -> Explorer p m c o -> InputT m (Maybe String) forall a b. (a -> b) -> a -> b $ Explorer p m c o ex case Maybe String minput of (Just String input) -> m (Explorer p m c o) -> InputT m (Explorer p m c o) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (if String metaPrefix String -> String -> Bool forall a. Eq a => [a] -> [a] -> Bool `isPrefixOf` String input then String -> m (Explorer p m c o) runMeta String input else String -> m (Explorer p m c o) runExec String input) InputT m (Explorer p m c o) -> (Explorer p m c o -> InputT m ()) -> InputT m () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Explorer p m c o -> InputT m () loop Maybe String Nothing -> () -> InputT m () forall (m :: * -> *) a. Monad m => a -> m a return () where runMeta :: String -> m (Explorer p m c o) runMeta String input = let (String pcmd, String args) = (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break Char -> Bool isSpace String input in case ((String, MetaHandler p m c o) -> Bool) -> MetaTable p m c o -> Maybe (String, MetaHandler p m c o) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a find (\(String cmd, MetaHandler p m c o _) -> (String metaPrefix String -> String -> String forall a. [a] -> [a] -> [a] ++ String cmd) String -> String -> Bool forall a. Eq a => a -> a -> Bool == String pcmd) MetaTable p m c o metaTable of Just (String _, MetaHandler p m c o f) -> MetaHandler p m c o f String args Explorer p m c o ex Maybe (String, MetaHandler p m c o) Nothing -> MetaHandler p m c o metaHandler String input Explorer p m c o ex runExec :: String -> m (Explorer p m c o) runExec String input = case RParser p c parser String input (Explorer p m c o -> c forall programs (m :: * -> *) configs output. Explorer programs m configs output -> configs config Explorer p m c o ex) of (Just p program) -> p -> Explorer p m c o -> m (Explorer p m c o, o) forall p (m :: * -> *) c o. Language p m c o => p -> Explorer p m c o -> m (Explorer p m c o, o) execute p program Explorer p m c o ex m (Explorer p m c o, o) -> ((Explorer p m c o, o) -> m (Explorer p m c o)) -> m (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \(Explorer p m c o newEx, o out) -> OutputHandler m o outputHandler o out m () -> m (Explorer p m c o) -> m (Explorer p m c o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o newEx Maybe p Nothing -> Explorer p m c o -> m (Explorer p m c o) forall (m :: * -> *) a. Monad m => a -> m a return Explorer p m c o ex