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