packages feed

ghc-session (empty) → 0.1.0.1

raw patch · 13 files changed

+526/−0 lines, 13 filesdep +basedep +exceptionsdep +ghcsetup-changed

Dependencies added: base, exceptions, ghc, ghc-mtl, ghc-paths, ghc-session, transformers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Piotr Młodawski++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-session.cabal view
@@ -0,0 +1,50 @@+name:                ghc-session+version:             0.1.0.1+synopsis:            Simplified GHC API+description:         Simplified GHC API+license:             MIT+license-file:        LICENSE+author:              Piotr Młodawski+maintainer:          remdezx+github@gmail.com+homepage:            http://github.com/pmlodawski/ghc-session+bug-reports:         http://github.com/pmlodawski/ghc-session/issues+category:            Language+build-type:          Simple+tested-with:         GHC == 7.8.4, GHC == 7.10.1, GHC == 7.10.2+cabal-version:       >=1.10++library+    exposed-modules:+        Language.Haskell.Config+        Language.Haskell.Session+        Language.Haskell.Session.GHC.Util+        Language.Haskell.Session.Hint.Conversions+        Language.Haskell.Session.Hint.Eval+        Language.Haskell.Session.Hint.Typecheck+        Language.Haskell.Session.Hint.Util+        Language.Haskell.Session.Binding+        Language.Haskell.Session.Session+    -- other-modules:+    -- other-extensions:+    default-language:    Haskell2010+    build-depends:      base >=4.7 && <4.9,+                        exceptions,+                        ghc,+                        ghc-mtl,+                        ghc-paths,+                        transformers++    hs-source-dirs:     src+    default-language:   Haskell2010++executable ghc-test+    main-is:            test/Main.hs+    default-language:   Haskell2010+    build-depends:      base >=4.7 && <4.9,+                        ghc-session,+                        transformers+++source-repository head+    type:     git+    location: http://github.com/pmlodawski/ghc-session.git
+ src/Language/Haskell/Config.hs view
@@ -0,0 +1,11 @@+module Language.Haskell.Config where+++data Config = Config { topDir :: FilePath+                     , pkgDb  :: PackageDB+                     } deriving Show+++data PackageDB = PackageDB { local  :: FilePath+                           , global :: FilePath+                           } deriving Show
+ src/Language/Haskell/Session.hs view
@@ -0,0 +1,9 @@+module Language.Haskell.Session (+    module Language.Haskell.Session.Session,+    module Language.Haskell.Session.Binding,+    module Language.Haskell.Session.Hint.Typecheck,+) where++import Language.Haskell.Session.Binding+import Language.Haskell.Session.Hint.Typecheck+import Language.Haskell.Session.Session
+ src/Language/Haskell/Session/Binding.hs view
@@ -0,0 +1,57 @@+module Language.Haskell.Session.Binding (+    getBindings,+    removeBinding,+) where++import qualified Data.List as List+import qualified GHC+import           GhcMonad  (GhcMonad)+import qualified GhcMonad+import qualified HscTypes+import qualified Linker++import Language.Haskell.Session.GHC.Util (dshow)++++bindingMatch :: GHC.DynFlags -> String -> HscTypes.TyThing -> Bool+bindingMatch dflags name binding = result where+    result = dropDot bname == name+    bname = dshow dflags $ HscTypes.tyThingAvailInfo binding+++dropDot :: String -> String+dropDot = reverse . List.takeWhile (/= '.') . reverse+++-- | Remove bound variable and release memory+removeBinding :: GhcMonad m => String -> m ()+removeBinding name = do+    dflags <- GHC.getSessionDynFlags+    matching <- filter (bindingMatch dflags name) <$> getIcTythings+    GhcMonad.liftIO $ Linker.deleteFromLinkEnv $ map GHC.getName matching+    removeIcTythings name+++getIcTythings :: GhcMonad m => m [HscTypes.TyThing]+getIcTythings = do+    hscEnv <- GhcMonad.getSession+    return $ HscTypes.ic_tythings $ HscTypes.hsc_IC hscEnv+++-- | Get list of bound variables+getBindings :: GhcMonad m => m [String]+getBindings = do+    dflags <- GHC.getSessionDynFlags+    map (dropDot . dshow dflags . HscTypes.tyThingAvailInfo) <$> getIcTythings+++removeIcTythings :: GhcMonad m => String -> m ()+removeIcTythings name = do+    dflags <- GHC.getSessionDynFlags+    GhcMonad.modifySession $ \hscEnv -> let+        hsc_IC       = HscTypes.hsc_IC       hscEnv+        ic_tythings  = HscTypes.ic_tythings hsc_IC+        ic_tythings' = filter (not . bindingMatch dflags name) ic_tythings+        hsc_IC'      = hsc_IC {HscTypes.ic_tythings = ic_tythings'}+        in hscEnv { HscTypes.hsc_IC = hsc_IC'}
+ src/Language/Haskell/Session/GHC/Util.hs view
@@ -0,0 +1,10 @@+module Language.Haskell.Session.GHC.Util where++import qualified GHC+import           Outputable (Outputable)+import qualified Outputable++++dshow :: Outputable a => GHC.DynFlags -> a -> String+dshow dflags = Outputable.showSDoc dflags . Outputable.ppr
+ src/Language/Haskell/Session/Hint/Conversions.hs view
@@ -0,0 +1,23 @@+---------------------------------------------------------------------------+-- Copyright (C) Flowbox, Inc - All Rights Reserved+-- Flowbox Team <contact@flowbox.io>, 2014+-- Proprietary and confidential+-- Unauthorized copying of this file, via any medium is strictly prohibited+---------------------------------------------------------------------------++module Language.Haskell.Session.Hint.Conversions where++import qualified DynFlags+import qualified GHC+import qualified Outputable+import qualified Type++++typeToString :: GHC.GhcMonad m => GHC.Type -> m String+typeToString t = do+    -- Unqualify necessary types+    -- (i.e., do not expose internals)+    unqual <- GHC.getPrintUnqual+    df <- DynFlags.getDynFlags+    return $ Outputable.showSDocForUser df unqual (Type.pprType t)
+ src/Language/Haskell/Session/Hint/Eval.hs view
@@ -0,0 +1,51 @@+---------------------------------------------------------------------------+-- Copyright (C) Flowbox, Inc - All Rights Reserved+-- Flowbox Team <contact@flowbox.io>, 2014+-- Proprietary and confidential+-- Unauthorized copying of this file, via any medium is strictly prohibited+---------------------------------------------------------------------------+{-# LANGUAGE MagicHash #-}++module Language.Haskell.Session.Hint.Eval (+    interpret+) where++import           Data.Typeable (Typeable)+import qualified Data.Typeable as Typeable+import qualified GHC+import qualified GHC.Exts      as Exts++import qualified Language.Haskell.Session.Hint.Util as Util++++interpret :: (GHC.GhcMonad m, Typeable a) => String -> m a+interpret expr = interpret' expr wit where+    wit :: a+    wit = undefined+++-- | Evaluates an expression, given a witness for its monomorphic type.+interpret' :: (GHC.GhcMonad m, Typeable a) => String -> a -> m a+interpret' expr wit = interpret'' expr typeStr where+    typeStr = show $ Typeable.typeOf wit+++interpret'' :: (GHC.GhcMonad m, Typeable a) => String -> String -> m a+interpret'' expr typeStr = do+    let typedExpr = concat [parens expr, " :: ", typeStr]+    exprVal <- GHC.compileExpr typedExpr+    return (Exts.unsafeCoerce# exprVal :: a)++-- | Conceptually, @parens s = \"(\" ++ s ++ \")\"@, where s is any valid haskell+-- expression. In practice, it is harder than this.+-- Observe that if @s@ ends with a trailing comment, then @parens s@ would+-- be a malformed expression. The straightforward solution for this is to+-- put the closing parenthesis in a different line. However, now we are+-- messing with the layout rules and we don't know where @s@ is going to+-- be used!+-- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@+parens :: String -> String+parens s = concat ["(let {", foo, " =\n", s, "\n",+                    "                     ;} in ", foo, ")"]+    where foo = Util.safeBndFor s
+ src/Language/Haskell/Session/Hint/Typecheck.hs view
@@ -0,0 +1,26 @@+---------------------------------------------------------------------------+-- Copyright (C) Flowbox, Inc - All Rights Reserved+-- Flowbox Team <contact@flowbox.io>, 2014+-- Proprietary and confidential+-- Unauthorized copying of this file, via any medium is strictly prohibited+---------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.Session.Hint.Typecheck where++import           Control.Monad          ((>=>))+import           Control.Monad.IO.Class (liftIO)+import qualified GHC++import qualified Language.Haskell.Session.Hint.Conversions as Conversions+++-- | Get string representation of expression type+typeOf :: GHC.GhcMonad m => String -> m String+typeOf = GHC.exprType >=> Conversions.typeToString++-- | Dump type of an expression+debugType :: GHC.GhcMonad m => String -> m ()+debugType v = do+    t <- typeOf v+    liftIO $ putStrLn $ v ++ "\n    :: " ++ t
+ src/Language/Haskell/Session/Hint/Util.hs view
@@ -0,0 +1,21 @@+---------------------------------------------------------------------------+-- Copyright (C) Flowbox, Inc - All Rights Reserved+-- Flowbox Team <contact@flowbox.io>, 2014+-- Proprietary and confidential+-- Unauthorized copying of this file, via any medium is strictly prohibited+---------------------------------------------------------------------------+module Language.Haskell.Session.Hint.Util where++import qualified Data.Char as Char+++type Expr = String++-- @safeBndFor expr@ generates a name @e@ such that it does not+-- occur free in @expr@ and, thus, it is safe to write something+-- like @e = expr@ (otherwise, it will get accidentally bound).+-- This ought to do the trick: observe that @safeBndFor expr@+-- contains more digits than @expr@ and, thus, cannot occur inside+-- @expr@.+safeBndFor :: Expr -> String+safeBndFor expr = "e_1" ++ filter Char.isDigit expr
+ src/Language/Haskell/Session/Session.hs view
@@ -0,0 +1,215 @@+module Language.Haskell.Session.Session (+    -- * Session+    run,+    initialize,+    runWith,+    initializeWith,++    -- * Flags+    setStrFlags,++    -- * Imports+    setImports,+    withImports,++    -- * GHC extensions+    setFlags,+    unsetFlags,+    withExtensionFlags,++    -- * Expression evaluation+    runStmt,+    runDecls,+    runAssignment,+    runAssignment',+    interpret,++    -- * Context and DynFlags protection+    sandboxDynFlags,+    sandboxContext,+    interceptErrors+) where++import qualified Control.Exception      as Exception+import           Control.Monad+import           Control.Monad.Catch    (bracket)+import qualified Control.Monad.Catch    as Catch+import           Control.Monad.Ghc      (lift)+import qualified Control.Monad.Ghc      as MGHC+import           Control.Monad.IO.Class (liftIO)+import           Data.Typeable          (Typeable)+import qualified DynFlags+import qualified GHC+import qualified HscTypes+import qualified GHC.Paths  as Paths++import           Language.Haskell.Config            as Config+import qualified Language.Haskell.Session.Binding   as Binding+import qualified Language.Haskell.Session.Hint.Eval as HEval+++type Session = MGHC.Ghc++type Import = String++--------------------------------------------------------------------------------+-- Session+--------------------------------------------------------------------------------++-- | Run session with default config.+run :: Session a -> IO a+run session = MGHC.runGhc (Just Paths.libdir) $ initialize >> session+++-- | Run session with custom GHC config.+runWith :: Config -> Session a -> IO a+runWith config session = MGHC.runGhc (Just $ Config.topDir config)+                       $ initializeWith config >> session+++-- | Initialize session with custom GHC config.+initializeWith :: Config -> Session ()+initializeWith config = do+    initialize+    let globalPkgDb = Config.global $ Config.pkgDb config+        localPkgDb  = Config.local  $ Config.pkgDb config+        isNotUser DynFlags.UserPkgConf = False+        isNotUser _ = True+        extraPkgConfs p = [ DynFlags.PkgConfFile globalPkgDb+                          , DynFlags.PkgConfFile localPkgDb+                          ] ++ filter isNotUser p+    flags <- GHC.getSessionDynFlags+    void  $  GHC.setSessionDynFlags flags+                { GHC.extraPkgConfs = extraPkgConfs+                --, GHC.verbosity = 4+                }++-- | Initialize session with default config.+initialize :: Session ()+initialize = do+    setStrFlags ["-fno-ghci-sandbox"]+    flags <- GHC.getSessionDynFlags+    void  $  GHC.setSessionDynFlags flags+                { GHC.hscTarget     = GHC.HscInterpreted+                , GHC.ghcLink       = GHC.LinkInMemory+                , GHC.ctxtStkDepth  = 1000+                --, GHC.verbosity = 4+                }++--------------------------------------------------------------------------------+-- Flags+--------------------------------------------------------------------------------++-- | Set ghc command line arguments.+setStrFlags :: [String] -> Session ()+setStrFlags strFlags = do+    flags <- GHC.getInteractiveDynFlags+    (flags2, leftovers, warns) <- GHC.parseDynamicFlags flags $ map GHC.noLoc strFlags+    liftIO $ HscTypes.handleFlagWarnings flags2 warns+    let unrecognized = map (show . GHC.unLoc) leftovers+    unless (null unrecognized) $+        fail $ "Unrecognized flags: " ++ unwords unrecognized+    void $ GHC.setInteractiveDynFlags flags2++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- | Set imports and replace existing ones.+setImports :: [Import] -> Session ()+setImports = GHC.setContext . map (GHC.IIDecl . GHC.simpleImportDecl . GHC.mkModuleName)+++-- | Run a code with temporary imports.+withImports :: [Import] -> Session a -> Session a+withImports imports action = sandboxContext $ do+    setImports imports+    action+++location :: String+location = "<target ghc-hs interactive>"++--------------------------------------------------------------------------------+-- GHC extensions+--------------------------------------------------------------------------------++-- | Set GHC extension flags.+setFlags :: [DynFlags.ExtensionFlag] -> Session ()+setFlags flags = do+    current <- GHC.getSessionDynFlags+    void $ GHC.setSessionDynFlags $ foldl DynFlags.xopt_set current flags++-- | Unset GHC extension flags.+unsetFlags :: [DynFlags.ExtensionFlag] -> Session ()+unsetFlags flags = do+    current <- GHC.getSessionDynFlags+    void $ GHC.setSessionDynFlags $ foldl DynFlags.xopt_unset current flags++-- | Run a code with temporary GHC extension flags.+withExtensionFlags :: [DynFlags.ExtensionFlag] -> [DynFlags.ExtensionFlag] -> Session a -> Session a+withExtensionFlags enable disable action = sandboxDynFlags $ do+    setFlags enable+    unsetFlags disable+    action++--------------------------------------------------------------------------------+-- Expression evaluation+--------------------------------------------------------------------------------++-- | Run statement as in ghci.+runStmt :: String -> Session ()+runStmt stmt = do+    result <- interceptErrors $ GHC.runStmtWithLocation location 1 stmt GHC.RunToCompletion+    case result of+        GHC.RunOk _         -> return ()+        GHC.RunException ex -> fail $ "runStmt : " ++ show ex+        GHC.RunBreak {}     -> fail $ "runStmt : RunBreak"++-- | Run declaration as in Haskell source file.+runDecls :: String -> Session ()+runDecls decls = do+    void $ interceptErrors $ GHC.runDeclsWithLocation location 1 decls+++-- | Bind expression do a variable using `let` syntax.+runAssignment :: String -> String -> Session ()+runAssignment asigned asignee = do+    Binding.removeBinding asigned+    -- do not use runDecls here: its bindings are hard to remove and cause memory leaks!+    runStmt $ "let " ++ asigned ++ " = " ++ asignee++-- | Bind expression to a variable using `bind` syntax. Expression must have type `IO a`.+runAssignment' :: String -> String -> Session ()+runAssignment' asigned asignee = do+    Binding.removeBinding asigned+    runStmt $ asigned ++ " <- " ++ asignee+++-- | Evaluate expression.+interpret :: Typeable a => String -> Session a+interpret = interceptErrors . HEval.interpret++--------------------------------------------------------------------------------+-- Context and DynFlags protection+--------------------------------------------------------------------------------++-- | Run a code which can safely modify DynFlags - it will be restored on exit.+sandboxDynFlags :: Session a -> Session a+sandboxDynFlags = bracket GHC.getSessionDynFlags GHC.setSessionDynFlags . const+++-- | Run a code which can safely modify Context w- it  will be restored on exit.+sandboxContext :: Session a -> Session a+sandboxContext = bracket GHC.getContext GHC.setContext . const+++-- | Restore session when exception will be raised.+interceptErrors :: MGHC.Ghc a -> Session a+interceptErrors ghc = do+    sessionBackup <- GHC.getSession+    let handler :: Catch.SomeException -> MGHC.Ghc a+        handler otherErr = do+            GHC.setSession sessionBackup+            Exception.throw otherErr+    Catch.catch ghc handler
+ test/Main.hs view
@@ -0,0 +1,31 @@+module Main where++import qualified Language.Haskell.Session as Session+import Control.Monad.IO.Class (liftIO)++++main = Session.run $ do+    Session.setImports ["Prelude"]+    Session.runAssignment "x" "5"+    Session.runAssignment "y" "\"bar\""+    foo <- Session.interpret "print (x, y)"+    x <- Session.interpret "x"--(x, y)"+    liftIO $ print (x :: Integer)+    liftIO $ (foo :: IO ())++    Session.runDecls "foo = print (x, y)"+    foo <- Session.interpret "foo"+    liftIO $ (foo :: IO ())++    Session.runAssignment "bar" "print (y, x)"+    bar <- Session.interpret "bar"+    liftIO $ (bar :: IO ())++    Session.runStmt "bar"+    Session.runStmt "print 555"+    Session.removeBinding "x"+    -- Session.runStmt "print x"++    Session.runDecls "data A = A deriving Show"+    Session.runStmt "print A"