git.iko.soy/project-m36
on 63fbef0 help sign in
project-m36/src/lib/ProjectM36/ScriptSession.hs
176 lines 7.2 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 homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb",
52 homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"
53 ]
55 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)
57 let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,
58 ghcLink = LinkInMemory,
59 safeHaskell = Sf_Trustworthy,
60 safeInfer = True,
61 safeInferred = True,
62 --verbosity = 3,
63#if __GLASGOW_HASKELL__ >= 800
64 trustFlags = map TrustPackage required_packages,
65#endif
66 packageFlags = packageFlags dflags ++ packages,
67 extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])
68 }
69 applyGopts flags = foldl gopt_set flags gopts
70 applyXopts flags = foldl xopt_set flags xopts
71#if __GLASGOW_HASKELL__ >= 800
72 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]
73#else
74 xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]
75#endif
76 gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]
77 required_packages = ["base",
78 "containers",
79 "Glob",
80 "directory",
81 "unordered-containers",
82 "hashable",
83 "uuid",
84 "vector",
85 "text",
86 "binary",
87 "vector-binary-instances",
88 "time",
89 "project-m36",
90 "bytestring"]
91#if __GLASGOW_HASKELL__ >= 800
92 packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages
93#else
94 packages = map TrustPackage required_packages
95#endif
96 --liftIO $ traceShowM (showSDoc dflags' (ppr packages))
97 _ <- setSessionDynFlags dflags'
98 let safeImportDecl mn mQual = ImportDecl {
99 ideclSourceSrc = Nothing,
100 ideclName = noLoc mn,
101 ideclPkgQual = Nothing,
102 ideclSource = False,
103 ideclSafe = True,
104 ideclImplicit = False,
105 ideclQualified = isJust mQual,
106 ideclAs = mQual,
107 ideclHiding = Nothing
108 }
109 unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [
110 "Prelude",
111 "Data.Map",
112 "Data.Either",
113 "Data.Time.Calendar",
114 "Control.Monad.State",
115 "ProjectM36.Base",
116 "ProjectM36.Relation",
117 "ProjectM36.AtomFunctionError",
118 "ProjectM36.DatabaseContextFunctionError",
119 "ProjectM36.DatabaseContextFunctionUtils",
120 "ProjectM36.RelationalExpression"]
121 qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModuleName qualNam))) [
122 ("Data.Text", "T")
123 ]
124 setContext (unqualifiedModules ++ qualifiedModules)
125 env <- getSession
126 atomFuncType <- mkTypeForName "AtomFunctionBodyType"
127 dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"
128 pure (Right (ScriptSession env atomFuncType dbcFuncType))
130addImport :: String -> Ghc ()
131addImport moduleNam = do
132 ctx <- getContext
133 setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )
135showType :: DynFlags -> Type -> String
136showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
138mkTypeForName :: String -> Ghc Type
139mkTypeForName name = do
140 lBodyName <- parseName name
141 case lBodyName of
142 [] -> error ("failed to parse " ++ name)
143 _:_:_ -> error "too many name matches"
144 [bodyName] -> do
145 mThing <- lookupName bodyName
146 case mThing of
147 Nothing -> error ("failed to find " ++ name)
148 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
149 Just typ -> pure typ
150 Nothing -> error (name ++ " is not a type synonym")
151 Just _ -> error ("failed to find type synonym " ++ name)
153compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
154compileScript funcType script = do
155 let sScript = unpack script
156 mErr <- typeCheckScript funcType script
157 case mErr of
158 Just err -> pure (Left err)
159 Nothing -> do
160 --catch exception here
161 --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.
162 -- we can't use dynCompileExpr here because
163 func <- compileExpr sScript
164 pure $ Right (unsafeCoerce func)
166typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
167typeCheckScript expectedType inp = do
168 dflags <- getSessionDynFlags
169 --catch exception for SyntaxError
170 funcType <- GHC.exprType (unpack inp)
171 --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
172 if eqType funcType expectedType then
173 pure Nothing
174 else
175 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))