git.iko.soy/project-m36
on e0e000c help sign in
project-m36/src/lib/ProjectM36/AtomFunctionBody.hs
140 lines 5.9 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2--tools to execute an atom function body
3module ProjectM36.AtomFunctionBody where
4import ProjectM36.Base
5import ProjectM36.Error
7import Control.Monad.IO.Class
8import Control.Exception
9import Data.Text hiding (map)
11import Unsafe.Coerce
12import GHC
13import GHC.Paths (libdir)
14import DynFlags
15import Outputable hiding ((<>))
16import PprTyThing
17import Type hiding (pprTyThing)
18import System.FilePath.Glob
20data ScriptSession = ScriptSession {
21 hscEnv :: HscEnv,
22 atomFunctionBodyType :: Type
23 }
25-- | Configure a GHC environment/session which we will use for all script compilation.
26initScriptSession :: [String] -> IO ScriptSession
27initScriptSession ghcPkgPaths = do
28 --for the sake of convenience, for developers' builds, include the local cabal sandbox pacakge database
29 sandboxPkgPaths <- liftIO (glob ".cabal-sandbox/*packages.conf.d")
30 runGhc (Just libdir) $ do
31 dflags <- getSessionDynFlags
32 let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)
34 let dflags' = dflags { hscTarget = HscInterpreted ,
35 ghcLink = LinkInMemory,
36 safeHaskell = Sf_Trustworthy,
37 safeInfer = True,
38 safeInferred = True,
39 --trustFlags = [TrustPackage "base"] -- new in 8
40 packageFlags = (packageFlags dflags) ++ packages,
41 extraPkgConfs = const ([GlobalPkgConf, UserPkgConf] ++ localPkgPaths)
42 }
43 `xopt_set` Opt_ExtendedDefaultRules
44 `xopt_set` Opt_ImplicitPrelude
45 `xopt_set` Opt_OverloadedStrings
46 `gopt_set` Opt_DistrustAllPackages
47 `xopt_set` Opt_ScopedTypeVariables
48 `gopt_set` Opt_PackageTrust
49 --`gopt_set` Opt_ImplicitImportQualified
50 packages = map TrustPackage ["base",
51 "containers",
52 "unordered-containers",
53 "hashable",
54 "uuid",
55 "vector",
56 "text",
57 "binary",
58 "vector-binary-instances",
59 "time",
60 "project-m36",
61 "bytestring"] -- package flags changed in 8.0
62 _ <- setSessionDynFlags dflags'
63 let safeImportDecl mn = ImportDecl {
64 ideclSourceSrc = Nothing,
65 ideclName = noLoc mn,
66 ideclPkgQual = Nothing,
67 ideclSource = False,
68 ideclSafe = True,
69 ideclImplicit = False,
70 ideclQualified = False,
71 ideclAs = Nothing,
72 ideclHiding = Nothing
73 }
74 setContext (map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn))
75 ["Prelude",
76 "Data.Map",
77 "ProjectM36.Base"])
78 env <- getSession
79 fType <- mkAtomFunctionBodyType
80 pure (ScriptSession env fType)
82mkAtomFunctionBodyType :: Ghc Type
83mkAtomFunctionBodyType = do
84 lBodyName <- parseName "AtomFunctionBodyType"
85 case lBodyName of
86 [] -> error "failed to parse AtomFunctionBodyType"
87 _:_:_ -> error "too many name matches"
88 bodyName:[] -> do
89 mThing <- lookupName bodyName
90 case mThing of
91 Nothing -> error "failed to find AtomFunctionBodyType"
92 Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of
93 Just typ -> pure typ
94 Nothing -> error "AtomFunctionBodyType is not a type synonym"
95 Just _ -> error "failed to find type synonym AtomFunctionBodyType"
97addImport :: String -> Ghc ()
98addImport moduleNam = do
99 ctx <- getContext
100 setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )
102showType :: DynFlags -> Type -> String
103showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
105-- | Typecheck and validate the
106typeCheckAtomFunctionScript :: Type -> AtomFunctionBodyScript -> Ghc (Maybe AtomFunctionBodyCompilationError)
107typeCheckAtomFunctionScript expectedType inp = do
108 dflags <- getSessionDynFlags
109 --catch exception for SyntaxError
110 funcType <- GHC.exprType (unpack inp)
112 if eqType funcType expectedType then
113 pure Nothing
114 else
115 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))
117-- | After compiling the script, it must accept a list of Atoms and return an Atom, otherwise an AtomFunctionBodyCompilationError is returned
118compileAtomFunctionScript :: ScriptSession -> AtomFunctionBodyScript -> Ghc (Either AtomFunctionBodyCompilationError AtomFunctionBodyType)
119compileAtomFunctionScript (ScriptSession _ funcType) script = do
120 let sScript = unpack script
121 mErr <- typeCheckAtomFunctionScript funcType script
122 case mErr of
123 Just err -> pure (Left err)
124 Nothing -> do
125 --catch exception here
126 --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.
127 -- we can't use dynCompileExpr here because
128 func <- compileExpr sScript
129 pure $ Right (unsafeCoerce func)
131catchCompileException :: MonadIO m => IO a -> m (Either AtomFunctionBodyCompilationError a)
132catchCompileException m = liftIO $ do
133 mres <- try m
134 case mres of
135 Left (err :: SomeException) -> do
136 pure (Left (OtherScriptCompilationError (show err)))
137 Right res -> pure (Right res)
139compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody
140compiledAtomFunctionBody func = AtomFunctionBody Nothing func