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