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