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