diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Chris Done + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Done nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hell.cabal b/hell.cabal new file mode 100644 --- /dev/null +++ b/hell.cabal @@ -0,0 +1,54 @@ +name: hell +version: 2.1 +synopsis: A Haskell shell based on shell-conduit +description: A Haskell shell based on shell-conduit +license: BSD3 +license-file: LICENSE +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2013 Chris Done +category: Shell +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Hell.Shell, Hell.Types, Hell + hs-source-dirs: src/ + build-depends: split >= 0.2.2, + template-haskell, + resourcet >= 1.1.2.2, + process-extras >= 0.2.0, + transformers >= 0.3.0.0, + base > 4 && <5, + process, + bytestring, + haskeline, + ghc, + ghc-paths, + directory, + data-default, + pdfinfo, + text, + filepath, + mtl, + unix, + monad-extras, + shell-conduit >= 4.1, + conduit >= 1.1.2.1, + conduit-extra >= 1.1.0.3 + + if impl(ghc >= 7.6) + build-depends: time + else + cpp-options: -DUSE_OLD_TIME + build-depends: old-time + ghc-options: -Wall -threaded -O2 + +executable hell + main-is: Main.hs + hs-source-dirs: src/main + build-depends: utf8-string >= 0.3.7, + transformers >= 0.3.0.0, + base > 4 && <5, + hell + ghc-options: -Wall -threaded -O2 diff --git a/src/Hell.hs b/src/Hell.hs new file mode 100644 --- /dev/null +++ b/src/Hell.hs @@ -0,0 +1,11 @@ +-- | Some additional utilities for the shell. + +module Hell where + +import System.Directory + +-- | Simpler to type alias for 'setCurrentDirectory'. It's one of the +-- few commands that are provided by the shell rather than a real +-- process. +cd :: FilePath -> IO () +cd = setCurrentDirectory diff --git a/src/Hell/Shell.hs b/src/Hell/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Hell/Shell.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +-- | The Hell shell. + +module Hell.Shell + (module Hell.Types + ,module Data.Default + ,startHell) + where + +import Hell.Types + +import Control.Applicative +import Control.Exception +import Control.Monad.Reader +import Control.Monad.Trans +import Data.Default +import Data.Dynamic +import Data.IORef +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import DynFlags +import Exception (ExceptionMonad) +import GHC hiding (History) +import GHC.Paths hiding (ghc) +import Name +import Outputable (Outputable(..),showSDoc) +import System.Console.Haskeline +import System.Console.Haskeline.History +import System.Directory +import System.FilePath +import System.Posix.User + +-- | Go to hell. +startHell :: Config -> IO () +startHell unreadyConfig = + do home <- io getHomeDirectory + let config = + unreadyConfig { configHistory = reifyHome home (configHistory unreadyConfig) } + runGhc + (Just libdir) + (do dflags <- getSessionDynFlags + void (setSessionDynFlags + (setFlags [Opt_ImplicitPrelude] + dflags)) + setImports (configImports config) + historyRef <- io (readHistory (configHistory config) >>= newIORef) + username <- io getEffectiveUserName + candidates <- fmap (map (occNameString . nameOccName)) + getNamesInScope + runReaderT (runHell repl) + (HellState config historyRef username home candidates)) + +-- | Read-eval-print loop. +repl :: Hell () +repl = + do state <- ask + config <- asks stateConfig + welcome <- asks (configWelcome . stateConfig) + unless (null welcome) (haskeline (outputStrLn welcome)) + loop config state + +-- | Do the get-line-and-looping. +loop :: Config -> HellState -> Hell () +loop config state = + fix (\again -> + do (mline,history) <- getLineAndHistory config state + case mline of + Nothing -> again + Just line -> + do historyRef <- asks stateHistory + io (writeIORef historyRef history) + _ <- ghc (runLine line) + io (writeHistory (configHistory config) history) + again) + +-- | Get a new line and return it with a new history. +getLineAndHistory :: Config -> HellState -> Hell (Maybe String, History) +getLineAndHistory config state = + do pwd <- io getCurrentDirectory + prompt <- prompter (stateUsername state) (stripHome home pwd) + haskeline (do line <- getInputLine prompt + history <- getHistory + return (line,history)) + where prompter = configPrompt config + home = stateHome state + +-- | Transform ~/foo to /home/chris/foo. +reifyHome :: FilePath -> String -> FilePath +reifyHome home fp + | isPrefixOf "~/" fp = home drop 2 fp + | otherwise = fp + +-- | Strip and replace /home/chris/blah with ~/blah. +stripHome :: FilePath -> FilePath -> FilePath +stripHome home path + | isPrefixOf home path = "~/" ++ dropWhile (=='/') (drop (length home) path) + | otherwise = path + +-- | Import the given modules. +setImports :: [String] -> Ghc () +setImports = + mapM (fmap IIDecl . parseImportDecl) >=> setContext + +-- | Compile the given expression and evaluate it. +runLine :: String -> Ghc () +runLine expr = + do mtyp <- gtry (exprType expr) + d <- getDynFlags + case mtyp of + Left err -> io (putStrLn (show err)) + Right ty -> + do let tyStr = showppr d ty + if isPrefixOf "GHC.Types.IO " tyStr + then runPrintableIO tyStr expr + else if isInfixOf "Conduit" tyStr + then runConduit tyStr expr + else runExpr tyStr expr + +-- | Compile the given IO statement and run it as IO, printing the +-- result. +runConduit :: String -> String -> Ghc () +runConduit typ expr = + do result <- gcatch (fmap Right (dynCompileExpr e)) + (\(e::SomeException) -> return (Left e)) + case result of + Left {} -> + liftIO (putStrLn typ) + Right compiled -> + gcatch (io (fromDyn compiled (putStrLn "Bad compile."))) + (\(e::SomeException) -> liftIO (print e)) + where e = "Data.Conduit.Shell.run (" ++ expr ++ ") :: IO ()" + +-- | Compile the given IO statement and run it as IO, printing the +-- result. +runPrintableIO :: String -> String -> Ghc () +runPrintableIO ty expr = + do result <- gcatch (fmap Right (dynCompileExpr e)) + (\(e::SomeException) -> return (Left e)) + case result of + Left {} -> + runIO ty expr + Right compiled -> + gcatch (io (fromDyn compiled (putStrLn "Bad compile."))) + (\(e::SomeException) -> liftIO (print e)) + where e | ty == "GHC.Types.IO ()" = expr + | otherwise = "(" ++ expr ++ ") >>= Prelude.print" + +-- | Compile the given IO statement and run it as IO. No result +-- printed. +runIO :: String -> String -> Ghc () +runIO typ expr = + do result <- gcatch (fmap Right (dynCompileExpr e)) + (\(e::SomeException) -> return (Left e)) + case result of + Left {} -> + liftIO (putStrLn typ) + Right compiled -> + gcatch (io (fromDyn compiled (putStrLn "Bad compile."))) + (\(e::SomeException) -> liftIO (print e)) + where e = "(" ++ expr ++ ") >> return ()" + +-- | Compile the given expression and print it. +runExpr :: String -> String -> Ghc () +runExpr ty expr = + do result <- gcatch (fmap Right (dynCompileExpr e)) + (\(e::SomeException) -> return (Left e)) + case result of + Left {} -> + liftIO (putStrLn ty) + Right compiled -> + do liftIO (putStrLn ty) + gcatch (io (fromDyn compiled (putStrLn "Bad compile."))) + (\(e::SomeException) -> liftIO (print e)) + where e = "Prelude.print (" ++ expr ++ ")" + +-- | Short-hand utility. +io :: MonadIO m => IO a -> m a +io = Control.Monad.Trans.liftIO + +-- | Run a Haskeline action in Hell. +haskeline :: InputT IO a -> Hell a +haskeline m = + do historyRef <- asks stateHistory + history <- io (readIORef historyRef) + state <- ask + io (runInputT (settings state) + (do putHistory history + m)) + where settings state = + setComplete (completeFilesAndFunctions (stateFunctions state)) + defaultSettings + +-- | Complete file names or functions in scope. +completeFilesAndFunctions :: [String] -> (String,String) -> IO (String,[Completion]) +completeFilesAndFunctions funcs (leftReversed,right) = do + (fileCandidate,fileResults) <- completeFilename (leftReversed,right) + return (fileCandidate <|> funcCandidate,map speech fileResults <> funcResults) + where speech (Completion (normalize -> rep) d fin) = Completion newrep d fin + where newrep = (if isPrefixOf "\"" rep then rep else "\"" <> rep) <> "\"" + funcResults = mapMaybe (completeFunc (reverse leftReversed)) funcs + funcCandidate = "" + normalize = T.unpack . T.replace "\\ " " " . T.pack + +-- | Complete a function name. +completeFunc :: String -> String -> Maybe Completion +completeFunc left func = + if isPrefixOf left func + then Just (Completion func func True) + else Nothing + +-- | Run a GHC action in Hell. +ghc :: Ghc a -> Hell a +ghc m = Hell (ReaderT (const m)) + +-- | Set the given flags. +setFlags :: [ExtensionFlag] -> DynFlags -> DynFlags +setFlags xs dflags = foldl xopt_set dflags xs + +-- | Something like Show but for things which annoyingly do not have +-- Show but Outputable instead. +showppr :: Outputable a => DynFlags -> a -> String +showppr d = showSDoc d . ppr + +-- | Try the thing or return the exception. +gtry :: (Functor m, ExceptionMonad m) => m a -> m (Either SomeException a) +gtry m = + gcatch (fmap Right m) + (\(e::SomeException) -> + return (Left e)) diff --git a/src/Hell/Types.hs b/src/Hell/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hell/Types.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Hell.Types where + +import Control.Applicative +import Control.Monad.Reader + +import Data.Default +import Data.IORef +import GhcMonad + +import System.Console.Haskeline.History + +-- | Shell config. +data Config = Config + { configImports :: ![String] -- ^ Starting imports. + , configWelcome :: String -- ^ A welcome string. + , configHistory :: FilePath + , configPrompt :: String -> FilePath -> Hell String -- ^ An action to generate the prompt. + } + +-- | State of the shell. +data HellState = HellState + { stateConfig :: !Config + , stateHistory :: !(IORef History) + , stateUsername :: !String + , stateHome :: !FilePath + , stateFunctions :: ![String] + } + +-- | Hell monad, containing user information and things like that. +newtype Hell a = + Hell {runHell :: ReaderT HellState Ghc a} + deriving (Monad,MonadIO,Functor,MonadReader HellState) + +instance Default Config where + def = + Config {configImports = + ["import Prelude" + ,"import Data.List" + ,"import Data.Ord" + ,"import Data.Conduit.Shell" + ,"import System.Directory" + ,"import Data.Conduit" + ,"import qualified Data.Conduit.List as CL" + ,"import Data.Bifunctor" + ,"import qualified Data.Conduit.Binary as CB" + ,"import qualified Data.ByteString.Char8 as S8" + ,"import Control.Monad" + ,"import Data.Function" + ,"import Hell"] + ,configWelcome = "Welcome to Hell!" + ,configPrompt = + \username pwd -> + return (username ++ ":" ++ pwd ++ "$ ") + ,configHistory = "~/.hell-history"} + +-- | Hopefully this shouldn't be a problem because while this is a +-- library it has a very narrow use-case. + +#if __GLASGOW_HASKELL__ == 706 +instance MonadIO Ghc where + liftIO = GhcMonad.liftIO +#endif diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -0,0 +1,9 @@ +-- | A sample Hell configuration. + +module Main where + +import Hell.Shell + +-- | Main entry point. +main :: IO () +main = startHell def