module Language.Haskell.Tools.AST.FromGHC.Monad where
import SrcLoc
import GHC
import Name
import ApiAnnotation
import Outputable (ppr, showSDocUnsafe)
import Control.Monad.Reader
import Language.Haskell.Tools.AST.FromGHC.SourceMap
import Language.Haskell.Tools.AST.FromGHC.GHCUtils
import Data.Map as Map
import Data.Function (on)
import Data.Maybe
import Language.Haskell.Tools.AST
import Debug.Trace
type Trf = ReaderT TrfInput Ghc
data TrfInput
= TrfInput { srcMap :: SourceMap
, pragmaComms :: Map String [Located String]
, declsToInsert :: [Ann UDecl (Dom RdrName) RangeStage]
, contRange :: SrcSpan
, localsInScope :: [[GHC.Name]]
, defining :: Bool
, definingTypeVars :: Bool
, originalNames :: Map SrcSpan RdrName
, declSplices :: [Located (HsSplice GHC.Name)]
, typeSplices :: [HsSplice GHC.Name]
, exprSplices :: [HsSplice GHC.Name]
}
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 n of
[name] | isVarName name || isTyVarName name -> typeVarTransform
_ -> id
addToScope :: HsHasName e => e -> Trf a -> Trf a
addToScope e = local (\s -> s { localsInScope = hsGetNames e : localsInScope s })
addToCurrentScope :: HsHasName e => e -> Trf a -> Trf a
addToCurrentScope e = local (\s -> s { localsInScope = case localsInScope s of lastScope:rest -> (hsGetNames e ++ lastScope):rest
[] -> [hsGetNames 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 GHC.Name)] -> [HsSplice GHC.Name] -> [HsSplice GHC.Name] -> Trf a -> Trf a
setSplices declSpls typeSpls exprSpls
= local (\s -> s { typeSplices = typeSpls, exprSplices = exprSpls, declSplices = declSpls })
setDeclsToInsert :: [Ann UDecl (Dom RdrName) RangeStage] -> Trf a -> Trf a
setDeclsToInsert decls = local (\s -> s {declsToInsert = decls})
exprSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
exprSpliceInserted spl = local (\s -> s { exprSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (exprSplices s) })
typeSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
typeSpliceInserted spl = local (\s -> s { typeSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (typeSplices s) })
getSpliceLoc :: HsSplice a -> SrcSpan
getSpliceLoc (HsTypedSplice _ e) = getLoc e
getSpliceLoc (HsUntypedSplice _ e) = getLoc e
getSpliceLoc (HsQuasiQuote _ _ sp _) = sp