hell (empty) → 2.1
raw patch · 7 files changed
+409/−0 lines, 7 filesdep +basedep +bytestringdep +conduitsetup-changed
Dependencies added: base, bytestring, conduit, conduit-extra, data-default, directory, filepath, ghc, ghc-paths, haskeline, hell, monad-extras, mtl, old-time, pdfinfo, process, process-extras, resourcet, shell-conduit, split, template-haskell, text, time, transformers, unix, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hell.cabal +54/−0
- src/Hell.hs +11/−0
- src/Hell/Shell.hs +237/−0
- src/Hell/Types.hs +66/−0
- src/main/Main.hs +9/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hell.cabal view
@@ -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
+ src/Hell.hs view
@@ -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
+ src/Hell/Shell.hs view
@@ -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))
+ src/Hell/Types.hs view
@@ -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
+ src/main/Main.hs view
@@ -0,0 +1,9 @@+-- | A sample Hell configuration.++module Main where++import Hell.Shell++-- | Main entry point.+main :: IO ()+main = startHell def