git.iko.soy/project-m36
on fc8cecc help sign in
project-m36/src/lib/ProjectM36/ScriptSession.hs
247 lines 9.2 kB history raw
1{-# LANGUAGE MagicHash, UnboxedTuples #-}
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
128 ideclName = noLoc mn,
129 ideclPkgQual = Nothing,
130 ideclSource = False,
131 ideclSafe = True,
132 ideclImplicit = False,
133 ideclQualified = isJust mQual,
134 ideclAs = mQual,
135 ideclHiding = Nothing
136 }
137 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [
138 "Prelude",
139 "Data.Map",
140 "Data.Either",
141 "Data.Time.Calendar",
142 "Control.Monad.State",
143 "ProjectM36.Base",
144 "ProjectM36.Relation",
145 "ProjectM36.AtomFunctionError",
146 "ProjectM36.DatabaseContextFunctionError",
147 "ProjectM36.DatabaseContextFunctionUtils",
148 "ProjectM36.RelationalExpression"]
149#if __GLASGOW_HASKELL__ >= 802
150 mkModName = noLoc . mkModuleName
151#else
152 mkModName = mkModuleName
153#endif
154 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [
155 ("Data.Text", "T")
156 ]
157 setContext (unqualifiedModules ++ qualifiedModules)
158 env <- getSession
159 atomFuncType <- mkTypeForName "AtomFunctionBodyType"
160 dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"
161 pure (Right (ScriptSession env atomFuncType dbcFuncType))
163addImport :: String -> Ghc ()
164addImport moduleNam = do
165 ctx <- getContext
166 setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )
168showType :: DynFlags -> Type -> String
169showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
171mkTypeForName :: String -> Ghc Type
172mkTypeForName name = do
173 lBodyName <- parseName name
174 case lBodyName of
175 [] -> error ("failed to parse " ++ name)
176 _:_:_ -> error "too many name matches"
177 [bodyName] -> do
178 mThing <- lookupName bodyName
179 case mThing of
180 Nothing -> error ("failed to find " ++ name)
181 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
182 Just typ -> pure typ
183 Nothing -> error (name ++ " is not a type synonym")
184 Just _ -> error ("failed to find type synonym " ++ name)
186compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
187compileScript funcType script = do
188 let sScript = unpack script
189 mErr <- typeCheckScript funcType script
190 case mErr of
191 Just err -> pure (Left err)
192 Nothing ->
193 --catch exception here
194 --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.
195 -- we can't use dynCompileExpr here because
196 Right . unsafeCoerce <$> compileExpr sScript
198typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
199typeCheckScript expectedType inp = do
200 dflags <- getSessionDynFlags
201 --catch exception for SyntaxError
202#if __GLASGOW_HASKELL__ >= 802
203 funcType <- GHC.exprType TM_Inst (unpack inp)
204#else
205 funcType <- GHC.exprType (unpack inp)
206#endif
207 --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
208 if eqType funcType expectedType then
209 pure Nothing
210 else
211 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))
213mangleSymbol :: Maybe String -> String -> String -> String
214mangleSymbol pkg module' valsym =
215 prefixUnderscore ++
216 maybe "" (\p -> zEncodeString p ++ "_") pkg ++
217 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"
219type ModName = String
220type FuncName = String
222data LoadSymbolError = LoadSymbolError
224loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
225loadFunction modName funcName objPath = do
226#if __GLASGOW_HASKELL__ >= 802
227 initObjLinker RetainCAFs
228#else
229 initObjLinker
230#endif
231 loadObj objPath
232 _ <- resolveObjs
233 ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)
234 case ptr of
235 Nothing -> pure (Left LoadSymbolError)
236 Just (Ptr addr) -> case addrToAny# addr of
237 (# hval #) -> pure (Right hval)
239prefixUnderscore :: String
240prefixUnderscore =
241 case (os,arch) of
242 ("mingw32","x86_64") -> ""
243 ("cygwin","x86_64") -> ""
244 ("mingw32",_) -> "_"
245 ("darwin",_) -> "_"
246 ("cygwin",_) -> "_"
247 _ -> ""