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, importModules, getImportedModules,
    getModuleExports,
    getLanguageExtensions, setLanguageExtensions,
    getSourceDirs, setSourceDirs,
    getGhcOpts, setGhcOpts,
    loadPrefsFromCabal,
    valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth',
    loadModules', reloadModules', getLoadedModules', importModules', getImportedModules',
    getModuleExports',
    getLanguageExtensions', setLanguageExtensions',
    getSourceDirs', setSourceDirs',
    getGhcOpts', setGhcOpts',
    loadPrefsFromCabal',
    reset, reset',
    cancel,
    Hint.InterpreterError, Hint.prettyPrintError,
    Hint.availableExtensions, Hint.Extension(..),
    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.Utils as Hint
import qualified Language.Haskell.Interpreter.Server as HS
import Utils.Log
import Data.List (isPrefixOf)
import Data.List.Utils
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.Compiler

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 ()
                                 } |
                    LoadingCabal { settingSrcDirs :: [FilePath],
                                   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 { -- 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 [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 [Hint.ModuleName])
getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules

getImportedModules :: HPage [Hint.ModuleName]
getImportedModules = confirmRunning >>= return . toList . importedModules 

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

loadPrefsFromCabal :: FilePath -> HPage (Either Hint.InterpreterError PackageIdentifier)
loadPrefsFromCabal file = do
                                let dir = dropFileName file
                                lbinfo <- liftIO $ getPersistBuildConfig dir
                                let pkgdesc = localPkgDescr lbinfo
                                    pkgname = package pkgdesc
                                    bldinfos= allBuildInfo pkgdesc
                                    dirs = uniq $ concatMap hsSourceDirs bldinfos
                                    exts = uniq . map (read . show) $ concatMap extensions bldinfos
                                    opts = uniq $ concatMap (hcOptions GHC) bldinfos
                                    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
                                res <- syncRun action
                                case res of
                                    Right _ ->
                                        modify (\ctx -> ctx{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 [Hint.ModuleName]))
getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules

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

loadPrefsFromCabal' :: FilePath -> HPage (MVar (Either Hint.InterpreterError PackageIdentifier))
loadPrefsFromCabal' file = do
                                let dir = dropFileName file
                                lbinfo <- liftIO $ getPersistBuildConfig dir
                                let pkgdesc = localPkgDescr lbinfo
                                    pkgname = package pkgdesc
                                    bldinfos= allBuildInfo pkgdesc
                                    dirs = uniq $ concatMap hsSourceDirs bldinfos
                                    exts = uniq . map (read . show) $ concatMap extensions bldinfos
                                    opts = joinWith " " . uniq $ concatMap (hcOptions GHC) bldinfos
                                    action = do
                                                liftTraceIO $ "loading package: " ++ show pkgname
                                                Hint.unsafeSetGhcOption "-i"
                                                Hint.unsafeSetGhcOption "-i."
                                                forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++)
                                                Hint.set [Hint.languageExtensions := exts]
                                                Hint.unsafeSetGhcOption opts
                                                return pkgname
                                res <- asyncRun action
                                modify $ \ctx -> ctx{running = Just $ LoadingCabal dirs opts $ action >> return ()}
                                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})
            

-- 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}
apply (Just LoadingCabal{settingSrcDirs = ssds, settingGhcOpts = opts, runningAction = ra}) c =
    c{extraSrcDirs = ssds, 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}