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