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