hpage-0.1.5: src/HPage/Control.hs
{-# LANGUAGE GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
FlexibleInstances,
FunctionalDependencies,
TypeSynonymInstances,
UndecidableInstances #-}
module HPage.Control (
-- MONAD CONTROLS --
HPage, evalHPage,
-- PAGE CONTROLS --
getPageIndex, setPageIndex, getPageCount,
addPage, openPage, closePage, closeAllPages, getPagePath,
savePage, savePageAs,
isModifiedPage, isModifiedPageNth,
closePageNth, getPageNthPath,
savePageNth, savePageNthAs,
PageDescription(..), getPageDesc, getPageNthDesc,
-- SAFE PAGE CONTROLS --
safeClosePage, safeCloseAllPages,
safeSavePageAs, safeClosePageNth,
safeSavePageNthAs,
-- EXPRESSION CONTROLS --
setPageText, getPageText, clearPage,
getExprIndex, setExprIndex, getExprCount,
addExpr, removeExpr,
setExprText, getExprText,
removeNth,
setExprNthText, getExprNthText,
-- EDITION CONTROLS --
undo, redo,
-- HINT CONTROLS --
valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth,
loadModules, reloadModules, getLoadedModules,
getLanguageExtensions, setLanguageExtensions,
valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth',
loadModules', reloadModules', getLoadedModules',
getLanguageExtensions', setLanguageExtensions',
reset, reset',
cancel,
Hint.InterpreterError, Hint.prettyPrintError,
Hint.availableExtensions, Extension,
-- DEBUG --
ctxString
) where
import System.IO
import System.Directory
import Data.Set (Set, empty, union, fromList, toList)
import Data.Char
import Control.Monad.Loops
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.State.Class
import Control.Concurrent.MVar
import Language.Haskell.Interpreter (OptionVal((:=)))
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Utils as Hint
import qualified Language.Haskell.Interpreter.Server as HS
import Utils.Log
import Data.List (isPrefixOf)
import qualified Data.List as List
import qualified Data.ByteString.Char8 as Str
import Language.Haskell.Exts.Parser
data PageDescription = PageDesc {pIndex :: Int,
pPath :: Maybe FilePath,
pIsModified :: Bool}
deriving (Eq, Show)
newtype Expression = Exp {exprText :: String}
deriving (Eq, Show)
data InFlightData = LoadModules { loadingModules :: Set String,
runningAction :: Hint.InterpreterT IO ()
} | Reset
data Page = Page { -- Display --
expressions :: [Expression],
currentExpr :: Int,
undoActions :: [HPage ()],
redoActions :: [HPage ()],
original :: [Expression],
-- File System --
filePath :: Maybe FilePath
}
instance Show Page where
show p = "Text: " ++ (showExpressions p) ++
"\nFile: " ++ show (filePath p)
where showExpressions pg = showWithCurrent (expressions pg) (currentExpr pg) "\n\n" $ ("["++) . (++"]")
data Context = Context { -- Pages --
pages :: [Page],
currentPage :: Int,
-- Hint --
loadedModules :: Set String,
server :: HS.ServerHandle,
running :: Maybe InFlightData,
recoveryLog :: Hint.InterpreterT IO () -- To allow cancelation of actions
}
instance Show Context where
show c = showWithCurrent (pages c) (currentPage c) sep $ (top++) . (++bottom)
where sep = "\n" ++ replicate 80 '-' ++ "\n"
top = replicate 80 'v' ++ "\n"
bottom = "\n" ++ replicate 80 '^'
newtype HPageT m a = HPT { state :: StateT Context m a }
deriving (Monad, MonadIO, MonadTrans)
instance Monad m => MonadState Context (HPageT m) where
get = HPT $ get
put = HPT . put
instance MonadError e m => MonadError e (HPageT m) where
throwError = lift . throwError
catchError (HPT a) h = HPT $ a `catchError` (\e -> state $ h e)
type Extension = Hint.Extension
instance Ord Extension where
e1 `compare` e2 = (show e1) `compare` (show e2)
type HPage = HPageT IO
evalHPage :: HPage a -> IO a
evalHPage hpt = do
hs <- liftIO $ HS.start
let nop = return ()
let emptyContext = Context [emptyPage] 0 empty hs Nothing nop
(state hpt) `evalStateT` emptyContext
ctxString :: HPage String
ctxString = get >>= return . show
addPage :: HPage ()
addPage = modify (\ctx -> ctx{pages = emptyPage:(pages ctx),
currentPage = 0})
openPage :: FilePath -> HPage ()
openPage file = do
liftTraceIO $ "opening: " ++ file
s <- liftIO $ Str.readFile file
let str = Str.unpack s
let (newExprs, curExpr) = fromString' str $ length str
newPage = emptyPage{expressions = newExprs,
currentExpr = curExpr,
filePath = Just file,
original = newExprs}
modify (\ctx -> ctx{pages = newPage : pages ctx,
currentPage = 0})
savePage :: HPage ()
savePage = get >>= savePageNth . currentPage
savePageNth :: Int -> HPage ()
savePageNth i = do
page <- getPageNth i
case filePath page of
Nothing ->
fail "No place to save"
Just file ->
savePageNthAs i file
savePageAs :: FilePath -> HPage ()
savePageAs file = get >>= (flip savePageNthAs) file . currentPage
savePageNthAs :: Int -> FilePath -> HPage ()
savePageNthAs i file = do
p <- getPageNth i
liftTraceIO $ "writing: " ++ file
liftIO $ Str.writeFile file $ Str.pack $ toString p
modifyPageNth i (\page -> page{filePath = Just file,
original = (expressions page)})
isModifiedPage :: HPage Bool
isModifiedPage = get >>= isModifiedPageNth . currentPage
isModifiedPageNth :: Int -> HPage Bool
isModifiedPageNth i = withPageIndex i $ do
page <- getPageNth i
return $ expressions page /= original page
getPagePath :: HPage (Maybe FilePath)
getPagePath = get >>= getPageNthPath . currentPage
getPageNthPath :: Int -> HPage (Maybe FilePath)
getPageNthPath i = getPageNth i >>= return . filePath
getPageCount :: HPage Int
getPageCount = get >>= return . length . pages
getPageIndex :: HPage Int
getPageIndex = get >>= return . currentPage
setPageIndex :: Int -> HPage ()
setPageIndex (-1) = modify (\ctx -> ctx{currentPage = (-1)})
setPageIndex i = withPageIndex i $ modify (\ctx -> ctx{currentPage = i})
getPageDesc :: HPage PageDescription
getPageDesc = get >>= getPageNthDesc . currentPage
getPageNthDesc :: Int -> HPage PageDescription
getPageNthDesc i = do
p <- getPageNthPath i
m <- isModifiedPageNth i
return $ PageDesc i p m
closePage :: HPage ()
closePage = get >>= closePageNth . currentPage
closePageNth :: Int -> HPage ()
closePageNth i = withPageIndex i $ do
count <- getPageCount
case count of
1 ->
closeAllPages
_ ->
modify (\c -> c{pages = insertAt i [] $ pages c,
currentPage = if i == currentPage c
then case i of
0 -> 0
_ -> i - 1
else currentPage c})
closeAllPages :: HPage ()
closeAllPages = modify (\ctx -> ctx{pages = [emptyPage],
currentPage = 0})
safeClosePage :: HPage ()
safeClosePage = get >>= safeClosePageNth . currentPage
safeCloseAllPages :: HPage ()
safeCloseAllPages = do
ps <- liftM (length . pages) $ get
ms <- anyM isModifiedPageNth [0..ps-1]
if ms then fail "There are modified pages"
else closeAllPages
safeClosePageNth :: Int -> HPage ()
safeClosePageNth i = do
m <- isModifiedPageNth i
if m then fail "The page is modified"
else closePageNth i
safeSavePageAs :: FilePath -> HPage ()
safeSavePageAs file = get >>= (flip safeSavePageNthAs) file . currentPage
safeSavePageNthAs :: Int -> FilePath -> HPage ()
safeSavePageNthAs i file = do
m <- liftIO $ doesFileExist file
if m then fail "The page is modified"
else savePageNthAs i file
clearPage :: HPage ()
clearPage = setPageText "" 0 >> return ()
setPageText :: String -> Int -> HPage Bool
setPageText s ip =
do
let (exprs, ix) = fromString' s ip
page <- getPage
if exprs /= expressions page || ix /= currentExpr page
then
do
modifyWithUndo (\p -> p{expressions = exprs,
currentExpr = ix})
return True
else
return False
getPageText :: HPage String
getPageText = getPage >>= return . toString
getExprIndex :: HPage Int
getExprIndex = getPage >>= return . currentExpr
setExprIndex :: Int -> HPage ()
setExprIndex (-1) = modifyWithUndo (\p -> p{currentExpr = -1})
setExprIndex nth = withExprIndex nth $ modifyWithUndo (\p -> p{currentExpr = nth})
getExprCount :: HPage Int
getExprCount = getPage >>= return . length . expressions
getExprText :: HPage String
getExprText = getPage >>= getExprNthText . currentExpr
setExprText :: String -> HPage ()
setExprText expr = getPage >>= flip setExprNthText expr . currentExpr
getExprNthText :: Int -> HPage String
getExprNthText nth = withExprIndex nth $ getPage >>= return . exprText . (!! nth) . expressions
setExprNthText :: Int -> String -> HPage ()
setExprNthText nth expr = withExprIndex nth $
do
page <- getPage
liftTraceIO ("setExprNthText",nth,expr,expressions page, currentExpr page)
modifyWithUndo (\p ->
let newExprs = insertAt nth (fromString expr) $ expressions p
curExpr = currentExpr p
in p{expressions = newExprs,
currentExpr = if curExpr < length newExprs then
curExpr else
length newExprs -1})
addExpr :: String -> HPage ()
addExpr expr = do
p <- getPage
liftTraceIO ("addExpr",expr,expressions p, currentExpr p)
modifyWithUndo (\page ->
let exprs = expressions page
newExprs = insertAt (length exprs) (fromString expr) exprs
in page{expressions = newExprs,
currentExpr = length newExprs - 1})
removeExpr :: HPage ()
removeExpr = getPage >>= removeNth . currentExpr
removeNth :: Int -> HPage ()
removeNth i = setExprNthText i ""
undo, redo :: HPage ()
undo = do
p <- getPage
case undoActions p of
[] ->
liftTraceIO ("not undo", expressions p)
-- return ()
(acc:accs) ->
do
acc
getPage >>= (\px -> liftTraceIO ("redo added", expressions p, expressions px))
modifyPage (\page ->
let redoAct = modifyPage (\pp -> pp{expressions = expressions p,
currentExpr = currentExpr p})
in page{redoActions = redoAct : redoActions page,
undoActions = accs})
redo = do
p <- getPage
case redoActions p of
[] ->
liftTraceIO ("not redo", expressions p)
-- return ()
(acc:accs) ->
do
acc
getPage >>= (\px -> liftTraceIO ("undo added", expressions px, expressions p))
modifyPage (\page ->
let undoAct = modifyPage (\pp -> pp{expressions = expressions p,
currentExpr = currentExpr p})
in page{undoActions = undoAct : undoActions page,
redoActions = accs})
valueOf, kindOf, typeOf :: HPage (Either Hint.InterpreterError String)
valueOf = getPage >>= valueOfNth . currentExpr
kindOf = getPage >>= kindOfNth . currentExpr
typeOf = getPage >>= typeOfNth . currentExpr
valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String)
valueOfNth = runInExprNthWithLets Hint.eval
kindOfNth = runInExprNth Hint.kindOf
typeOfNth = runInExprNthWithLets Hint.typeOf
loadModules :: [String] -> HPage (Either Hint.InterpreterError ())
loadModules ms = do
let action = do
liftTraceIO $ "loading: " ++ show ms
Hint.loadModules ms
Hint.getLoadedModules >>= Hint.setTopLevelModules
res <- syncRun action
case res of
Right _ ->
modify (\ctx -> ctx{loadedModules = union (fromList ms) (loadedModules ctx),
recoveryLog = recoveryLog ctx >> action >> return ()})
Left e ->
liftErrorIO $ ("Error loading modules", ms, e)
return res
reloadModules :: HPage (Either Hint.InterpreterError ())
reloadModules = do
ctx <- confirmRunning
let ms = toList $ loadedModules ctx
syncRun $ do
liftTraceIO $ "reloading: " ++ (show ms)
Hint.loadModules ms
Hint.getLoadedModules >>= Hint.setTopLevelModules
getLoadedModules :: HPage (Either Hint.InterpreterError [Hint.ModuleName])
getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules
getLanguageExtensions :: HPage (Either Hint.InterpreterError [Hint.Extension])
getLanguageExtensions = confirmRunning >> syncRun (Hint.get Hint.languageExtensions)
setLanguageExtensions :: [Hint.Extension] -> HPage (Either Hint.InterpreterError ())
setLanguageExtensions exs = confirmRunning >> syncRun (Hint.set [Hint.languageExtensions := exs])
reset :: HPage (Either Hint.InterpreterError ())
reset = do
res <- syncRun $ do
liftTraceIO $ "resetting"
Hint.reset
Hint.setImports ["Prelude"]
ms <- Hint.getLoadedModules
liftTraceIO $ "remaining modules: " ++ show ms
case res of
Right _ ->
modify (\ctx -> ctx{loadedModules = empty,
running = Nothing,
recoveryLog = return ()})
Left e ->
liftErrorIO $ ("Error resetting", e)
return res
valueOf', kindOf', typeOf' :: HPage (MVar (Either Hint.InterpreterError String))
valueOf' = getPage >>= valueOfNth' . currentExpr
kindOf' = getPage >>= kindOfNth' . currentExpr
typeOf' = getPage >>= typeOfNth' . currentExpr
valueOfNth', kindOfNth', typeOfNth' :: Int -> HPage (MVar (Either Hint.InterpreterError String))
valueOfNth' = runInExprNthWithLets' Hint.eval
kindOfNth' = runInExprNth' Hint.kindOf
typeOfNth' = runInExprNthWithLets' Hint.typeOf
loadModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ()))
loadModules' ms = do
let action = do
liftTraceIO $ "loading': " ++ show ms
Hint.loadModules ms
Hint.getLoadedModules >>= Hint.setTopLevelModules
res <- asyncRun action
modify (\ctx -> ctx{running = Just $ LoadModules (fromList ms) action})
return res
reloadModules' :: HPage (MVar (Either Hint.InterpreterError ()))
reloadModules' = do
page <- confirmRunning
let ms = toList $ loadedModules page
asyncRun $ do
liftTraceIO $ "reloading': " ++ (show ms)
Hint.loadModules ms
Hint.getLoadedModules >>= Hint.setTopLevelModules
getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [Hint.ModuleName]))
getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules
getLanguageExtensions' :: HPage (MVar (Either Hint.InterpreterError [Hint.Extension]))
getLanguageExtensions' = confirmRunning >> asyncRun (Hint.get Hint.languageExtensions)
setLanguageExtensions' :: [Hint.Extension] -> HPage (MVar (Either Hint.InterpreterError ()))
setLanguageExtensions' exs = confirmRunning >> asyncRun (Hint.set [Hint.languageExtensions := exs])
reset' :: HPage (MVar (Either Hint.InterpreterError ()))
reset' = do
res <- asyncRun $ do
liftTraceIO $ "resetting'"
Hint.reset
Hint.setImports ["Prelude"]
ms <- Hint.getLoadedModules
liftTraceIO $ "remaining modules: " ++ show ms
modify (\ctx -> ctx{running = Just Reset})
return res
cancel :: HPage ()
cancel = do
liftTraceIO $ "canceling"
ctx <- get
liftIO $ HS.stop $ server ctx
hs <- liftIO $ HS.start
liftIO $ HS.runIn hs $ recoveryLog ctx
modify (\c -> c{server = hs,
running = Nothing})
-- PRIVATE FUNCTIONS -----------------------------------------------------------
modifyPage :: (Page -> Page) -> HPage ()
modifyPage f = get >>= (flip modifyPageNth) f . currentPage
modifyPageNth :: Int -> (Page -> Page) -> HPage ()
modifyPageNth i f = withPageIndex i $ modify (\c ->
let pgs = pages c
newPage = f $ pgs !! i
in c{pages = insertAt i [newPage] pgs})
getPage :: HPage Page
getPage = get >>= getPageNth . currentPage
getPageNth :: Int -> HPage Page
getPageNth i = withPageIndex i $ get >>= return . (!! i) . pages
withPageIndex :: Int -> HPage a -> HPage a
withPageIndex i acc = get >>= withIndex i acc . pages
withExprIndex :: Int -> HPage a -> HPage a
withExprIndex i acc = getPage >>= withIndex i acc . expressions
withIndex :: Show b => Int -> HPage a -> [b] -> HPage a
withIndex i acc is = case i of
-1 ->
fail "Nothing selected"
x | x >= length is ->
fail "Invalid index"
_ ->
acc
runInExprNth :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String)
runInExprNth action i = do
page <- getPage
let exprs = expressions page
flip (withIndex i) exprs $ do
let expr = exprText $ exprs !! i
syncRun $ if "" == expr
then return ""
else action expr
runInExprNth' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (Either Hint.InterpreterError String))
runInExprNth' action i = do
page <- getPage
let exprs = expressions page
flip (withIndex i) exprs $ do
let expr = exprText $ exprs !! i
asyncRun $ if "" == expr
then return ""
else action expr
runInExprNthWithLets :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String)
runInExprNthWithLets action i = do
page <- getPage
let exprs = expressions page
flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs
lets = filter isNamedExpr $ b ++ a
expr = letsToString lets ++ exprText item
in syncRun $ if "" == exprText item
then return ""
else action expr
runInExprNthWithLets' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (Either Hint.InterpreterError String))
runInExprNthWithLets' action i = do
page <- getPage
let exprs = expressions page
flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs
lets = filter isNamedExpr $ b ++ a
expr = letsToString lets ++ exprText item
in asyncRun $ action expr
syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a)
syncRun action = do
liftTraceIO "sync - running"
page <- confirmRunning
liftIO $ HS.runIn (server page) action
asyncRun :: Hint.InterpreterT IO a -> HPage (MVar (Either Hint.InterpreterError a))
asyncRun action = do
liftTraceIO "async - running"
page <- confirmRunning
liftIO $ HS.asyncRunIn (server page) action
confirmRunning :: HPage Context
confirmRunning = modify (\ctx -> apply (running ctx) ctx) >> get
apply :: Maybe InFlightData -> Context -> Context
apply Nothing c = c
apply (Just Reset) c = c{loadedModules = empty,
recoveryLog = return (),
running = Nothing}
apply (Just lm) c = c{loadedModules = union (loadingModules lm) (loadedModules c),
recoveryLog = (recoveryLog c) >> (runningAction lm)}
fromString :: String -> [Expression]
fromString s = map Exp $ splitOn "\n\n" s
isNamedExpr :: Expression -> Bool
isNamedExpr e = case parseDecl (exprText e) of
ParseOk _ -> True
_ -> False
fromString' :: String -> Int -> ([Expression], Int)
fromString' "" 0 = ([], -1)
fromString' s 0 = (fromString s, 0)
fromString' s i = (fromString s,
flip (-) 1 . length . splitOn "\n\n" $ take i s)
toString :: Page -> String
toString = joinWith "\n\n" . map exprText . expressions
splitOn :: Eq a => [a] -> [a] -> [[a]]
splitOn [] xs = [xs]
splitOn _ [] = []
splitOn s xs = splitOn' [] s xs
splitOn' :: Eq a => [a] -> [a] -> [a] -> [[a]]
splitOn' [] _ [] = []
splitOn' acc _ [] = [reverse acc]
splitOn' acc s r@(x:xs)
| isPrefixOf s r = (reverse acc) : splitOn' [] s (drop (length s) r)
| otherwise = splitOn' (x:acc) s xs
joinWith :: [a] -> [[a]] -> [a]
joinWith _ [] = []
joinWith sep (x:xs) = x ++ (concat . map (sep ++) $ xs)
insertAt :: Int -> [a] -> [a] -> [a]
insertAt 0 new [] = new
insertAt i new old | i == length old = old ++ new
| otherwise = let (before, (_:after)) = splitAt i old
in before ++ new ++ after
showWithCurrent :: Show a => [a] -> Int -> String -> (String -> String) -> String
showWithCurrent allItems curItem sep mark =
drop (length sep) . concat $ map (showNth allItems curItem) [0..itemCount - 1]
where itemCount = length allItems
showNth list sel cur = sep ++ ((if sel == cur then mark else id) $ show $ list !! cur)
modifyWithUndo :: (Page -> Page) -> HPage ()
modifyWithUndo f = modifyPage (\page ->
let newPage = f page
undoAct = modifyPage (\pp -> pp{expressions = expressions page,
currentExpr = currentExpr page})
in newPage{undoActions = undoAct : undoActions page,
redoActions = []})
emptyPage :: Page
emptyPage = Page [] (-1) [] [] [] Nothing
letsToString :: [Expression] -> String
letsToString [] = ""
letsToString exs = "let " ++ joinWith "; " (map exprText exs) ++ " in "