{-# 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, importModules, getImportedModules, getPackageModules, getModuleExports, getLanguageExtensions, setLanguageExtensions, getSourceDirs, setSourceDirs, getGhcOpts, setGhcOpts, loadPackage, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', loadModules', reloadModules', getLoadedModules', importModules', getImportedModules', getModuleExports', getLanguageExtensions', setLanguageExtensions', getSourceDirs', setSourceDirs', getGhcOpts', setGhcOpts', reset, reset', cancel, Hint.InterpreterError, prettyPrintError, Hint.availableExtensions, Hint.Extension(..), ModuleDescription(..), ModuleElemDesc(..), -- DEBUG -- ctxString ) where import System.IO import System.Directory import System.FilePath 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.Unsafe as Hint import qualified Language.Haskell.Interpreter.Server as HS import HPage.Utils.Log import Data.List (isPrefixOf) import qualified Data.List as List import qualified Data.ByteString.Char8 as Str import qualified Language.Haskell.Exts.Parser as Parser import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo import Distribution.Package import Distribution.PackageDescription import Distribution.ModuleName import Distribution.Compiler data ModuleDescription = ModDesc {modName :: String, modInterpreted :: Bool} deriving (Eq) instance Show ModuleDescription where show m = show (modName m, modInterpreted m) data ModuleElemDesc = MEFun {funName :: String, funType :: String} | MEClass {clsName :: String, clsFuns :: [ModuleElemDesc]} | MEData {datName :: String, datCtors :: [ModuleElemDesc]} deriving (Eq) instance Show ModuleElemDesc where show MEFun{funName = fn, funType = []} = fn show MEFun{funName = fn, funType = ft} = fn ++ " :: " ++ ft show MEClass{clsName = cn, clsFuns = []} = "class " ++ cn show MEClass{clsName = cn, clsFuns = cfs} = "class " ++ cn ++ " where " ++ joinWith "\n" (map show cfs) show MEData{datName = dn, datCtors = []} = "data " ++ dn show MEData{datName = dn, datCtors = dcs} = "data " ++ dn ++ " = " ++ joinWith " | " (map show dcs) 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 () } | ImportModules { importingModules :: Set String, runningAction :: Hint.InterpreterT IO () } | SetSourceDirs { settingSrcDirs :: [FilePath], runningAction :: Hint.InterpreterT IO () } | SetGhcOpts { settingGhcOpts :: 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 { -- Package -- activePackage :: Maybe PackageIdentifier, pkgModules :: [Hint.ModuleName], -- Pages -- pages :: [Page], currentPage :: Int, -- Hint -- loadedModules :: Set String, importedModules :: Set String, extraSrcDirs :: [FilePath], ghcOptions :: 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 Nothing [] [emptyPage] 0 empty (fromList ["Prelude"]) [] "" 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 importModules :: [String] -> HPage (Either Hint.InterpreterError ()) importModules newms = do ctx <- confirmRunning let ms = toList $ importedModules ctx action = do liftTraceIO $ "importing: " ++ show newms Hint.setImports $ ms ++ newms res <- syncRun action case res of Right _ -> modify (\ctx -> ctx{importedModules = union (fromList newms) (importedModules ctx), recoveryLog = recoveryLog ctx >> action >> return ()}) Left e -> liftErrorIO $ ("Error importing 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 [ModuleDescription]) getLoadedModules = do confirmRunning syncRun $ do mns <- Hint.getLoadedModules let mis = map (>0) [1..] return $ zipWith ModDesc mns mis getImportedModules :: HPage [Hint.ModuleName] getImportedModules = confirmRunning >>= return . toList . importedModules getPackageModules :: HPage [Hint.ModuleName] getPackageModules = confirmRunning >>= return . pkgModules getModuleExports :: Hint.ModuleName -> HPage (Either Hint.InterpreterError [ModuleElemDesc]) getModuleExports mn = do confirmRunning let action = do exs <- Hint.getModuleExports mn mapM moduleElemDesc exs syncRun action 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]) getSourceDirs :: HPage [FilePath] getSourceDirs = confirmRunning >>= return . extraSrcDirs setSourceDirs :: [FilePath] -> HPage (Either Hint.InterpreterError ()) setSourceDirs ds = do let action = do liftTraceIO $ "setting src dirs: " ++ show ds Hint.unsafeSetGhcOption "-i" Hint.unsafeSetGhcOption "-i." forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) res <- syncRun action case res of Right _ -> modify (\ctx -> ctx{extraSrcDirs = ds, recoveryLog = recoveryLog ctx >> action >> return ()}) Left e -> liftErrorIO $ ("Error setting source dirs", ds, e) return res getGhcOpts :: HPage String getGhcOpts = confirmRunning >> get >>= return . ghcOptions setGhcOpts :: String -> HPage (Either Hint.InterpreterError ()) setGhcOpts opts = do let action = do liftTraceIO $ "setting ghc opts: " ++ opts Hint.unsafeSetGhcOption opts res <- syncRun action case res of Right _ -> modify (\ctx -> ctx{ghcOptions = (ghcOptions ctx) ++ " " ++ opts, recoveryLog = recoveryLog ctx >> action >> return ()}) Left e -> liftErrorIO $ ("Error setting ghc opts dirs", opts, e) return res loadPackage :: FilePath -> HPage (Either Hint.InterpreterError PackageIdentifier) loadPackage file = do let dir = dropFileName file lbinfo <- liftIO $ getPersistBuildConfig dir let pkgdesc = localPkgDescr lbinfo pkgname = package pkgdesc bldinfos= allBuildInfo pkgdesc dirs = ("dist" "build" "autogen") : (uniq $ concatMap hsSourceDirs bldinfos) exts = uniq . map (read . show) $ concatMap extensions bldinfos opts = uniq $ concatMap (hcOptions GHC) bldinfos mods = uniq . map (joinWith "." . components) $ exeModules pkgdesc ++ (libModules pkgdesc) action = do liftTraceIO $ "loading package: " ++ show pkgname Hint.unsafeSetGhcOption "-i" Hint.unsafeSetGhcOption "-i." forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++) Hint.set [Hint.languageExtensions := exts] forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ()) return pkgname liftDebugIO mods res <- syncRun action case res of Right _ -> modify (\ctx -> ctx{activePackage = Just pkgname, pkgModules = mods, extraSrcDirs = dirs, ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts), recoveryLog = recoveryLog ctx >> action >> return ()}) Left e -> liftErrorIO $ ("Error loading package", pkgname, e) return res 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, importedModules = fromList ["Prelude"], extraSrcDirs = [], ghcOptions = "", 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 importModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ())) importModules' newms = do ctx <- confirmRunning let ms = toList $ importedModules ctx action = do liftTraceIO $ "importing': " ++ show newms Hint.setImports $ ms ++ newms res <- asyncRun action modify (\ctx -> ctx{running = Just $ ImportModules (fromList newms) action}) return res reloadModules' :: HPage (MVar (Either Hint.InterpreterError ())) reloadModules' = do ctx <- confirmRunning let ms = toList $ loadedModules ctx asyncRun $ do liftTraceIO $ "reloading': " ++ (show ms) Hint.loadModules ms Hint.getLoadedModules >>= Hint.setTopLevelModules getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [ModuleDescription])) getLoadedModules' = do confirmRunning asyncRun $ do mns <- Hint.getLoadedModules let mis = map (>0) [1..] return $ zipWith ModDesc mns mis getImportedModules' :: HPage (MVar [Hint.ModuleName]) getImportedModules' = confirmRunning >>= liftIO . newMVar . toList . importedModules getModuleExports' :: Hint.ModuleName -> HPage (MVar (Either Hint.InterpreterError [Hint.ModuleElem])) getModuleExports' mn = confirmRunning >> asyncRun (Hint.getModuleExports mn) 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]) getSourceDirs' :: HPage (MVar [FilePath]) getSourceDirs' = confirmRunning >>= liftIO . newMVar . extraSrcDirs setSourceDirs' :: [FilePath] -> HPage (MVar (Either Hint.InterpreterError ())) setSourceDirs' ds = do let action = do liftTraceIO $ "setting src dirs: " ++ show ds Hint.unsafeSetGhcOption "-i" Hint.unsafeSetGhcOption "-i." forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) res <- asyncRun action modify $ \ctx -> ctx{running = Just $ SetSourceDirs ds action} return res getGhcOpts' :: HPage (MVar String) getGhcOpts' = confirmRunning >> get >>= liftIO . newMVar . ghcOptions setGhcOpts' :: String -> HPage (MVar (Either Hint.InterpreterError ())) setGhcOpts' opts = do let action = do liftTraceIO $ "setting ghc opts: " ++ opts Hint.unsafeSetGhcOption opts res <- asyncRun action modify $ \ctx -> ctx{running = Just $ SetGhcOpts opts action} return res 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}) prettyPrintError :: Hint.InterpreterError -> String prettyPrintError (Hint.WontCompile ghcerr) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerr) prettyPrintError (Hint.UnknownError errStr) = "Unknown Error: " ++ errStr prettyPrintError (Hint.NotAllowed errStr) = "Not Allowed Action: " ++ errStr prettyPrintError (Hint.GhcException errStr) = errStr -- 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, importedModules = fromList ["Prelude"], extraSrcDirs = [], ghcOptions = "", recoveryLog = return (), running = Nothing} apply (Just LoadModules{loadingModules = lms, runningAction = ra}) c = c{loadedModules = union lms (loadedModules c), recoveryLog = (recoveryLog c) >> ra} apply (Just ImportModules{importingModules = ims, runningAction = ra}) c = c{importedModules = union ims (importedModules c), recoveryLog = (recoveryLog c) >> ra} apply (Just SetSourceDirs{settingSrcDirs = ssds, runningAction = ra}) c = c{extraSrcDirs = ssds, recoveryLog = (recoveryLog c) >> ra} apply (Just SetGhcOpts{settingGhcOpts = opts, runningAction = ra}) c = c{ghcOptions = (ghcOptions c) ++ " " ++ opts, recoveryLog = (recoveryLog c) >> ra} fromString :: String -> [Expression] fromString s = map Exp $ splitOn "\n\n" s isNamedExpr :: Expression -> Bool isNamedExpr e = case Parser.parseDecl (exprText e) of Parser.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 " moduleElemDesc :: Hint.ModuleElem -> Hint.InterpreterT IO ModuleElemDesc moduleElemDesc (Hint.Fun fn) = do t <- (Hint.typeOf fn) `catchError` (\e -> return []) return MEFun{funName = fn, funType = t} moduleElemDesc (Hint.Class cn cfs) = do mcfs <- flip mapM cfs $ moduleElemDesc . Hint.Fun return MEClass{clsName = cn, clsFuns = mcfs} moduleElemDesc (Hint.Data dn dcs) = do mdcs <- flip mapM dcs $ moduleElemDesc . Hint.Fun return MEData{datName = dn, datCtors = mdcs} {- | Given a list, returns a new list with all duplicate elements removed. For example: >uniq "Mississippi" -> "Misp" You should not rely on this function necessarily preserving order, though the current implementation happens to. This function is not compatible with infinite lists. TAKEN FROM: http://hackage.haskell.org/packages/archive/MissingH/1.0.0/doc/html/src/Data-List-Utils.html#uniq -} uniq :: Eq a => [a] -> [a] uniq [] = [] uniq (x:xs) = x : uniq (filter (/= x) xs)