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