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