git.iko.soy/project-m36
on 76effd4 help sign in
project-m36/src/lib/ProjectM36/ScriptSession.hs
271 lines 9.8 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__ >= 806
151 ideclExt = NoExt,
152#endif
153 ideclName = noLoc mn,
154 ideclPkgQual = Nothing,
155 ideclSource = False,
156 ideclSafe = True,
157 ideclImplicit = False,
158 ideclQualified = isJust mQual,
159 ideclAs = mQual,
160 ideclHiding = Nothing
161 }
162#if __GLASGOW_HASKELL__ >= 806
163 :: ImportDecl (GhcPass (c :: Pass))
164#endif
165 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [
166 "Prelude",
167 "Data.Map",
168 "Data.Either",
169 "Data.Time.Calendar",
170 "Control.Monad.State",
171 "ProjectM36.Base",
172 "ProjectM36.Relation",
173 "ProjectM36.AtomFunctionError",
174 "ProjectM36.DatabaseContextFunctionError",
175 "ProjectM36.DatabaseContextFunctionUtils",
176 "ProjectM36.RelationalExpression"]
177#if __GLASGOW_HASKELL__ >= 802
178 mkModName = noLoc . mkModuleName
179#else
180 mkModName = mkModuleName
181#endif
182 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [
183 ("Data.Text", "T")
184 ]
185 setContext (unqualifiedModules ++ qualifiedModules)
186 env <- getSession
187 atomFuncType <- mkTypeForName "AtomFunctionBodyType"
188 dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"
189 pure (Right (ScriptSession env atomFuncType dbcFuncType))
191addImport :: String -> Ghc ()
192addImport moduleNam = do
193 ctx <- getContext
194 setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx)
196showType :: DynFlags -> Type -> String
197showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
199mkTypeForName :: String -> Ghc Type
200mkTypeForName name = do
201 lBodyName <- parseName name
202 case lBodyName of
203 [] -> error ("failed to parse " ++ name)
204 _:_:_ -> error "too many name matches"
205 [bodyName] -> do
206 mThing <- lookupName bodyName
207 case mThing of
208 Nothing -> error ("failed to find " ++ name)
209 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
210 Just typ -> pure typ
211 Nothing -> error (name ++ " is not a type synonym")
212 Just _ -> error ("failed to find type synonym " ++ name)
214compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
215compileScript funcType script = do
216 let sScript = unpack script
217 mErr <- typeCheckScript funcType script
218 case mErr of
219 Just err -> pure (Left err)
220 Nothing ->
221 --catch exception here
222 --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.
223 -- we can't use dynCompileExpr here because
224 Right . unsafeCoerce <$> compileExpr sScript
226typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
227typeCheckScript expectedType inp = do
228 dflags <- getSessionDynFlags
229 --catch exception for SyntaxError
230#if __GLASGOW_HASKELL__ >= 802
231 funcType <- GHC.exprType TM_Inst (unpack inp)
232#else
233 funcType <- GHC.exprType (unpack inp)
234#endif
235 --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
236 if eqType funcType expectedType then
237 pure Nothing
238 else
239 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))
241mangleSymbol :: Maybe String -> String -> String -> String
242mangleSymbol pkg module' valsym =
243 prefixUnderscore ++
244 maybe "" (\p -> zEncodeString p ++ "_") pkg ++
245 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"
247loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
248loadFunction modName funcName objPath = do
249#if __GLASGOW_HASKELL__ >= 802
250 initObjLinker RetainCAFs
251#else
252 initObjLinker
253#endif
254 loadObj objPath
255 _ <- resolveObjs
256 ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)
257 case ptr of
258 Nothing -> pure (Left LoadSymbolError)
259 Just (Ptr addr) -> case addrToAny# addr of
260 (# hval #) -> pure (Right hval)
262prefixUnderscore :: String
263prefixUnderscore =
264 case (os,arch) of
265 ("mingw32","x86_64") -> ""
266 ("cygwin","x86_64") -> ""
267 ("mingw32",_) -> "_"
268 ("darwin",_) -> "_"
269 ("cygwin",_) -> "_"
270 _ -> ""
271#endif