module Language.Haskell.Tools.AST.FromGHC.Monad where
import ApiAnnotation (ApiAnnKey)
import Control.Monad.Reader
import Data.Function (on)
import Data.Map as Map (Map, lookup, empty)
import Data.Maybe (fromMaybe)
import GHC
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.AST.FromGHC.GHCUtils (HsHasName(..), rdrNameStr)
import Language.Haskell.Tools.AST.FromGHC.SourceMap (SourceMap, annotationsToSrcMap)
import Name (Name, isVarName, isTyVarName)
import SrcLoc
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
addEmptyScope :: Trf a -> Trf a
addEmptyScope = local (\s -> s { localsInScope = [] : localsInScope s })
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
getSpliceLoc (HsSpliced _ _) = noSrcSpan