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