git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/ScriptSession.hs
277 lines 10.0 kB history raw
1{-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-}
2#ifdef PM36_HASKELL_SCRIPTING
3{-# LANGUAGE MagicHash #-}
4#endif
5module ProjectM36.ScriptSession where
7#ifdef PM36_HASKELL_SCRIPTING
8import ProjectM36.Error
9import GHC
10import Control.Exception
11import Control.Monad
12import System.IO.Error
13import System.Directory
14import Control.Monad.IO.Class
15import System.FilePath.Glob
16import System.FilePath
17import System.Info (os, arch)
18import Data.Text (Text, unpack)
19import Data.Maybe
20import GHC.Paths (libdir)
21import System.Environment
22#if __GLASGOW_HASKELL__ >= 800
23import GHC.LanguageExtensions
24import GHCi.ObjLink
25#else
26import ObjLink
27#endif
28#if __GLASGOW_HASKELL__ >= 802
29import BasicTypes
30#endif
31import DynFlags
32import Panic
33import Outputable --hiding ((<>))
34import PprTyThing
35import Unsafe.Coerce
36#if __GLASGOW_HASKELL__ >= 802
37import Type
38#elif __GLASGOW_HASKELL__ >= 710
39import Type hiding (pprTyThing)
40#else
41#endif
42import GHC.Exts (addrToAny#)
43import GHC.Ptr (Ptr(..))
44import Encoding
45#endif
48data ScriptSession = ScriptSession {
49#ifdef PM36_HASKELL_SCRIPTING
50 hscEnv :: HscEnv,
51 atomFunctionBodyType :: Type,
52 dbcFunctionBodyType :: Type
53#endif
54 }
56#ifdef PM36_HASKELL_SCRIPTING
57data ScriptSessionError = ScriptSessionLoadError GhcException
58 | ScriptingDisabled
59 deriving (Show)
60#else
61data ScriptSessionError = ScriptingDisabled
62 deriving (Show)
63#endif
65data LoadSymbolError = LoadSymbolError
66type ModName = String
67type FuncName = String
69-- | Configure a GHC environment/session which we will use for all script compilation.
70initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)
71#if !defined(PM36_HASKELL_SCRIPTING)
72initScriptSession _ = pure (Left ScriptingDisabled)
73#else
74initScriptSession ghcPkgPaths = do
75 --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database
76 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory
77 let homeDir = either (const "/") id eHomeDir
78 let excHandler exc = pure $ Left (ScriptSessionLoadError exc)
79 handleGhcException excHandler $ runGhc (Just libdir) $ do
80 dflags <- getSessionDynFlags
81 let ghcVersion = projectVersion dflags
82 -- get nix packages dir, if available
83 mNixLibDir <- liftIO $ lookupEnv "NIX_GHC_LIBDIR"
85 sandboxPkgPaths <- liftIO $ concat <$> mapM glob [
86 --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"
87 ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",
88 ".stack-work/install/*/*/" ++ ghcVersion ++ "/pkgdb",
89 ".stack-work/install/*/pkgdb/", --windows stack build
90 "C:/sr/snapshots/b201cfe6/pkgdb", --windows stack build- ideally, we could run `stack path --snapshot-pkg-db, but this is sufficient to pass CI
91 homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb"
92 --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"
93 ]
95 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir)
97 let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,
98 ghcLink = LinkInMemory,
99 safeHaskell = Sf_Trustworthy,
100 safeInfer = True,
101 safeInferred = True,
102 --verbosity = 3,
103#if __GLASGOW_HASKELL__ >= 800
104 trustFlags = map TrustPackage required_packages,
105#endif
106 packageFlags = packageFlags dflags ++ packages,
107#if __GLASGOW_HASKELL__ >= 802
108 packageDBFlags = map PackageDB localPkgPaths
109#else
110 extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])
111#endif
113 }
114 applyGopts flags = foldl gopt_set flags gopts
115 applyXopts flags = foldl xopt_set flags xopts
116#if __GLASGOW_HASKELL__ >= 800
117 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]
118#else
119 xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]
120#endif
121 gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]
122 required_packages = ["base",
123 "containers",
124 "Glob",
125 "directory",
126 "unordered-containers",
127 "hashable",
128 "uuid",
129 "vector",
130 "text",
131 "binary",
132 "vector-binary-instances",
133 "time",
134 "project-m36",
135 "bytestring"]
136#if __GLASGOW_HASKELL__ >= 800
137 packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages
138#else
139 packages = map TrustPackage required_packages
140#endif
141 --liftIO $ traceShowM (showSDoc dflags' (ppr packages))
142 _ <- setSessionDynFlags dflags'
143 let safeImportDecl mn mQual = ImportDecl {
144#if __GLASGOW_HASKELL__ >= 802
145 ideclSourceSrc = NoSourceText,
146#else
147 ideclSourceSrc = Nothing,
148#endif
150#if __GLASGOW_HASKELL__ >= 810
151 ideclExt = noExtField,
152#elif __GLASGOW_HASKELL__ >= 806
153 ideclExt = NoExt,
154#endif
155 ideclName = noLoc mn,
156 ideclPkgQual = Nothing,
157 ideclSource = False,
158 ideclSafe = True,
159 ideclImplicit = False,
160#if __GLASGOW_HASKELL__ >= 810
161 ideclQualified = if isJust mQual then QualifiedPre else NotQualified,
162#else
163 ideclQualified = isJust mQual,
164#endif
165 ideclAs = mQual,
166 ideclHiding = Nothing
167 }
168#if __GLASGOW_HASKELL__ >= 806
169 :: ImportDecl (GhcPass (c :: Pass))
170#endif
171 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [
172 "Prelude",
173 "Data.Map",
174 "Data.Either",
175 "Data.Time.Calendar",
176 "Control.Monad.State",
177 "ProjectM36.Base",
178 "ProjectM36.Relation",
179 "ProjectM36.AtomFunctionError",
180 "ProjectM36.DatabaseContextFunctionError",
181 "ProjectM36.DatabaseContextFunctionUtils",
182 "ProjectM36.RelationalExpression"]
183#if __GLASGOW_HASKELL__ >= 802
184 mkModName = noLoc . mkModuleName
185#else
186 mkModName = mkModuleName
187#endif
188 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [
189 ("Data.Text", "T")
190 ]
191 setContext (unqualifiedModules ++ qualifiedModules)
192 env <- getSession
193 atomFuncType <- mkTypeForName "AtomFunctionBodyType"
194 dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"
195 pure (Right (ScriptSession env atomFuncType dbcFuncType))
197addImport :: String -> Ghc ()
198addImport moduleNam = do
199 ctx <- getContext
200 setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx)
202showType :: DynFlags -> Type -> String
203showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
205mkTypeForName :: String -> Ghc Type
206mkTypeForName name = do
207 lBodyName <- parseName name
208 case lBodyName of
209 [] -> error ("failed to parse " ++ name)
210 _:_:_ -> error "too many name matches"
211 [bodyName] -> do
212 mThing <- lookupName bodyName
213 case mThing of
214 Nothing -> error ("failed to find " ++ name)
215 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
216 Just typ -> pure typ
217 Nothing -> error (name ++ " is not a type synonym")
218 Just _ -> error ("failed to find type synonym " ++ name)
220compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
221compileScript funcType script = do
222 let sScript = unpack script
223 mErr <- typeCheckScript funcType script
224 case mErr of
225 Just err -> pure (Left err)
226 Nothing ->
227 --catch exception here
228 --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.
229 -- we can't use dynCompileExpr here because
230 Right . unsafeCoerce <$> compileExpr sScript
232typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
233typeCheckScript expectedType inp = do
234 dflags <- getSessionDynFlags
235 --catch exception for SyntaxError
236#if __GLASGOW_HASKELL__ >= 802
237 funcType <- GHC.exprType TM_Inst (unpack inp)
238#else
239 funcType <- GHC.exprType (unpack inp)
240#endif
241 --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
242 if eqType funcType expectedType then
243 pure Nothing
244 else
245 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))
247mangleSymbol :: Maybe String -> String -> String -> String
248mangleSymbol pkg module' valsym =
249 prefixUnderscore ++
250 maybe "" (\p -> zEncodeString p ++ "_") pkg ++
251 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"
253loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
254loadFunction modName funcName objPath = do
255#if __GLASGOW_HASKELL__ >= 802
256 initObjLinker RetainCAFs
257#else
258 initObjLinker
259#endif
260 loadObj objPath
261 _ <- resolveObjs
262 ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)
263 case ptr of
264 Nothing -> pure (Left LoadSymbolError)
265 Just (Ptr addr) -> case addrToAny# addr of
266 (# hval #) -> pure (Right hval)
268prefixUnderscore :: String
269prefixUnderscore =
270 case (os,arch) of
271 ("mingw32","x86_64") -> ""
272 ("cygwin","x86_64") -> ""
273 ("mingw32",_) -> "_"
274 ("darwin",_) -> "_"
275 ("cygwin",_) -> "_"
276 _ -> ""
277#endif