haskell-tools-backend-ghc 1.1.0.2 → 1.1.1.0
raw patch · 20 files changed
+619/−560 lines, 20 filesdep ~basedep ~containersdep ~ghc
Dependency ranges changed: base, containers, ghc, ghc-boot-th, template-haskell
Files
- Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs +13/−8
- Language/Haskell/Tools/BackendGHC/Binds.hs +44/−43
- Language/Haskell/Tools/BackendGHC/Binds.hs-boot +6/−4
- Language/Haskell/Tools/BackendGHC/Decls.hs +157/−166
- Language/Haskell/Tools/BackendGHC/Exprs.hs +95/−91
- Language/Haskell/Tools/BackendGHC/Exprs.hs-boot +5/−3
- Language/Haskell/Tools/BackendGHC/GHCUtils.hs +73/−65
- Language/Haskell/Tools/BackendGHC/Kinds.hs +29/−21
- Language/Haskell/Tools/BackendGHC/Literals.hs +1/−0
- Language/Haskell/Tools/BackendGHC/Modules.hs +10/−11
- Language/Haskell/Tools/BackendGHC/Monad.hs +7/−7
- Language/Haskell/Tools/BackendGHC/Names.hs +33/−6
- Language/Haskell/Tools/BackendGHC/Patterns.hs +26/−24
- Language/Haskell/Tools/BackendGHC/Stmts.hs +17/−15
- Language/Haskell/Tools/BackendGHC/TH.hs +22/−21
- Language/Haskell/Tools/BackendGHC/TH.hs-boot +5/−3
- Language/Haskell/Tools/BackendGHC/Types.hs +54/−56
- Language/Haskell/Tools/BackendGHC/Types.hs-boot +7/−2
- Language/Haskell/Tools/BackendGHC/Utils.hs +9/−8
- haskell-tools-backend-ghc.cabal +6/−6
Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Tools.BackendGHC.AddTypeInfo (addTypeInfos) where @@ -14,7 +15,7 @@ import SrcLoc as GHC import TcEvidence as GHC (EvBind(..), TcEvBinds(..)) import Type as GHC (Type, mkTyVarTy, mkTyConTy) -import TysWiredIn as GHC (starKindTyCon) +import TysWiredIn as GHC (anyTyCon) import UniqDFM as GHC (eltsUDFM) import UniqSupply as GHC (uniqFromSupply, mkSplitUniqSupply) import Var as GHC (Var(..)) @@ -31,6 +32,8 @@ import Data.List as List import qualified Data.Map as Map (fromList, lookup) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) +import GHC.Stack (emptyCallStack) + import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.SemaInfoTypes as AST import Language.Haskell.Tools.BackendGHC.GHCUtils (getTopLevelId) @@ -55,7 +58,7 @@ -> case Map.lookup l locMapping of Just id -> return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id _ -> do (none,rest) <- gets (break ((\case (RealSrcSpan sp) -> sp `containsSpan` loc) . fst)) - case rest of [] -> throw $ ConvertionProblem (RealSrcSpan loc) "Ambiguous or implicit name missing" + case rest of [] -> throw $ ConvertionProblem emptyCallStack (RealSrcSpan loc) "Ambiguous or implicit name missing" ((_,id):more) -> do put (none ++ more) return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id _ -> convProblem "addTypeInfos: Cannot access a the semantics of a name.") @@ -82,20 +85,22 @@ where exprLits :: [LHsExpr GhcTc] exprLits = concatMap universeBi . bagToList $ bnds - decompExprLit (L loc (HsOverLit lit)) = Just (loc, ol_type lit) + decompExprLit :: LHsExpr GhcTc -> Maybe (SrcSpan, Type) + decompExprLit (L loc (HsOverLit _ lit)) = Just (loc, ol_type (ol_ext lit)) decompExprLit x = Nothing patLits :: [LPat GhcTc] patLits = concatMap universeBi . bagToList $ bnds - decompPatLit (L loc (NPat llit _ _ _)) = Just (loc, ol_type . unLoc $ llit) + decompPatLit :: LPat GhcTc -> Maybe (SrcSpan, Type) + decompPatLit (L loc (NPat llit _ _ _)) = Just (loc, llit) decompPatLit x = Nothing mkUnknownType :: IO Type mkUnknownType = do tUnique <- mkSplitUniqSupply 'x' - return $ mkTyVarTy $ mkVanillaGlobal (mkSystemName (uniqFromSupply tUnique) (mkDataOcc "TypeNotFound")) (mkTyConTy starKindTyCon) + return $ mkTyVarTy $ mkVanillaGlobal (mkSystemName (uniqFromSupply tUnique) (mkDataOcc "TypeNotFound")) (mkTyConTy anyTyCon) getFixities :: Ghc [(Module, (OccName, GHC.Fixity))] getFixities = do env <- getSession @@ -106,8 +111,8 @@ extractExprIds :: LHsBinds GhcTc -> [Located Id] -- expressions like HsRecFld are removed from the typechecked representation, they are replaced by HsVar -extractExprIds = catMaybes . map (\case L l (HsVar (L _ n) :: HsExpr GhcTc) -> Just (L l n) - L l (HsWrap _ (HsVar (L _ n))) -> Just (L l n) +extractExprIds = catMaybes . map (\case L l (HsVar _ (L _ n) :: HsExpr GhcTc) -> Just (L l n) + L l (HsWrap _ _ (HsVar _ (L _ n))) -> Just (L l n) _ -> Nothing ) . concatMap universeBi . bagToList @@ -126,7 +131,7 @@ extractSigBindIds :: LHsBinds GhcTc -> [(SrcSpan,Id)] extractSigBindIds = filter (isGoodSrcSpan . fst) . catMaybes - . map (\case L l (IPBind (Right id) _ :: IPBind GhcTc) -> Just (l,id) + . map (\case L l (IPBind _ (Right id) _ :: IPBind GhcTc) -> Just (l,id) _ -> Nothing ) . concatMap universeBi . bagToList
Language/Haskell/Tools/BackendGHC/Binds.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the value and function definitions of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Binds where @@ -18,7 +19,7 @@ import Name as GHC (isSymOcc) import PlaceHolder as GHC (NameOrRdrName) import SrcLoc as GHC -import HsExtension (IdP) +import HsExtension (GhcPass, IdP) import Control.Monad.Reader (Monad(..), mapM, asks) import Data.List @@ -35,42 +36,42 @@ import Language.Haskell.Tools.AST (Ann, AnnMaybeG, AnnListG, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.UValueBind (Dom r) RangeStage) +trfBind :: (TransformName n r, n ~ GhcPass p) => Located (HsBind n) -> Trf (Ann AST.UValueBind (Dom r) RangeStage) trfBind = trfLocNoSema trfBind' -trfBind' :: forall n r . TransformName n r => HsBind n -> Trf (AST.UValueBind (Dom r) RangeStage) +trfBind' :: forall n r p . (TransformName n r, n ~ GhcPass p) => HsBind n -> Trf (AST.UValueBind (Dom r) RangeStage) -- A value binding with a strcitness annotation -trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_ctxt = FunRhs { mc_strictness = SrcStrict }, m_pats = [], m_grhss = GRHSs [L _ (GRHS [] expr)] (L _ locals) })]} }) +trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_ctxt = FunRhs { mc_strictness = SrcStrict }, m_pats = [], m_grhss = GRHSs _ [L _ (GRHS _ [] expr)] (L _ locals) })]} }) = do bangLoc <- focusBeforeLoc (srcSpanStart $ getLoc id) $ tokenLoc AnnBang AST.USimpleBind <$> annLocNoSema (pure $ combineSrcSpans bangLoc (getLoc id)) (AST.UBangPat <$> copyAnnot AST.UVarPat (define $ trfName @n id)) <*> addEmptyScope (addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr))) <*> addEmptyScope (trfWhereLocalBinds (getLoc expr) locals) -- A value binding (not a function) -trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = GRHSs [L _ (GRHS [] expr)] (L _ locals) })]} }) +trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = GRHSs _ [L _ (GRHS _ [] expr)] (L _ locals) })]} }) = AST.USimpleBind <$> copyAnnot AST.UVarPat (define $ trfName @n id) <*> addEmptyScope (addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr))) <*> addEmptyScope (trfWhereLocalBinds (getLoc expr) locals) -trfBind' (FunBind id (MG (unLoc -> matches) _ _ _) _ _ _) +trfBind' (FunBind _ id (MG _ (unLoc -> matches) _) _ _) = AST.UFunBind <$> makeNonemptyIndentedList (mapM (trfMatch (unLoc id)) matches) -trfBind' (PatBind pat (GRHSs rhs (unLoc -> locals)) _ _ _) +trfBind' (PatBind _ pat (GRHSs _ rhs (unLoc -> locals)) _) = AST.USimpleBind <$> trfPattern pat <*> addEmptyScope (addToScope locals (trfRhss rhs)) <*> addEmptyScope (trfWhereLocalBinds (collectLocs rhs) locals) -trfBind' (PatSynBind _) = convertionProblem "Pattern synonym bindings should be recognized on the declaration level" +trfBind' (PatSynBind _ _) = convertionProblem "Pattern synonym bindings should be recognized on the declaration level" trfBind' b = unhandledElement "binding" b -trfMatch :: TransformName n r => IdP n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.UMatch (Dom r) RangeStage) +trfMatch :: (TransformName n r, n ~ GhcPass p) => IdP n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.UMatch (Dom r) RangeStage) trfMatch id = trfLocNoSema (trfMatch' id) -trfMatch' :: TransformName n r => IdP n -> Match n (LHsExpr n) -> Trf (AST.UMatch (Dom r) RangeStage) -trfMatch' name (Match funid pats (GRHSs rhss (unLoc -> locBinds))) +trfMatch' :: (TransformName n r, n ~ GhcPass p) => IdP n -> Match n (LHsExpr n) -> Trf (AST.UMatch (Dom r) RangeStage) +trfMatch' name (Match _ funid pats (GRHSs _ rhss (unLoc -> locBinds))) -- TODO: add the optional typ to pats = AST.UMatch <$> trfMatchLhs name funid pats <*> addToScope pats (addToScope locBinds (trfRhss rhss)) <*> addToScope pats (trfWhereLocalBinds (collectLocs rhss) locBinds) -trfMatchLhs :: forall n r . TransformName n r => IdP n -> HsMatchContext (NameOrRdrName (IdP n)) -> [LPat n] -> Trf (Ann AST.UMatchLhs (Dom r) RangeStage) +trfMatchLhs :: forall n r p . (TransformName n r, n ~ GhcPass p) => IdP n -> HsMatchContext (NameOrRdrName (IdP n)) -> [LPat n] -> Trf (Ann AST.UMatchLhs (Dom r) RangeStage) trfMatchLhs name fb pats = do implicitIdLoc <- mkSrcSpan <$> atTheStart <*> atTheStart parenOpLoc <- tokensLoc [AnnOpenP, AnnVal, AnnCloseP] @@ -91,77 +92,77 @@ (left:right:rest, True) -> AST.UInfixLhs left <$> define (trfOperator @n n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest) _ -> AST.UNormalLhs <$> define (trfName @n n) <*> makeList " " (pure closeLoc) (pure args) -trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.URhs (Dom r) RangeStage) +trfRhss :: (TransformName n r, n ~ GhcPass p) => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.URhs (Dom r) RangeStage) -- the original location on the GRHS misleadingly contains the local bindings -trfRhss [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) - (AST.UUnguardedRhs <$> trfExpr body) +trfRhss [unLoc -> GRHS _ [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) + (AST.UUnguardedRhs <$> trfExpr body) trfRhss rhss = annLocNoSema (pure $ collectLocs rhss) (AST.UGuardedRhss . nonemptyAnnList <$> mapM trfGuardedRhs rhss) -trfGuardedRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedRhs (Dom r) RangeStage) -trfGuardedRhs = trfLocNoSema $ \(GRHS guards body) +trfGuardedRhs :: (TransformName n r, n ~ GhcPass p) => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedRhs (Dom r) RangeStage) +trfGuardedRhs = trfLocNoSema $ \(GRHS _ guards body) -> AST.UGuardedRhs . nonemptyAnnList <$> trfScopedSequence trfRhsGuard guards <*> addToScope guards (trfExpr body) -trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage) +trfRhsGuard :: (TransformName n r, n ~ GhcPass p) => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage) trfRhsGuard = trfLocNoSema trfRhsGuard' -trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage) -trfRhsGuard' (BindStmt pat body _ _ _) = AST.UGuardBind <$> trfPattern pat <*> trfExpr body -trfRhsGuard' (BodyStmt body _ _ _) = AST.UGuardCheck <$> trfExpr body -trfRhsGuard' (LetStmt (unLoc -> binds)) = AST.UGuardLet <$> trfLocalBinds AnnLet binds +trfRhsGuard' :: (TransformName n r, n ~ GhcPass p) => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage) +trfRhsGuard' (BindStmt _ pat body _ _) = AST.UGuardBind <$> trfPattern pat <*> trfExpr body +trfRhsGuard' (BodyStmt _ body _ _) = AST.UGuardCheck <$> trfExpr body +trfRhsGuard' (LetStmt _ (unLoc -> binds)) = AST.UGuardLet <$> trfLocalBinds AnnLet binds trfRhsGuard' d = unhandledElement "guard" d -trfWhereLocalBinds :: TransformName n r => SrcSpan -> HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage) -trfWhereLocalBinds _ EmptyLocalBinds = nothing "" "" atTheEnd +trfWhereLocalBinds :: (TransformName n r, n ~ GhcPass p) => SrcSpan -> HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage) +trfWhereLocalBinds _ (EmptyLocalBinds _) = nothing "" "" atTheEnd trfWhereLocalBinds bef binds = makeJust <$> annLocNoSema (combineSrcSpans (srcLocSpan (srcSpanEnd bef) `combineSrcSpans` getBindLocs binds) <$> tokenLocBack AnnWhere) (AST.ULocalBinds <$> addToScope binds (trfLocalBinds AnnWhere binds)) -getBindLocs :: HsLocalBinds n -> SrcSpan -getBindLocs (HsValBinds (ValBindsIn binds sigs)) = foldLocs $ map getLoc (bagToList binds) ++ map getLoc sigs -getBindLocs (HsValBinds (ValBindsOut binds sigs)) = foldLocs $ map getLoc (concatMap (bagToList . snd) binds) ++ map getLoc sigs -getBindLocs (HsIPBinds (IPBinds binds _)) = foldLocs $ map getLoc binds -getBindLocs EmptyLocalBinds = noSrcSpan +getBindLocs :: n ~ GhcPass p => HsLocalBinds n -> SrcSpan +getBindLocs (HsValBinds _ (ValBinds _ binds sigs)) = foldLocs $ map getLoc (bagToList binds) ++ map getLoc sigs +getBindLocs (HsValBinds _ (XValBindsLR (NValBinds binds sigs))) = foldLocs $ map getLoc (concatMap (bagToList . snd) binds) ++ map getLoc sigs +getBindLocs (HsIPBinds _ (IPBinds _ binds)) = foldLocs $ map getLoc binds +getBindLocs (EmptyLocalBinds _) = noSrcSpan -trfLocalBinds :: TransformName n r => AnnKeywordId -> HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) -trfLocalBinds token (HsValBinds (ValBindsIn binds sigs)) +trfLocalBinds :: (TransformName n r, n ~ GhcPass p) => AnnKeywordId -> HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) +trfLocalBinds token (HsValBinds _ (ValBinds _ binds sigs)) = makeIndentedListBefore " " (after token) (orderDefs <$> ((++) <$> mapM (copyAnnot AST.ULocalValBind . trfBind) (bagToList binds) <*> mapM trfLocalSig sigs)) -trfLocalBinds token (HsValBinds (ValBindsOut binds sigs)) +trfLocalBinds token (HsValBinds _ (XValBindsLR (NValBinds binds sigs))) = makeIndentedListBefore " " (after token) (orderDefs <$> ((++) <$> (concat <$> mapM (mapM (copyAnnot AST.ULocalValBind . trfBind) . bagToList . snd) binds) <*> mapM trfLocalSig sigs)) -trfLocalBinds token (HsIPBinds (IPBinds binds _)) +trfLocalBinds token (HsIPBinds _ (IPBinds _ binds)) = makeIndentedListBefore " " (after token) (mapM trfIpBind binds) trfLocalBinds _ b = unhandledElement "local binds" b -trfIpBind :: TransformName n r => Located (IPBind n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) +trfIpBind :: (TransformName n r, n ~ GhcPass p) => Located (IPBind n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) trfIpBind = trfLocNoSema $ \case - IPBind (Left (L l ipname)) expr + IPBind _ (Left (L l ipname)) expr -> AST.ULocalValBind <$> (annContNoSema $ AST.USimpleBind <$> focusOn l (annContNoSema (AST.UVarPat <$> define (trfImplicitName ipname))) <*> annFromNoSema AnnEqual (AST.UUnguardedRhs <$> trfExpr expr) <*> nothing " " "" atTheEnd) - IPBind (Right _) _ -> convertionProblem "trfIpBind: called on typechecked AST" + IPBind _ (Right _) _ -> convertionProblem "trfIpBind: called on typechecked AST" -trfLocalSig :: forall n r . TransformName n r => Located (Sig n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) +trfLocalSig :: forall n r p . (TransformName n r, n ~ GhcPass p) => Located (Sig n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) trfLocalSig = trfLocNoSema $ \case ts@(TypeSig {}) -> AST.ULocalSignature <$> annContNoSema (trfTypeSig' ts) - (FixSig fs) -> AST.ULocalFixity <$> annContNoSema (trfFixitySig fs) - (InlineSig name prag) -> AST.ULocalInline <$> trfInlinePragma @n name prag + (FixSig _ fs) -> AST.ULocalFixity <$> annContNoSema (trfFixitySig fs) + (InlineSig _ name prag) -> AST.ULocalInline <$> trfInlinePragma @n name prag d -> unhandledElement "local signature" d -trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.UTypeSignature (Dom r) RangeStage) +trfTypeSig :: (TransformName n r, n ~ GhcPass p) => Located (Sig n) -> Trf (Ann AST.UTypeSignature (Dom r) RangeStage) trfTypeSig = trfLocNoSema trfTypeSig' -trfTypeSig' :: forall n r . TransformName n r => Sig n -> Trf (AST.UTypeSignature (Dom r) RangeStage) -trfTypeSig' (TypeSig names typ) +trfTypeSig' :: forall n r p . (TransformName n r, n ~ GhcPass p) => Sig n -> Trf (AST.UTypeSignature (Dom r) RangeStage) +trfTypeSig' (TypeSig _ names typ) = defineTypeVars $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM (trfName @n) names) <*> trfType (hsib_body $ hswc_body typ) trfTypeSig' ts = unhandledElement "type signature" ts trfFixitySig :: forall n r . TransformName n r => FixitySig n -> Trf (AST.UFixitySignature (Dom r) RangeStage) -trfFixitySig (FixitySig names (Fixity _ prec dir)) +trfFixitySig (FixitySig _ names (Fixity _ prec dir)) = do precLoc <- tokenLoc AnnVal -- the precedence token or one of the names AST.UFixitySignature <$> transformDir dir <*> (if isGoodSrcSpan precLoc && all (srcSpanEnd precLoc <) (map (srcSpanStart . getLoc) names)
Language/Haskell/Tools/BackendGHC/Binds.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Tools.BackendGHC.Binds where import ApiAnnotation (AnnKeywordId) @@ -8,8 +9,9 @@ import Language.Haskell.Tools.BackendGHC.Monad (Trf) import Language.Haskell.Tools.BackendGHC.Names (TransformName(..)) import SrcLoc as GHC (Located, SrcSpan) +import HsExtension (GhcPass) -trfLocalBinds :: TransformName n r => AnnKeywordId -> HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) -trfWhereLocalBinds :: TransformName n r => SrcSpan -> HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage) -trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage) -trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage) +trfLocalBinds :: (TransformName n r, n ~ GhcPass p)=> AnnKeywordId -> HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) +trfWhereLocalBinds :: (TransformName n r, n ~ GhcPass p) => SrcSpan -> HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage) +trfRhsGuard :: (TransformName n r, n ~ GhcPass p) => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage) +trfRhsGuard' :: (TransformName n r, n ~ GhcPass p) => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/Decls.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the declarations of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Decls where @@ -20,12 +21,14 @@ import RdrName as GHC (RdrName, rdrNameOcc) import SrcLoc as GHC import TyCon as GHC (Role(..)) +import HsExtension (GhcPass, NoExt(..)) import Control.Monad.Reader import Control.Reference import Data.Generics.Uniplate.Data () import Data.List import Data.Maybe (Maybe(..), fromMaybe) +import GHC.Stack (HasCallStack) import Language.Haskell.Tools.BackendGHC.Binds import Language.Haskell.Tools.BackendGHC.Exprs (trfExpr) @@ -42,29 +45,28 @@ import qualified Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo, mkNoSemanticInfo, trfImportInfo) -trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) +trfDecls :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) trfDecls decls = addToCurrentScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls) -trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) -trfDeclsGroup g@(HsGroup vals splices tycls derivs fixities defaults foreigns warns anns rules vects _) +trfDeclsGroup :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) +trfDeclsGroup g@(HsGroup _ vals splices tycls derivs fixities defaults foreigns warns anns rules _) = do rdrSpls <- asks declSplices -- now we don't want to rename the splices, just interested in their locations to -- filter out the declarations that are generated from them let (sigs, bagToList -> binds) = getBindsAndSigs vals -- collect the declarations from the group alldecls :: [Located (HsDecl n)] - alldecls = (map (fmap SpliceD) splices) - ++ (map (fmap ValD) binds) - ++ (map (fmap SigD) sigs) - ++ (map (fmap TyClD) (concat $ map group_tyclds tycls)) - ++ (map (fmap DerivD) derivs) - ++ (map (fmap (SigD . FixSig)) (mergeFixityDefs fixities)) - ++ (map (fmap DefD) defaults) - ++ (map (fmap ForD) foreigns) - ++ (map (fmap WarningD) warns) - ++ (map (fmap AnnD) anns) - ++ (map (fmap RuleD) rules) - ++ (map (fmap VectD) vects) - ++ (map (fmap InstD) (hsGroupInstDecls g)) + alldecls = (map (fmap (SpliceD NoExt)) splices) + ++ (map (fmap (ValD NoExt)) binds) + ++ (map (fmap (SigD NoExt)) sigs) + ++ (map (fmap (TyClD NoExt)) (concat $ map group_tyclds tycls)) + ++ (map (fmap (DerivD NoExt)) derivs) + ++ (map (fmap (SigD NoExt . FixSig NoExt)) (mergeFixityDefs fixities)) + ++ (map (fmap (DefD NoExt)) defaults) + ++ (map (fmap (ForD NoExt)) foreigns) + ++ (map (fmap (WarningD NoExt)) warns) + ++ (map (fmap (AnnD NoExt)) anns) + ++ (map (fmap (RuleD NoExt)) rules) + ++ (map (fmap (InstD NoExt)) (hsGroupInstDecls g)) -- Declarations generated from TH should only be in scope after the splice. let (genNames, sourceNames) = partition (\d -> any (\spl -> getLoc spl `containsRealSpan` getLoc d) rdrSpls) alldecls addToCurrentScope sourceNames $ do @@ -77,7 +79,7 @@ where -- use the definitions generated by previous splices when transforming a definition trfDeclsWithScope genNames d = local (\s -> s {declSplices = []}) - $ addToCurrentScope namesGeneratedBefore (trfDecl d) + $ addToCurrentScope namesGeneratedBefore (trfDecl @n @r @p d) where namesGeneratedBefore = filter ((srcSpanStart (getLoc d) >) . srcSpanEnd . getLoc) genNames replaceSpliceDecls :: [Located (HsSplice n)] -> [Located (HsDecl n)] -> [Located (HsDecl n)] @@ -97,7 +99,7 @@ mergeSplice :: [Located (HsDecl n)] -> Located (HsSplice n) -> [Located (HsDecl n)] mergeSplice decls spl@(L spLoc@(RealSrcSpan rss) _) - = L spLoc (SpliceD (SpliceDecl spl ExplicitSplice)) : filter (\(L (RealSrcSpan rdsp) _) -> not (rss `containsSpan` rdsp)) decls + = L spLoc (SpliceD NoExt (SpliceDecl NoExt spl ExplicitSplice)) : filter (\(L (RealSrcSpan rdsp) _) -> not (rss `containsSpan` rdsp)) decls mergeSplice _ (L (UnhelpfulSpan {}) _) = convProblem "mergeSplice: no real span" getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage] @@ -114,32 +116,32 @@ ++ ", locals: " ++ (concat $ intersperse ", " $ map (showSDocUnsafe . ppr) locals)) $ find ((occNameString (rdrNameOcc rdr) ==) . occNameString . nameOccName) locals -trfDecl :: forall n r . TransformName n r => Located (HsDecl n) -> Trf (Ann AST.UDecl (Dom r) RangeStage) +trfDecl :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsDecl n) -> Trf (Ann AST.UDecl (Dom r) RangeStage) trfDecl = trfLocNoSema $ \case - TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars _ kindSig inj)) + TyClD _ (FamDecl _ (FamilyDecl _ (ClosedTypeFamily typeEqs) name tyVars _ kindSig inj)) -> AST.UClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars) <*> trfFamilyResultSig kindSig inj <*> trfTypeEqs typeEqs - TyClD (FamDecl fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd) - TyClD (SynDecl name vars _ rhs _) + TyClD _ (FamDecl _ fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd) + TyClD _ (SynDecl _ name vars _ rhs) -> AST.UTypeDecl <$> between AnnType AnnEqual (createDeclHead name vars) <*> trfType rhs - TyClD (DataDecl name vars _ (HsDataDefn nd ctx _ kind cons derivs) _ _) + TyClD _ (DataDecl _ name vars _ (HsDataDefn _ nd ctx _ kind cons derivs)) -> do let ctxTok = case nd of DataType -> AnnData NewType -> AnnNewtype consLoc = focusBeforeIfPresent AnnDeriving atTheEnd whereLoc <- tokenLoc AnnWhere if isGoodSrcSpan whereLoc then trfGADT nd name vars ctx kind cons derivs ctxTok consLoc else trfDataDef nd name vars ctx cons derivs ctxTok consLoc - TyClD (ClassDecl ctx name vars _ funDeps sigs defs typeFuns typeFunDefs _ _) + TyClD _ (ClassDecl _ ctx name vars _ funDeps sigs defs typeFuns typeFunDefs _) -> AST.UClassDecl <$> trfCtx (after AnnClass) ctx <*> betweenIfPresent AnnClass AnnWhere (createDeclHead name vars) <*> trfFunDeps @n funDeps <*> createClassBody sigs defs typeFuns typeFunDefs - InstD (ClsInstD (ClsInstDecl typ binds sigs typefam datafam overlap)) + InstD _ (ClsInstD _ (ClsInstDecl _ typ binds sigs typefam datafam overlap)) -> AST.UInstDecl <$> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body typ) <*> trfInstBody binds sigs typefam datafam - InstD (DataFamInstD (DataFamInstDecl (hsib_body -> FamEqn con pats _ (HsDataDefn nd _ _ _ cons derivs)))) + InstD _ (DataFamInstD _ (DataFamInstDecl (hsib_body -> FamEqn _ con pats _ (HsDataDefn _ nd _ _ _ cons derivs)))) | all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons -> AST.UDataInstDecl <$> trfDataKeyword nd <*> (focusAfter AnnInstance . focusBeforeIfPresent AnnEqual . focusBeforeIfPresent AnnDeriving) @@ -147,39 +149,39 @@ -- the location is needed when there is no = sign <*> makeListBefore " = " " | " (pure $ srcSpanStart $ foldLocs $ getLoc con : map getLoc pats) (mapM trfConDecl cons) <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) - InstD (DataFamInstD (DataFamInstDecl (hsib_body -> FamEqn con pats _ (HsDataDefn nd _ _ kind cons _)))) + InstD _ (DataFamInstD _ (DataFamInstDecl (hsib_body -> FamEqn _ con pats _ (HsDataDefn _ nd _ _ kind cons _)))) -> AST.UGDataInstDecl <$> trfDataKeyword nd <*> (focusAfter AnnInstance . focusBeforeIfPresent AnnWhere) (makeInstanceRuleTyVars con pats) <*> focusBefore AnnWhere (trfKindSig kind) <*> makeIndentedListBefore " where " atTheEnd (mapM trfGADTConDecl cons) - InstD (TyFamInstD (TyFamInstDecl (hsib_body -> FamEqn con pats _ rhs))) + InstD _ (TyFamInstD _ (TyFamInstDecl (hsib_body -> FamEqn _ con pats _ rhs))) -> AST.UTypeInstDecl <$> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats) <*> trfType rhs - ValD bind -> trfVal bind - SigD sig -> trfSig sig - DerivD (DerivDecl t strat overlap) -> AST.UDerivDecl <$> trfDerivingStrategy strat <*> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body t) - RuleD (HsRules _ rules) -> AST.UPragmaDecl <$> annContNoSema (AST.URulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules)) - RoleAnnotD (RoleAnnotDecl name roles) -> AST.URoleDecl <$> trfQualifiedName @n False name <*> makeList " " atTheEnd (mapM trfRole roles) - DefD (DefaultDecl types) -> AST.UDefaultDecl <$> makeList "," (after AnnOpenP) (mapM trfType types) - ForD (ForeignImport name (hsib_body -> typ) _ (CImport ccall safe _ _ _)) - -> AST.UForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName @n name) <*> trfType typ - ForD (ForeignExport name (hsib_body -> typ) _ (CExport (L l (CExportStatic _ _ ccall)) _)) - -> AST.UForeignExport <$> annLocNoSema (pure l) (trfCallConv' ccall) <*> trfName @n name <*> trfType typ - SpliceD (SpliceDecl (unLoc -> spl) _) -> AST.USpliceDecl <$> trfSplice spl - WarningD (Warnings _ []) + ValD _ bind -> trfVal bind + SigD _ sig -> trfSig sig + DerivD _ (DerivDecl _ t strat overlap) -> AST.UDerivDecl <$> trfDerivingStrategy strat <*> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body $ hswc_body t) + RuleD _ (HsRules _ _ rules) -> AST.UPragmaDecl <$> annContNoSema (AST.URulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules)) + RoleAnnotD _ (RoleAnnotDecl _ name roles) -> AST.URoleDecl <$> trfQualifiedName @n False name <*> makeList " " atTheEnd (mapM trfRole roles) + DefD _ (DefaultDecl _ types) -> AST.UDefaultDecl <$> makeList "," (after AnnOpenP) (mapM trfType types) + ForD _ (ForeignImport _ name typ (CImport ccall safe _ _ _)) + -> AST.UForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName @n name) <*> trfType (hsib_body typ) + ForD _ (ForeignExport _ name typ (CExport (L l (CExportStatic _ _ ccall)) _)) + -> AST.UForeignExport <$> annLocNoSema (pure l) (trfCallConv' ccall) <*> trfName @n name <*> trfType (hsib_body typ) + SpliceD _ (SpliceDecl _ (unLoc -> spl) _) -> AST.USpliceDecl <$> trfSplice spl + WarningD _ (Warnings _ _ []) -> AST.UPragmaDecl <$> annContNoSema (AST.UDeprPragma <$> (makeList " " (after AnnOpen) (pure [])) <*> makeList ", " (before AnnClose) (pure [])) - WarningD (Warnings _ [L _ (Warning names (DeprecatedTxt _ stringLits))]) + WarningD _ (Warnings _ _ [L _ (Warning _ names (DeprecatedTxt _ stringLits))]) -> AST.UPragmaDecl <$> annContNoSema (AST.UDeprPragma <$> (makeList " " (after AnnOpen) $ mapM (trfName @n) names) <*> makeList ", " (before AnnClose) (mapM (\(L l (StringLiteral _ fs)) -> trfFastString (L l fs)) stringLits)) - WarningD (Warnings _ [L _ (Warning names (WarningTxt _ stringLits))]) + WarningD _ (Warnings _ _ [L _ (Warning _ names (WarningTxt _ stringLits))]) -> AST.UPragmaDecl <$> annContNoSema (AST.UWarningPragma <$> (makeNonemptyList " " $ mapM (trfName @n) names) <*> makeList ", " (before AnnClose) (mapM (\(L l (StringLiteral _ fs)) -> trfFastString (L l fs)) stringLits)) - AnnD (HsAnnotation stxt subject expr) + AnnD _ (HsAnnotation _ stxt subject expr) -> AST.UPragmaDecl <$> annContNoSema (AST.UAnnPragma <$> trfAnnotationSubject @n stxt subject (srcSpanStart $ getLoc expr) <*> trfExpr expr) d -> unhandledElement "declaration" d -trfGADT :: TransformName n r => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n) +trfGADT :: (TransformName n r, n ~ GhcPass p, HasCallStack) => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n) -> Maybe (Located (HsKind n)) -> [Located (ConDecl n)] -> Located [LHsDerivingClause n] -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage) trfGADT nd name vars ctx kind cons derivs ctxTok consLoc @@ -190,7 +192,7 @@ <*> makeIndentedListBefore " where " consLoc (mapM trfGADTConDecl cons) <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) -trfDataDef :: TransformName n r => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n) +trfDataDef :: (TransformName n r, n ~ GhcPass p, HasCallStack) => NewOrData -> Located (IdP n) -> LHsQTyVars n -> Located (HsContext n) -> [Located (ConDecl n)] -> Located [LHsDerivingClause n] -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage) trfDataDef nd name vars ctx cons derivs ctxTok consLoc @@ -200,117 +202,106 @@ <*> makeListBefore "=" " | " consLoc (mapM trfConDecl cons) <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) -trfVal :: TransformName n r => HsBindLR n n -> Trf (AST.UDecl (Dom r) RangeStage) -trfVal (PatSynBind psb) = AST.UPatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb) +trfVal :: (TransformName n r, n ~ GhcPass p, HasCallStack) => HsBindLR n n -> Trf (AST.UDecl (Dom r) RangeStage) +trfVal (PatSynBind _ psb) = AST.UPatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb) trfVal bind = AST.UValueBinding <$> (annContNoSema $ trfBind' bind) -trfSig :: forall n r . TransformName n r => Sig n -> Trf (AST.UDecl (Dom r) RangeStage) +trfSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Sig n -> Trf (AST.UDecl (Dom r) RangeStage) trfSig (ts@TypeSig {}) = AST.UTypeSigDecl <$> defineTypeVars (annContNoSema $ trfTypeSig' ts) -trfSig (FixSig fs) = AST.UFixityDecl <$> (annContNoSema $ trfFixitySig fs) -trfSig (PatSynSig ids typ) +trfSig (FixSig _ fs) = AST.UFixityDecl <$> (annContNoSema $ trfFixitySig fs) +trfSig (PatSynSig _ ids typ) = AST.UPatTypeSigDecl <$> annContNoSema (AST.UPatternTypeSignature <$> trfAnnList ", " (trfName' @n) ids <*> trfType (hsib_body typ)) -trfSig (InlineSig name prag) +trfSig (InlineSig _ name prag) = AST.UPragmaDecl <$> annContNoSema (AST.UInlinePragmaDecl <$> trfInlinePragma @n name prag) -trfSig (SpecSig name (map hsib_body -> types) (inl_act -> phase)) +trfSig (SpecSig _ name (map hsib_body -> types) (inl_act -> phase)) = AST.UPragmaDecl <$> annContNoSema (AST.USpecializeDecl <$> trfSpecializePragma name types phase) -trfSig (CompleteMatchSig _ names typeConstraint) +trfSig (CompleteMatchSig _ _ names typeConstraint) = AST.UPragmaDecl <$> annContNoSema (AST.UCompletePragma <$> trfAnnList ", " (trfName' @n) (unLoc names) <*> trfMaybe " :: " "" (trfName @n) typeConstraint) trfSig s = unhandledElement "signature" s -trfSpecializePragma :: forall n r . TransformName n r +trfSpecializePragma :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (IdP n) -> [Located (HsType n)] -> Activation -> Trf (Ann AST.USpecializePragma (Dom r) RangeStage) trfSpecializePragma name types phase = annContNoSema $ AST.USpecializePragma <$> trfPhase (pure $ srcSpanStart (getLoc name)) phase <*> trfName @n name <*> (orderAnnList <$> trfAnnList ", " trfType' types) -trfConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UConDecl (Dom r) RangeStage) +trfConDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDecl n) -> Trf (Ann AST.UConDecl (Dom r) RangeStage) trfConDecl = trfLocNoSema trfConDecl' -trfConDecl' :: forall n r . TransformName n r => ConDecl n -> Trf (AST.UConDecl (Dom r) RangeStage) -trfConDecl' (ConDeclH98 { con_name = name, con_qvars = tyVars, con_cxt = ctx, con_details = PrefixCon args }) - = AST.UConDecl <$> trfConTyVars tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> makeList " " atTheEnd (mapM trfType args) -trfConDecl' (ConDeclH98 { con_name = name, con_qvars = tyVars, con_cxt = ctx, con_details = RecCon (unLoc -> flds) }) - = AST.URecordDecl <$> trfConTyVars tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds) -trfConDecl' (ConDeclH98 { con_name = name, con_qvars = tyVars, con_cxt = ctx, con_details = InfixCon t1 t2 }) - = AST.UInfixConDecl <$> trfConTyVars tyVars <*> trfConCtx ctx <*> trfType t1 <*> define (trfOperator @n name) <*> trfType t2 +trfConDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDecl n -> Trf (AST.UConDecl (Dom r) RangeStage) +trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = PrefixCon args }) + = AST.UConDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> makeList " " atTheEnd (mapM trfType args) +trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = RecCon (unLoc -> flds) }) + = AST.URecordDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> define (trfName @n name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds) +trfConDecl' (ConDeclH98 { con_name = name, con_ex_tvs = tyVars, con_mb_cxt = ctx, con_args = InfixCon t1 t2 }) + = AST.UInfixConDecl <$> trfBindings tyVars <*> trfConCtx ctx <*> trfType t1 <*> define (trfOperator @n name) <*> trfType t2 trfConDecl' gadt@(ConDeclGADT {}) = unhandledElement "normal constructor declaration" gadt -trfConTyVars :: TransformName n r => Maybe (LHsQTyVars n) -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage) -trfConTyVars Nothing = makeListAfter "." " " atTheStart (return []) -trfConTyVars (Just vars) = trfBindings $ hsq_explicit vars - -trfConCtx :: TransformName n r => Maybe (LHsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage) +trfConCtx :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Maybe (LHsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage) trfConCtx Nothing = nothing "" " => " atTheStart trfConCtx (Just ctx) = trfCtx atTheStart ctx -trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage) +trfGADTConDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage) trfGADTConDecl = trfLocNoSema trfGADTConDecl' -trfGADTConDecl' :: forall n r . TransformName n r => ConDecl n -> Trf (AST.UGadtConDecl (Dom r) RangeStage) -trfGADTConDecl' (ConDeclGADT { con_names = names, con_type = hsib_body -> typ }) - = let nameLoc = collectLocs names - typLoc = getLoc typ - (vars, ctx, t) = getTypeVarsAndCtx typ - in AST.UGadtConDecl <$> define (trfAnnList ", " (trfName' @n) names) - <*> focusOn (mkSrcSpan (srcSpanEnd nameLoc) (srcSpanStart typLoc)) (trfBindings vars) - <*> updateFocus (return . updateEnd (\_ -> srcSpanStart typLoc)) (focusAfterIfPresent AnnDot (trfCtx atTheStart ctx)) - <*> trfGadtConType t - where getTypeVarsAndCtx :: LHsType n -> ([LHsTyVarBndr n], LHsContext n, LHsType n) - getTypeVarsAndCtx (L _ (HsForAllTy [] typ)) = getTypeVarsAndCtx typ - getTypeVarsAndCtx (L _ (HsForAllTy bndrs typ)) = let (_,ctx,t) = getTypeVarsAndCtx typ in (bndrs, ctx, t) - getTypeVarsAndCtx (L _ (HsQualTy ctx typ)) = let (vars,_,t) = getTypeVarsAndCtx typ in (vars, ctx, t) - getTypeVarsAndCtx t = ([], L noSrcSpan [], t) +trfGADTConDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDecl n -> Trf (AST.UGadtConDecl (Dom r) RangeStage) +trfGADTConDecl' (ConDeclGADT { con_names = names, con_res_ty = t, con_mb_cxt = ctx, con_qvars = vars }) + = AST.UGadtConDecl <$> define (trfAnnList ", " (trfName' @n) names) + <*> focusOn (mkSrcSpan (srcSpanEnd nameLoc) (srcSpanStart (getLoc t))) (trfBindings (hsq_explicit vars)) + <*> updateFocus (return . updateEnd (\_ -> srcSpanStart (getLoc t))) (focusAfterIfPresent AnnDot (trfCtx atTheStart (fromMaybe (L noSrcSpan []) ctx))) + <*> trfGadtConType t + where nameLoc = last (map getLoc names ++ map getLoc (hsq_explicit vars)) -trfGadtConType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UGadtConType (Dom r) RangeStage) +trfGadtConType :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UGadtConType (Dom r) RangeStage) trfGadtConType = trfLocNoSema $ \case - HsFunTy (cleanHsType . unLoc -> HsRecTy flds) resType + HsFunTy _ (unLoc -> HsRecTy _ flds) resType -> AST.UGadtRecordType <$> between AnnOpenC AnnCloseC (trfAnnList ", " trfFieldDecl' flds) <*> trfType resType typ -> AST.UGadtNormalType <$> annContNoSema (trfType' typ) -trfFieldDecl :: TransformName n r => Located (ConDeclField n) -> Trf (Ann AST.UFieldDecl (Dom r) RangeStage) +trfFieldDecl :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (ConDeclField n) -> Trf (Ann AST.UFieldDecl (Dom r) RangeStage) trfFieldDecl = trfLocNoSema trfFieldDecl' -trfFieldDecl' :: forall n r . TransformName n r => ConDeclField n -> Trf (AST.UFieldDecl (Dom r) RangeStage) -trfFieldDecl' (ConDeclField names typ _) = AST.UFieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName @n . getFieldOccName) names) <*> trfType typ +trfFieldDecl' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => ConDeclField n -> Trf (AST.UFieldDecl (Dom r) RangeStage) +trfFieldDecl' (ConDeclField _ names typ _) = AST.UFieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName @n . getFieldOccName) names) <*> trfType typ -trfDerivings :: TransformName n r => Located (HsDerivingClause n) -> Trf (Ann AST.UDeriving (Dom r) RangeStage) +trfDerivings :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsDerivingClause n) -> Trf (Ann AST.UDeriving (Dom r) RangeStage) trfDerivings = trfLocNoSema $ \case - HsDerivingClause strat (unLoc->[hsib_body -> typ@(unLoc -> HsTyVar {})]) + HsDerivingClause _ strat (unLoc->[hsib_body -> typ@(unLoc -> HsTyVar {})]) -> AST.UDerivingOne <$> trfDerivingStrategy strat <*> trfInstanceHead typ - HsDerivingClause strat derivs + HsDerivingClause _ strat derivs -> AST.UDerivings <$> trfDerivingStrategy strat <*> focusOn (getLoc derivs) (trfAnnList ", " trfInstanceHead' (map hsib_body (unLoc derivs))) -trfDerivingStrategy :: Maybe (Located DerivStrategy) -> Trf (AnnMaybeG AST.UDeriveStrategy (Dom r) RangeStage) +trfDerivingStrategy :: (TransformName n r, HasCallStack) => Maybe (Located (DerivStrategy n)) -> Trf (AnnMaybeG AST.UDeriveStrategy (Dom r) RangeStage) trfDerivingStrategy = trfMaybeDefault " " "" (trfLocNoSema $ \case StockStrategy -> return AST.UStockStrategy AnyclassStrategy -> return AST.UAnyClassStrategy NewtypeStrategy -> return AST.UNewtypeStrategy) atTheStart -trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) -trfInstanceRule = trfLocNoSema (trfInstanceRule' . cleanHsType) +trfInstanceRule :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) +trfInstanceRule = trfLocNoSema trfInstanceRule' -trfInstanceRule' :: forall n r . TransformName n r => HsType n -> Trf (AST.UInstanceRule (Dom r) RangeStage) -trfInstanceRule' (HsForAllTy bndrs (unLoc -> HsQualTy ctx typ)) +trfInstanceRule' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UInstanceRule (Dom r) RangeStage) +trfInstanceRule' (HsForAllTy _ bndrs (unLoc -> HsQualTy _ ctx typ)) = AST.UInstanceRule <$> (makeJust <$> annLocNoSema (pure $ collectLocs bndrs) (trfBindings bndrs)) <*> trfCtx (after AnnDot) ctx <*> trfInstanceHead typ -trfInstanceRule' (HsQualTy ctx typ) = AST.UInstanceRule <$> nothing "" " . " atTheStart +trfInstanceRule' (HsQualTy _ ctx typ) = AST.UInstanceRule <$> nothing "" " . " atTheStart <*> trfCtx atTheStart ctx <*> trfInstanceHead typ -trfInstanceRule' (HsParTy typ) = instanceHead $ annContNoSema (AST.UInstanceHeadParen <$> trfInstanceHead typ) -trfInstanceRule' (HsTyVar _ tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName @n tv) -trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2) -trfInstanceRule' (HsOpTy t1 op t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> annLocNoSema (pure $ getLoc t1 `combineSrcSpans` getLoc op) (AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator @n op) <*> trfType t2) +trfInstanceRule' (HsParTy _ typ) = instanceHead $ annContNoSema (AST.UInstanceHeadParen <$> trfInstanceHead typ) +trfInstanceRule' (HsTyVar _ _ tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName @n tv) +trfInstanceRule' (HsAppTy _ t1 t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2) +trfInstanceRule' (HsOpTy _ t1 op t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> annLocNoSema (pure $ getLoc t1 `combineSrcSpans` getLoc op) (AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator @n op) <*> trfType t2) trfInstanceRule' t = unhandledElement "instance rule" t -instanceHead :: Trf (Ann AST.UInstanceHead (Dom r) RangeStage) -> Trf (AST.UInstanceRule (Dom r) RangeStage) +instanceHead :: HasCallStack => Trf (Ann AST.UInstanceHead (Dom r) RangeStage) -> Trf (AST.UInstanceRule (Dom r) RangeStage) instanceHead hd = AST.UInstanceRule <$> (nothing "" " . " atTheStart) <*> (nothing " " "" atTheStart) <*> hd -makeInstanceRuleTyVars :: forall n r . TransformName n r => Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) +makeInstanceRuleTyVars :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) makeInstanceRuleTyVars n vars | isSymOcc (occName @n (unLoc n)) , leftOp:rest <- vars @@ -329,29 +320,29 @@ where foldTypeArgs base typ = annLocNoSema (pure $ combineSrcSpans (getLoc n) (getLoc typ)) $ AST.UInstanceHeadApp <$> base <*> (trfType typ) -trfInstanceHead :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceHead (Dom r) RangeStage) +trfInstanceHead :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UInstanceHead (Dom r) RangeStage) trfInstanceHead = trfLocNoSema trfInstanceHead' -trfInstanceHead' :: forall n r . TransformName n r => HsType n -> Trf (AST.UInstanceHead (Dom r) RangeStage) -trfInstanceHead' = trfInstanceHead'' . cleanHsType where - trfInstanceHead'' (HsForAllTy [] (unLoc -> t)) = trfInstanceHead' t - trfInstanceHead'' (HsTyVar _ tv) = AST.UInstanceHeadCon <$> trfName @n tv - trfInstanceHead'' (HsAppTy t1 t2) = AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2 - trfInstanceHead'' (HsParTy typ) = AST.UInstanceHeadParen <$> trfInstanceHead typ - trfInstanceHead'' (HsOpTy t1 op t2) +trfInstanceHead' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UInstanceHead (Dom r) RangeStage) +trfInstanceHead' = trfInstanceHead'' where + trfInstanceHead'' (HsForAllTy _ [] (unLoc -> t)) = trfInstanceHead' t + trfInstanceHead'' (HsTyVar _ _ tv) = AST.UInstanceHeadCon <$> trfName @n tv + trfInstanceHead'' (HsAppTy _ t1 t2) = AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2 + trfInstanceHead'' (HsParTy _ typ) = AST.UInstanceHeadParen <$> trfInstanceHead typ + trfInstanceHead'' (HsOpTy _ t1 op t2) = AST.UInstanceHeadApp <$> (annLocNoSema (pure $ combineSrcSpans (getLoc t1) (getLoc op)) (AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator @n op)) <*> trfType t2 trfInstanceHead'' t = unhandledElement "instance head" t -trfTypeEqs :: TransformName n r => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnListG AST.UTypeEqn (Dom r) RangeStage) +trfTypeEqs :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnListG AST.UTypeEqn (Dom r) RangeStage) trfTypeEqs eqs = do toks <- tokensAfter AnnWhere case toks of [] -> convertionProblem "trfTypeEqs: no where found after closed type family" loc:_ -> makeList "\n" (pure $ srcSpanStart loc) (mapM (trfTypeEq . fmap hsib_body) (fromMaybe [] eqs)) -trfTypeEq :: forall n r . TransformName n r => Located (FamEqn n (HsTyPats n) (LHsType n)) -> Trf (Ann AST.UTypeEqn (Dom r) RangeStage) -trfTypeEq = trfLocNoSema $ \(FamEqn name pats _ rhs) +trfTypeEq :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamEqn n (HsTyPats n) (LHsType n)) -> Trf (Ann AST.UTypeEqn (Dom r) RangeStage) +trfTypeEq = trfLocNoSema $ \(FamEqn _ name pats _ rhs) -> AST.UTypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name pats)) <*> trfType rhs where combineTypes :: Located (IdP n) -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage) combineTypes name [lhs, rhs] | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) @@ -364,17 +355,17 @@ annLocNoSema (pure $ combineSrcSpans (getRange typ) (getLoc p)) (AST.UTyApp <$> pure typ <*> trfType p)) base pats -trfFunDeps :: forall n r . TransformName n r +trfFunDeps :: forall n r . (TransformName n r, HasCallStack) => [Located (FunDep (Located (IdP n)))] -> Trf (AnnMaybeG AST.UFunDeps (Dom r) RangeStage) trfFunDeps [] = do whereToken <- tokenLoc AnnWhere nothing "| " "" (if isGoodSrcSpan whereToken then pure $ srcSpanStart whereToken else atTheEnd) trfFunDeps fundeps = makeJust <$> annLocNoSema (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar) (AST.UFunDeps <$> trfAnnList ", " (trfFunDep' @n) fundeps) -trfFunDep' :: forall n r . TransformName n r => FunDep (Located (IdP n)) -> Trf (AST.UFunDep (Dom r) RangeStage) +trfFunDep' :: forall n r . (TransformName n r, HasCallStack) => FunDep (Located (IdP n)) -> Trf (AST.UFunDep (Dom r) RangeStage) trfFunDep' (lhs, rhs) = AST.UFunDep <$> trfAnnList ", " (trfName' @n) lhs <*> trfAnnList ", " (trfName' @n) rhs -createDeclHead :: forall n r . TransformName n r => Located (IdP n) -> LHsQTyVars n -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) +createDeclHead :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (IdP n) -> LHsQTyVars n -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) createDeclHead name (hsq_explicit -> lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) -- infix declaration @@ -383,7 +374,7 @@ (AST.UDHInfix <$> defineTypeVars (trfTyVar lhs) <*> define (trfOperator @n name) <*> defineTypeVars (trfTyVar rhs)) createDeclHead name vars = defineTypeVars $ wrapDeclHead (hsq_explicit vars) (define $ copyAnnot AST.UDeclHead (trfName @n name)) -wrapDeclHead :: TransformName n r => [LHsTyVarBndr n] -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) +wrapDeclHead :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LHsTyVarBndr n] -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) wrapDeclHead vars base = foldl (\t p -> do typ <- t annLocNoSema (addParenLocs $ combineSrcSpans (getRange typ) (getLoc p)) @@ -398,7 +389,7 @@ (combineSrcSpans <$> (combineSrcSpans sp <$> tokenLoc AnnOpenP) <*> tokenLocBack AnnCloseP) -createClassBody :: TransformName n r => [LSig n] -> LHsBinds n -> [LFamilyDecl n] +createClassBody :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [LSig n] -> LHsBinds n -> [LFamilyDecl n] -> [LTyFamDefltEqn n] -> Trf (AnnMaybeG AST.UClassBody (Dom r) RangeStage) createClassBody sigs binds typeFams typeFamDefs = do isThereWhere <- isGoodSrcSpan <$> (tokenLoc AnnWhere) @@ -415,35 +406,35 @@ getFams = mapM (copyAnnot AST.UClsTypeFam . trfTypeFam) typeFams getFamDefs = mapM trfTypeFamDef typeFamDefs -trfClassElemSig :: forall n r . TransformName n r => Located (Sig n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) +trfClassElemSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (Sig n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) trfClassElemSig = trfLocNoSema $ \case - TypeSig names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) - <*> trfType (hsib_body $ hswc_body typ)) - ClassOpSig True [name] typ -> AST.UClsDefSig <$> trfName @n name <*> trfType (hsib_body typ) - ClassOpSig False names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) - <*> trfType (hsib_body typ)) - MinimalSig _ formula -> AST.UClsMinimal <$> trfMinimalFormula @n formula - InlineSig name prag -> AST.UClsInline <$> trfInlinePragma @n name prag - FixSig fixity -> AST.UClsFixity <$> annContNoSema (trfFixitySig fixity) + TypeSig _ names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) + <*> trfType (hsib_body $ hswc_body typ)) + ClassOpSig _ True [name] typ -> AST.UClsDefSig <$> trfName @n name <*> trfType (hsib_body typ) + ClassOpSig _ False names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) + <*> trfType (hsib_body typ)) + MinimalSig _ _ formula -> AST.UClsMinimal <$> trfMinimalFormula @n formula + InlineSig _ name prag -> AST.UClsInline <$> trfInlinePragma @n name prag + FixSig _ fixity -> AST.UClsFixity <$> annContNoSema (trfFixitySig fixity) s -> unhandledElement "signature in class" s -trfTypeFam :: TransformName n r => Located (FamilyDecl n) -> Trf (Ann AST.UTypeFamily (Dom r) RangeStage) +trfTypeFam :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyDecl n) -> Trf (Ann AST.UTypeFamily (Dom r) RangeStage) trfTypeFam = trfLocNoSema trfTypeFam' -trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.UTypeFamily (Dom r) RangeStage) -trfTypeFam' (FamilyDecl DataFamily name tyVars _ kindSig _) - = AST.UDataFamily <$> (case unLoc kindSig of KindSig _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars) +trfTypeFam' :: (TransformName n r, n ~ GhcPass p, HasCallStack) => FamilyDecl n -> Trf (AST.UTypeFamily (Dom r) RangeStage) +trfTypeFam' (FamilyDecl _ DataFamily name tyVars _ kindSig _) + = AST.UDataFamily <$> (case unLoc kindSig of KindSig _ _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars) <*> trfFamilyKind kindSig -trfTypeFam' (FamilyDecl OpenTypeFamily name tyVars _ kindSig injectivity) - = AST.UTypeFamily <$> (case unLoc kindSig of KindSig _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars) +trfTypeFam' (FamilyDecl _ OpenTypeFamily name tyVars _ kindSig injectivity) + = AST.UTypeFamily <$> (case unLoc kindSig of KindSig _ _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars) <*> trfFamilyResultSig kindSig injectivity -trfTypeFam' (FamilyDecl (ClosedTypeFamily {}) _ _ _ _ _) = convertionProblem "trfTypeFam': closed type family received" +trfTypeFam' (FamilyDecl _ (ClosedTypeFamily {}) _ _ _ _ _) = convertionProblem "trfTypeFam': closed type family received" -trfTypeFamDef :: TransformName n r => Located (TyFamDefltEqn n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) -trfTypeFamDef = trfLocNoSema $ \(FamEqn con pats _ rhs) +trfTypeFamDef :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (TyFamDefltEqn n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) +trfTypeFamDef = trfLocNoSema $ \(FamEqn _ con pats _ rhs) -> AST.UClsTypeDef <$> between AnnType AnnEqual (createDeclHead con pats) <*> trfType rhs -trfInstBody :: TransformName n r => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybeG AST.UInstBody (Dom r) RangeStage) +trfInstBody :: (TransformName n r, n ~ GhcPass p, HasCallStack) => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybeG AST.UInstBody (Dom r) RangeStage) trfInstBody binds sigs fams dats = do wh <- tokenLoc AnnWhere if isGoodSrcSpan wh then @@ -459,23 +450,23 @@ getFams = mapM trfInstTypeFam fams getDats = mapM trfInstDataFam dats -trfClassInstSig :: forall n r . TransformName n r => Located (Sig n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) +trfClassInstSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (Sig n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) trfClassInstSig = trfLocNoSema $ \case - TypeSig names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM (trfName @n) names) + TypeSig _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM (trfName @n) names) <*> trfType (hsib_body $ hswc_body typ)) - ClassOpSig _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) + ClassOpSig _ _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM (trfName @n) names)) <*> trfType (hsib_body typ)) - SpecInstSig _ typ -> AST.USpecializeInstance <$> trfType (hsib_body typ) - SpecSig name (map hsib_body -> tys) (inl_act -> phase) -> AST.UInstanceSpecialize <$> trfSpecializePragma name tys phase - InlineSig name prag -> AST.UInlineInstance <$> trfInlinePragma @n name prag + SpecInstSig _ _ typ -> AST.USpecializeInstance <$> trfType (hsib_body typ) + SpecSig _ name (map hsib_body -> tys) (inl_act -> phase) -> AST.UInstanceSpecialize <$> trfSpecializePragma name tys phase + InlineSig _ name prag -> AST.UInlineInstance <$> trfInlinePragma @n name prag s -> unhandledElement "class instance signature" s -trfInstTypeFam :: TransformName n r => Located (TyFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) +trfInstTypeFam :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (TyFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) trfInstTypeFam (L l (TyFamInstDecl (hsib_body -> eqn))) = copyAnnot AST.UInstBodyTypeDecl (trfTypeEq (L l eqn)) -trfInstDataFam :: forall n r . TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) +trfInstDataFam :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (DataFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) trfInstDataFam = trfLocNoSema $ \case - (DataFamInstDecl (hsib_body -> FamEqn tc pats _ (HsDataDefn dn ctx _ ks cons derivs))) + (DataFamInstDecl (hsib_body -> FamEqn _ tc pats _ (HsDataDefn _ dn ctx _ ks cons derivs))) | all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons -> AST.UInstBodyDataDecl <$> trfDataKeyword dn @@ -508,8 +499,8 @@ (annLocNoSema (pure $ getLoc p `combineSrcSpans` getLoc tc) (AST.UInstanceHeadInfix <$> trfType p <*> trfOperator @n tc)) rest -trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.UPatternSynonym (Dom r) RangeStage) -trfPatternSynonym (PSB id _ lhs def dir) +trfPatternSynonym :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => PatSynBind n n -> Trf (AST.UPatternSynonym (Dom r) RangeStage) +trfPatternSynonym (PSB _ id lhs def dir) = let sep = case dir of ImplicitBidirectional -> AnnEqual _ -> AnnLarrow rhsLoc = combineSrcSpans (getLoc def) <$> tokenLoc sep @@ -537,23 +528,23 @@ trfPatSynWhere :: MatchGroup n (LHsExpr n) -> Trf (Ann AST.UPatSynWhere (Dom r) RangeStage) trfPatSynWhere (MG { mg_alts = alts }) = annLocNoSema (pure $ getLoc alts) (AST.UPatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts))) -trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) +trfFamilyKind :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyResultSig n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) trfFamilyKind (unLoc -> fr) = case fr of - NoSig -> nothing "" " " atTheEnd - KindSig k -> trfKindSig (Just k) - TyVarSig _ -> convertionProblem "trfFamilyKind: TyVarSig not supported" + NoSig _ -> nothing "" " " atTheEnd + KindSig _ k -> trfKindSig (Just k) + TyVarSig _ _ -> convertionProblem "trfFamilyKind: TyVarSig not supported" -trfFamilyResultSig :: forall n r . TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage) +trfFamilyResultSig :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage) trfFamilyResultSig (L l fr) Nothing = case fr of - NoSig -> nothing "" " " atTheEnd - KindSig k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k) - TyVarSig tv -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyTyVar <$> trfTyVar tv) + NoSig _ -> nothing "" " " atTheEnd + KindSig _ k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k) + TyVarSig _ tv -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyTyVar <$> trfTyVar tv) trfFamilyResultSig (L _ sig) (Just (L l (InjectivityAnn n deps))) = makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> tv <*> trfAnnList ", " (trfName' @n) deps)) - where tv = case sig of TyVarSig tv -> trfTyVar tv + where tv = case sig of TyVarSig _ tv -> trfTyVar tv _ -> annLocNoSema (pure $ getLoc n) (AST.UTyVarDecl <$> trfName @n n <*> nothing "" "" (pure $ srcSpanEnd (getLoc n))) -trfAnnotationSubject :: forall n r . TransformName n r => SourceText -> AnnProvenance (IdP n) -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage) +trfAnnotationSubject :: forall n r . (TransformName n r, HasCallStack) => SourceText -> AnnProvenance (IdP n) -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage) trfAnnotationSubject (fromSrcText -> stxt) subject payloadEnd = do payloadStart <- advanceStr stxt <$> atTheStart case subject of ValueAnnProvenance name@(L l _) -> annLocNoSema (pure l) (AST.UNameAnnotation <$> trfName @n name) @@ -561,7 +552,7 @@ (AST.UTypeAnnotation <$> trfName @n name) ModuleAnnProvenance -> annLocNoSema (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.UModuleAnnotation) -trfDataKeyword :: NewOrData -> Trf (Ann AST.UDataOrNewtypeKeyword (Dom r) RangeStage) +trfDataKeyword :: NewOrData -> Trf (Ann AST.UDataOrNewtypeKeyword (Dom r) RangeStage) trfDataKeyword NewType = annLocNoSema (tokenLoc AnnNewtype) (pure AST.UNewtypeKeyword) trfDataKeyword DataType = annLocNoSema (tokenLoc AnnData) (pure AST.UDataKeyword) @@ -597,23 +588,23 @@ Just GHC.Phantom -> pure AST.UPhantom Nothing -> convertionProblem "trfRole: no role" -trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.URule (Dom r) RangeStage) -trfRewriteRule = trfLocNoSema $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) -> +trfRewriteRule :: (TransformName n r, n ~ GhcPass p) => Located (RuleDecl n) -> Trf (Ann AST.URule (Dom r) RangeStage) +trfRewriteRule = trfLocNoSema $ \(HsRule _ (L nameLoc (_, ruleName)) act bndrs left right) -> AST.URule <$> trfFastString (L nameLoc ruleName) <*> trfPhase (pure $ srcSpanEnd nameLoc) act <*> makeListAfter " " " " (pure $ srcSpanStart $ getLoc left) (mapM trfRuleBndr bndrs) <*> trfExpr left <*> trfExpr right -trfRuleBndr :: forall n r . TransformName n r => Located (RuleBndr n) -> Trf (Ann AST.URuleVar (Dom r) RangeStage) -trfRuleBndr = trfLocNoSema $ \case (RuleBndr n) -> AST.URuleVar <$> trfName @n n - (RuleBndrSig n k) -> AST.USigRuleVar <$> trfName @n n <*> trfType (hsib_body $ hswc_body k) +trfRuleBndr :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (RuleBndr n) -> Trf (Ann AST.URuleVar (Dom r) RangeStage) +trfRuleBndr = trfLocNoSema $ \case (RuleBndr _ n) -> AST.URuleVar <$> trfName @n n + (RuleBndrSig _ n k) -> AST.USigRuleVar <$> trfName @n n <*> trfType (hsib_body $ hswc_body k) -trfMinimalFormula :: forall n r . TransformName n r => Located (BooleanFormula (Located (IdP n))) -> Trf (Ann AST.UMinimalFormula (Dom r) RangeStage) +trfMinimalFormula :: forall n r . (TransformName n r, HasCallStack) => Located (BooleanFormula (Located (IdP n))) -> Trf (Ann AST.UMinimalFormula (Dom r) RangeStage) trfMinimalFormula = trfLocCorrect (pure mkNoSemanticInfo) (\sp -> if isGoodSrcSpan sp then pure sp else srcLocSpan <$> before AnnClose) (trfMinimalFormula' @n) -trfMinimalFormula' :: forall n r . TransformName n r => BooleanFormula (Located (IdP n)) -> Trf (AST.UMinimalFormula (Dom r) RangeStage) +trfMinimalFormula' :: forall n r . (TransformName n r, HasCallStack) => BooleanFormula (Located (IdP n)) -> Trf (AST.UMinimalFormula (Dom r) RangeStage) trfMinimalFormula' (Var name) = AST.UMinimalName <$> trfName @n name trfMinimalFormula' (And formulas) -- empty Minimal pragma is mapped to an empty list = AST.UMinimalAnd <$> makeListBefore " " " , " atTheEnd (mapM (trfLocNoSema (trfMinimalFormula' @n)) formulas)
Language/Haskell/Tools/BackendGHC/Exprs.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the expression-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Exprs where @@ -34,9 +35,9 @@ import Language.Haskell.Tools.AST (Ann, AnnListG, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) +trfExpr :: forall n r p . (TransformName n r, n ~ GhcPass p) => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) -- correction for empty cases -trfExpr (L l cs@(HsCase expr (unLoc . mg_alts -> []))) +trfExpr (L l cs@(HsCase _ expr (unLoc . mg_alts -> []))) = do let realSpan = combineSrcSpans l (getLoc expr) tokensAfter <- allTokensAfter (srcSpanEnd realSpan) let actualSpan = case take 3 tokensAfter of @@ -62,50 +63,50 @@ createScopeInfo = do scope <- asks localsInScope return (mkScopeInfo scope) -trfExpr' :: forall n r . TransformName n r => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage) -trfExpr' (HsVar name) = AST.UVar <$> trfName @n name -trfExpr' (HsUnboundVar name) = AST.UVar <$> trfNameText (occNameString $ unboundVarOcc name) -trfExpr' (HsRecFld fld) = AST.UVar <$> (asks contRange >>= \l -> trfAmbiguousFieldName' l fld) -trfExpr' (HsIPVar ip) = AST.UVar <$> trfImplicitName ip -trfExpr' (HsOverLit (ol_val -> val)) = AST.ULit <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit val) -trfExpr' (HsLit val) = AST.ULit <$> annCont (pure $ RealLiteralInfo (monoLiteralType val)) (trfLiteral' val) -trfExpr' (HsLam (unLoc . mg_alts -> [unLoc -> Match _ pats (GRHSs [unLoc -> GRHS [] expr] (unLoc -> EmptyLocalBinds))])) +trfExpr' :: forall n r p . (TransformName n r, n ~ GhcPass p) => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage) +trfExpr' (HsVar _ name) = AST.UVar <$> trfName @n name +trfExpr' (HsUnboundVar _ name) = AST.UVar <$> trfNameText (occNameString $ unboundVarOcc name) +trfExpr' (HsRecFld _ fld) = AST.UVar <$> (asks contRange >>= \l -> trfAmbiguousFieldName' l fld) +trfExpr' (HsIPVar _ ip) = AST.UVar <$> trfImplicitName ip +trfExpr' (HsOverLit _ (ol_val -> val)) = AST.ULit <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit val) +trfExpr' (HsLit _ val) = AST.ULit <$> annCont (pure $ RealLiteralInfo (monoLiteralType val)) (trfLiteral' val) +trfExpr' (HsLam _ (unLoc . mg_alts -> [unLoc -> Match _ _ pats (GRHSs _ [unLoc -> GRHS _ [] expr] (unLoc -> EmptyLocalBinds _))])) = AST.ULambda <$> (makeNonemptyList " " $ mapM trfPattern pats) <*> addToScope pats (trfExpr expr) -trfExpr' (HsLamCase (unLoc . mg_alts -> matches)) = AST.ULamCase <$> addToScope matches (trfAnnList " " trfAlt' matches) -trfExpr' (HsApp e1 e2) = AST.UApp <$> trfExpr e1 <*> trfExpr e2 -trfExpr' (OpApp e1 (unLoc -> HsVar op) _ e2) +trfExpr' (HsLamCase _ (unLoc . mg_alts -> matches)) = AST.ULamCase <$> addToScope matches (trfAnnList " " trfAlt' matches) +trfExpr' (HsApp _ e1 e2) = AST.UApp <$> trfExpr e1 <*> trfExpr e2 +trfExpr' (OpApp _ e1 (unLoc -> HsVar _ op) e2) = AST.UInfixApp <$> trfExpr e1 <*> trfOperator @n op <*> trfExpr e2 -trfExpr' (OpApp e1 (L nameLoc (HsRecFld fld)) _ e2) +trfExpr' (OpApp _ e1 (L nameLoc (HsRecFld _ fld)) e2) = AST.UInfixApp <$> trfExpr e1 <*> trfAmbiguousOperator' nameLoc fld <*> trfExpr e2 -trfExpr' (OpApp _ (L _ op) _ _) = unhandledElement "OpApp expression" op -trfExpr' (NegApp e _) = AST.UPrefixApp <$> annLocNoSema loc (AST.UNormalOp <$> annLoc info loc (AST.nameFromList <$> trfOperatorStr False "-")) +trfExpr' (OpApp _ _ (L _ op) _) = unhandledElement "OpApp expression" op +trfExpr' (NegApp _ e _) = AST.UPrefixApp <$> annLocNoSema loc (AST.UNormalOp <$> annLoc info loc (AST.nameFromList <$> trfOperatorStr False "-")) <*> trfExpr e where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e)) info = createNameInfo =<< (fromMaybe (convProblem "minus operation is not found") <$> liftGhc negateOpName) negateOpName = getFromNameUsing @r (\n -> (\case Just (AnId id) -> Just id; _ -> Nothing) <$> lookupName n) negateName -trfExpr' (HsPar (unLoc -> SectionL expr (unLoc -> HsVar op))) = AST.ULeftSection <$> trfExpr expr <*> trfOperator @n op -trfExpr' (HsPar (unLoc -> SectionL expr (L nameLoc (HsRecFld op)))) +trfExpr' (HsPar _ (unLoc -> SectionL _ expr (unLoc -> HsVar _ op))) = AST.ULeftSection <$> trfExpr expr <*> trfOperator @n op +trfExpr' (HsPar _ (unLoc -> SectionL _ expr (L nameLoc (HsRecFld _ op)))) = AST.ULeftSection <$> trfExpr expr <*> trfAmbiguousOperator' nameLoc op -trfExpr' (HsPar (unLoc -> SectionR (unLoc -> HsVar op) expr)) = AST.URightSection <$> trfOperator @n op <*> trfExpr expr -trfExpr' (HsPar (unLoc -> SectionR (L nameLoc (HsRecFld op)) expr)) +trfExpr' (HsPar _ (unLoc -> SectionR _ (unLoc -> HsVar _ op) expr)) = AST.URightSection <$> trfOperator @n op <*> trfExpr expr +trfExpr' (HsPar _ (unLoc -> SectionR _ (L nameLoc (HsRecFld _ op)) expr)) = AST.URightSection <$> trfAmbiguousOperator' nameLoc op <*> trfExpr expr -trfExpr' (HsPar expr) = AST.UParen <$> trfExpr expr -trfExpr' (ExplicitTuple tupArgs box) | all tupArgPresent tupArgs +trfExpr' (HsPar _ expr) = AST.UParen <$> trfExpr expr +trfExpr' (ExplicitTuple _ tupArgs box) | all tupArgPresent tupArgs = wrap <$> between (if box == Boxed then AnnOpenP else AnnOpen) (if box == Boxed then AnnCloseP else AnnClose) - (trfAnnList' ", " (trfExpr . (\(Present e) -> e) . unLoc) tupArgs) + (trfAnnList' ", " (trfExpr . (\(Present _ e) -> e) . unLoc) tupArgs) where wrap = if box == Boxed then AST.UTuple else AST.UUnboxedTuple -trfExpr' (ExplicitTuple tupArgs box) +trfExpr' (ExplicitTuple _ tupArgs box) = wrap <$> between (if box == Boxed then AnnOpenP else AnnOpen) (if box == Boxed then AnnCloseP else AnnClose) (do locs <- elemLocs makeList ", " atTheEnd $ mapM trfTupSecElem (zip (map unLoc tupArgs) locs)) where wrap = if box == Boxed then AST.UTupleSection else AST.UUnboxedTupSec - trfTupSecElem :: forall n r . TransformName n r => (HsTupArg n, SrcSpan) -> Trf (Ann AST.UTupSecElem (Dom r) RangeStage) - trfTupSecElem (Present e, l) + trfTupSecElem :: forall n r . (TransformName n r, n ~ GhcPass p) => (HsTupArg n, SrcSpan) -> Trf (Ann AST.UTupSecElem (Dom r) RangeStage) + trfTupSecElem (Present _ e, l) = annLocNoSema (pure l) (AST.Present <$> (annCont createScopeInfo (trfExpr' (unLoc e)))) trfTupSecElem (Missing _, l) = annLocNoSema (pure l) (pure AST.Missing) existingArgs :: [SrcSpan] - existingArgs = catMaybes $ map (\case Present p -> Just (getLoc p); _ -> Nothing) $ map unLoc tupArgs + existingArgs = catMaybes $ map (\case Present _ p -> Just (getLoc p); _ -> Nothing) $ map unLoc tupArgs elemLocs :: Trf [SrcSpan] elemLocs = do r <- asks contRange @@ -122,28 +123,28 @@ | realSp `containsSpan` realSep = [mkSrcSpan (srcSpanStart sp) (srcSpanStart sep), mkSrcSpan (srcSpanEnd sep) (srcSpanEnd sp)] breakUpOne _ sp = [sp] -trfExpr' (HsCase expr (unLoc . mg_alts -> cases)) = AST.UCase <$> trfExpr expr <*> (addToScope cases $ makeIndentedList (focusBeforeIfPresent AnnCloseC atTheEnd) (mapM trfAlt cases)) -trfExpr' (HsIf _ expr thenE elseE) = AST.UIf <$> trfExpr expr <*> trfExpr thenE <*> trfExpr elseE +trfExpr' (HsCase _ expr (unLoc . mg_alts -> cases)) = AST.UCase <$> trfExpr expr <*> (addToScope cases $ makeIndentedList (focusBeforeIfPresent AnnCloseC atTheEnd) (mapM trfAlt cases)) +trfExpr' (HsIf _ _ expr thenE elseE) = AST.UIf <$> trfExpr expr <*> trfExpr thenE <*> trfExpr elseE trfExpr' (HsMultiIf _ parts) = AST.UMultiIf <$> trfAnnList "" trfGuardedCaseRhs' parts -trfExpr' (HsLet (unLoc -> binds) expr) = addToScope binds (AST.ULet <$> trfLocalBinds AnnLet binds <*> trfExpr expr) -trfExpr' (HsDo DoExpr (unLoc -> stmts) _) = AST.UDo <$> annLocNoSema (tokenLoc AnnDo) (pure AST.UDoKeyword) +trfExpr' (HsLet _ (unLoc -> binds) expr) = addToScope binds (AST.ULet <$> trfLocalBinds AnnLet binds <*> trfExpr expr) +trfExpr' (HsDo _ DoExpr (unLoc -> stmts)) = AST.UDo <$> annLocNoSema (tokenLoc AnnDo) (pure AST.UDoKeyword) <*> makeNonemptyIndentedList (trfScopedSequence trfDoStmt stmts) -trfExpr' (HsDo MDoExpr (unLoc -> [unLoc -> RecStmt { recS_stmts = stmts }, lastStmt]) _) +trfExpr' (HsDo _ MDoExpr (unLoc -> [unLoc -> RecStmt { recS_stmts = stmts }, lastStmt])) = AST.UDo <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.UMDoKeyword) <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt (stmts ++ [lastStmt]))) -trfExpr' (HsDo MDoExpr (unLoc -> stmts) _) = AST.UDo <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.UMDoKeyword) +trfExpr' (HsDo _ MDoExpr (unLoc -> stmts)) = AST.UDo <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.UMDoKeyword) <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt stmts)) -trfExpr' (HsDo ListComp (unLoc -> stmts) _) +trfExpr' (HsDo _ ListComp (unLoc -> stmts)) = AST.UListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts -trfExpr' (HsDo MonadComp (unLoc -> stmts) _) +trfExpr' (HsDo _ MonadComp (unLoc -> stmts)) = AST.UListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts -trfExpr' (HsDo PArrComp (unLoc -> stmts) _) +trfExpr' (HsDo _ (ParStmtCtxt _) (unLoc -> stmts)) = AST.UParArrayComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts trfExpr' (ExplicitList _ _ exprs) = AST.UList <$> trfAnnList' ", " trfExpr exprs -trfExpr' (ExplicitPArr _ exprs) = AST.UParArray <$> trfAnnList' ", " trfExpr exprs -trfExpr' (RecordCon name _ _ fields) = AST.URecCon <$> trfName @n name <*> trfFieldInits fields -trfExpr' (RecordUpd expr fields _ _ _ _) = AST.URecUpdate <$> trfExpr expr <*> trfAnnList ", " trfFieldUpdate fields -trfExpr' (ExprWithTySig expr typ) = AST.UTypeSig <$> trfExpr expr <*> trfType (hsib_body $ hswc_body typ) +-- trfExpr' (ExplicitPArr _ exprs) = AST.UParArray <$> trfAnnList' ", " trfExpr exprs +trfExpr' (RecordCon _ name fields) = AST.URecCon <$> trfName @n name <*> trfFieldInits fields +trfExpr' (RecordUpd _ expr fields) = AST.URecUpdate <$> trfExpr expr <*> trfAnnList ", " trfFieldUpdate fields +trfExpr' (ExprWithTySig typ expr) = AST.UTypeSig <$> trfExpr expr <*> trfType (hsib_body $ hswc_body typ) trfExpr' (ArithSeq _ _ (From from)) = AST.UEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> nothing "" "" (before AnnCloseS) trfExpr' (ArithSeq _ _ (FromThen from step)) @@ -153,27 +154,27 @@ <*> (makeJust <$> trfExpr to) trfExpr' (ArithSeq _ _ (FromThenTo from step to)) = AST.UEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> (makeJust <$> trfExpr to) -trfExpr' (PArrSeq _ (FromTo from to)) - = AST.UParArrayEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> trfExpr to -trfExpr' (PArrSeq _ (FromThenTo from step to)) - = AST.UParArrayEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> trfExpr to -trfExpr' (HsBracket brack) = AST.UBracketExpr <$> annContNoSema (trfBracket' brack) -trfExpr' (HsSpliceE qq@(HsQuasiQuote {})) = AST.UQuasiQuoteExpr <$> annContNoSema (trfQuasiQuotation' qq) -trfExpr' (HsSpliceE splice) = AST.USplice <$> trfSplice splice -trfExpr' (HsRnBracketOut br _) = AST.UBracketExpr <$> annContNoSema (trfBracket' br) -trfExpr' (HsProc pat cmdTop) = AST.UProc <$> trfPattern pat <*> trfCmdTop cmdTop +-- trfExpr' (PArrSeq _ (FromTo from to)) +-- = AST.UParArrayEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> trfExpr to +-- trfExpr' (PArrSeq _ (FromThenTo from step to)) +-- = AST.UParArrayEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> trfExpr to +trfExpr' (HsBracket _ brack) = AST.UBracketExpr <$> annContNoSema (trfBracket' brack) +trfExpr' (HsSpliceE _ qq@(HsQuasiQuote {})) = AST.UQuasiQuoteExpr <$> annContNoSema (trfQuasiQuotation' qq) +trfExpr' (HsSpliceE _ splice) = AST.USplice <$> trfSplice splice +trfExpr' (HsRnBracketOut _ br _) = AST.UBracketExpr <$> annContNoSema (trfBracket' br) +trfExpr' (HsProc _ pat cmdTop) = AST.UProc <$> trfPattern pat <*> trfCmdTop cmdTop trfExpr' (HsStatic _ expr) = AST.UStaticPtr <$> trfExpr expr -trfExpr' (HsAppType expr typ) = AST.UExplTypeApp <$> trfExpr expr <*> trfType (hswc_body typ) -trfExpr' (HsSCC _ lit expr) = AST.UExprPragma <$> pragma <*> trfExpr expr +trfExpr' (HsAppType typ expr) = AST.UExplTypeApp <$> trfExpr expr <*> trfType (hswc_body typ) +trfExpr' (HsSCC _ _ lit expr) = AST.UExprPragma <$> pragma <*> trfExpr expr where pragma = do pragLoc <- tokensLoc [AnnOpen, AnnClose] focusOn pragLoc $ annContNoSema (AST.USccPragma <$> annLocNoSema (mappend <$> tokenLoc AnnValStr <*> tokenLocBack AnnVal) (trfText' lit)) -trfExpr' (HsCoreAnn _ lit expr) = AST.UExprPragma <$> pragma <*> trfExpr expr +trfExpr' (HsCoreAnn _ _ lit expr) = AST.UExprPragma <$> pragma <*> trfExpr expr where pragma = do pragLoc <- tokensLoc [AnnOpen, AnnClose] focusOn pragLoc $ annContNoSema (AST.UCorePragma <$> annLocNoSema (mappend <$> tokenLoc AnnValStr <*> tokenLocBack AnnVal) (trfText' lit)) -trfExpr' (HsTickPragma _ source _ expr) = AST.UExprPragma <$> pragma <*> trfExpr expr +trfExpr' (HsTickPragma _ _ source _ expr) = AST.UExprPragma <$> pragma <*> trfExpr expr where pragma = do pragLoc <- tokensLoc [AnnOpen, AnnClose] focusOn pragLoc $ annContNoSema (AST.UGeneratedPragma <$> (trfSourceRange source)) -trfExpr' (ExplicitSum tag arity expr _) +trfExpr' (ExplicitSum _ tag arity expr) = do sepsBefore <- focusBeforeLoc (srcSpanStart (getLoc expr)) (eachTokenLoc (AnnOpen : replicate (tag - 1) AnnVbar)) sepsAfter <- focusAfterLoc (srcSpanEnd (getLoc expr)) (eachTokenLoc (replicate (arity - tag) AnnVbar)) let locsBefore = map srcSpanEnd $ init sepsBefore @@ -182,81 +183,81 @@ <*> trfExpr expr <*> makeList " | " (before AnnClose) (mapM makePlaceholder locsAfter) where makePlaceholder l = annLocNoSema (pure (srcLocSpan l)) (pure AST.UUnboxedSumPlaceHolder) -trfExpr' EWildPat = return AST.UHole +trfExpr' (EWildPat _) = return AST.UHole trfExpr' t = unhandledElement "expression" t -trfFieldInits :: TransformName n r => HsRecFields n (LHsExpr n) -> Trf (AnnListG AST.UFieldUpdate (Dom r) RangeStage) +trfFieldInits :: (TransformName n r, n ~ GhcPass p) => HsRecFields n (LHsExpr n) -> Trf (AnnListG AST.UFieldUpdate (Dom r) RangeStage) trfFieldInits (HsRecFields fields dotdot) = do cont <- asks contRange let (normalFlds, implicitFlds) = partition ((cont /=) . getLoc) fields makeList ", " (before AnnCloseC) $ ((++) <$> mapM trfFieldInit normalFlds <*> (if isJust dotdot then (:[]) <$> annLocNoSema (tokenLoc AnnDotdot) - (AST.UFieldWildcard <$> (annCont (createImplicitFldInfo (unLoc . (\(HsVar n) -> n) . unLoc) (map unLoc implicitFlds)) (pure AST.FldWildcard))) + (AST.UFieldWildcard <$> (annCont (createImplicitFldInfo (unLoc . (\(HsVar _ n) -> n) . unLoc) (map unLoc implicitFlds)) (pure AST.FldWildcard))) else pure [])) -trfFieldInit :: forall n r . TransformName n r => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.UFieldUpdate (Dom r) RangeStage) +trfFieldInit :: forall n r p . (TransformName n r, n ~ GhcPass p) => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.UFieldUpdate (Dom r) RangeStage) trfFieldInit = trfLocNoSema $ \case HsRecField id _ True -> AST.UFieldPun <$> trfName @n (getFieldOccName id) HsRecField id val False -> AST.UNormalFieldUpdate <$> trfName @n (getFieldOccName id) <*> trfExpr val -trfFieldUpdate :: TransformName n r => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.UFieldUpdate (Dom r) RangeStage) +trfFieldUpdate :: (TransformName n r, n ~ GhcPass p) => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.UFieldUpdate (Dom r) RangeStage) trfFieldUpdate (HsRecField id _ True) = AST.UFieldPun <$> trfAmbiguousFieldName id trfFieldUpdate (HsRecField id val False) = AST.UNormalFieldUpdate <$> trfAmbiguousFieldName id <*> trfExpr val -trfAlt :: TransformName n r => Located (Match n (LHsExpr n)) -> Trf (Ann AST.UAlt (Dom r) RangeStage) +trfAlt :: (TransformName n r, n ~ GhcPass p) => Located (Match n (LHsExpr n)) -> Trf (Ann AST.UAlt (Dom r) RangeStage) trfAlt = trfLocNoSema trfAlt' -trfAlt' :: TransformName n r => Match n (LHsExpr n) -> Trf (AST.UAlt (Dom r) RangeStage) +trfAlt' :: (TransformName n r, n ~ GhcPass p) => Match n (LHsExpr n) -> Trf (AST.UAlt (Dom r) RangeStage) trfAlt' = gTrfAlt' trfExpr -gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Match n (Located (ge n)) -> Trf (AST.UAlt' ae (Dom r) RangeStage) -gTrfAlt' te (Match _ [pat] (GRHSs rhss (unLoc -> locBinds))) +gTrfAlt' :: (TransformName n r, n ~ GhcPass p) => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Match n (Located (ge n)) -> Trf (AST.UAlt' ae (Dom r) RangeStage) +gTrfAlt' te (Match _ _ [pat] (GRHSs _ rhss (unLoc -> locBinds))) = AST.UAlt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds (collectLocs rhss) locBinds gTrfAlt' _ _ = convertionProblem "gTrfAlt': not exactly one alternative when transforming a case alternative" -trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.UCaseRhs (Dom r) RangeStage) +trfCaseRhss :: (TransformName n r, n ~ GhcPass p) => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.UCaseRhs (Dom r) RangeStage) trfCaseRhss = gTrfCaseRhss trfExpr -gTrfCaseRhss :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.UCaseRhs' ae) (Dom r) RangeStage) -gTrfCaseRhss te [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> updateFocus (pure . updateEnd (const $ srcSpanStart $ getLoc body)) - (tokenLocBack AnnRarrow)) +gTrfCaseRhss :: (TransformName n r, n ~ GhcPass p) => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.UCaseRhs' ae) (Dom r) RangeStage) +gTrfCaseRhss te [unLoc -> GRHS _ [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> updateFocus (pure . updateEnd (const $ srcSpanStart $ getLoc body)) + (tokenLocBack AnnRarrow)) (AST.UUnguardedCaseRhs <$> te body) gTrfCaseRhss te rhss = annLocNoSema (pure $ collectLocs rhss) (AST.UGuardedCaseRhss <$> trfAnnList ";" (gTrfGuardedCaseRhs' te) rhss) -trfGuardedCaseRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedCaseRhs (Dom r) RangeStage) +trfGuardedCaseRhs :: (TransformName n r, n ~ GhcPass p) => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedCaseRhs (Dom r) RangeStage) trfGuardedCaseRhs = trfLocNoSema trfGuardedCaseRhs' -trfGuardedCaseRhs' :: TransformName n r => GRHS n (LHsExpr n) -> Trf (AST.UGuardedCaseRhs (Dom r) RangeStage) +trfGuardedCaseRhs' :: (TransformName n r, n ~ GhcPass p) => GRHS n (LHsExpr n) -> Trf (AST.UGuardedCaseRhs (Dom r) RangeStage) trfGuardedCaseRhs' = gTrfGuardedCaseRhs' trfExpr -gTrfGuardedCaseRhs' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> GRHS n (Located (ge n)) -> Trf (AST.UGuardedCaseRhs' ae (Dom r) RangeStage) -gTrfGuardedCaseRhs' te (GRHS guards body) = AST.UGuardedCaseRhs <$> trfAnnList " " trfRhsGuard' guards <*> te body +gTrfGuardedCaseRhs' :: (TransformName n r, n ~ GhcPass p) => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> GRHS n (Located (ge n)) -> Trf (AST.UGuardedCaseRhs' ae (Dom r) RangeStage) +gTrfGuardedCaseRhs' te (GRHS _ guards body) = AST.UGuardedCaseRhs <$> trfAnnList " " trfRhsGuard' guards <*> te body -trfCmdTop :: TransformName n r => Located (HsCmdTop n) -> Trf (Ann AST.UCmd (Dom r) RangeStage) -trfCmdTop (L _ (HsCmdTop cmd _ _ _)) = trfCmd cmd +trfCmdTop :: (TransformName n r, n ~ GhcPass p) => Located (HsCmdTop n) -> Trf (Ann AST.UCmd (Dom r) RangeStage) +trfCmdTop (L _ (HsCmdTop _ cmd)) = trfCmd cmd -trfCmd :: TransformName n r => Located (HsCmd n) -> Trf (Ann AST.UCmd (Dom r) RangeStage) +trfCmd :: (TransformName n r, n ~ GhcPass p) => Located (HsCmd n) -> Trf (Ann AST.UCmd (Dom r) RangeStage) trfCmd = trfLocNoSema trfCmd' -trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage) -trfCmd' (HsCmdArrApp left right _ typ dir) = AST.UArrowAppCmd <$> trfExpr left <*> op <*> trfExpr right +trfCmd' :: (TransformName n r, n ~ GhcPass p) => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage) +trfCmd' (HsCmdArrApp _ left right typ dir) = AST.UArrowAppCmd <$> trfExpr left <*> op <*> trfExpr right where op = case (typ, dir) of (HsFirstOrderApp, False) -> annLocNoSema (tokenLoc Annrarrowtail) (pure AST.URightAppl) (HsFirstOrderApp, True) -> annLocNoSema (tokenLoc Annlarrowtail) (pure AST.ULeftAppl) (HsHigherOrderApp, False) -> annLocNoSema (tokenLoc AnnRarrowtail) (pure AST.URightHighApp) (HsHigherOrderApp, True) -> annLocNoSema (tokenLoc AnnLarrowtail) (pure AST.ULeftHighApp) -- FIXME: needs a before -trfCmd' (HsCmdArrForm expr _ _ cmds) = AST.UArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds) -trfCmd' (HsCmdApp cmd expr) = AST.UAppCmd <$> trfCmd cmd <*> trfExpr expr -trfCmd' (HsCmdLam (MG (unLoc -> [unLoc -> Match _ pats (GRHSs [unLoc -> GRHS [] body] _)]) _ _ _)) +trfCmd' (HsCmdArrForm _ expr _ _ cmds) = AST.UArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds) +trfCmd' (HsCmdApp _ cmd expr) = AST.UAppCmd <$> trfCmd cmd <*> trfExpr expr +trfCmd' (HsCmdLam _ (MG _ (unLoc -> [unLoc -> Match _ _ pats (GRHSs _ [unLoc -> GRHS _ [] body] _)]) _)) = AST.ULambdaCmd <$> (makeNonemptyList " " $ mapM trfPattern pats) <*> trfCmd body -trfCmd' (HsCmdPar cmd) = AST.UParenCmd <$> trfCmd cmd -trfCmd' (HsCmdCase expr (MG (unLoc -> alts) _ _ _)) +trfCmd' (HsCmdPar _ cmd) = AST.UParenCmd <$> trfCmd cmd +trfCmd' (HsCmdCase _ expr (MG _ (unLoc -> alts) _)) = AST.UCaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfAlt' trfCmd)) alts) -trfCmd' (HsCmdIf _ pred thenExpr elseExpr) = AST.UIfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr -trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.ULetCmd <$> trfLocalBinds AnnLet binds <*> trfCmd cmd) -trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.UDoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts) +trfCmd' (HsCmdIf _ _ pred thenExpr elseExpr) = AST.UIfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr +trfCmd' (HsCmdLet _ (unLoc -> binds) cmd) = addToScope binds (AST.ULetCmd <$> trfLocalBinds AnnLet binds <*> trfCmd cmd) +trfCmd' (HsCmdDo _ (unLoc -> stmts)) = AST.UDoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts) -- | TODO: implement trfCmd' (HsCmdLam {}) = convertionProblem "trfCmd': cmd lambda not supported yet" trfCmd' (HsCmdWrap {}) = convertionProblem "trfCmd': cmd wrap not supported yet" @@ -267,10 +268,13 @@ trfSourceRange :: (StringLiteral, (Int, Int), (Int, Int)) -> Trf (Ann AST.USourceRange (Dom r) RangeStage) trfSourceRange (fileName, (startRow, startCol), (endRow, endCol)) = do fnLoc <- tokenLoc AnnValStr - [srLoc, scLoc, erLoc, ecLoc] <- allTokenLoc AnnVal - annLocNoSema (pure (fnLoc `combineSrcSpans` ecLoc)) - (AST.USourceRange <$> annLocNoSema (pure fnLoc) (trfText' fileName) - <*> annLocNoSema (pure srLoc) (pure $ AST.Number $ fromIntegral startRow) - <*> annLocNoSema (pure scLoc) (pure $ AST.Number $ fromIntegral startCol) - <*> annLocNoSema (pure erLoc) (pure $ AST.Number $ fromIntegral endRow) - <*> annLocNoSema (pure ecLoc) (pure $ AST.Number $ fromIntegral endCol)) + tokens <- allTokenLoc AnnVal + case tokens of + [srLoc, scLoc, erLoc, ecLoc] -> do + annLocNoSema (pure (fnLoc `combineSrcSpans` ecLoc)) + (AST.USourceRange <$> annLocNoSema (pure fnLoc) (trfText' fileName) + <*> annLocNoSema (pure srLoc) (pure $ AST.Number $ fromIntegral startRow) + <*> annLocNoSema (pure scLoc) (pure $ AST.Number $ fromIntegral startCol) + <*> annLocNoSema (pure erLoc) (pure $ AST.Number $ fromIntegral endRow) + <*> annLocNoSema (pure ecLoc) (pure $ AST.Number $ fromIntegral endCol)) + _ -> convertionProblem "trfSourceRange: tokens not found"
Language/Haskell/Tools/BackendGHC/Exprs.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Tools.BackendGHC.Exprs where import HsExpr as GHC (HsExpr, HsCmd) @@ -6,7 +7,8 @@ import Language.Haskell.Tools.BackendGHC.Monad (Trf) import Language.Haskell.Tools.BackendGHC.Names (TransformName(..)) import SrcLoc as GHC (Located) +import HsExtension (GhcPass) -trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) -trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage) -trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage)+trfExpr :: (TransformName n r, n ~ GhcPass p) => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) +trfExpr' :: (TransformName n r, n ~ GhcPass p) => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage) +trfCmd' :: (TransformName n r, n ~ GhcPass p) => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/GHCUtils.hs view
@@ -27,22 +27,22 @@ import SrcLoc import Type (TyThing(..), mkFunTys) -class OutputableBndrId name => GHCName name where +class (OutputableBndrId name) => GHCName name where rdrName :: IdP name -> RdrName getFromNameUsing :: Applicative f => (Name -> Ghc (f Id)) -> Name -> Ghc (f (IdP name)) getBindsAndSigs :: HsValBinds name -> ([LSig name], LHsBinds name) nameFromId :: Id -> IdP name - unpackPostRn :: RdrName -> PostRn name (IdP name) -> IdP name - gunpackPostRn :: a -> (IdP name -> a) -> PostRn name (IdP name) -> a + fieldOccToId :: RdrName -> XCFieldOcc name -> IdP name + nameIfThereIs :: IdP name -> Maybe Name instance GHCName GhcPs where rdrName = id getFromNameUsing _ n = return $ pure (nameRdrName n) - getBindsAndSigs (ValBindsIn binds sigs) = (sigs, binds) + getBindsAndSigs (ValBinds _ binds sigs) = (sigs, binds) getBindsAndSigs _ = error "ValBindsOut: ValBindsOut in parsed source" nameFromId = nameRdrName . getName - unpackPostRn rdr _ = rdr - gunpackPostRn a _ _ = a + fieldOccToId rdr _ = rdr + nameIfThereIs _ = Nothing occName :: forall n . GHCName n => IdP n -> OccName occName = rdrNameOcc . rdrName @n @@ -50,18 +50,17 @@ instance GHCName GhcRn where rdrName = nameRdrName getFromNameUsing f n = fmap (nameFromId @GhcRn) <$> f n - getBindsAndSigs (ValBindsOut bindGroups sigs) = (sigs, unionManyBags (map snd bindGroups)) + getBindsAndSigs (XValBindsLR (NValBinds bindGroups sigs)) = (sigs, unionManyBags (map snd bindGroups)) getBindsAndSigs _ = error "getBindsAndSigs: ValBindsIn in renamed source" nameFromId = getName - unpackPostRn _ a = a - - gunpackPostRn _ f pr = f pr + fieldOccToId _ name = name + nameIfThereIs name = Just name getFieldOccName :: forall n . GHCName n => Located (FieldOcc n) -> Located (IdP n) -getFieldOccName (L l (FieldOcc (L _ rdr) postRn)) = L l ((unpackPostRn @n) rdr postRn) +getFieldOccName (L l (FieldOcc name (L _ rdr))) = L l (fieldOccToId @n rdr name) getFieldOccName' :: forall n . GHCName n => FieldOcc n -> IdP n -getFieldOccName' (FieldOcc (L _ rdr) postRn) = (unpackPostRn @n) rdr postRn +getFieldOccName' (FieldOcc name (L _ rdr)) = fieldOccToId @n rdr name -- | Loading ids for top-level ghc names getTopLevelId :: GHC.Name -> Ghc (Maybe GHC.Id) @@ -96,33 +95,33 @@ instance HsHasName e => HsHasName (Located e) where hsGetNames p (L _ e) = hsGetNames p e -instance HsHasName (IdP n) => HsHasName (HsLocalBinds n) where - hsGetNames p (HsValBinds bnds) = hsGetNames p bnds +instance HsHasName (IdP (GhcPass n)) => HsHasName (HsLocalBinds (GhcPass n)) where + hsGetNames p (HsValBinds _ bnds) = hsGetNames p bnds hsGetNames _ _ = [] instance (GHCName n, HsHasName (IdP n)) => HsHasName (HsDecl n) where - hsGetNames p (TyClD tycl) = hsGetNames p tycl - hsGetNames p (ValD vald) = hsGetNames p vald - hsGetNames p (ForD ford) = hsGetNames p ford - hsGetNames p (InstD inst) = hsGetNames p inst + hsGetNames p (TyClD _ tycl) = hsGetNames p tycl + hsGetNames p (ValD _ vald) = hsGetNames p vald + hsGetNames p (ForD _ ford) = hsGetNames p ford + hsGetNames p (InstD _ inst) = hsGetNames p inst hsGetNames _ _ = [] instance (GHCName n, HsHasName (IdP n)) => HsHasName (InstDecl n) where - hsGetNames p (ClsInstD clsInst) = hsGetNames p (cid_datafam_insts clsInst) - hsGetNames p (DataFamInstD dataFamInst) = hsGetNames p dataFamInst + hsGetNames p (ClsInstD _ clsInst) = hsGetNames p (cid_datafam_insts clsInst) + hsGetNames p (DataFamInstD _ dataFamInst) = hsGetNames p dataFamInst hsGetNames _ _ = [] instance (GHCName n, HsHasName (IdP n), HsHasName r) => HsHasName (FamEqn n p r) where - hsGetNames p (FamEqn id _ _ rhs) = hsGetNames p id ++ hsGetNames p rhs + hsGetNames p (FamEqn _ id _ _ rhs) = hsGetNames p id ++ hsGetNames p rhs instance (GHCName n, HsHasName (IdP n)) => HsHasName (DataFamInstDecl n) where hsGetNames p dfid = hsGetNames p (hsib_body $ dfid_eqn dfid) instance (GHCName n, HsHasName (IdP n)) => HsHasName (TyClGroup n) where - hsGetNames p (TyClGroup tycls _ _) = hsGetNames p tycls + hsGetNames p (TyClGroup _ tycls _ _) = hsGetNames p tycls instance (GHCName n, HsHasName (IdP n)) => HsHasName (TyClDecl n) where - hsGetNames p (FamDecl fd) = hsGetNames p fd + hsGetNames p (FamDecl _ fd) = hsGetNames p fd hsGetNames p (SynDecl {tcdLName = name}) = hsGetNames p name hsGetNames p (DataDecl {tcdLName = name, tcdDataDefn = datadef}) = let n = hsGetNames p name in n ++ hsGetNames (listToMaybe (map fst n)) datadef @@ -137,12 +136,12 @@ hsGetNames p (HsDataDefn {dd_cons = ctors}) = hsGetNames p ctors instance (GHCName n, HsHasName (IdP n)) => HsHasName (ConDecl n) where - hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsFunTy (L _ (HsRecTy flds)) _)) _)}) + hsGetNames p (ConDeclGADT {con_names = names, con_res_ty = (L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _))}) = hsGetNames p names ++ hsGetNames p flds - hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsRecTy flds)) _)}) + hsGetNames p (ConDeclGADT {con_names = names, con_res_ty = (L _ (HsRecTy _ flds))}) = hsGetNames p names ++ hsGetNames p flds hsGetNames p (ConDeclGADT {con_names = names}) = hsGetNames p names - hsGetNames p (ConDeclH98 {con_name = name, con_details = details}) + hsGetNames p (ConDeclH98 {con_name = name, con_args = details}) = hsGetNames p name ++ hsGetNames p details instance (GHCName n, HsHasName (IdP n)) => HsHasName (HsConDeclDetails n) where @@ -150,24 +149,25 @@ hsGetNames _ _ = [] instance (GHCName n, HsHasName (IdP n)) => HsHasName (ConDeclField n) where - hsGetNames p (ConDeclField name _ _) = hsGetNames p name + hsGetNames p (ConDeclField _ name _ _) = hsGetNames p name instance forall n . (GHCName n, HsHasName (IdP n)) => HsHasName (FieldOcc n) where - hsGetNames p (FieldOcc _ pr) = (gunpackPostRn @n) [] (hsGetNames p :: IdP n -> [(Name, Maybe Name)]) pr + hsGetNames p fl = case nameIfThereIs @n (getFieldOccName' fl) of Just n -> [(n, p)] + _ -> [] instance (GHCName n, HsHasName (IdP n)) => HsHasName (Sig n) where - hsGetNames p (TypeSig n _) = hsGetNames p n - hsGetNames p (ClassOpSig _ n _) = hsGetNames p n - hsGetNames p (PatSynSig n _) = hsGetNames p n + hsGetNames p (TypeSig _ n _) = hsGetNames p n + hsGetNames p (ClassOpSig _ _ n _) = hsGetNames p n + hsGetNames p (PatSynSig _ n _) = hsGetNames p n hsGetNames _ _ = [] instance HsHasName (IdP n) => HsHasName (ForeignDecl n) where - hsGetNames p (ForeignImport n _ _ _) = hsGetNames p n + hsGetNames p (ForeignImport _ n _ _) = hsGetNames p n hsGetNames _ _ = [] -instance HsHasName (IdP n) => HsHasName (HsValBinds n) where - hsGetNames p (ValBindsIn bnds _) = hsGetNames p bnds - hsGetNames p (ValBindsOut bnds _) = hsGetNames p $ map snd bnds +instance forall n . HsHasName (IdP (GhcPass n)) => HsHasName (HsValBinds (GhcPass n)) where + hsGetNames p (ValBinds _ bnds _) = hsGetNames p bnds + hsGetNames p (XValBindsLR (NValBinds bnds _ :: NHsValBindsLR (GhcPass n))) = hsGetNames p $ map snd bnds instance HsHasName n => HsHasName (Bag n) where hsGetNames p = hsGetNames p . bagToList @@ -176,49 +176,52 @@ hsGetNames p (FunBind {fun_id = lname}) = hsGetNames p lname hsGetNames p (PatBind {pat_lhs = pat}) = hsGetNames p pat hsGetNames p (VarBind {var_id = id}) = hsGetNames p id - hsGetNames p (PatSynBind (PSB {psb_id = id})) = hsGetNames p id + hsGetNames p (PatSynBind _ (PSB {psb_id = id})) = hsGetNames p id hsGetNames _ _ = error "hsGetNames: called on compiler-generated binding" instance HsHasName (IdP n) => HsHasName (ParStmtBlock l n) where - hsGetNames p (ParStmtBlock _ binds _) = hsGetNames p binds + hsGetNames p (ParStmtBlock _ _ binds _) = hsGetNames p binds --instance HsHasName n => HsHasName (LHsTyVarBndrs n) where -- hsGetNames (HsQTvs kvs tvs) = hsGetNames kvs ++ hsGetNames tvs instance HsHasName (IdP n) => HsHasName (HsTyVarBndr n) where - hsGetNames p (UserTyVar n) = hsGetNames p n - hsGetNames p (KindedTyVar n _) = hsGetNames p n + hsGetNames p (UserTyVar _ n) = hsGetNames p n + hsGetNames p (KindedTyVar _ n _) = hsGetNames p n + hsGetNames _ _ = [] instance HsHasName (IdP n) => HsHasName (Match n b) where - hsGetNames p (Match _ pats _) = concatMap (hsGetNames p) pats + hsGetNames p (Match _ _ pats _) = concatMap (hsGetNames p) pats -instance HsHasName (IdP n) => HsHasName (Stmt n b) where - hsGetNames p (LetStmt binds) = hsGetNames p binds - hsGetNames p (BindStmt pat _ _ _ _) = hsGetNames p pat +instance HsHasName (IdP (GhcPass n)) => HsHasName (StmtLR (GhcPass n) (GhcPass n) b) where + hsGetNames p (LetStmt _ binds) = hsGetNames p binds + hsGetNames p (BindStmt _ pat _ _ _) = hsGetNames p pat hsGetNames p (RecStmt {recS_rec_ids = ids}) = hsGetNames p ids hsGetNames _ _ = [] instance HsHasName (IdP n) => HsHasName (Pat n) where - hsGetNames x (VarPat id) = hsGetNames x id - hsGetNames x (LazyPat p) = hsGetNames x p - hsGetNames x (AsPat lname p) = hsGetNames x lname ++ hsGetNames x p - hsGetNames x (ParPat p) = hsGetNames x p - hsGetNames x (BangPat p) = hsGetNames x p - hsGetNames x (ListPat pats _ _) = concatMap (hsGetNames x) pats - hsGetNames x (TuplePat pats _ _) = concatMap (hsGetNames x) pats - hsGetNames x (PArrPat pats _) = concatMap (hsGetNames x) pats + hsGetNames x (VarPat _ id) = hsGetNames x id + hsGetNames x (LazyPat _ p) = hsGetNames x p + hsGetNames x (AsPat _ lname p) = hsGetNames x lname ++ hsGetNames x p + hsGetNames x (ParPat _ p) = hsGetNames x p + hsGetNames x (BangPat _ p) = hsGetNames x p + hsGetNames x (ListPat _ pats) = concatMap (hsGetNames x) pats + hsGetNames x (TuplePat _ pats _) = concatMap (hsGetNames x) pats hsGetNames x (ConPatIn _ details) = concatMap (hsGetNames x) (hsConPatArgs details) hsGetNames x (ConPatOut {pat_args = details}) = concatMap (hsGetNames x) (hsConPatArgs details) - hsGetNames x (ViewPat _ p _) = hsGetNames x p - hsGetNames x (NPlusKPat lname _ _ _ _ _) = hsGetNames x lname - hsGetNames x (SigPatIn p _) = hsGetNames x p - hsGetNames x (SigPatOut p _) = hsGetNames x p + hsGetNames x (ViewPat _ _ p) = hsGetNames x p + hsGetNames x (NPlusKPat _ lname _ _ _ _) = hsGetNames x lname + hsGetNames x (SigPat _ p) = hsGetNames x p hsGetNames _ _ = [] -instance (GHCName n, HsHasName (IdP n)) => HsHasName (HsGroup n) where - hsGetNames p g@(HsGroup vals _ clds _ _ _ foreigns _ _ _ _ _) +instance (GHCName (GhcPass n), HsHasName (IdP (GhcPass n))) => HsHasName (HsGroup (GhcPass n)) where + hsGetNames p g@(HsGroup _ vals _ clds _ _ _ foreigns _ _ _ _) = hsGetNames p vals ++ hsGetNames p clds ++ hsGetNames p (hsGroupInstDecls g) ++ hsGetNames p foreigns +-- instance (GHCName n, HsHasName (IdP n)) => HsHasName (DefaultDecl n) where +-- hsGetNames p (DefaultDecl _ ts) = hsGetNames p ts +-- hsGetNames _ _ = [] + -- | Get the original form of a name rdrNameStr :: RdrName -> String rdrNameStr name = showSDocUnsafe $ ppr name @@ -233,9 +236,12 @@ instance FromGHCName GHC.Name where fromGHCName = id + + +{- -- | Tries to simplify the type that has HsAppsTy before renaming. Does not always provide the correct form. -- Treats each operator as if they are of equivalent precedence and always left-associative. -cleanHsType :: forall n . (OutputableBndrId n, SourceTextX n) => HsType n -> HsType n +cleanHsType :: forall n . (OutputableBndrId n {-, SourceTextX n -}) => HsType n -> HsType n -- for some reason * is considered infix cleanHsType (HsAppsTy apps) = unLoc $ guessType apps where guessType :: OutputableBndrId n => [LHsAppType n] -> LHsType n @@ -258,25 +264,27 @@ hsOpTy :: LHsType n -> Located (IdP n) -> LHsType n -> LHsType n hsOpTy t1 n t2 = L (getLoc t1 `combineSrcSpans` getLoc t2) $ HsOpTy t1 n t2 cleanHsType t = t +-} mergeFixityDefs :: [Located (FixitySig n)] -> [Located (FixitySig n)] mergeFixityDefs (s@(L l _) : rest) = let (same, different) = partition ((== l) . getLoc) rest in foldl mergeWith s (map unLoc same) : mergeFixityDefs different - where mergeWith (L l (FixitySig names fixity)) (FixitySig otherNames _) = L l (FixitySig (names ++ otherNames) fixity) + where mergeWith (L l (FixitySig x names fixity)) (FixitySig _ otherNames _) = L l (FixitySig x (names ++ otherNames) fixity) mergeFixityDefs [] = [] -getGroupRange :: HsGroup n -> SrcSpan +getGroupRange :: HsGroup (GhcPass n) -> SrcSpan getGroupRange (HsGroup {..}) = foldr combineSrcSpans noSrcSpan locs - where locs = [getHsValRange hs_valds] ++ map getLoc hs_splcds ++ map getLoc (concatMap group_tyclds hs_tyclds) ++ map getLoc (concatMap group_roles hs_tyclds) + where locs = [getHsValRange hs_valds] ++ map getLoc hs_splcds ++ map getLoc (concatMap group_tyclds hs_tyclds) + ++ map getLoc (concatMap group_roles hs_tyclds) ++ map getLoc hs_derivds ++ map getLoc hs_fixds ++ map getLoc hs_defds - ++ map getLoc hs_fords ++ map getLoc hs_warnds ++ map getLoc hs_annds ++ map getLoc hs_ruleds ++ map getLoc hs_vects + ++ map getLoc hs_fords ++ map getLoc hs_warnds ++ map getLoc hs_annds ++ map getLoc hs_ruleds ++ map getLoc hs_docs -getHsValRange :: HsValBinds n -> SrcSpan -getHsValRange (ValBindsIn vals sig) = foldr combineSrcSpans noSrcSpan $ map getLoc (bagToList vals) ++ map getLoc sig -getHsValRange (ValBindsOut vals sig) = foldr combineSrcSpans noSrcSpan $ concatMap (map getLoc . bagToList . snd) vals ++ map getLoc sig +getHsValRange :: HsValBinds (GhcPass n) -> SrcSpan +getHsValRange (ValBinds _ vals sig) = foldr combineSrcSpans noSrcSpan $ map getLoc (bagToList vals) ++ map getLoc sig +getHsValRange ((XValBindsLR (NValBinds vals sig))) = foldr combineSrcSpans noSrcSpan $ concatMap (map getLoc . bagToList . snd) vals ++ map getLoc sig fromSrcText :: SourceText -> String fromSrcText (SourceText s) = s
Language/Haskell/Tools/BackendGHC/Kinds.hs view
@@ -3,62 +3,70 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the kind-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Kinds where +import Data.Data + import ApiAnnotation as GHC (AnnKeywordId(..)) import FastString as GHC (unpackFS) import HsTypes as GHC import Name as GHC (occNameString, nameOccName, isWiredInName) import RdrName as GHC (RdrName(..)) import SrcLoc as GHC +import HsExtension (GhcPass) +import Outputable import Language.Haskell.Tools.AST (Ann, AnnMaybeG, Dom, RangeStage, HasNoSemanticInfo) import qualified Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.BackendGHC.GHCUtils (GHCName(..), cleanHsType) +import Language.Haskell.Tools.BackendGHC.GHCUtils (GHCName(..)) import Language.Haskell.Tools.BackendGHC.Monad (Trf, transformingPossibleVar) import Language.Haskell.Tools.BackendGHC.Names (TransformName, trfOperator, trfName) import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.Types (trfType') import Language.Haskell.Tools.BackendGHC.Utils -trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) +trfKindSig :: (TransformName n r, Outputable (HsType n), Data (HsType n), n ~ GhcPass p) + => Maybe (LHsKind n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) trfKindSig = trfMaybe "" "" trfKindSig' -trfKindSig' :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.UKindConstraint (Dom r) RangeStage) +trfKindSig' :: (TransformName n r, Outputable (HsType n), Data (HsType n), n ~ GhcPass p) + => Located (HsKind n) -> Trf (Ann AST.UKindConstraint (Dom r) RangeStage) trfKindSig' k = annLocNoSema (combineSrcSpans (getLoc k) <$> (tokenBefore (srcSpanStart (getLoc k)) AnnDcolon)) (AST.UKindConstraint <$> trfLocNoSema trfKind' k) -trfKind :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.UKind (Dom r) RangeStage) -trfKind = trfLocNoSema (trfKind' . cleanHsType) +trfKind :: (TransformName n r, Outputable (HsType n), Data (HsType n), n ~ GhcPass p) => Located (HsKind n) -> Trf (Ann AST.UKind (Dom r) RangeStage) +trfKind = trfLocNoSema trfKind' -trfKind' :: forall n r . TransformName n r => HsKind n -> Trf (AST.UKind (Dom r) RangeStage) -trfKind' = trfKind'' . cleanHsType where - trfKind'' (HsTyVar _ (rdrName @n . unLoc -> Exact n)) +trfKind' :: forall n r p . (TransformName n r, Outputable (HsType n), Data (HsType n), n ~ GhcPass p) => HsKind n -> Trf (AST.UKind (Dom r) RangeStage) +trfKind' = trfKind'' where + trfKind'' (HsTyVar _ _ (rdrName @n . unLoc -> Exact n)) | isWiredInName n && occNameString (nameOccName n) == "*" = pure AST.UStarKind | isWiredInName n && occNameString (nameOccName n) == "#" = pure AST.UUnboxKind - trfKind'' (HsParTy kind) = AST.UParenKind <$> trfKind kind - trfKind'' (HsFunTy k1 k2) = AST.UFunKind <$> trfKind k1 <*> trfKind k2 - trfKind'' (HsAppTy k1 k2) = AST.UAppKind <$> trfKind k1 <*> trfKind k2 - trfKind'' (HsOpTy k1 op k2) = AST.UInfixAppKind <$> trfKind k1 <*> trfOperator @n op <*> trfKind k2 - trfKind'' (HsTyVar _ kv) = transformingPossibleVar kv (AST.UVarKind <$> trfName @n kv) - trfKind'' (HsListTy kind) = AST.UListKind <$> trfKind kind - trfKind'' (HsTupleTy _ kinds) = AST.UTupleKind <$> makeList ", " atTheStart (mapM trfKind kinds) - trfKind'' (HsAppsTy [unLoc -> HsAppPrefix t]) = trfKind' (unLoc t) - trfKind'' (HsAppsTy [unLoc -> HsAppInfix n]) = AST.UVarKind <$> trfName @n n + trfKind'' (HsStarTy _ _) = pure AST.UStarKind + trfKind'' (HsParTy _ kind) = AST.UParenKind <$> trfKind kind + trfKind'' (HsParTy _ kind) = AST.UParenKind <$> trfKind kind + trfKind'' (HsFunTy _ k1 k2) = AST.UFunKind <$> trfKind k1 <*> trfKind k2 + trfKind'' (HsAppTy _ k1 k2) = AST.UAppKind <$> trfKind k1 <*> trfKind k2 + trfKind'' (HsOpTy _ k1 op k2) = AST.UInfixAppKind <$> trfKind k1 <*> trfOperator @n op <*> trfKind k2 + trfKind'' (HsTyVar _ _ kv) = transformingPossibleVar kv (AST.UVarKind <$> trfName @n kv) + trfKind'' (HsListTy _ kind) = AST.UListKind <$> trfKind kind + trfKind'' (HsTupleTy _ _ kinds) = AST.UTupleKind <$> makeList ", " atTheStart (mapM trfKind kinds) trfKind'' pt@(HsExplicitListTy {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) trfKind'' pt@(HsExplicitTupleTy {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) trfKind'' pt@(HsTyLit {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) trfKind'' t = AST.UTypeKind <$> annContNoSema (trfType' t) -trfPromoted' :: forall n r a . (TransformName n r, HasNoSemanticInfo (Dom r) a) +trfPromoted' :: forall n r a . (TransformName n r, HasNoSemanticInfo (Dom r) a, Outputable (HsType n), Data (HsType n)) => (HsType n -> Trf (a (Dom r) RangeStage)) -> HsType n -> Trf (AST.UPromoted a (Dom r) RangeStage) -trfPromoted' _ (HsTyLit (HsNumTy _ int)) = pure $ AST.UPromotedInt int -trfPromoted' _ (HsTyLit (HsStrTy _ str)) = pure $ AST.UPromotedString (unpackFS str) -trfPromoted' _ (HsTyVar _ name) = AST.UPromotedCon <$> trfName @n name +trfPromoted' _ (HsTyLit _ (HsNumTy _ int)) = pure $ AST.UPromotedInt int +trfPromoted' _ (HsTyLit _ (HsStrTy _ str)) = pure $ AST.UPromotedString (unpackFS str) +trfPromoted' _ (HsTyVar _ _ name) = AST.UPromotedCon <$> trfName @n name trfPromoted' f (HsExplicitListTy _ _ elems) = AST.UPromotedList <$> between AnnOpenS AnnCloseS (trfAnnList ", " f elems) trfPromoted' f (HsExplicitTupleTy _ elems) = AST.UPromotedTuple <$> between AnnOpenP AnnCloseP (trfAnnList ", " f elems) trfPromoted' _ t = unhandledElement "promoted type/kind" t
Language/Haskell/Tools/BackendGHC/Literals.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- | Functions that convert the literals of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Literals where
Language/Haskell/Tools/BackendGHC/Modules.hs view
@@ -24,7 +24,6 @@ import FastString as GHC (unpackFS) import FieldLabel as GHC (FieldLbl(..)) import GHC -import Avail import SrcLoc as GHC import TcRnMonad as GHC (Applicative(..), (<$>)) @@ -73,7 +72,7 @@ exportSubspecsRngs = map (map AST.getRange) exportSubspecs replaceSubspecLocs :: [LIE GhcRn] -> [LIE GhcRn] - replaceSubspecLocs exps = zipWith (\ss ie -> case ie of (L l (IEThingWith n wc ls flds)) -> L l (IEThingWith n wc (replaceNames ss ls) (replaceFieldNames (drop (length ls) ss) flds)) + replaceSubspecLocs exps = zipWith (\ss ie -> case ie of (L l (IEThingWith ext n wc ls flds)) -> L l (IEThingWith ext n wc (replaceNames ss ls) (replaceFieldNames (drop (length ls) ss) flds)) _ -> ie) exportSubspecsRngs exps where replaceNames ss ls = zipWith (\(L _ iew) l -> case iew of IEName (L _ n) -> L l (IEName (L l n)) _ -> L l iew) ls ss @@ -107,9 +106,9 @@ -- | Extract the template haskell splices from the representation and adds them to the transformation state. loadSplices :: HsModule GhcPs -> Trf a -> Trf a loadSplices hsMod trf = do - let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] - exprSpls = mapMaybe (\case L l (HsSpliceE sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] - typeSpls = mapMaybe (\case L l (HsSpliceTy sp _) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] + let declSpls = map (\(SpliceDecl _ sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] + exprSpls = mapMaybe (\case L l (HsSpliceE _ sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] + typeSpls = mapMaybe (\case L l (HsSpliceTy _ sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice GhcPs)] setSplices declSpls typeSpls exprSpls trf trfModuleHead :: TransformName n r @@ -155,7 +154,7 @@ trfExport :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.UExportSpec (Dom r) RangeStage)) trfExport = trfMaybeLocNoSema $ \case - IEModuleContents n -> Just . AST.UModuleExport <$> (trfModuleName n) + IEModuleContents _ n -> Just . AST.UModuleExport <$> (trfModuleName n) other -> do trf <- trfIESpec' other fmap AST.UDeclExport <$> (sequence $ fmap (annContNoSema . return) trf) @@ -171,7 +170,7 @@ <*> (srcLocSpan . srcSpanEnd <$> tokenLoc AnnWhere)) trfImport :: TransformName n r => LImportDecl n -> Trf (Ann AST.UImportDecl (Dom r) RangeStage) -trfImport (L l (GHC.ImportDecl _ name pkg isSrc _ isQual _ declAs declHiding)) = focusOn l $ +trfImport (L l (GHC.ImportDecl _ _ name pkg isSrc _ isQual _ declAs declHiding)) = focusOn l $ do safeTok <- tokenLoc AnnSafe let -- default positions of optional parts of an import declaration annBeforeQual = if isSrc then AnnClose else AnnImport @@ -205,12 +204,12 @@ trfIESpec = trfMaybeLocNoSema trfIESpec' trfIESpec' :: forall n r . TransformName n r => IE n -> Trf (Maybe (AST.UIESpec (Dom r) RangeStage)) -trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) -trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) -trfIESpec' (IEThingAll n) +trfIESpec' (IEVar _ n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEThingAbs _ n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEThingAll _ n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (makeJust <$> subspec)) where subspec = annLocNoSema (combineSrcSpans <$> tokenLocBack AnnOpenP <*> tokenLocBack AnnCloseP) (pure AST.USubSpecAll) -trfIESpec' (IEThingWith n _ ls flds) +trfIESpec' (IEThingWith _ n _ ls flds) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName @n (getWrappedName n) <*> (makeJust <$> subspec)) where subspec = annLocNoSema (combineSrcSpans <$> tokenLocBack AnnOpenP <*> tokenLocBack AnnCloseP) $ AST.USubSpecList <$> between AnnOpenP AnnCloseP (makeList ", " atTheStart ((++) <$> mapM ((trfName @n) . getWrappedName) ls <*> mapM (trfName @n) (map (fmap flSelector) flds)))
Language/Haskell/Tools/BackendGHC/Monad.hs view
@@ -147,7 +147,7 @@ -- group up locals by name $ 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 } + 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))) @@ -158,12 +158,12 @@ return $ fromMaybe (throw $ SpliceInsertionProblem rng typecheckErrors) (snd tcSpl) where - tcHsSplice' (HsTypedSplice dec id e) - = HsTypedSplice dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) - tcHsSplice' (HsUntypedSplice dec id e) - = HsUntypedSplice dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) - tcHsSplice' (HsQuasiQuote id1 id2 sp fs) - = pure $ HsQuasiQuote (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs + 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)]
Language/Haskell/Tools/BackendGHC/Names.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} -- | Functions that convert the basic elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Names where @@ -13,6 +14,7 @@ import Control.Monad.Reader ((=<<), asks) import Data.Char (isAlphaNum) import Data.List.Split (splitOn) +import Data.Data (Data) import FastString as GHC (FastString, unpackFS) import HsSyn as GHC @@ -22,6 +24,9 @@ import RdrName as GHC (RdrName) import SrcLoc as GHC import qualified Id as GHC (Id) +import HsLit as GHC (OverLitVal(..), HsLit(..)) +import Outputable (Outputable) +import HsTypes as GHC import Language.Haskell.Tools.AST (Ann(..), AnnListG, RangeStage, Dom) import qualified Language.Haskell.Tools.AST as AST @@ -52,22 +57,44 @@ trfAmbiguousFieldName (L l af) = trfAmbiguousFieldName' l af trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UName (Dom r) RangeStage) -trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' @n (unpackPostRn @n rdr pr) +trfAmbiguousFieldName' l (Unambiguous pr (L _ rdr)) = annLocNoSema (pure l) $ trfName' @n (fieldOccToId @n rdr pr) -- no Id transformation is done, so we can basically ignore the postTC value -trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _) +trfAmbiguousFieldName' _ (Ambiguous _ (L l rdr)) = annLocNoSema (pure l) $ (if (isSymOcc (occName @GhcPs rdr)) then AST.UParenName else AST.UNormalName) <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (isSymOcc (occName @GhcPs rdr)) (rdrNameStr rdr)) trfAmbiguousOperator' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UOperator (Dom r) RangeStage) -trfAmbiguousOperator' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfOperator' @n (unpackPostRn @n rdr pr) +trfAmbiguousOperator' l (Unambiguous pr (L _ rdr)) = annLocNoSema (pure l) $ trfOperator' @n (fieldOccToId @n rdr pr) -- no Id transformation is done, so we can basically ignore the postTC value -trfAmbiguousOperator' _ (Ambiguous (L l rdr) _) +trfAmbiguousOperator' _ (Ambiguous _ (L l rdr)) = annLocNoSema (pure l) $ (if (isSymOcc (occName @GhcPs rdr)) then AST.UNormalOp else AST.UBacktickOp) <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfOperatorStr (not $ isSymOcc (occName @GhcPs rdr)) (rdrNameStr rdr)) -class (DataId n, Eq n, GHCName n, FromGHCName (IdP n), NameOrRdrName (IdP n) ~ IdP n, HasOccName (IdP n), SourceTextX n) +type CorrectPass n = ( Data (HsLit n), Outputable (HsLit n) + , Data (HsType n), Outputable (HsType n) + , Data (Pat n), Outputable (Pat n) + , Data (HsExpr n), Outputable (HsExpr n) + , Data (Stmt n (LHsExpr n)), Outputable (Stmt n (LHsExpr n)) + , Data (Stmt n (LHsCmd n)), Outputable (Stmt n (LHsCmd n)) + , Data (HsCmd n), Outputable (HsCmd n) + , Data (Sig n), Outputable (Sig n) + , Data (HsLocalBinds n), Outputable (HsLocalBinds n) + , Data (HsBind n), Outputable (HsBind n) + , Data (IdP n), Outputable (IdP n) + , Data (ConDecl n), Outputable (ConDecl n) + , Data (HsDecl n), Outputable (HsDecl n) + , Data (HsSplice n), Outputable (HsSplice n) + ) + +type ConvOk n = ( XSigPat n ~ HsWildCardBndrs n (HsImplicitBndrs n (LHsType n)) + , XExprWithTySig n ~ LHsSigWcType n + , XAppTypeE n ~ LHsWcType n + , NameOrRdrName (IdP n) ~ IdP n + ) + +class (ConvOk n, Eq n, CorrectPass n, GHCName n, FromGHCName (IdP n), HasOccName (IdP n)) => TransformableName n where correctNameString :: IdP n -> Trf String transformSplice :: HsSplice GhcPs -> Trf (HsSplice n) @@ -82,7 +109,7 @@ -- | This class allows us to use the same transformation code for multiple variants of the GHC AST. -- GHC UName annotated with 'name' can be transformed to our representation with semantic annotations of 'res'. -class (TransformableName name, HsHasName (IdP name), FromGHCName (IdP res), Eq (IdP name) {-, TransformableName res, HsHasName res -}, GHCName res, NameOrRdrName (IdP name) ~ (IdP name)) +class (TransformableName name, HsHasName (IdP name), FromGHCName (IdP res), Eq (IdP name), GHCName res, NameOrRdrName (IdP name) ~ (IdP name), XUnambiguous name ~ XCFieldOcc name) => TransformName name res where -- | Demote a given name transformName :: IdP name -> IdP res
Language/Haskell/Tools/BackendGHC/Patterns.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the pattern-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Patterns where @@ -12,30 +14,31 @@ import HsExpr (HsSplice(..)) import HsLit as GHC (HsOverLit(..)) import HsPat as GHC -import HsTypes as GHC (HsWildCardBndrs(..), HsImplicitBndrs(..), HsConDetails(..)) +import HsTypes as GHC (HsConDetails(..), hswc_body, hsib_body) import Language.Haskell.Tools.BackendGHC.GHCUtils (getFieldOccName) import SrcLoc as GHC import Control.Monad.Reader +import HsExtension (GhcPass) import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.Exprs (trfExpr) +import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.Types (trfType) import Language.Haskell.Tools.AST.SemaInfoTypes import Language.Haskell.Tools.BackendGHC.Literals import Language.Haskell.Tools.BackendGHC.Monad import Language.Haskell.Tools.BackendGHC.Names (TransformName(..), trfOperator, trfName) import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.TH (trfSplice, trfQuasiQuotation') -import Language.Haskell.Tools.BackendGHC.Types (trfType) import Language.Haskell.Tools.BackendGHC.Utils import Language.Haskell.Tools.AST (Ann, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfPattern :: forall n r . TransformName n r => Located (Pat n) -> Trf (Ann AST.UPattern (Dom r) RangeStage) +trfPattern :: forall n r p . (TransformName n r, n ~ GhcPass p) => Located (Pat n) -> Trf (Ann AST.UPattern (Dom r) RangeStage) -- field wildcards are not directly represented in GHC AST trfPattern (L l (ConPatIn name (RecCon (HsRecFields flds _)))) | any ((l ==) . getLoc) flds = focusOn l $ do let (fromWC, notWC) = partition ((l ==) . getLoc) flds normalFields <- mapM (trfLocNoSema trfPatternField') notWC - wildc <- annLocNoSema (tokenLocBack AnnDotdot) (AST.UFieldWildcardPattern <$> annCont (createImplicitFldInfo (unLoc . (\(VarPat n) -> n) . unLoc) (map unLoc fromWC)) (pure AST.FldWildcard)) + wildc <- annLocNoSema (tokenLocBack AnnDotdot) (AST.UFieldWildcardPattern <$> annCont (createImplicitFldInfo (unLoc . (\(VarPat _ n) -> n) . unLoc) (map unLoc fromWC)) (pure AST.FldWildcard)) annLocNoSema (pure l) (AST.URecPat <$> trfName @n name <*> makeNonemptyList ", " (pure (normalFields ++ [wildc]))) trfPattern p = trfLocNoSema trfPattern' (correctPatternLoc p) @@ -45,29 +48,28 @@ = L (getLoc (correctPatternLoc left) `combineSrcSpans` getLoc (correctPatternLoc right)) p correctPatternLoc p = p -trfPattern' :: forall n r . TransformName n r => Pat n -> Trf (AST.UPattern (Dom r) RangeStage) +trfPattern' :: forall n r p . (TransformName n r, n ~ GhcPass p) => Pat n -> Trf (AST.UPattern (Dom r) RangeStage) trfPattern' (WildPat _) = pure AST.UWildPat -trfPattern' (VarPat name) = define $ AST.UVarPat <$> trfName @n name -trfPattern' (LazyPat pat) = AST.UIrrefutablePat <$> trfPattern pat -trfPattern' (AsPat name pat) = AST.UAsPat <$> define (trfName @n name) <*> trfPattern pat -trfPattern' (ParPat pat) = AST.UParenPat <$> trfPattern pat -trfPattern' (BangPat pat) = AST.UBangPat <$> trfPattern pat -trfPattern' (ListPat pats _ _) = AST.UListPat <$> makeList ", " atTheEnd (mapM trfPattern pats) -trfPattern' (TuplePat pats Boxed _) = AST.UTuplePat <$> makeList ", " atTheEnd (mapM trfPattern pats) -trfPattern' (TuplePat pats Unboxed _) = AST.UUnboxTuplePat <$> makeList ", " atTheEnd (mapM trfPattern pats) -trfPattern' (PArrPat pats _) = AST.UParArrPat <$> makeList ", " atTheEnd (mapM trfPattern pats) +trfPattern' (VarPat _ name) = define $ AST.UVarPat <$> trfName @n name +trfPattern' (LazyPat _ pat) = AST.UIrrefutablePat <$> trfPattern pat +trfPattern' (AsPat _ name pat) = AST.UAsPat <$> define (trfName @n name) <*> trfPattern pat +trfPattern' (ParPat _ pat) = AST.UParenPat <$> trfPattern pat +trfPattern' (BangPat _ pat) = AST.UBangPat <$> trfPattern pat +trfPattern' (ListPat _ pats) = AST.UListPat <$> makeList ", " atTheEnd (mapM trfPattern pats) +trfPattern' (TuplePat _ pats Boxed) = AST.UTuplePat <$> makeList ", " atTheEnd (mapM trfPattern pats) +trfPattern' (TuplePat _ pats Unboxed) = AST.UUnboxTuplePat <$> makeList ", " atTheEnd (mapM trfPattern pats) trfPattern' (ConPatIn name (PrefixCon args)) = AST.UAppPat <$> trfName @n name <*> makeList " " atTheEnd (mapM trfPattern args) trfPattern' (ConPatIn name (RecCon (HsRecFields flds _))) = AST.URecPat <$> trfName @n name <*> trfAnnList ", " trfPatternField' flds trfPattern' (ConPatIn name (InfixCon left right)) = AST.UInfixAppPat <$> trfPattern left <*> trfOperator @n name <*> trfPattern right -trfPattern' (ViewPat expr pat _) = AST.UViewPat <$> trfExpr expr <*> trfPattern pat -trfPattern' (SplicePat qq@(HsQuasiQuote {})) = AST.UQuasiQuotePat <$> annContNoSema (trfQuasiQuotation' qq) -trfPattern' (SplicePat splice) = AST.USplicePat <$> trfSplice splice -trfPattern' (LitPat lit) = AST.ULitPat <$> annCont (pure $ RealLiteralInfo (monoLiteralType lit)) (trfLiteral' lit) -trfPattern' (SigPatIn pat (hsib_body . hswc_body -> typ)) = AST.UTypeSigPat <$> trfPattern pat <*> trfType typ -trfPattern' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.ULitPat <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit lit) -trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.UNPlusKPat <$> define (trfName @n id) <*> annLoc (asks contRange >>= pure . PreLiteralInfo) (pure l) (trfOverloadedLit (ol_val lit)) -trfPattern' (CoPat _ pat _) = trfPattern' pat -- coercion pattern introduced by GHC -trfPattern' (SumPat pat tag arity _) +trfPattern' (ViewPat _ expr pat) = AST.UViewPat <$> trfExpr expr <*> trfPattern pat +trfPattern' (SplicePat _ qq@(HsQuasiQuote {})) = AST.UQuasiQuotePat <$> annContNoSema (trfQuasiQuotation' qq) +trfPattern' (SplicePat _ splice) = AST.USplicePat <$> trfSplice splice +trfPattern' (LitPat _ lit) = AST.ULitPat <$> annCont (pure $ RealLiteralInfo (monoLiteralType lit)) (trfLiteral' lit) +trfPattern' (NPat _ (ol_val . unLoc -> lit) _ _) = AST.ULitPat <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit lit) +trfPattern' (NPlusKPat _ id (L l lit) _ _ _) = AST.UNPlusKPat <$> define (trfName @n id) <*> annLoc (asks contRange >>= pure . PreLiteralInfo) (pure l) (trfOverloadedLit (ol_val lit)) +trfPattern' (SigPat typ pat) = AST.UTypeSigPat <$> trfPattern pat <*> trfType (hsib_body $ hswc_body typ) +trfPattern' (CoPat _ _ pat _) = trfPattern' pat -- coercion pattern introduced by GHC +trfPattern' (SumPat _ pat tag arity) = do sepsBefore <- focusBeforeLoc (srcSpanStart (getLoc pat)) (eachTokenLoc (AnnOpen : replicate (tag - 1) AnnVbar)) sepsAfter <- focusAfterLoc (srcSpanEnd (getLoc pat)) (eachTokenLoc (replicate (arity - tag) AnnVbar)) let locsBefore = map srcSpanEnd $ init sepsBefore @@ -78,6 +80,6 @@ where makePlaceholder l = annLocNoSema (pure (srcLocSpan l)) (pure AST.UUnboxedSumPlaceHolder) trfPattern' p = unhandledElement "pattern" p -trfPatternField' :: forall n r . TransformName n r => HsRecField n (LPat n) -> Trf (AST.UPatternField (Dom r) RangeStage) +trfPatternField' :: forall n r p . (TransformName n r, n ~ GhcPass p) => HsRecField n (LPat n) -> Trf (AST.UPatternField (Dom r) RangeStage) trfPatternField' (HsRecField id arg False) = AST.UNormalFieldPattern <$> trfName @n (getFieldOccName id) <*> trfPattern arg trfPatternField' (HsRecField id _ True) = AST.UFieldPunPattern <$> trfName @n (getFieldOccName id)
Language/Haskell/Tools/BackendGHC/Stmts.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} -- | Functions that convert the statement-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Stmts where @@ -11,6 +12,7 @@ import HsExpr as GHC import Outputable (Outputable) import SrcLoc as GHC +import HsExtension (GhcPass) import Language.Haskell.Tools.AST (Ann, AnnListG, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST @@ -23,25 +25,25 @@ import Data.Data (Data) -trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.UStmt (Dom r) RangeStage) +trfDoStmt :: (TransformName n r, n ~ GhcPass p) => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.UStmt (Dom r) RangeStage) trfDoStmt = trfLocNoSema trfDoStmt' -trfDoStmt' :: TransformName n r => Stmt n (Located (HsExpr n)) -> Trf (AST.UStmt' AST.UExpr (Dom r) RangeStage) +trfDoStmt' :: (TransformName n r, n ~ GhcPass p) => Stmt n (Located (HsExpr n)) -> Trf (AST.UStmt' AST.UExpr (Dom r) RangeStage) trfDoStmt' = gTrfDoStmt' trfExpr -gTrfDoStmt' :: (TransformName n r, Data (ge n), Outputable (ge n)) +gTrfDoStmt' :: (TransformName n r, Data (ge n), Outputable (ge n), n ~ GhcPass p, Data (Stmt n (Located (ge n)))) => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Stmt n (Located (ge n)) -> Trf (AST.UStmt' ae (Dom r) RangeStage) -gTrfDoStmt' et (BindStmt pat expr _ _ _) = AST.UBindStmt <$> trfPattern pat <*> et expr -gTrfDoStmt' et (BodyStmt expr _ _ _) = AST.UExprStmt <$> et expr -gTrfDoStmt' _ (LetStmt (unLoc -> binds)) = AST.ULetStmt . orderAnnList <$> addToScope binds (trfLocalBinds AnnLet binds) -gTrfDoStmt' et (LastStmt body _ _) = AST.UExprStmt <$> et body +gTrfDoStmt' et (BindStmt _ pat expr _ _) = AST.UBindStmt <$> trfPattern pat <*> et expr +gTrfDoStmt' et (BodyStmt _ expr _ _) = AST.UExprStmt <$> et expr +gTrfDoStmt' _ (LetStmt _ (unLoc -> binds)) = AST.ULetStmt . orderAnnList <$> addToScope binds (trfLocalBinds AnnLet binds) +gTrfDoStmt' et (LastStmt _ body _ _) = AST.UExprStmt <$> et body gTrfDoStmt' et (RecStmt { recS_stmts = stmts }) = AST.URecStmt <$> trfAnnList "," (gTrfDoStmt' et) stmts gTrfDoStmt' _ stmt = unhandledElement "simple statement" stmt -trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnListG AST.UListCompBody (Dom r) RangeStage) -trfListCompStmts [unLoc -> ParStmt blocks _ _ _, unLoc -> (LastStmt {})] +trfListCompStmts :: (TransformName n r, n ~ GhcPass p) => [Located (Stmt n (LHsExpr n))] -> Trf (AnnListG AST.UListCompBody (Dom r) RangeStage) +trfListCompStmts [unLoc -> ParStmt _ blocks _ _, unLoc -> (LastStmt {})] = nonemptyAnnList - <$> trfScopedSequence (\(ParStmtBlock stmts _ _) -> + <$> trfScopedSequence (\(ParStmtBlock _ stmts _ _) -> let ann = collectLocs $ getNormalStmts stmts in annLocNoSema (pure ann) (AST.UListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt stmts)) ) blocks @@ -51,15 +53,15 @@ ((:[]) <$> annLocNoSema (pure ann) (AST.UListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt others))) -trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.UCompStmt (Dom r) RangeStage] +trfListCompStmt :: (TransformName n r, n ~ GhcPass p) => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.UCompStmt (Dom r) RangeStage] trfListCompStmt (L _ trst@(TransStmt { trS_stmts = stmts })) = (++) <$> (concat <$> local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanEnd (getLoc (last stmts))) }) (trfScopedSequence trfListCompStmt stmts)) <*> ((:[]) <$> extractActualStmt trst) -- last statement is extracted -trfListCompStmt (unLoc -> LastStmt _ _ _) = pure [] +trfListCompStmt (unLoc -> LastStmt _ _ _ _) = pure [] trfListCompStmt other = (:[]) <$> copyAnnot AST.UCompStmt (trfDoStmt other) -extractActualStmt :: TransformName n r => Stmt n (LHsExpr n) -> Trf (Ann AST.UCompStmt (Dom r) RangeStage) +extractActualStmt :: (TransformName n r, n ~ GhcPass p) => Stmt n (LHsExpr n) -> Trf (Ann AST.UCompStmt (Dom r) RangeStage) extractActualStmt = \case TransStmt { trS_form = ThenForm, trS_using = using, trS_by = by } -> addAnnotation by using (AST.UThenStmt <$> trfExpr using <*> trfMaybe "," "" trfExpr by) @@ -71,11 +73,11 @@ <$> tokenLocBack AnnThen) getNormalStmts :: [Located (Stmt n (LHsExpr n))] -> [Located (Stmt n (LHsExpr n))] -getNormalStmts (L _ (LastStmt _ _ _) : rest) = getNormalStmts rest +getNormalStmts (L _ (LastStmt _ _ _ _) : rest) = getNormalStmts rest getNormalStmts (stmt : rest) = stmt : getNormalStmts rest getNormalStmts [] = [] getLastStmt :: [Located (Stmt n (LHsExpr n))] -> Located (HsExpr n) -getLastStmt (L _ (LastStmt body _ _) : _) = body +getLastStmt (L _ (LastStmt _ body _ _) : _) = body getLastStmt (_ : rest) = getLastStmt rest getLastStmt [] = convProblem "getLastStmt: empty"
Language/Haskell/Tools/BackendGHC/TH.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications, TypeFamilies #-} -- | Functions that convert the Template-Haskell-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.TH where @@ -8,6 +8,7 @@ import FastString as GHC (unpackFS) import HsExpr as GHC (HsSplice(..), HsExpr(..), HsBracket(..)) import SrcLoc as GHC +import HsExtension (GhcPass) import Language.Haskell.Tools.BackendGHC.Decls (trfDecls, trfDeclsGroup) import Language.Haskell.Tools.BackendGHC.Exprs (trfExpr, createScopeInfo) @@ -22,7 +23,7 @@ trfQuasiQuotation' :: forall n r . TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage) -- the lexer does not provide us with tokens '[', '|' and '|]' -trfQuasiQuotation' (HsQuasiQuote _ id l str) +trfQuasiQuotation' (HsQuasiQuote _ _ id l str) = AST.UQuasiQuote <$> annLocNoSema quoterLoc (trfName' @n id) <*> annLocNoSema (pure strLoc) (pure $ AST.QQString (unpackFS str)) where -- assume that there are no white spaces ain the head and the end of the quasi quote @@ -31,23 +32,23 @@ strLoc = mkSrcSpan (srcSpanStart l) (updateCol (subtract 2) (srcSpanEnd l)) trfQuasiQuotation' qq = unhandledElement "quasi quotation" qq -trfSplice :: TransformName n r => HsSplice n -> Trf (Ann AST.USplice (Dom r) RangeStage) +trfSplice :: (TransformName n r, n ~ GhcPass p) => HsSplice n -> Trf (Ann AST.USplice (Dom r) RangeStage) trfSplice spls = do rng <- asks contRange annLocNoSema (pure $ getSpliceLoc spls `mappend` rng) (trfSplice' spls) getSpliceLoc :: HsSplice a -> SrcSpan -getSpliceLoc (HsTypedSplice _ _ e) = getLoc e -getSpliceLoc (HsUntypedSplice _ _ e) = getLoc e -getSpliceLoc (HsQuasiQuote _ _ sp _) = sp -getSpliceLoc (HsSpliced _ _) = noSrcSpan +getSpliceLoc (HsTypedSplice _ _ _ e) = getLoc e +getSpliceLoc (HsUntypedSplice _ _ _ e) = getLoc e +getSpliceLoc (HsQuasiQuote _ _ _ sp _) = sp +getSpliceLoc (HsSpliced _ _ _) = noSrcSpan -trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) -trfSplice' (HsTypedSplice _ _ expr) = trfSpliceExpr expr -trfSplice' (HsUntypedSplice _ _ expr) = trfSpliceExpr expr +trfSplice' :: (TransformName n r, n ~ GhcPass p) => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) +trfSplice' (HsTypedSplice _ _ _ expr) = trfSpliceExpr expr +trfSplice' (HsUntypedSplice _ _ _ expr) = trfSpliceExpr expr trfSplice' s = unhandledElement "splice" s -- | TODO: easier with splice decoration -trfSpliceExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (AST.USplice (Dom r) RangeStage) +trfSpliceExpr :: forall n r p . (TransformName n r, n ~ GhcPass p) => Located (HsExpr n) -> Trf (AST.USplice (Dom r) RangeStage) trfSpliceExpr expr = do hasDollar <- allTokenLoc AnnThIdSplice hasDoubleDollar <- allTokenLoc AnnThIdTySplice @@ -55,17 +56,17 @@ ([], []) -> getLoc expr (_, []) -> updateStart (updateCol (+1)) (getLoc expr) ([], _) -> updateStart (updateCol (+2)) (getLoc expr) - case expr of L _ (HsVar (L _ varName)) -> AST.UIdSplice <$> trfName @n (L newSp varName) - L _ (HsRecFld fldName) -> AST.UIdSplice <$> trfAmbiguousFieldName' newSp fldName + case expr of L _ (HsVar _ (L _ varName)) -> AST.UIdSplice <$> trfName @n (L newSp varName) + L _ (HsRecFld _ fldName) -> AST.UIdSplice <$> trfAmbiguousFieldName' newSp fldName expr -> AST.UParenSplice <$> trfExpr expr -trfBracket' :: forall n r . TransformName n r => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage) -trfBracket' (ExpBr expr) = AST.UExprBracket <$> trfExpr expr -trfBracket' (TExpBr expr) = AST.UExprBracket <$> trfExpr expr -trfBracket' (VarBr isSingle expr) +trfBracket' :: forall n r p . (TransformName n r, n ~ GhcPass p) => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage) +trfBracket' (ExpBr _ expr) = AST.UExprBracket <$> trfExpr expr +trfBracket' (TExpBr _ expr) = AST.UExprBracket <$> trfExpr expr +trfBracket' (VarBr _ isSingle expr) = AST.UExprBracket <$> annLoc createScopeInfo (updateStart (updateCol (if isSingle then (+1) else (+2))) <$> asks contRange) (AST.UVar <$> (annContNoSema (trfName' @n expr))) -trfBracket' (PatBr pat) = AST.UPatternBracket <$> trfPattern pat -trfBracket' (DecBrL decls) = AST.UDeclsBracket <$> trfDecls decls -trfBracket' (DecBrG decls) = AST.UDeclsBracket <$> trfDeclsGroup decls -trfBracket' (TypBr typ) = AST.UTypeBracket <$> trfType typ +trfBracket' (PatBr _ pat) = AST.UPatternBracket <$> trfPattern pat +trfBracket' (DecBrL _ decls) = AST.UDeclsBracket <$> trfDecls decls +trfBracket' (DecBrG _ decls) = AST.UDeclsBracket <$> trfDeclsGroup decls +trfBracket' (TypBr _ typ) = AST.UTypeBracket <$> trfType typ
Language/Haskell/Tools/BackendGHC/TH.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Tools.BackendGHC.TH where import HsExpr as GHC (HsSplice, HsBracket) @@ -5,8 +6,9 @@ import qualified Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.BackendGHC.Monad (Trf) import Language.Haskell.Tools.BackendGHC.Names (TransformName(..)) +import HsExtension (GhcPass) trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage) -trfSplice :: TransformName n r => HsSplice n -> Trf (Ann AST.USplice (Dom r) RangeStage) -trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) -trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage) +trfSplice :: (TransformName n r, n ~ GhcPass p) => HsSplice n -> Trf (Ann AST.USplice (Dom r) RangeStage) +trfSplice' :: (TransformName n r, n ~ GhcPass p) => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) +trfBracket' :: (TransformName n r, n ~ GhcPass p) => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/Types.hs view
@@ -1,18 +1,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the type-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Types where import ApiAnnotation as GHC (AnnKeywordId(..)) import HsExpr (HsSplice(..)) -import HsExtension (IdP) import HsTypes as GHC -import Id (mkVanillaGlobal) import SrcLoc as GHC -import TyCon as GHC (TyCon(..)) -import TysWiredIn (heqTyCon) +import HsExtension (GhcPass) import Control.Applicative (Applicative(..), (<$>), Alternative(..)) import Control.Monad.Reader.Class (asks) @@ -20,16 +19,16 @@ import Data.Function (on) import Data.List import Data.Maybe (Maybe(..), fromJust) +import GHC.Stack (HasCallStack) import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.BackendGHC.GHCUtils (GHCName(..), cleanHsType) import Language.Haskell.Tools.BackendGHC.Kinds (trfKindSig, trfKind, trfPromoted') import Language.Haskell.Tools.BackendGHC.Monad import Language.Haskell.Tools.BackendGHC.Names import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.TH (trfSplice, trfQuasiQuotation') import Language.Haskell.Tools.BackendGHC.Utils -trfType :: forall n r . TransformName n r => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage) +trfType :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage) trfType typ | RealSrcSpan loce <- getLoc typ = do othSplices <- asks typeSplices let contSplice = filter (\sp -> case getLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) othSplices @@ -38,56 +37,55 @@ in typeSpliceInserted lsp (annLocNoSema (pure l) (AST.UTySplice <$> (trfSplice =<< rdrSplice sp))) | otherwise = trfLocNoSema trfType' typ -trfType' :: forall n r . TransformName n r => HsType n -> Trf (AST.UType (Dom r) RangeStage) -trfType' = trfType'' . cleanHsType where +trfType' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UType (Dom r) RangeStage) +trfType' = trfType'' where trfType'' :: HsType n -> Trf (AST.UType (Dom r) RangeStage) - trfType'' (HsForAllTy [] typ) = trfType' (unLoc typ) - trfType'' (HsForAllTy bndrs typ) = AST.UTyForall <$> defineTypeVars (trfBindings bndrs) - <*> addToScope bndrs (trfType typ) - trfType'' (HsQualTy (L _ []) typ) = trfType' (unLoc typ) - trfType'' (HsQualTy ctx typ) = AST.UTyCtx <$> (fromJust . (^. annMaybe) <$> trfCtx atTheStart ctx) - <*> trfType typ - trfType'' (HsTyVar _ name) = AST.UTyVar <$> transformingPossibleVar name (trfName @n name) - trfType'' (HsAppsTy apps) | Just (head, args, _) <- getAppsTyHead_maybe apps - = foldl (\core t -> AST.UTyApp <$> annLocNoSema (pure $ getLoc head `combineSrcSpans` getLoc t) core <*> trfType t) (trfType' (unLoc head)) args - trfType'' (HsAppTy t1 t2) = AST.UTyApp <$> trfType t1 <*> trfType t2 - trfType'' (HsFunTy t1 t2) = AST.UTyFun <$> trfType t1 <*> trfType t2 - trfType'' (HsListTy typ) = AST.UTyList <$> trfType typ - trfType'' (HsPArrTy typ) = AST.UTyParArray <$> trfType typ - trfType'' (HsTupleTy HsBoxedOrConstraintTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs - trfType'' (HsTupleTy HsBoxedTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs - trfType'' (HsTupleTy HsUnboxedTuple typs) = AST.UTyUnbTuple <$> trfAnnList ", " trfType' typs - trfType'' (HsOpTy t1 op t2) = AST.UTyInfix <$> trfType t1 <*> trfOperator @n op <*> trfType t2 - trfType'' (HsParTy typ) = AST.UTyParen <$> trfType typ - trfType'' (HsKindSig typ kind) = AST.UTyKinded <$> trfType typ <*> trfKind kind - trfType'' (HsSpliceTy qq@(HsQuasiQuote {}) _) = AST.UTyQuasiQuote <$> annContNoSema (trfQuasiQuotation' qq) - trfType'' (HsSpliceTy splice _) = AST.UTySplice <$> trfSplice splice - trfType'' (HsBangTy (HsSrcBang _ SrcUnpack _) typ) = AST.UTyUnpack <$> trfType typ - trfType'' (HsBangTy (HsSrcBang _ SrcNoUnpack _) typ) = AST.UTyNoUnpack <$> trfType typ - trfType'' (HsBangTy (HsSrcBang _ _ SrcStrict) typ) = AST.UTyBang <$> trfType typ - trfType'' (HsBangTy (HsSrcBang _ _ SrcLazy) typ) = AST.UTyLazy <$> trfType typ + trfType'' (HsForAllTy _ [] typ) = trfType' (unLoc typ) + trfType'' (HsForAllTy _ bndrs typ) = AST.UTyForall <$> defineTypeVars (trfBindings bndrs) + <*> addToScope bndrs (trfType typ) + trfType'' (HsQualTy _ (L _ []) typ) = trfType' (unLoc typ) + trfType'' (HsQualTy _ ctx typ) = AST.UTyCtx <$> (fromJust . (^. annMaybe) <$> trfCtx atTheStart ctx) + <*> trfType typ + trfType'' (HsTyVar _ _ name) = AST.UTyVar <$> transformingPossibleVar name (trfName @n name) + trfType'' (HsAppTy _ t1 t2) = AST.UTyApp <$> trfType t1 <*> trfType t2 + trfType'' (HsFunTy _ t1 t2) = AST.UTyFun <$> trfType t1 <*> trfType t2 + trfType'' (HsListTy _ typ) = AST.UTyList <$> trfType typ + -- trfType'' (HsPArrTy _ typ) = AST.UTyParArray <$> trfType typ + trfType'' (HsTupleTy _ HsBoxedOrConstraintTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs + trfType'' (HsTupleTy _ HsBoxedTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs + trfType'' (HsTupleTy _ HsUnboxedTuple typs) = AST.UTyUnbTuple <$> trfAnnList ", " trfType' typs + trfType'' (HsOpTy _ t1 op t2) = AST.UTyInfix <$> trfType t1 <*> trfOperator @n op <*> trfType t2 + trfType'' (HsParTy _ typ) = AST.UTyParen <$> trfType typ + trfType'' (HsKindSig _ typ kind) = AST.UTyKinded <$> trfType typ <*> trfKind kind + trfType'' (HsSpliceTy _ qq@(HsQuasiQuote {})) = AST.UTyQuasiQuote <$> annContNoSema (trfQuasiQuotation' qq) + trfType'' (HsSpliceTy _ splice) = AST.UTySplice <$> trfSplice splice + trfType'' (HsBangTy _ (HsSrcBang _ SrcUnpack _) typ) = AST.UTyUnpack <$> trfType typ + trfType'' (HsBangTy _ (HsSrcBang _ SrcNoUnpack _) typ) = AST.UTyNoUnpack <$> trfType typ + trfType'' (HsBangTy _ (HsSrcBang _ _ SrcStrict) typ) = AST.UTyBang <$> trfType typ + trfType'' (HsBangTy _ (HsSrcBang _ _ SrcLazy) typ) = AST.UTyLazy <$> trfType typ trfType'' pt@(HsExplicitListTy {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' pt@(HsExplicitTupleTy {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' pt@(HsTyLit {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' (HsWildCardTy _) = pure AST.UTyWildcard -- TODO: named wildcards - trfType'' (HsSumTy types) = AST.UUnbSumType <$> trfAnnList " | " trfType' types + trfType'' (HsSumTy _ types) = AST.UUnbSumType <$> trfAnnList " | " trfType' types trfType'' t = unhandledElement "type" t -trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage) +trfBindings :: (TransformName n r, n ~ GhcPass p, HasCallStack) => [Located (HsTyVarBndr n)] -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage) +trfBindings [] = makeList " " atTheStart (pure []) trfBindings vars = trfAnnList " " trfTyVar' vars -trfTyVar :: TransformName n r => Located (HsTyVarBndr n) -> Trf (Ann AST.UTyVar (Dom r) RangeStage) +trfTyVar :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsTyVarBndr n) -> Trf (Ann AST.UTyVar (Dom r) RangeStage) trfTyVar = trfLocNoSema trfTyVar' -trfTyVar' :: forall n r . TransformName n r => HsTyVarBndr n -> Trf (AST.UTyVar (Dom r) RangeStage) -trfTyVar' (UserTyVar name) = AST.UTyVarDecl <$> typeVarTransform (trfName @n name) - <*> (nothing " " "" atTheEnd) -trfTyVar' (KindedTyVar name kind) = AST.UTyVarDecl <$> typeVarTransform (trfName @n name) - <*> trfKindSig (Just kind) +trfTyVar' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsTyVarBndr n -> Trf (AST.UTyVar (Dom r) RangeStage) +trfTyVar' (UserTyVar _ name) = AST.UTyVarDecl <$> typeVarTransform (trfName @n name) + <*> (nothing " " "" atTheEnd) +trfTyVar' (KindedTyVar _ name kind) = AST.UTyVarDecl <$> typeVarTransform (trfName @n name) + <*> trfKindSig (Just kind) -trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage) +trfCtx :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage) trfCtx sp (L _ []) = nothing " " "" sp -trfCtx _ (L l [L _ (HsParTy t)]) +trfCtx _ (L l [L _ (HsParTy _ t)]) = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) (AST.UContext <$> annLocNoSema (pure l) (AST.UTupleAssert <$> (trfAnnList ", " trfAssertion' [t]))) trfCtx _ (L l [t]) @@ -96,28 +94,28 @@ trfCtx _ (L l ctx) = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) (AST.UContext <$> annLocNoSema (pure l) (AST.UTupleAssert <$> (trfAnnList ", " trfAssertion' ctx))) -trfAssertion :: TransformName n r => LHsType n -> Trf (Ann AST.UAssertion (Dom r) RangeStage) +trfAssertion :: (TransformName n r, n ~ GhcPass p, HasCallStack) => LHsType n -> Trf (Ann AST.UAssertion (Dom r) RangeStage) trfAssertion = trfLocNoSema trfAssertion' -trfAssertion' :: forall n r . TransformName n r => HsType n -> Trf (AST.UAssertion (Dom r) RangeStage) -trfAssertion' (cleanHsType -> HsParTy t) +trfAssertion' :: forall n r p . (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UAssertion (Dom r) RangeStage) +trfAssertion' (HsParTy _ t) = trfAssertion' (unLoc t) -trfAssertion' (cleanHsType -> HsOpTy left op right) +trfAssertion' (HsOpTy _ left op right) = AST.UInfixAssert <$> trfType left <*> trfOperator @n op <*> trfType right -trfAssertion' (cleanHsType -> HsTupleTy _ tys) +trfAssertion' (HsTupleTy _ _ tys) = AST.UTupleAssert <$> makeList ", " (after AnnOpenP) (mapM trfAssertion tys) -trfAssertion' (cleanHsType -> HsWildCardTy _) +trfAssertion' (HsWildCardTy _) = pure AST.UWildcardAssert -trfAssertion' (cleanHsType -> t) = case cleanHsType base of - HsTyVar _ name -> AST.UClassAssert <$> trfName @n name <*> trfAnnList " " trfType' args - HsEqTy t1 t2 -> AST.UInfixAssert <$> trfType t1 <*> annLocNoSema (tokenLoc AnnTilde) (trfOperator' @n typeEq) <*> trfType t2 - HsIParamTy name t -> AST.UImplicitAssert <$> define (focusOn (getLoc name) (trfImplicitName (unLoc name))) <*> trfType t +trfAssertion' t = case base of + HsTyVar _ _ name -> AST.UClassAssert <$> trfName @n name <*> trfAnnList " " trfType' args + -- HsEqTy t1 t2 -> AST.UInfixAssert <$> trfType t1 <*> annLocNoSema (tokenLoc AnnTilde) (trfOperator' @n typeEq) <*> trfType t2 + HsIParamTy _ name t -> AST.UImplicitAssert <$> define (focusOn (getLoc name) (trfImplicitName (unLoc name))) <*> trfType t t -> unhandledElement "assertion" t where (args, _, base) = getArgs t getArgs :: HsType n -> ([LHsType n], Maybe SrcSpan, HsType n) - getArgs (HsAppTy (L l ft) at) = case getArgs ft of (args, sp, base) -> (args++[at], sp <|> Just l, base) + getArgs (HsAppTy _ (L l ft) at) = case getArgs ft of (args, sp, base) -> (args++[at], sp <|> Just l, base) getArgs t = ([], Nothing, t) - typeEq :: IdP n - typeEq = nameFromId @n (mkVanillaGlobal (tyConName heqTyCon) (tyConKind heqTyCon)) + -- typeEq :: IdP n + -- typeEq = nameFromId @n (mkVanillaGlobal (tyConName heqTyCon) (tyConKind heqTyCon))
Language/Haskell/Tools/BackendGHC/Types.hs-boot view
@@ -1,9 +1,14 @@+{-# LANGUAGE TypeFamilies #-} -- | Functions that convert the type-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Types where import HsTypes as GHC (HsType) -import Language.Haskell.Tools.AST as AST (UType, Dom, RangeStage) +import Language.Haskell.Tools.AST as AST (Ann, UType, Dom, RangeStage) import Language.Haskell.Tools.BackendGHC.Monad (Trf) import Language.Haskell.Tools.BackendGHC.Names (TransformName) +import HsExtension (GhcPass) +import SrcLoc as GHC (Located) +import GHC.Stack (HasCallStack) -trfType' :: TransformName n r => HsType n -> Trf (AST.UType (Dom r) RangeStage) +trfType :: (TransformName n r, n ~ GhcPass p, HasCallStack) => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage) +trfType' :: (TransformName n r, n ~ GhcPass p, HasCallStack) => HsType n -> Trf (AST.UType (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/Utils.hs view
@@ -26,6 +26,7 @@ import Packages import Finder import SrcLoc +import GHC.Stack hiding (SrcLoc(..)) import Control.Exception (Exception, throw) import Control.Monad.Reader @@ -83,7 +84,7 @@ -- | Adds semantic information to an impord declaration. See ImportInfo. createImportData :: forall r n . (GHCName r, HsHasName (IdP n)) => GHC.ImportDecl n -> Trf (ImportInfo r) -createImportData (GHC.ImportDecl _ name pkg _ _ _ _ _ declHiding) = +createImportData (GHC.ImportDecl _ _ name pkg _ _ _ _ _ declHiding) = do (mod,importedNames) <- getImportedNames (GHC.moduleNameString $ unLoc name) (fmap (unpackFS . sl_fs) pkg) names <- liftGhc $ filterM (checkImportVisible declHiding . (^. pName)) importedNames -- TODO: only use getFromNameUsing once @@ -147,10 +148,10 @@ ieSpecMatches (concatMap hsGetNames' . HsSyn.ieNames -> ls) name | name `elem` ls = return True -- ieNames does not consider field names -ieSpecMatches (IEThingWith thing _ with flds) name +ieSpecMatches (IEThingWith _ thing _ with flds) name | name `elem` concatMap hsGetNames' (map (ieWrappedName . unLoc) (thing : with) ++ map (flSelector . unLoc) flds) = return True -ieSpecMatches ie@(IEThingAll _) name | [n] <- hsGetNames' (HsSyn.ieName ie), isTyConName n +ieSpecMatches ie@(IEThingAll {}) name | [n] <- hsGetNames' (HsSyn.ieName ie), isTyConName n = do entity <- lookupName n return $ case entity of Just (ATyCon tc) | Just cls <- tyConClass_maybe tc @@ -476,10 +477,10 @@ compareSpans _ _ = EQ -- | Report errors when cannot convert a type of element -unhandledElement :: (Data a, Outputable a) => String -> a -> Trf b +unhandledElement :: (Data a, Outputable a, HasCallStack) => String -> a -> Trf b unhandledElement label e = convertionProblem ("Illegal " ++ label ++ ": " ++ showSDocUnsafe (ppr e) ++ " (ctor: " ++ show (toConstr e) ++ ")") -unhandledElementNoPpr :: (Data a) => String -> a -> Trf b +unhandledElementNoPpr :: (Data a, HasCallStack) => String -> a -> Trf b unhandledElementNoPpr label e = convertionProblem ("Illegal " ++ label ++ ": (ctor: " ++ show (toConstr e) ++ ")") instance Semigroup SrcSpan where @@ -489,15 +490,15 @@ instance Monoid SrcSpan where mempty = noSrcSpan -data ConvertionProblem = ConvertionProblem SrcSpan String +data ConvertionProblem = ConvertionProblem CallStack SrcSpan String | UnrootedConvertionProblem String deriving Show instance Exception ConvertionProblem -convertionProblem :: String -> Trf a +convertionProblem :: HasCallStack => String -> Trf a convertionProblem msg = do rng <- asks contRange - throw $ ConvertionProblem rng msg + throw $ ConvertionProblem callStack rng msg convProblem :: String -> a convProblem = throw . UnrootedConvertionProblem
haskell-tools-backend-ghc.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-backend-ghc -version: 1.1.0.2 +version: 1.1.1.0 synopsis: Creating the Haskell-Tools AST from GHC's representations description: This package collects information from various representations of a Haskell program in GHC. Basically GHC provides us with the parsed, the renamed and the type checked representation of the program, if it was type correct. Each version contains different information. For example, the renamed AST contains the unique names of the definitions, however, template haskell splices are already resolved and thus missing from that version of the AST. To get the final representation we perform a transformation on the parsed and renamed representation, and then use the type checked one to look up the types of the names. The whole transformation is defined in the `Modules` module. Other modules define the functions that convert elements of the GHC AST to our AST. homepage: https://github.com/nboldi/haskell-tools @@ -31,17 +31,17 @@ , Language.Haskell.Tools.BackendGHC.SourceMap , Language.Haskell.Tools.BackendGHC.AddTypeInfo - build-depends: base >= 4.11 && < 4.12 + build-depends: base >= 4.11 && < 4.13 , transformers >= 0.5 && < 0.6 , references >= 0.3 && < 0.4 , bytestring >= 0.10 && < 0.11 , safe >= 0.3 && < 0.4 , uniplate >= 1.6 && < 1.7 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.7 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 0.3 - , template-haskell >= 2.13 && < 2.14 - , ghc >= 8.4 && < 8.5 + , template-haskell >= 2.13 && < 2.15 + , ghc >= 8.4 && < 8.7 , haskell-tools-ast >= 1.1 && < 1.2 - , ghc-boot-th >= 8.4 && < 8.5 + , ghc-boot-th >= 8.4 && < 8.7 default-language: Haskell2010