module Language.Haskell.Tools.BackendGHC.Monad where
import Control.Applicative ((<|>))
import Control.Exception (Exception, evaluate, throw)
import Control.Monad.Reader
import Control.Reference
import Data.Function (on)
import Data.List
import Data.Map as Map (Map, lookup, empty)
import Data.Maybe
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.AST.SemaInfoTypes (PName(..), UsageSpec(..))
import Language.Haskell.Tools.BackendGHC.GHCUtils (HsHasName(..), rdrNameStr)
import Language.Haskell.Tools.BackendGHC.SourceMap (SourceMap, annotationsToSrcMap)
import ApiAnnotation (ApiAnnKey)
import DynFlags (xopt_set)
import ErrUtils (pprErrMsgBagWithLoc)
import GHC
import GHC.LanguageExtensions.Type (Extension(..))
import HscTypes (HscEnv(..))
import Name (Name, isVarName, isTyVarName)
import OccName as GHC (HasOccName(..), mkOccEnv)
import Outputable hiding (empty)
import RdrName
import RnUnbound (mkUnboundNameRdr)
import RnExpr (rnLExpr)
import TcRnMonad
import TcRnTypes (TcGblEnv(..))
type Trf = ReaderT TrfInput Ghc
data TrfInput
= TrfInput { srcMap :: SourceMap
, pragmaComms :: Map String [Located String]
, declsToInsert :: [Ann UDecl (Dom GhcPs) RangeStage]
, contRange :: SrcSpan
, localsInScope :: [[(GHC.Name, Maybe [UsageSpec], Maybe Name)]]
, defining :: Bool
, definingTypeVars :: Bool
, originalNames :: Map SrcSpan RdrName
, declSplices :: [Located (HsSplice GhcPs)]
, typeSplices :: [Located (HsSplice GhcPs)]
, exprSplices :: [Located (HsSplice GhcPs)]
}
trfInit :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> TrfInput
trfInit annots comments
= TrfInput { srcMap = annotationsToSrcMap annots
, pragmaComms = comments
, declsToInsert = []
, contRange = noSrcSpan
, localsInScope = []
, defining = False
, definingTypeVars = False
, originalNames = empty
, declSplices = []
, typeSplices = []
, exprSplices = []
}
liftGhc :: Ghc a -> Trf a
liftGhc = lift
define :: Trf a -> Trf a
define = local (\s -> s { defining = True })
defineTypeVars :: Trf a -> Trf a
defineTypeVars = local (\s -> s { definingTypeVars = True })
typeVarTransform :: Trf a -> Trf a
typeVarTransform = local (\s -> s { defining = defining s || definingTypeVars s })
transformingPossibleVar :: HsHasName n => n -> Trf a -> Trf a
transformingPossibleVar n = case hsGetNames Nothing n of
[(name,_)] | isVarName name || isTyVarName name -> typeVarTransform
_ -> id
addEmptyScope :: Trf a -> Trf a
addEmptyScope = local (\s -> s { localsInScope = [] : localsInScope s })
addToScopeImported :: [(String, Maybe String, Bool, [PName GhcRn])] -> Trf a -> Trf a
addToScopeImported ls = local (\s -> s { localsInScope = concatMap (\(mn, asName, q, e) -> map (\(PName n p) -> (n, Just [UsageSpec q mn (fromMaybe mn asName)], p)) e) ls : localsInScope s })
addToScope :: HsHasName e => e -> Trf a -> Trf a
addToScope e = local (\s -> s { localsInScope = map (\(n,p) -> (n, Nothing, p)) (hsGetNames Nothing e) : localsInScope s })
addToCurrentScope :: HsHasName e => e -> Trf a -> Trf a
addToCurrentScope e = local (\s -> s { localsInScope = case localsInScope s of lastScope:rest -> (map (\(n,p) -> (n, Nothing, p)) (hsGetNames Nothing e) ++ lastScope):rest
[] -> [map (\(n,p) -> (n, Nothing, p)) (hsGetNames Nothing e)] })
runTrf :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> Trf a -> Ghc a
runTrf annots comments trf = runReaderT trf (trfInit annots comments)
setOriginalNames :: Map SrcSpan RdrName -> Trf a -> Trf a
setOriginalNames names = local (\s -> s { originalNames = names })
getOriginalName :: RdrName -> Trf String
getOriginalName n = do sp <- asks contRange
asks (rdrNameStr . fromMaybe n . (Map.lookup sp) . originalNames)
setSplices :: [Located (HsSplice GhcPs)] -> [Located (HsSplice GhcPs)] -> [Located (HsSplice GhcPs)] -> Trf a -> Trf a
setSplices declSpls typeSpls exprSpls
= local (\s -> s { typeSplices = typeSpls, exprSplices = exprSpls, declSplices = declSpls })
setDeclsToInsert :: [Ann UDecl (Dom GhcPs) RangeStage] -> Trf a -> Trf a
setDeclsToInsert decls = local (\s -> s {declsToInsert = decls})
exprSpliceInserted :: Located (HsSplice n) -> Trf a -> Trf a
exprSpliceInserted spl = local (\s -> s { exprSplices = Prelude.filter (\sp -> getLoc sp /= getLoc spl) (exprSplices s) })
typeSpliceInserted :: Located (HsSplice n) -> Trf a -> Trf a
typeSpliceInserted spl = local (\s -> s { typeSplices = Prelude.filter (\sp -> getLoc sp /= getLoc spl) (typeSplices s) })
rdrSplice :: HsSplice GhcPs -> Trf (HsSplice GhcRn)
rdrSplice spl = do
rng <- asks contRange
env <- liftGhc getSession
locals <- unifyScopes [] <$> asks localsInScope
let createLocalGRE (n,imp,p) = [GRE n (maybe NoParent ParentIs p) (isNothing imp) (maybe [] (map createGREImport) imp) ]
createGREImport (UsageSpec q useQ asQ) = ImpSpec (ImpDeclSpec (mkModuleName useQ) (mkModuleName asQ) q noSrcSpan) ImpAll
let readEnv = mkOccEnv $ map (foldl1 (\e1 e2 -> (fst e1, snd e1 ++ snd e2))) $ groupBy ((==) `on` fst) $ sortOn fst
$ map (\n -> (GHC.occName ((^. _1) n), createLocalGRE n))
$ map (foldl1 (\e1 e2 -> ((^. _1) e1, (^. _2) e1 `mappend` (^. _2) e2, (^. _3) e1 <|> (^. _3) e2)))
$ groupBy ((==) `on` (^. _1)) $ sortBy (compare `on` (^. _1)) locals
tcSpl <- liftIO $ runTcInteractive (env { hsc_dflags = xopt_set (hsc_dflags env) TemplateHaskellQuotes })
$ updGblEnv (\gbl -> gbl { tcg_rdr_env = readEnv })
$ tcHsSplice' spl
let typecheckErrors = showSDocUnsafe (vcat (pprErrMsgBagWithLoc (fst (fst tcSpl)))
<+> vcat (pprErrMsgBagWithLoc (snd (fst tcSpl))))
liftIO $ evaluate (snd tcSpl)
return $ fromMaybe (throw $ SpliceInsertionProblem rng typecheckErrors)
(snd tcSpl)
where
tcHsSplice' (HsTypedSplice ex dec id e)
= HsTypedSplice ex dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
tcHsSplice' (HsUntypedSplice ex dec id e)
= HsUntypedSplice ex dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
tcHsSplice' (HsQuasiQuote ex id1 id2 sp fs)
= pure $ HsQuasiQuote ex (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs
unifyScopes :: [GHC.Name] -> [[(GHC.Name, Maybe [UsageSpec], Maybe GHC.Name)]] -> [(GHC.Name, Maybe [UsageSpec], Maybe GHC.Name)]
unifyScopes _ [] = []
unifyScopes ex (sc:scs) = filteredSc ++ unifyScopes (ex ++ map (^. _1) filteredSc) scs
where filteredSc = filter ((\s -> isNothing $ find (\e -> occName e == occName s) ex) . (^. _1)) sc
data SpliceInsertionProblem = SpliceInsertionProblem SrcSpan String
deriving Show
instance Exception SpliceInsertionProblem