git.iko.soy/project-m36
on add5922 help sign in
project-m36/src/lib/ProjectM36/ScriptSession.hs
203 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#else
31import Type hiding (pprTyThing)
32#endif
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#if __GLASGOW_HASKELL__ >= 802
77 packageDBFlags = map PackageDB localPkgPaths
78#else
79 extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])
80#endif
82 }
83 applyGopts flags = foldl gopt_set flags gopts
84 applyXopts flags = foldl xopt_set flags xopts
85#if __GLASGOW_HASKELL__ >= 800
86 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]
87#else
88 xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]
89#endif
90 gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]
91 required_packages = ["base",
92 "containers",
93 "Glob",
94 "directory",
95 "unordered-containers",
96 "hashable",
97 "uuid",
98 "vector",
99 "text",
100 "binary",
101 "vector-binary-instances",
102 "time",
103 "project-m36",
104 "bytestring"]
105#if __GLASGOW_HASKELL__ >= 800
106 packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages
107#else
108 packages = map TrustPackage required_packages
109#endif
110 --liftIO $ traceShowM (showSDoc dflags' (ppr packages))
111 _ <- setSessionDynFlags dflags'
112 let safeImportDecl mn mQual = ImportDecl {
113#if __GLASGOW_HASKELL__ >= 802
114 ideclSourceSrc = NoSourceText,
115#else
116 ideclSourceSrc = Nothing,
117#endif
118 ideclName = noLoc mn,
119 ideclPkgQual = Nothing,
120 ideclSource = False,
121 ideclSafe = True,
122 ideclImplicit = False,
123 ideclQualified = isJust mQual,
124 ideclAs = mQual,
125 ideclHiding = Nothing
126 }
127 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [
128 "Prelude",
129 "Data.Map",
130 "Data.Either",
131 "Data.Time.Calendar",
132 "Control.Monad.State",
133 "ProjectM36.Base",
134 "ProjectM36.Relation",
135 "ProjectM36.AtomFunctionError",
136 "ProjectM36.DatabaseContextFunctionError",
137 "ProjectM36.DatabaseContextFunctionUtils",
138 "ProjectM36.RelationalExpression"]
139#if __GLASGOW_HASKELL__ >= 802
140 mkModName = noLoc . mkModuleName
141#else
142 mkModName = mkModuleName
143#endif
144 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [
145 ("Data.Text", "T")
146 ]
147 setContext (unqualifiedModules ++ qualifiedModules)
148 env <- getSession
149 atomFuncType <- mkTypeForName "AtomFunctionBodyType"
150 dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"
151 pure (Right (ScriptSession env atomFuncType dbcFuncType))
153addImport :: String -> Ghc ()
154addImport moduleNam = do
155 ctx <- getContext
156 setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )
158showType :: DynFlags -> Type -> String
159showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
161mkTypeForName :: String -> Ghc Type
162mkTypeForName name = do
163 lBodyName <- parseName name
164 case lBodyName of
165 [] -> error ("failed to parse " ++ name)
166 _:_:_ -> error "too many name matches"
167 [bodyName] -> do
168 mThing <- lookupName bodyName
169 case mThing of
170 Nothing -> error ("failed to find " ++ name)
171 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
172 Just typ -> pure typ
173 Nothing -> error (name ++ " is not a type synonym")
174 Just _ -> error ("failed to find type synonym " ++ name)
176compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
177compileScript funcType script = do
178 let sScript = unpack script
179 mErr <- typeCheckScript funcType script
180 case mErr of
181 Just err -> pure (Left err)
182 Nothing -> do
183 --catch exception here
184 --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.
185 -- we can't use dynCompileExpr here because
186 func <- compileExpr sScript
187 pure $ Right (unsafeCoerce func)
189typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
190typeCheckScript expectedType inp = do
191 dflags <- getSessionDynFlags
192 --catch exception for SyntaxError
193#if __GLASGOW_HASKELL__ >= 802
194 funcType <- GHC.exprType TM_Inst (unpack inp)
195#else
196 funcType <- GHC.exprType (unpack inp)
197#endif
198 --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
199 if eqType funcType expectedType then
200 pure Nothing
201 else
202 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))