hpage-0.12.1: src/HPage/Control.hs
{-# LANGUAGE GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
FlexibleInstances,
FunctionalDependencies,
TypeSynonymInstances,
UndecidableInstances #-}
module HPage.Control (
-- MONAD CONTROLS --
HPage, evalHPage,
-- PAGE CONTROLS --
getPageIndex, getPageText, setPageText,
addPage, openPage, closePage, closeAllPages, getPagePath, setPageIndex,
savePage, savePageAs, getPageCount,
PageDescription(..), getPageNthDesc,
-- EDITION CONTROLS --
undo, redo,
-- HINT CONTROLS --
Hint.InterpreterError, prettyPrintError,
getLanguageExtensions, setLanguageExtensions,
getSourceDirs, setSourceDirs,
getGhcOpts, setGhcOpts,
getPackageModules,
loadPackage, loadModules, getLoadedModules, reloadModules,
importModules, getImportedModules,
getModuleExports, ModuleDescription(..), ModuleElemDesc(..),
interpret, Interpretation, intKind, intValue, intValues, intResult,
intType, isIntType, isIntExprs, isIntExpr, isIntIOExpr,
Hint.availableExtensions,
Hint.Extension(..),
cancel,
-- DEBUG --
ctxString
) where
import System.Directory
import System.FilePath
import Data.Set (Set, empty, union, fromList, toList)
import Control.Monad.Error
import Control.Monad.State
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.ByteString.Char8 as Str
import qualified Language.Haskell.Exts as Xs
import Distribution.Simple.Configure hiding (tryGetConfigStateFile)
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Package
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Compiler
import qualified HPage.IOServer as HPIO
import Control.Exception(SomeException)
data Interpretation = Type {intKind :: String} |
Expr {intValue :: String, intType :: String} |
IOExpr{intResult :: MVar (Either SomeException String), intType :: String} |
Exprs {intValues :: [String], intType :: String}
deriving (Eq)
instance Show Interpretation where
show (Type x) = "type :: " ++ show x
show (IOExpr _ t) = " io :: " ++ show t
show (Expr x t) = x ++ show t
show (Exprs xs t) = show xs ++ " :: [" ++ show t ++ "]"
isIntType :: Interpretation -> Bool
isIntType Type{} = True
isIntType IOExpr{}= False
isIntType Expr{} = False
isIntType Exprs{} = False
isIntExprs :: Interpretation -> Bool
isIntExprs Type{} = False
isIntExprs IOExpr{}= False
isIntExprs Expr{} = False
isIntExprs Exprs{} = True
isIntExpr :: Interpretation -> Bool
isIntExpr Type{} = False
isIntExpr IOExpr{}= False
isIntExpr Expr{} = True
isIntExpr Exprs{} = False
isIntIOExpr :: Interpretation -> Bool
isIntIOExpr Type{} = False
isIntIOExpr IOExpr{}= True
isIntIOExpr Expr{} = False
isIntIOExpr Exprs{} = False
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 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,
recoveryLog :: Hint.InterpreterT IO (), -- To allow cancelation of actions
-- IO Server --
ioServer :: HPIO.ServerHandle
}
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
hpios <- liftIO $ HPIO.start
let nop = return ()
let emptyContext = Context Nothing [] [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs nop hpios
(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) = exprFromString' 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)})
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})
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})
setPageText :: String -> Int -> HPage Bool
setPageText s ip =
do
let (exprs, ix) = exprFromString' 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
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})
interpret :: HPage (Either Hint.InterpreterError Interpretation)
interpret = getPage >>= interpretNth . currentExpr
interpretNth :: Int -> HPage (Either Hint.InterpreterError Interpretation)
interpretNth i =
do
liftDebugIO ("Interpreting", i)
typeRes <- typeOfNth i
case typeRes of
Left terr ->
do
kindRes <- kindOfNth i
case kindRes of
Left _ -> return $ Left terr
Right k -> return . Right $ Type{intKind = k}
Right t ->
do
if isIO t
then do
valueRes <- getIOFromExprNth i
case valueRes of
Right ioAction ->
do
ctx <- get
iores <- liftIO $ HPIO.runIn (ioServer ctx) $ ioAction
return . Right $ IOExpr{intResult = iores, intType = t}
Left err ->
return $ Left err
else if isList t
then do
liftDebugIO "interpreting a list"
valueRes <- getListFromExprNth i
case valueRes of
Left verr ->
if isNotShowable verr
then return $ Right $ Expr{intValue = "", intType = t}
else return $ Left verr
Right list -> return . Right $ Exprs{intValues = list, intType = t}
else do
liftDebugIO "interpreting a value"
valueRes <- valueOfNth i
case valueRes of
Left verr ->
if isNotShowable verr
then return $ Right $ Expr{intValue = "", intType = t}
else return $ Left verr
Right v -> return $ Right $ Expr{intValue = v, intType = t}
where isNotShowable (Hint.WontCompile ghcerrs) = any complainsAboutShow ghcerrs
isNotShowable _ = False
complainsAboutShow err = let errMsg = Hint.errMsg err
in "No instance for (GHC.Show" `isPrefixOf` errMsg
valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String)
valueOfNth i = runInExprNthWithLets Hint.eval i
kindOfNth = runInExprNth Hint.kindOf
typeOfNth = runInExprNthWithLets Hint.typeOf
loadModules :: [String] -> HPage (Either Hint.InterpreterError ())
loadModules ms = do
prevctx <- get
let ims = toList $ importedModules prevctx
action = do
liftTraceIO $ "loading: " ++ show ms
Hint.loadModules ms
Hint.setImports ims
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 ->
do
liftErrorIO $ ("Error loading modules", ms, e)
Right () <- syncRun $ Hint.setImports ims
return ()
return res
importModules :: [String] -> HPage (Either Hint.InterpreterError ())
importModules newms = do
ctx <- get
let ms = toList $ importedModules ctx
action = do
liftTraceIO $ "importing: " ++ show newms
Hint.setImports $ ms ++ newms
res <- syncRun action
case res of
Right _ ->
modify (\c -> c{importedModules = union (fromList newms) (importedModules c),
recoveryLog = recoveryLog c >> action >> return ()})
Left e ->
do
liftErrorIO $ ("Error importing modules", ms, e)
Right () <- syncRun $ Hint.setImports ms
return ()
return res
reloadModules :: HPage (Either Hint.InterpreterError ())
reloadModules = do
ctx <- get
let ms = toList $ loadedModules ctx
ims = toList $ importedModules ctx
action = do
liftTraceIO $ "reloading: " ++ (show ms)
Hint.loadModules ms
Hint.setImports ims
Hint.getLoadedModules >>= Hint.setTopLevelModules
res <- syncRun action
case res of
Right _ ->
return ()
Left e ->
do
liftErrorIO $ ("Error reloading modules", ms, e)
Right () <- syncRun $ Hint.setImports ims
return ()
return res
getLoadedModules :: HPage (Either Hint.InterpreterError [ModuleDescription])
getLoadedModules = syncRun $ do
mns <- Hint.getLoadedModules
mis <- mapM Hint.isModuleInterpreted mns
return $ zipWith ModDesc mns mis
getImportedModules :: HPage [Hint.ModuleName]
getImportedModules = get >>= return . toList . importedModules
getPackageModules :: HPage [Hint.ModuleName]
getPackageModules = get >>= return . pkgModules
getModuleExports :: Hint.ModuleName -> HPage (Either Hint.InterpreterError [ModuleElemDesc])
getModuleExports mn = syncRun $ do
exs <- Hint.getModuleExports mn
mapM moduleElemDesc exs
getLanguageExtensions :: HPage (Either Hint.InterpreterError [Hint.Extension])
getLanguageExtensions = get >> syncRun (Hint.get Hint.languageExtensions)
setLanguageExtensions :: [Hint.Extension] -> HPage (Either Hint.InterpreterError ())
setLanguageExtensions exs = get >> syncRun (Hint.set [Hint.languageExtensions := exs])
getSourceDirs :: HPage [FilePath]
getSourceDirs = get >>= 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 = get >> 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 String PackageIdentifier)
loadPackage file = do
let dir = dropFileName file
res <- liftIO $ tryGetPersistBuildConfig dir
case res of
Left err ->
return $ Left $ "Couldn't load package: " ++ err
Right lbinfo ->
do
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
libmods = case library pkgdesc of
Nothing -> []
Just l -> libModules l
exemods = concat (map exeModules $ executables pkgdesc)
mods = uniq . map (joinWith "." . components) $ exemods ++ libmods
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
res2 <- syncRun action
case res2 of
Right x ->
do
modify (\ctx -> ctx{activePackage = Just pkgname,
pkgModules = mods,
extraSrcDirs = dirs,
ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts),
recoveryLog = recoveryLog ctx >> action >> return ()})
return $ Right x
Left e ->
do
liftErrorIO $ ("Error loading package", pkgname, e)
return . Left $ prettyPrintError e
cancel :: HPage ()
cancel = do
liftTraceIO $ "canceling..."
ctx <- get
liftIO $ HS.stop $ server ctx
liftIO $ HPIO.stop $ ioServer ctx
hs <- liftIO $ HS.start
hpios <- liftIO $ HPIO.start
_ <- liftIO $ HS.runIn hs $ recoveryLog ctx
modify (\c -> c{server = hs,
ioServer = hpios})
prettyPrintError :: Hint.InterpreterError -> String
prettyPrintError (Hint.WontCompile ghcerrs) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerrs)
prettyPrintError (Hint.UnknownError errStr) = "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
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
getIOFromExprNth :: Int -> HPage (Either Hint.InterpreterError (IO String))
getIOFromExprNth 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 ++ ") >>= return . show"
in syncRun $ Hint.interpret expr (Hint.as :: IO String)
getListFromExprNth :: Int -> HPage (Either Hint.InterpreterError [String])
getListFromExprNth 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 = "map show (" ++ letsToString lets ++ exprText item ++ ")"
in syncRun $ Hint.interpret expr (Hint.as :: [String])
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 do
liftDebugIO ("runInExprNthWithLets", expr)
syncRun $ if "" == exprText item
then return ""
else action expr
syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a)
syncRun action = get >>= (\ctx -> liftIO $ HS.runIn (server ctx) action)
exprFromString :: String -> [Expression]
exprFromString s = map Exp $ splitOn "\n\n" s
isNamedExpr :: Expression -> Bool
isNamedExpr e = case Xs.parseDecl (exprText e) of
Xs.ParseOk _ -> True
_ -> False
isType :: (Xs.Type -> Bool) -> String -> Bool
isType f t = case Xs.parseType t of
Xs.ParseOk ty -> f ty
_ -> False -- couldn't parse
isList :: String -> Bool
isList = isType isList'
isChar, isList' :: Xs.Type -> Bool
isList' (Xs.TyForall _ _ inttype) = isList' inttype
isList' (Xs.TyParen inttype) = isList' inttype
isList' (Xs.TyList inttype) = not $ isChar inttype
isList' (Xs.TyCon (Xs.Special Xs.ListCon)) = True
isList' _ = False
isChar (Xs.TyForall _ _ inttype) = isChar inttype
isChar (Xs.TyParen inttype) = isChar inttype
isChar (Xs.TyCon (Xs.Qual _ (Xs.Ident "Char"))) = True
isChar (Xs.TyCon (Xs.UnQual (Xs.Ident "Char"))) = True
isChar _ = False
isIO :: String -> Bool
isIO = isType isIO'
isIO'', isIO' :: Xs.Type -> Bool
isIO' (Xs.TyForall _ _ inttype) = isIO' inttype
isIO' (Xs.TyParen inttype) = isIO' inttype
isIO' (Xs.TyApp inttype _) = isIO'' inttype
isIO' _ = False
isIO'' (Xs.TyForall _ _ inttype) = isIO'' inttype
isIO'' (Xs.TyParen inttype) = isIO'' inttype
isIO'' (Xs.TyCon (Xs.Qual _ (Xs.Ident "IO"))) = True
isIO'' (Xs.TyCon (Xs.UnQual (Xs.Ident "IO"))) = True
isIO'' _ = False
exprFromString' :: String -> Int -> ([Expression], Int)
exprFromString' "" 0 = ([], -1)
exprFromString' s 0 = (exprFromString s, 0)
exprFromString' s i = (exprFromString 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\n " ++ joinWith ";\n " (map (joinWith "\n " . lines . exprText) exs) ++ "\n in "
moduleElemDesc :: Hint.ModuleElem -> Hint.InterpreterT IO ModuleElemDesc
moduleElemDesc (Hint.Fun fn) = do
t <- (Hint.typeOf fn) `catchError` (\_ -> 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)
{- Taken from the source code of Distribution.Simple.Configure -}
tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)
tryGetPersistBuildConfig distPref
= tryGetConfigStateFile (localBuildInfoFile distPref)
tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)
tryGetConfigStateFile filename = do
exists <- doesFileExist filename
if not exists
then return (Left missing)
else withFileContents filename $ \str ->
case lines str of
[_header, rest] -> case reads rest of
[(bi,_)] -> return (Right bi)
_ -> return (Left cantParse)
_ -> return (Left cantParse)
where
missing = "Run the 'configure' command first."
cantParse = "Saved package config file seems to be corrupt. "
++ "Try re-running the 'configure' command."