diff --git a/Language/Haskell/Tools/AST/FromGHC/Base.hs b/Language/Haskell/Tools/AST/FromGHC/Base.hs --- a/Language/Haskell/Tools/AST/FromGHC/Base.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Base.hs @@ -35,81 +35,84 @@ import Bag as GHC import Data.Data (Data) -import Language.Haskell.Tools.AST (Ann(..), AnnList(..), AnnMaybe(..), SemanticInfo(..), annotation, semanticInfo) +import Language.Haskell.Tools.AST (Ann(..), AnnList(..), AnnMaybe(..), SemanticInfo(..), RangeStage, Dom, annotation, semanticInfo) +import Language.Haskell.Tools.AST (NoSemanticInfo(..)) import qualified Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.GHCUtils -trfOperator :: TransformName name res => Located name -> Trf (Ann AST.Operator res) -trfOperator = trfLoc trfOperator' +trfOperator :: TransformName n r => Located n -> Trf (Ann AST.Operator (Dom r) RangeStage) +trfOperator = trfLocNoSema trfOperator' -trfOperator' :: TransformName name res => name -> Trf (AST.Operator res) +trfOperator' :: TransformName n r => n -> Trf (AST.Operator (Dom r) RangeStage) trfOperator' n - | isSymOcc (occName n) = AST.NormalOp <$> (addNameInfo n =<< annCont (trfSimpleName' n)) - | otherwise = AST.BacktickOp <$> (addNameInfo n =<< annLoc loc (trfSimpleName' n)) + | isSymOcc (occName n) = AST.NormalOp <$> (annCont (createNameInfo (transformName n)) (trfSimpleName' n)) + | otherwise = AST.BacktickOp <$> (annLoc (createNameInfo (transformName n)) loc (trfSimpleName' n)) where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd) -trfName :: TransformName name res => Located name -> Trf (Ann AST.Name res) -trfName = trfLoc trfName' +trfName :: TransformName n r => Located n -> Trf (Ann AST.Name (Dom r) RangeStage) +trfName = trfLocNoSema trfName' -trfName' :: TransformName name res => name -> Trf (AST.Name res) +trfName' :: TransformName n r => n -> Trf (AST.Name (Dom r) RangeStage) trfName' n - | isSymOcc (occName n) = AST.ParenName <$> (addNameInfo n =<< annLoc loc (trfSimpleName' n)) - | otherwise = AST.NormalName <$> (addNameInfo n =<< annCont (trfSimpleName' n)) + | isSymOcc (occName n) = AST.ParenName <$> (annLoc (createNameInfo (transformName n)) loc (trfSimpleName' n)) + | otherwise = AST.NormalName <$> (annCont (createNameInfo (transformName n)) (trfSimpleName' n)) where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd) -trfAmbiguousFieldName :: TransformName n res => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.Name res) +trfAmbiguousFieldName :: TransformName n r => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.Name (Dom r) RangeStage) trfAmbiguousFieldName all@(L l af) = trfAmbiguousFieldName' l af -trfAmbiguousFieldName' :: forall n res . (TransformName n res) => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.Name res) -trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLoc (pure l) $ trfName' (unpackPostRn @n rdr pr) +trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.Name (Dom r) RangeStage) +trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' (unpackPostRn @n rdr pr) -- no Id transformation is done, so we can basically ignore the postTC value trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _) = do locals <- asks localsInScope isDefining <- asks defining - annLoc (pure l) + annLocNoSema (pure l) $ AST.NormalName - <$> (annotation .- addSemanticInfo (AmbiguousNameInfo locals isDefining rdr l :: SemanticInfo n)) - <$> (annLoc (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr)) + <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr)) class (DataId n, Eq n, GHCName n) => TransformableName n where correctNameString :: n -> Trf String + fromGHCName :: GHC.Name -> n instance TransformableName RdrName where correctNameString = pure . rdrNameStr + fromGHCName = rdrName instance TransformableName GHC.Name where correctNameString n = getOriginalName (rdrName n) - + fromGHCName = id -- | This class allows us to use the same transformation code for multiple variants of the GHC AST. -- GHC Name annotated with 'name' can be transformed to our representation with semantic annotations of 'res'. -class (RangeAnnot res, SemanticAnnot res name, SemanticAnnot res GHC.Name, TransformableName name, HsHasName name) +class (TransformableName name, HsHasName name, TransformableName res, HsHasName res, GHCName res) => TransformName name res where -instance TransformName RdrName AST.RangeInfo where -instance (RangeAnnot r, SemanticAnnot r GHC.Name) => TransformName GHC.Name r where + -- | Demote a given name + transformName :: name -> res -addNameInfo :: TransformName n r => n -> Ann AST.SimpleName r -> Trf (Ann AST.SimpleName r) -addNameInfo name ast = do locals <- asks localsInScope - isDefining <- asks defining - return (annotation .- addSemanticInfo (NameInfo locals isDefining name) $ ast) +instance {-# OVERLAPPABLE #-} (n ~ r, TransformableName n, HsHasName n) => TransformName n r where + transformName = id -trfSimpleName :: TransformName name res => Located name -> Trf (Ann AST.SimpleName res) -trfSimpleName name@(L l n) = addNameInfo n =<< annLoc (pure l) (trfSimpleName' n) +instance {-# OVERLAPS #-} (TransformableName res, GHCName res, HsHasName res) => TransformName GHC.Name res where + transformName = fromGHCName -trfSimpleName' :: TransformName name res => name -> Trf (AST.SimpleName res) +trfSimpleName :: TransformName n r => Located n -> Trf (Ann AST.SimpleName (Dom r) RangeStage) +trfSimpleName name@(L l n) = annLoc (createNameInfo (transformName n)) (pure l) (trfSimpleName' n) + +trfSimpleName' :: TransformName n r => n -> Trf (AST.SimpleName (Dom r) RangeStage) trfSimpleName' n = AST.nameFromList <$> (trfNameStr =<< correctNameString n) -- | Creates a qualified name from a name string -trfNameStr :: RangeAnnot a => String -> Trf (AnnList AST.UnqualName a) -trfNameStr str = (\loc -> AnnList (toListAnnot "" "" "." loc) $ trfNameStr' str loc) <$> atTheStart +trfNameStr :: String -> Trf (AnnList AST.UnqualName (Dom r) RangeStage) +trfNameStr str = makeList "." atTheStart (trfNameStr' str <$> atTheStart) -trfNameStr' :: RangeAnnot a => String -> SrcLoc -> [Ann AST.UnqualName a] +trfNameStr' :: String -> SrcLoc -> [Ann AST.UnqualName (Dom r) RangeStage] trfNameStr' str srcLoc = fst $ foldl (\(r,loc) np -> let nextLoc = advanceAllSrcLoc loc np - in ( r ++ [Ann (toNodeAnnot $ mkSrcSpan loc nextLoc) (AST.UnqualName np)], advanceAllSrcLoc nextLoc "." ) ) + in ( r ++ [Ann (noSemaInfo $ AST.NodeSpan (mkSrcSpan loc nextLoc)) (AST.UnqualName np)], advanceAllSrcLoc nextLoc "." ) ) ([], srcLoc) (nameParts str) where -- | Move the source location according to a string advanceAllSrcLoc :: SrcLoc -> String -> SrcLoc @@ -128,56 +131,56 @@ nameParts' carry [] = [reverse carry] nameParts' carry str = error $ "nameParts': " ++ show carry ++ " " ++ show str -trfModuleName :: RangeAnnot a => Located ModuleName -> Trf (Ann AST.SimpleName a) -trfModuleName = trfLoc trfModuleName' +trfModuleName :: Located ModuleName -> Trf (Ann AST.ModuleName (Dom r) RangeStage) +trfModuleName = trfLocNoSema trfModuleName' -trfModuleName' :: RangeAnnot a => ModuleName -> Trf (AST.SimpleName a) -trfModuleName' = (AST.nameFromList <$>) . trfNameStr . moduleNameString +trfModuleName' :: ModuleName -> Trf (AST.ModuleName (Dom r) RangeStage) +trfModuleName' = pure . AST.ModuleName . moduleNameString -trfFastString :: RangeAnnot a => Located FastString -> Trf (Ann AST.StringNode a) -trfFastString = trfLoc $ pure . AST.StringNode . unpackFS +trfFastString :: Located FastString -> Trf (Ann AST.StringNode (Dom r) RangeStage) +trfFastString = trfLocNoSema $ pure . AST.StringNode . unpackFS -trfDataKeyword :: RangeAnnot a => NewOrData -> Trf (Ann AST.DataOrNewtypeKeyword a) -trfDataKeyword NewType = annLoc (tokenLoc AnnNewtype) (pure AST.NewtypeKeyword) -trfDataKeyword DataType = annLoc (tokenLoc AnnData) (pure AST.DataKeyword) +trfDataKeyword :: NewOrData -> Trf (Ann AST.DataOrNewtypeKeyword (Dom r) RangeStage) +trfDataKeyword NewType = annLocNoSema (tokenLoc AnnNewtype) (pure AST.NewtypeKeyword) +trfDataKeyword DataType = annLocNoSema (tokenLoc AnnData) (pure AST.DataKeyword) -trfCallConv :: RangeAnnot a => Located CCallConv -> Trf (Ann AST.CallConv a) -trfCallConv = trfLoc trfCallConv' +trfCallConv :: Located CCallConv -> Trf (Ann AST.CallConv (Dom r) RangeStage) +trfCallConv = trfLocNoSema trfCallConv' -trfCallConv' :: RangeAnnot a => CCallConv -> Trf (AST.CallConv a) +trfCallConv' :: CCallConv -> Trf (AST.CallConv (Dom r) RangeStage) trfCallConv' CCallConv = pure AST.CCall trfCallConv' CApiConv = pure AST.CApi trfCallConv' StdCallConv = pure AST.StdCall -- trfCallConv' PrimCallConv = trfCallConv' JavaScriptCallConv = pure AST.JavaScript -trfSafety :: RangeAnnot a => SrcSpan -> Located Safety -> Trf (AnnMaybe AST.Safety a) +trfSafety :: SrcSpan -> Located Safety -> Trf (AnnMaybe AST.Safety (Dom r) RangeStage) trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l - = makeJust <$> trfLoc (pure . \case + = makeJust <$> trfLocNoSema (pure . \case PlaySafe -> AST.Safe PlayInterruptible -> AST.Interruptible PlayRisky -> AST.Unsafe) lsaf | otherwise = nothing " " "" (pure $ srcSpanEnd ccLoc) -trfOverlap :: RangeAnnot a => Located OverlapMode -> Trf (Ann AST.OverlapPragma a) -trfOverlap = trfLoc $ pure . \case +trfOverlap :: Located OverlapMode -> Trf (Ann AST.OverlapPragma (Dom r) RangeStage) +trfOverlap = trfLocNoSema $ pure . \case NoOverlap _ -> AST.DisableOverlap Overlappable _ -> AST.Overlappable Overlapping _ -> AST.Overlapping Overlaps _ -> AST.Overlaps Incoherent _ -> AST.IncoherentOverlap -trfRole :: RangeAnnot a => Located (Maybe Role) -> Trf (Ann AST.Role a) -trfRole = trfLoc $ \case Just Nominal -> pure AST.Nominal - Just Representational -> pure AST.Representational - Just GHC.Phantom -> pure AST.Phantom +trfRole :: Located (Maybe Role) -> Trf (Ann AST.Role (Dom r) RangeStage) +trfRole = trfLocNoSema $ \case Just Nominal -> pure AST.Nominal + Just Representational -> pure AST.Representational + Just GHC.Phantom -> pure AST.Phantom -trfPhase :: RangeAnnot a => Trf SrcLoc -> Activation -> Trf (AnnMaybe AST.PhaseControl a) +trfPhase :: Trf SrcLoc -> Activation -> Trf (AnnMaybe AST.PhaseControl (Dom r) RangeStage) trfPhase l AlwaysActive = nothing "" " " l -trfPhase _ (ActiveAfter _ pn) = makeJust <$> annLoc (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) - (AST.PhaseControl <$> nothing "" "" (before AnnCloseS) <*> trfPhaseNum pn) -trfPhase _ (ActiveBefore _ pn) = makeJust <$> annLoc (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) - (AST.PhaseControl <$> (makeJust <$> annLoc (tokenLoc AnnTilde) (pure AST.PhaseInvert)) <*> trfPhaseNum pn) +trfPhase _ (ActiveAfter _ pn) = makeJust <$> annLocNoSema (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) + (AST.PhaseControl <$> nothing "" "" (before AnnCloseS) <*> trfPhaseNum pn) +trfPhase _ (ActiveBefore _ pn) = makeJust <$> annLocNoSema (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) + (AST.PhaseControl <$> (makeJust <$> annLocNoSema (tokenLoc AnnTilde) (pure AST.PhaseInvert)) <*> trfPhaseNum pn) -trfPhaseNum :: RangeAnnot a => PhaseNum -> Trf (Ann AST.PhaseNumber a) -trfPhaseNum i = annLoc (tokenLoc AnnVal) $ pure (AST.PhaseNumber $ fromIntegral i) +trfPhaseNum :: PhaseNum -> Trf (Ann AST.PhaseNumber (Dom r) RangeStage) +trfPhaseNum i = annLocNoSema (tokenLoc AnnVal) $ pure (AST.PhaseNumber $ fromIntegral i) diff --git a/Language/Haskell/Tools/AST/FromGHC/Binds.hs b/Language/Haskell/Tools/AST/FromGHC/Binds.hs --- a/Language/Haskell/Tools/AST/FromGHC/Binds.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Binds.hs @@ -31,74 +31,74 @@ import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..)) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.ValueBind r) -trfBind = trfLoc trfBind' +trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.ValueBind (Dom r) RangeStage) +trfBind = trfLocNoSema trfBind' -trfBind' :: TransformName n r => HsBind n -> Trf (AST.ValueBind r) +trfBind' :: TransformName n r => HsBind n -> Trf (AST.ValueBind (Dom r) RangeStage) -- a value binding (not a function) trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = unLoc -> [L matchLoc (Match { m_pats = [], m_grhss = GRHSs [L rhsLoc (GRHS [] expr)] (unLoc -> locals) })]} }) = AST.SimpleBind <$> copyAnnot AST.VarPat (define $ trfName id) - <*> addToScope locals (annLoc (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UnguardedRhs <$> trfExpr expr)) + <*> addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UnguardedRhs <$> trfExpr expr)) <*> addToScope locals (trfWhereLocalBinds locals) trfBind' (FunBind id (MG (unLoc -> matches) _ _ _) _ _ _) = AST.FunBind <$> makeNonemptyIndentedList (mapM (trfMatch (unLoc id)) matches) trfBind' (PatBind pat (GRHSs rhs (unLoc -> locals)) _ _ _) = AST.SimpleBind <$> trfPattern pat <*> trfRhss rhs <*> trfWhereLocalBinds locals trfBind' (AbsBinds _ _ _ _ _) = error "AbsBinds are not allowed as an input to the conversion (they are generated by the type checker)" trfBind' (PatSynBind _) = error "Pattern synonym bindings should be recognized on the declaration level" -trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.Match r) -trfMatch id = trfLoc (trfMatch' id) +trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.Match (Dom r) RangeStage) +trfMatch id = trfLocNoSema (trfMatch' id) -trfMatch' :: TransformName n r => n -> Match n (LHsExpr n) -> Trf (AST.Match r) +trfMatch' :: TransformName n r => n -> Match n (LHsExpr n) -> Trf (AST.Match (Dom r) RangeStage) trfMatch' name (Match funid pats typ (GRHSs rhss (unLoc -> locBinds))) -- TODO: add the optional typ to pats = AST.Match <$> trfMatchLhs name funid pats <*> addToScope pats (trfRhss rhss) <*> addToScope pats (trfWhereLocalBinds locBinds) -trfMatchLhs :: TransformName n r => n -> MatchFixity n -> [LPat n] -> Trf (Ann AST.MatchLhs r) +trfMatchLhs :: TransformName n r => n -> MatchFixity n -> [LPat n] -> Trf (Ann AST.MatchLhs (Dom r) RangeStage) trfMatchLhs name fb pats = do implicitIdLoc <- mkSrcSpan <$> atTheStart <*> atTheStart closeLoc <- srcSpanStart <$> (combineSrcSpans <$> tokenLoc AnnEqual <*> tokenLoc AnnVbar) let (n, isInfix) = case fb of NonFunBindMatch -> (L implicitIdLoc name, False) FunBindMatch n inf -> (n, inf) args <- mapM trfPattern pats - annLoc (mkSrcSpan <$> atTheStart <*> (pure closeLoc)) $ + annLocNoSema (mkSrcSpan <$> atTheStart <*> (pure closeLoc)) $ case (args, isInfix) of (left:right:rest, True) -> AST.InfixLhs left <$> define (trfOperator n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest) _ -> AST.NormalLhs <$> define (trfName n) <*> makeList " " (pure closeLoc) (pure args) -trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.Rhs r) +trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.Rhs (Dom r) RangeStage) -- the original location on the GRHS misleadingly contains the local bindings -trfRhss [unLoc -> GRHS [] body] = annLoc (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) +trfRhss [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) (AST.UnguardedRhs <$> trfExpr body) -trfRhss rhss = annLoc (pure $ collectLocs rhss) +trfRhss rhss = annLocNoSema (pure $ collectLocs rhss) (AST.GuardedRhss . nonemptyAnnList <$> mapM trfGuardedRhs rhss) -trfGuardedRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedRhs r) -trfGuardedRhs = trfLoc $ \(GRHS guards body) +trfGuardedRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedRhs (Dom r) RangeStage) +trfGuardedRhs = trfLocNoSema $ \(GRHS guards body) -> AST.GuardedRhs . nonemptyAnnList <$> trfScopedSequence trfRhsGuard guards <*> addToScope guards (trfExpr body) -trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard r) -trfRhsGuard = trfLoc trfRhsGuard' +trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard (Dom r) RangeStage) +trfRhsGuard = trfLocNoSema trfRhsGuard' -trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard r) +trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard (Dom r) RangeStage) trfRhsGuard' (BindStmt pat body _ _ _) = AST.GuardBind <$> trfPattern pat <*> trfExpr body trfRhsGuard' (BodyStmt body _ _ _) = AST.GuardCheck <$> trfExpr body trfRhsGuard' (LetStmt (unLoc -> binds)) = AST.GuardLet <$> trfLocalBinds binds -trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds r) +trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds (Dom r) RangeStage) trfWhereLocalBinds EmptyLocalBinds = nothing "" "" atTheEnd trfWhereLocalBinds binds - = makeJust <$> annLoc (combineSrcSpans (getBindLocs binds) <$> tokenLoc AnnWhere) (AST.LocalBinds <$> addToScope binds (trfLocalBinds binds)) + = makeJust <$> annLocNoSema (combineSrcSpans (getBindLocs binds) <$> tokenLoc AnnWhere) (AST.LocalBinds <$> addToScope binds (trfLocalBinds 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 -trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind r) +trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind (Dom r) RangeStage) trfLocalBinds (HsValBinds (ValBindsIn binds sigs)) = makeIndentedList (after AnnWhere) (orderDefs <$> ((++) <$> mapM (copyAnnot AST.LocalValBind . trfBind) (bagToList binds) @@ -108,45 +108,45 @@ (orderDefs <$> ((++) <$> (concat <$> mapM (mapM (copyAnnot AST.LocalValBind . trfBind) . bagToList . snd) binds) <*> mapM trfLocalSig sigs)) -trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.LocalBind r) -trfLocalSig = trfLoc $ \case - ts@(TypeSig {}) -> AST.LocalSignature <$> annCont (trfTypeSig' ts) - (FixSig fs) -> AST.LocalFixity <$> annCont (trfFixitySig fs) +trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.LocalBind (Dom r) RangeStage) +trfLocalSig = trfLocNoSema $ \case + ts@(TypeSig {}) -> AST.LocalSignature <$> annContNoSema (trfTypeSig' ts) + (FixSig fs) -> AST.LocalFixity <$> annContNoSema (trfFixitySig fs) -trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.TypeSignature r) -trfTypeSig = trfLoc trfTypeSig' +trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.TypeSignature (Dom r) RangeStage) +trfTypeSig = trfLocNoSema trfTypeSig' -trfTypeSig' :: TransformName n r => Sig n -> Trf (AST.TypeSignature r) +trfTypeSig' :: TransformName n r => Sig n -> Trf (AST.TypeSignature (Dom r) RangeStage) trfTypeSig' (TypeSig names typ) = defineTypeVars $ AST.TypeSignature <$> makeNonemptyList ", " (mapM trfName names) <*> trfType (hswc_body $ hsib_body typ) -trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.FixitySignature r) +trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.FixitySignature (Dom r) RangeStage) trfFixitySig (FixitySig names (Fixity _ prec dir)) = AST.FixitySignature <$> transformDir dir - <*> annLoc (tokenLoc AnnVal) (pure $ AST.Precedence prec) + <*> annLocNoSema (tokenLoc AnnVal) (pure $ AST.Precedence prec) <*> (nonemptyAnnList . nub <$> mapM trfOperator names) where transformDir InfixL = directionChar (pure AST.AssocLeft) transformDir InfixR = directionChar (pure AST.AssocRight) - transformDir InfixN = annLoc (srcLocSpan . srcSpanEnd <$> tokenLoc AnnInfix) (pure AST.AssocNone) + transformDir InfixN = annLocNoSema (srcLocSpan . srcSpanEnd <$> tokenLoc AnnInfix) (pure AST.AssocNone) - directionChar = annLoc ((\l -> mkSrcSpan (updateCol (subtract 1) l) l) . srcSpanEnd <$> tokenLoc AnnInfix) + directionChar = annLocNoSema ((\l -> mkSrcSpan (updateCol (subtract 1) l) l) . srcSpanEnd <$> tokenLoc AnnInfix) -trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.Rule r) -trfRewriteRule = trfLoc $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) -> +trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.Rule (Dom r) RangeStage) +trfRewriteRule = trfLocNoSema $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) -> AST.Rule <$> trfFastString (L nameLoc ruleName) <*> trfPhase (before AnnForall) act <*> makeNonemptyList " " (mapM trfRuleBndr bndrs) <*> trfExpr left <*> trfExpr right -trfRuleBndr :: TransformName n r => Located (RuleBndr n) -> Trf (Ann AST.TyVar r) -trfRuleBndr = trfLoc $ \case (RuleBndr n) -> AST.TyVarDecl <$> trfName n <*> nothing " " "" atTheEnd - (RuleBndrSig n k) -> AST.TyVarDecl <$> trfName n <*> (makeJust <$> (trfKindSig' (hswc_body $ hsib_body k))) +trfRuleBndr :: TransformName n r => Located (RuleBndr n) -> Trf (Ann AST.TyVar (Dom r) RangeStage) +trfRuleBndr = trfLocNoSema $ \case (RuleBndr n) -> AST.TyVarDecl <$> trfName n <*> nothing " " "" atTheEnd + (RuleBndrSig n k) -> AST.TyVarDecl <$> trfName n <*> (makeJust <$> (trfKindSig' (hswc_body $ hsib_body k))) -trfMinimalFormula :: TransformName n r => Located (BooleanFormula (Located n)) -> Trf (Ann AST.MinimalFormula r) -trfMinimalFormula = trfLoc trfMinimalFormula' +trfMinimalFormula :: TransformName n r => Located (BooleanFormula (Located n)) -> Trf (Ann AST.MinimalFormula (Dom r) RangeStage) +trfMinimalFormula = trfLocNoSema trfMinimalFormula' -trfMinimalFormula' :: TransformName n r => BooleanFormula (Located n) -> Trf (AST.MinimalFormula r) +trfMinimalFormula' :: TransformName n r => BooleanFormula (Located n) -> Trf (AST.MinimalFormula (Dom r) RangeStage) trfMinimalFormula' (Var name) = AST.MinimalName <$> trfName name trfMinimalFormula' (And formulas) = AST.MinimalAnd <$> trfAnnList " & " trfMinimalFormula' formulas trfMinimalFormula' (Or formulas) = AST.MinimalOr <$> trfAnnList " | " trfMinimalFormula' formulas diff --git a/Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot b/Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot --- a/Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot +++ b/Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot @@ -8,10 +8,10 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.Base -import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..)) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind r) -trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds r) -trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard r) -trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard r) +trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind (Dom r) RangeStage) +trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds (Dom r) RangeStage) +trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard (Dom r) RangeStage) +trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard (Dom r) RangeStage) diff --git a/Language/Haskell/Tools/AST/FromGHC/Decls.hs b/Language/Haskell/Tools/AST/FromGHC/Decls.hs --- a/Language/Haskell/Tools/AST/FromGHC/Decls.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Decls.hs @@ -35,16 +35,16 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), RangeWithName, getRange) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), getRange, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST import Debug.Trace -trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnList AST.Decl r) +trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnList AST.Decl (Dom r) RangeStage) -- TODO: filter documentation comments trfDecls decls = addToScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls) -trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnList AST.Decl r) +trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnList AST.Decl (Dom r) RangeStage) trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects docs) = addAllToScope $ makeIndentedListNewlineBefore atTheEnd (fmap (orderDefs . concat) $ sequence $ [ trfBindOrSig vals @@ -61,20 +61,20 @@ , mapM (trfDecl . (fmap VectD)) vects -- , mapM (trfDecl . (fmap DocD)) docs ]) - where trfBindOrSig :: HsValBinds n -> Trf [Ann AST.Decl r] + where trfBindOrSig :: HsValBinds n -> Trf [Ann AST.Decl (Dom r) RangeStage] trfBindOrSig (getBindsAndSigs -> (sigs, binds)) - = (++) <$> mapM (trfLoc trfVal) (bagToList binds) - <*> mapM (trfLoc trfSig) sigs + = (++) <$> mapM (trfLocNoSema trfVal) (bagToList binds) + <*> mapM (trfLocNoSema trfSig) sigs addAllToScope = addToCurrentScope vals . addToCurrentScope tycls . addToCurrentScope foreigns -trfDecl :: TransformName n r => Located (HsDecl n) -> Trf (Ann AST.Decl r) -trfDecl = trfLoc $ \case +trfDecl :: TransformName n r => Located (HsDecl n) -> Trf (Ann AST.Decl (Dom r) RangeStage) +trfDecl = trfLocNoSema $ \case TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars kindSig _)) -> AST.ClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars) <*> trfFamilyKind kindSig <*> trfTypeEqs typeEqs - TyClD (FamDecl fd) -> AST.TypeFamilyDecl <$> annCont (trfTypeFam' fd) + TyClD (FamDecl fd) -> AST.TypeFamilyDecl <$> annContNoSema (trfTypeFam' fd) TyClD (SynDecl name vars rhs _) -> AST.TypeDecl <$> between AnnType AnnEqual (createDeclHead name vars) <*> trfType rhs TyClD (DataDecl name vars (HsDataDefn nd ctx _ kind cons derivs) _ _) @@ -104,21 +104,21 @@ SigD sig -> trfSig sig DerivD (DerivDecl t overlap) -> AST.DerivDecl <$> trfMaybe "" "" trfOverlap overlap <*> trfInstanceRule (hsib_body t) -- TODO: INLINE, SPECIALIZE, MINIMAL, VECTORISE pragmas, Warnings, Annotations, rewrite rules, role annotations - RuleD (HsRules _ rules) -> AST.PragmaDecl <$> annCont (AST.RulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules)) + RuleD (HsRules _ rules) -> AST.PragmaDecl <$> annContNoSema (AST.RulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules)) RoleAnnotD (RoleAnnotDecl name roles) -> AST.RoleDecl <$> trfSimpleName name <*> makeList " " atTheEnd (mapM trfRole roles) DefD (DefaultDecl types) -> AST.DefaultDecl . nonemptyAnnList <$> mapM trfType types ForD (ForeignImport name (hsib_body -> typ) _ (CImport ccall safe _ _ _)) -> AST.ForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName name) <*> trfType typ ForD (ForeignExport name (hsib_body -> typ) _ (CExport (L l (CExportStatic _ _ ccall)) _)) - -> AST.ForeignExport <$> annLoc (pure l) (trfCallConv' ccall) <*> trfName name <*> trfType typ - SpliceD (SpliceDecl (unLoc -> spl) _) -> AST.SpliceDecl <$> (annCont $ trfSplice' spl) + -> AST.ForeignExport <$> annLocNoSema (pure l) (trfCallConv' ccall) <*> trfName name <*> trfType typ + SpliceD (SpliceDecl (unLoc -> spl) _) -> AST.SpliceDecl <$> (annContNoSema $ trfSplice' spl) AnnD (HsAnnotation stxt subject expr) - -> AST.PragmaDecl <$> annCont (AST.AnnPragma <$> trfAnnotationSubject stxt subject (srcSpanStart $ getLoc expr) <*> trfExpr expr) + -> AST.PragmaDecl <$> annContNoSema (AST.AnnPragma <$> trfAnnotationSubject stxt subject (srcSpanStart $ getLoc expr) <*> trfExpr expr) d -> error ("Illegal declaration: " ++ showSDocUnsafe (ppr d) ++ " (ctor: " ++ show (toConstr d) ++ ")") trfGADT :: TransformName n r => NewOrData -> Located n -> LHsQTyVars n -> Located (HsContext n) -> Maybe (Located (HsKind n)) -> [Located (ConDecl n)] - -> Maybe (Located [LHsSigType n]) -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.Decl r) + -> Maybe (Located [LHsSigType n]) -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.Decl (Dom r) RangeStage) trfGADT nd name vars ctx kind cons derivs ctxTok consLoc = AST.GDataDecl <$> trfDataKeyword nd <*> trfCtx (after ctxTok) ctx @@ -129,7 +129,7 @@ trfDataDef :: TransformName n r => NewOrData -> Located n -> LHsQTyVars n -> Located (HsContext n) -> [Located (ConDecl n)] -> Maybe (Located [LHsSigType n]) - -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.Decl r) + -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.Decl (Dom r) RangeStage) trfDataDef nd name vars ctx cons derivs ctxTok consLoc = AST.DataDecl <$> trfDataKeyword nd <*> trfCtx (after ctxTok) ctx @@ -137,38 +137,38 @@ <*> makeListBefore "=" " | " consLoc (mapM trfConDecl cons) <*> trfMaybe "" "" trfDerivings derivs -trfVal :: TransformName n r => HsBindLR n n -> Trf (AST.Decl r) -trfVal (PatSynBind psb) = AST.PatternSynonymDecl <$> annCont (trfPatternSynonym psb) -trfVal bind = AST.ValueBinding <$> (annCont $ trfBind' bind) +trfVal :: TransformName n r => HsBindLR n n -> Trf (AST.Decl (Dom r) RangeStage) +trfVal (PatSynBind psb) = AST.PatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb) +trfVal bind = AST.ValueBinding <$> (annContNoSema $ trfBind' bind) -trfSig :: TransformName n r => Sig n -> Trf (AST.Decl r) -trfSig (ts @ (TypeSig {})) = AST.TypeSigDecl <$> defineTypeVars (annCont $ trfTypeSig' ts) -trfSig (FixSig fs) = AST.FixityDecl <$> (annCont $ trfFixitySig fs) +trfSig :: TransformName n r => Sig n -> Trf (AST.Decl (Dom r) RangeStage) +trfSig (ts @ (TypeSig {})) = AST.TypeSigDecl <$> defineTypeVars (annContNoSema $ trfTypeSig' ts) +trfSig (FixSig fs) = AST.FixityDecl <$> (annContNoSema $ trfFixitySig fs) trfSig (PatSynSig id typ) - = AST.PatTypeSigDecl <$> annCont (AST.PatternTypeSignature <$> trfName id <*> trfType (hsib_body typ)) + = AST.PatTypeSigDecl <$> annContNoSema (AST.PatternTypeSignature <$> trfName id <*> trfType (hsib_body typ)) trfSig (InlineSig name (InlinePragma _ Inlinable _ phase _)) - = AST.PragmaDecl <$> annCont (AST.InlinablePragma <$> trfPhase (pure $ srcSpanStart $ getLoc name) phase <*> trfName name) + = AST.PragmaDecl <$> annContNoSema (AST.InlinablePragma <$> trfPhase (pure $ srcSpanStart $ getLoc name) phase <*> trfName name) trfSig (InlineSig name (InlinePragma src inl _ phase cl)) = do rng <- asks contRange let parts = map getLoc $ splitLocated (L rng src) - AST.PragmaDecl <$> annCont ((case inl of Inline -> AST.InlinePragma; NoInline -> AST.NoInlinePragma) + AST.PragmaDecl <$> annContNoSema ((case inl of Inline -> AST.InlinePragma; NoInline -> AST.NoInlinePragma) <$> trfConlike parts cl <*> trfPhase (pure $ srcSpanStart (getLoc name)) phase <*> trfName name) trfSig (SpecSig name (map hsib_body -> types) (inl_act -> phase)) - = AST.PragmaDecl <$> annCont (AST.SpecializePragma <$> trfPhase (pure $ srcSpanStart (getLoc name)) phase + = AST.PragmaDecl <$> annContNoSema (AST.SpecializePragma <$> trfPhase (pure $ srcSpanStart (getLoc name)) phase <*> trfName name <*> (orderAnnList <$> trfAnnList ", " trfType' types)) trfSig s = error ("Illegal signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")") -trfConlike :: RangeAnnot a => [SrcSpan] -> RuleMatchInfo -> Trf (AnnMaybe AST.ConlikeAnnot a) -trfConlike parts ConLike = makeJust <$> annLoc (pure $ parts !! 2) (pure AST.ConlikeAnnot) +trfConlike :: [SrcSpan] -> RuleMatchInfo -> Trf (AnnMaybe AST.ConlikeAnnot (Dom r) RangeStage) +trfConlike parts ConLike = makeJust <$> annLocNoSema (pure $ parts !! 2) (pure AST.ConlikeAnnot) trfConlike parts FunLike = nothing " " "" (pure $ srcSpanEnd $ parts !! 1) -trfConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.ConDecl r) -trfConDecl = trfLoc trfConDecl' +trfConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.ConDecl (Dom r) RangeStage) +trfConDecl = trfLocNoSema trfConDecl' -trfConDecl' :: TransformName n r => ConDecl n -> Trf (AST.ConDecl r) +trfConDecl' :: TransformName n r => ConDecl n -> Trf (AST.ConDecl (Dom r) RangeStage) trfConDecl' (ConDeclH98 { con_name = name, con_details = PrefixCon args }) = AST.ConDecl <$> define (trfName name) <*> makeList " " atTheEnd (mapM trfType args) trfConDecl' (ConDeclH98 { con_name = name, con_details = RecCon (unLoc -> flds) }) @@ -176,110 +176,110 @@ trfConDecl' (ConDeclH98 { con_name = name, con_details = InfixCon t1 t2 }) = AST.InfixConDecl <$> trfType t1 <*> define (trfOperator name) <*> trfType t2 -trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.GadtConDecl r) -trfGADTConDecl = trfLoc $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ }) +trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.GadtConDecl (Dom r) RangeStage) +trfGADTConDecl = trfLocNoSema $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ }) -> AST.GadtConDecl <$> define (trfAnnList ", " trfName' names) <*> trfGadtConType typ -trfGadtConType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.GadtConType r) -trfGadtConType = trfLoc $ \case +trfGadtConType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.GadtConType (Dom r) RangeStage) +trfGadtConType = trfLocNoSema $ \case HsFunTy (cleanHsType . unLoc -> HsRecTy flds) resType -> AST.GadtRecordType <$> between AnnOpenC AnnCloseC (trfAnnList ", " trfFieldDecl' flds) <*> trfType resType - typ -> AST.GadtNormalType <$> annCont (trfType' typ) + typ -> AST.GadtNormalType <$> annContNoSema (trfType' typ) -trfFieldDecl :: TransformName n r => Located (ConDeclField n) -> Trf (Ann AST.FieldDecl r) -trfFieldDecl = trfLoc trfFieldDecl' +trfFieldDecl :: TransformName n r => Located (ConDeclField n) -> Trf (Ann AST.FieldDecl (Dom r) RangeStage) +trfFieldDecl = trfLocNoSema trfFieldDecl' -trfFieldDecl' :: TransformName n r => ConDeclField n -> Trf (AST.FieldDecl r) +trfFieldDecl' :: TransformName n r => ConDeclField n -> Trf (AST.FieldDecl (Dom r) RangeStage) trfFieldDecl' (ConDeclField names typ _) = AST.FieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName . getFieldOccName) names) <*> trfType typ -trfDerivings :: TransformName n r => Located [LHsSigType n] -> Trf (Ann AST.Deriving r) -trfDerivings = trfLoc $ \case +trfDerivings :: TransformName n r => Located [LHsSigType n] -> Trf (Ann AST.Deriving (Dom r) RangeStage) +trfDerivings = trfLocNoSema $ \case [hsib_body -> typ@(unLoc -> HsTyVar cls)] -> AST.DerivingOne <$> trfInstanceHead typ derivs -> AST.Derivings <$> trfAnnList ", " trfInstanceHead' (map hsib_body derivs) -trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceRule r) -trfInstanceRule = trfLoc (trfInstanceRule' . cleanHsType) +trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceRule (Dom r) RangeStage) +trfInstanceRule = trfLocNoSema (trfInstanceRule' . cleanHsType) -trfInstanceRule' :: TransformName n r => HsType n -> Trf (AST.InstanceRule r) +trfInstanceRule' :: TransformName n r => HsType n -> Trf (AST.InstanceRule (Dom r) RangeStage) trfInstanceRule' (HsForAllTy bndrs (unLoc -> HsQualTy ctx typ)) - = AST.InstanceRule <$> (makeJust <$> annLoc (pure $ collectLocs bndrs) (trfBindings bndrs)) + = AST.InstanceRule <$> (makeJust <$> annLocNoSema (pure $ collectLocs bndrs) (trfBindings bndrs)) <*> trfCtx (after AnnDot) ctx <*> trfInstanceHead typ trfInstanceRule' (HsQualTy ctx typ) = AST.InstanceRule <$> nothing "" " . " atTheStart <*> trfCtx atTheStart ctx <*> trfInstanceHead typ trfInstanceRule' (HsParTy typ) = AST.InstanceParen <$> trfInstanceRule typ -trfInstanceRule' (HsTyVar tv) = instanceHead $ annCont (AST.InstanceHeadCon <$> trfName tv) -trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annCont (AST.InstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2) +trfInstanceRule' (HsTyVar tv) = instanceHead $ annContNoSema (AST.InstanceHeadCon <$> trfName tv) +trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annContNoSema (AST.InstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2) trfInstanceRule' t = error (showSDocUnsafe $ ppr t) -instanceHead :: RangeAnnot r => Trf (Ann AST.InstanceHead r) -> Trf (AST.InstanceRule r) +instanceHead :: Trf (Ann AST.InstanceHead (Dom r) RangeStage) -> Trf (AST.InstanceRule (Dom r) RangeStage) instanceHead hd = AST.InstanceRule <$> (nothing "" " . " atTheStart) <*> (nothing " " "" atTheStart) <*> hd -makeInstanceRuleTyVars :: TransformName n r => Located n -> HsImplicitBndrs n [LHsType n] -> Trf (Ann AST.InstanceRule r) -makeInstanceRuleTyVars n vars = annCont +makeInstanceRuleTyVars :: TransformName n r => Located n -> HsImplicitBndrs n [LHsType n] -> Trf (Ann AST.InstanceRule (Dom r) RangeStage) +makeInstanceRuleTyVars n vars = annContNoSema $ AST.InstanceRule <$> nothing "" " . " atTheStart <*> nothing " " "" atTheStart - <*> foldl (\c t -> annLoc (pure $ combineSrcSpans (getLoc n) (getLoc t)) $ AST.InstanceHeadApp <$> c <*> (trfType t)) + <*> foldl (\c t -> annLocNoSema (pure $ combineSrcSpans (getLoc n) (getLoc t)) $ AST.InstanceHeadApp <$> c <*> (trfType t)) (copyAnnot AST.InstanceHeadCon (trfName n)) (hsib_body vars) -trfInstanceHead :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceHead r) -trfInstanceHead = trfLoc trfInstanceHead' +trfInstanceHead :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceHead (Dom r) RangeStage) +trfInstanceHead = trfLocNoSema trfInstanceHead' -trfInstanceHead' :: TransformName n r => HsType n -> Trf (AST.InstanceHead r) +trfInstanceHead' :: TransformName n r => HsType n -> Trf (AST.InstanceHead (Dom r) RangeStage) trfInstanceHead' = trfInstanceHead'' . cleanHsType where trfInstanceHead'' (HsForAllTy [] (unLoc -> t)) = trfInstanceHead' t trfInstanceHead'' (HsTyVar tv) = AST.InstanceHeadCon <$> trfName tv trfInstanceHead'' (HsAppTy t1 t2) = AST.InstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2 trfInstanceHead'' (HsParTy typ) = AST.InstanceHeadParen <$> trfInstanceHead typ trfInstanceHead'' (HsOpTy t1 op t2) - = AST.InstanceHeadApp <$> (annLoc (pure $ combineSrcSpans (getLoc t1) (getLoc op)) + = AST.InstanceHeadApp <$> (annLocNoSema (pure $ combineSrcSpans (getLoc t1) (getLoc op)) (AST.InstanceHeadInfix <$> trfType t1 <*> trfName op)) <*> trfType t2 trfInstanceHead'' t = error ("Illegal instance head: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")") -trfTypeEqs :: TransformName n r => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnList AST.TypeEqn r) +trfTypeEqs :: TransformName n r => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnList AST.TypeEqn (Dom r) RangeStage) trfTypeEqs Nothing = makeList "\n" (after AnnWhere) (pure []) trfTypeEqs (Just eqs) = makeNonemptyList "\n" (mapM trfTypeEq eqs) -trfTypeEq :: TransformName n r => Located (TyFamInstEqn n) -> Trf (Ann AST.TypeEqn r) -trfTypeEq = trfLoc $ \(TyFamEqn name pats rhs) +trfTypeEq :: TransformName n r => Located (TyFamInstEqn n) -> Trf (Ann AST.TypeEqn (Dom r) RangeStage) +trfTypeEq = trfLocNoSema $ \(TyFamEqn name pats rhs) -> AST.TypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name (hsib_body pats))) <*> trfType rhs - where combineTypes :: TransformName n r => Located n -> [LHsType n] -> Trf (Ann AST.Type r) + where combineTypes :: TransformName n r => Located n -> [LHsType n] -> Trf (Ann AST.Type (Dom r) RangeStage) combineTypes name (lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) - = annCont $ AST.TyInfix <$> trfType lhs <*> trfOperator name <*> trfType rhs - combineTypes name pats = wrapTypes (annLoc (pure $ getLoc name) (AST.TyVar <$> trfName name)) pats + = annContNoSema $ AST.TyInfix <$> trfType lhs <*> trfOperator name <*> trfType rhs + combineTypes name pats = wrapTypes (annLocNoSema (pure $ getLoc name) (AST.TyVar <$> trfName name)) pats - wrapTypes :: TransformName n r => Trf (Ann AST.Type r) -> [LHsType n] -> Trf (Ann AST.Type r) + wrapTypes :: TransformName n r => Trf (Ann AST.Type (Dom r) RangeStage) -> [LHsType n] -> Trf (Ann AST.Type (Dom r) RangeStage) wrapTypes base pats = foldl (\t p -> do typ <- t - annLoc (pure $ combineSrcSpans (getRange $ _annotation typ) (getLoc p)) + annLocNoSema (pure $ combineSrcSpans (getRange typ) (getLoc p)) (AST.TyApp <$> pure typ <*> trfType p)) base pats -trfFunDeps :: TransformName n r => [Located (FunDep (Located n))] -> Trf (AnnMaybe AST.FunDeps r) +trfFunDeps :: TransformName n r => [Located (FunDep (Located n))] -> Trf (AnnMaybe AST.FunDeps (Dom r) RangeStage) trfFunDeps [] = nothing "| " "" $ focusBeforeIfPresent AnnWhere atTheEnd -trfFunDeps fundeps = makeJust <$> annLoc (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar) +trfFunDeps fundeps = makeJust <$> annLocNoSema (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar) (AST.FunDeps <$> trfAnnList ", " trfFunDep' fundeps) -trfFunDep' :: TransformName n r => FunDep (Located n) -> Trf (AST.FunDep r) +trfFunDep' :: TransformName n r => FunDep (Located n) -> Trf (AST.FunDep (Dom r) RangeStage) trfFunDep' (lhs, rhs) = AST.FunDep <$> trfAnnList ", " trfName' lhs <*> trfAnnList ", " trfName' rhs -createDeclHead :: TransformName n r => Located n -> LHsQTyVars n -> Trf (Ann AST.DeclHead r) +createDeclHead :: TransformName n r => Located n -> LHsQTyVars n -> Trf (Ann AST.DeclHead (Dom r) RangeStage) createDeclHead name (hsq_explicit -> lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) -- infix declaration = wrapDeclHead rest - $ annLoc (addParenLocs $ getLoc lhs `combineSrcSpans` getLoc rhs) + $ annLocNoSema (addParenLocs $ getLoc lhs `combineSrcSpans` getLoc rhs) (AST.DHInfix <$> defineTypeVars (trfTyVar lhs) <*> define (trfOperator name) <*> defineTypeVars (trfTyVar rhs)) createDeclHead name vars = defineTypeVars $ wrapDeclHead (hsq_explicit vars) (define $ copyAnnot AST.DeclHead (trfName name)) -wrapDeclHead :: TransformName n r => [LHsTyVarBndr n] -> Trf (Ann AST.DeclHead r) -> Trf (Ann AST.DeclHead r) +wrapDeclHead :: TransformName n r => [LHsTyVarBndr n] -> Trf (Ann AST.DeclHead (Dom r) RangeStage) -> Trf (Ann AST.DeclHead (Dom r) RangeStage) wrapDeclHead vars base = foldl (\t p -> do typ <- t - annLoc (addParenLocs $ combineSrcSpans (getRange $ _annotation typ) (getLoc p)) + annLocNoSema (addParenLocs $ combineSrcSpans (getRange typ) (getLoc p)) (AST.DHApp typ <$> trfTyVar p) ) base vars @@ -292,13 +292,13 @@ createClassBody :: TransformName n r => [LSig n] -> LHsBinds n -> [LFamilyDecl n] - -> [LTyFamDefltEqn n] -> Trf (AnnMaybe AST.ClassBody r) + -> [LTyFamDefltEqn n] -> Trf (AnnMaybe AST.ClassBody (Dom r) RangeStage) createClassBody sigs binds typeFams typeFamDefs = do isThereWhere <- isGoodSrcSpan <$> (tokenLoc AnnWhere) if isThereWhere - then makeJust <$> annLoc (combinedLoc <$> tokenLoc AnnWhere) - (AST.ClassBody <$> makeList "" (after AnnWhere) - (orderDefs . concat <$> sequenceA allDefs)) + then makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere) + (AST.ClassBody <$> makeList "" (after AnnWhere) + (orderDefs . concat <$> sequenceA allDefs)) else nothing " where " "" atTheEnd where combinedLoc wh = foldl combineSrcSpans wh allLocs allLocs = map getLoc sigs ++ map getLoc (bagToList binds) ++ map getLoc typeFams ++ map getLoc typeFamDefs @@ -308,20 +308,20 @@ getFams = mapM (copyAnnot AST.ClsTypeFam . trfTypeFam) typeFams getFamDefs = mapM trfTypeFamDef typeFamDefs -trfClassElemSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ClassElement r) -trfClassElemSig = trfLoc $ \case - TypeSig names typ -> AST.ClsSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) +trfClassElemSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ClassElement (Dom r) RangeStage) +trfClassElemSig = trfLocNoSema $ \case + TypeSig names typ -> AST.ClsSig <$> (annContNoSema $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) <*> trfType (hswc_body $ hsib_body typ)) ClassOpSig True [name] typ -> AST.ClsDefSig <$> trfName name <*> trfType (hsib_body typ) - ClassOpSig False names typ -> AST.ClsSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) + ClassOpSig False names typ -> AST.ClsSig <$> (annContNoSema $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) <*> trfType (hsib_body typ)) MinimalSig _ formula -> AST.ClsMinimal <$> trfMinimalFormula formula s -> error ("Illegal signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")") -trfTypeFam :: TransformName n r => Located (FamilyDecl n) -> Trf (Ann AST.TypeFamily r) -trfTypeFam = trfLoc trfTypeFam' +trfTypeFam :: TransformName n r => Located (FamilyDecl n) -> Trf (Ann AST.TypeFamily (Dom r) RangeStage) +trfTypeFam = trfLocNoSema trfTypeFam' -trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.TypeFamily r) +trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.TypeFamily (Dom r) RangeStage) trfTypeFam' (FamilyDecl DataFamily name tyVars kindSig _) = AST.DataFamily <$> (case unLoc kindSig of KindSig _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars) <*> trfFamilyKind kindSig @@ -329,15 +329,15 @@ = AST.TypeFamily <$> (case unLoc kindSig of KindSig _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars) <*> trfFamilyResultSig kindSig injectivity -trfTypeFamDef :: TransformName n r => Located (TyFamDefltEqn n) -> Trf (Ann AST.ClassElement r) -trfTypeFamDef = trfLoc $ \(TyFamEqn con pats rhs) +trfTypeFamDef :: TransformName n r => Located (TyFamDefltEqn n) -> Trf (Ann AST.ClassElement (Dom r) RangeStage) +trfTypeFamDef = trfLocNoSema $ \(TyFamEqn con pats rhs) -> AST.ClsTypeDef <$> between AnnType AnnEqual (createDeclHead con pats) <*> trfType rhs -trfInstBody :: TransformName n r => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybe AST.InstBody r) +trfInstBody :: TransformName n r => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybe AST.InstBody (Dom r) RangeStage) trfInstBody binds sigs fams dats = do wh <- tokenLoc AnnWhere if isGoodSrcSpan wh then - makeJust <$> annLoc (combinedLoc <$> tokenLoc AnnWhere) + makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere) (AST.InstBody <$> (makeList "" (after AnnWhere) (orderDefs . concat <$> sequenceA allDefs))) else nothing " where " "" atTheEnd @@ -349,33 +349,33 @@ getFams = mapM trfInstTypeFam fams getDats = mapM trfInstDataFam dats -trfClassInstSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.InstBodyDecl r) -trfClassInstSig = trfLoc $ \case - TypeSig names typ -> AST.InstBodyTypeSig <$> (annCont $ AST.TypeSignature <$> makeNonemptyList ", " (mapM trfName names) +trfClassInstSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.InstBodyDecl (Dom r) RangeStage) +trfClassInstSig = trfLocNoSema $ \case + TypeSig names typ -> AST.InstBodyTypeSig <$> (annContNoSema $ AST.TypeSignature <$> makeNonemptyList ", " (mapM trfName names) <*> trfType (hswc_body $ hsib_body typ)) - ClassOpSig _ names typ -> AST.InstBodyTypeSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) + ClassOpSig _ names typ -> AST.InstBodyTypeSig <$> (annContNoSema $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) <*> trfType (hsib_body typ)) SpecInstSig _ typ -> AST.SpecializeInstance <$> trfType (hsib_body typ) s -> error ("Illegal class instance signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")") -trfInstTypeFam :: TransformName n r => Located (TyFamInstDecl n) -> Trf (Ann AST.InstBodyDecl r) +trfInstTypeFam :: TransformName n r => Located (TyFamInstDecl n) -> Trf (Ann AST.InstBodyDecl (Dom r) RangeStage) trfInstTypeFam (unLoc -> TyFamInstDecl eqn _) = copyAnnot AST.InstBodyTypeDecl (trfTypeEq eqn) -trfInstDataFam :: TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.InstBodyDecl r) -trfInstDataFam = trfLoc $ \case +trfInstDataFam :: TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.InstBodyDecl (Dom r) RangeStage) +trfInstDataFam = trfLocNoSema $ \case (DataFamInstDecl tc (hsib_body -> pats) (HsDataDefn dn ctx _ _ cons derivs) _) -> AST.InstBodyDataDecl <$> trfDataKeyword dn - <*> annLoc (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx) - (AST.InstanceRule <$> nothing "" " . " atTheStart - <*> trfCtx atTheStart ctx - <*> foldr (\t r -> annLoc (combineSrcSpans (getLoc t) . getRange . _annotation <$> r) - (AST.InstanceHeadApp <$> r <*> (trfType t))) - (copyAnnot AST.InstanceHeadCon (trfName tc)) pats) + <*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx) + (AST.InstanceRule <$> nothing "" " . " atTheStart + <*> trfCtx atTheStart ctx + <*> foldr (\t r -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r) + (AST.InstanceHeadApp <$> r <*> (trfType t))) + (copyAnnot AST.InstanceHeadCon (trfName tc)) pats) <*> trfAnnList "" trfConDecl' cons <*> trfMaybe " deriving " "" trfDerivings derivs -trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.PatternSynonym r) +trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.PatternSynonym (Dom r) RangeStage) trfPatternSynonym (PSB id _ lhs def dir) = let sep = case dir of ImplicitBidirectional -> AnnEqual _ -> AnnLarrow @@ -385,40 +385,40 @@ _ -> [] changedRhs = biplateRef .- (\n -> case lookup n rewrites of Just x -> x; Nothing -> n) $ def in AST.PatternSynonym <$> trfPatSynLhs id lhs - <*> annLoc rhsLoc (trfPatSynRhs dir changedRhs) + <*> annLocNoSema rhsLoc (trfPatSynRhs dir changedRhs) - where trfPatSynLhs :: TransformName n r => Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.PatSynLhs r) + where trfPatSynLhs :: TransformName n r => Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.PatSynLhs (Dom r) RangeStage) trfPatSynLhs id (PrefixPatSyn args) - = annLoc (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.NormalPatSyn <$> trfName id <*> trfAnnList " " trfName' args + = annLocNoSema (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.NormalPatSyn <$> trfName id <*> trfAnnList " " trfName' args trfPatSynLhs op (InfixPatSyn lhs rhs) - = annLoc (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.InfixPatSyn <$> trfName lhs <*> trfOperator op <*> trfName rhs + = annLocNoSema (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.InfixPatSyn <$> trfName lhs <*> trfOperator op <*> trfName rhs trfPatSynLhs id (RecordPatSyn flds) - = annLoc (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) + = annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) $ AST.RecordPatSyn <$> trfName id <*> trfAnnList ", " trfName' (map recordPatSynSelectorId flds) - trfPatSynRhs :: TransformName n r => HsPatSynDir n -> Located (Pat n) -> Trf (AST.PatSynRhs r) + trfPatSynRhs :: TransformName n r => HsPatSynDir n -> Located (Pat n) -> Trf (AST.PatSynRhs (Dom r) RangeStage) trfPatSynRhs ImplicitBidirectional pat = AST.BidirectionalPatSyn <$> trfPattern pat <*> nothing " where " "" atTheEnd trfPatSynRhs (ExplicitBidirectional mg) pat = AST.BidirectionalPatSyn <$> trfPattern pat <*> (makeJust <$> trfPatSynWhere mg) trfPatSynRhs Unidirectional pat = AST.OneDirectionalPatSyn <$> trfPattern pat - trfPatSynWhere :: TransformName n r => MatchGroup n (LHsExpr n) -> Trf (Ann AST.PatSynWhere r) - trfPatSynWhere (MG { mg_alts = alts }) = annLoc (pure $ getLoc alts) (AST.PatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts))) + trfPatSynWhere :: TransformName n r => MatchGroup n (LHsExpr n) -> Trf (Ann AST.PatSynWhere (Dom r) RangeStage) + trfPatSynWhere (MG { mg_alts = alts }) = annLocNoSema (pure $ getLoc alts) (AST.PatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts))) -trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybe AST.KindConstraint r) +trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybe AST.KindConstraint (Dom r) RangeStage) trfFamilyKind (unLoc -> fr) = case fr of NoSig -> nothing "" " " atTheEnd KindSig k -> trfKindSig (Just k) -trfFamilyResultSig :: TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybe AST.TypeFamilySpec r) +trfFamilyResultSig :: TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybe AST.TypeFamilySpec (Dom r) RangeStage) trfFamilyResultSig (L l fr) Nothing = case fr of NoSig -> nothing "" " " atTheEnd - KindSig k -> makeJust <$> (annLoc (pure l) $ AST.TypeFamilyKind <$> trfKindSig' k) + KindSig k -> makeJust <$> (annLocNoSema (pure l) $ AST.TypeFamilyKind <$> trfKindSig' k) trfFamilyResultSig _ (Just (L l (InjectivityAnn n deps))) - = makeJust <$> (annLoc (pure l) $ AST.TypeFamilyInjectivity <$> (annCont $ AST.InjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps)) + = makeJust <$> (annLocNoSema (pure l) $ AST.TypeFamilyInjectivity <$> (annContNoSema $ AST.InjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps)) -trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.AnnotationSubject r) +trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.AnnotationSubject (Dom r) RangeStage) trfAnnotationSubject stxt subject payloadEnd = do payloadStart <- advanceStr stxt <$> atTheStart - case subject of ValueAnnProvenance name@(L l _) -> annLoc (pure l) (AST.NameAnnotation <$> trfName name) - TypeAnnProvenance name@(L l _) -> annLoc (pure $ mkSrcSpan payloadStart (srcSpanEnd l)) - (AST.TypeAnnotation <$> trfName name) - ModuleAnnProvenance -> annLoc (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.ModuleAnnotation) + case subject of ValueAnnProvenance name@(L l _) -> annLocNoSema (pure l) (AST.NameAnnotation <$> trfName name) + TypeAnnProvenance name@(L l _) -> annLocNoSema (pure $ mkSrcSpan payloadStart (srcSpanEnd l)) + (AST.TypeAnnotation <$> trfName name) + ModuleAnnProvenance -> annLocNoSema (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.ModuleAnnotation) diff --git a/Language/Haskell/Tools/AST/FromGHC/Exprs.hs b/Language/Haskell/Tools/AST/FromGHC/Exprs.hs --- a/Language/Haskell/Tools/AST/FromGHC/Exprs.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Exprs.hs @@ -11,6 +11,7 @@ import Control.Monad.Reader import Control.Reference +import GHC import SrcLoc as GHC import RdrName as GHC import HsTypes as GHC @@ -22,6 +23,7 @@ import ApiAnnotation as GHC import FastString as GHC import Outputable as GHC +import PrelNames as GHC import Language.Haskell.Tools.AST.FromGHC.Base import Language.Haskell.Tools.AST.FromGHC.Types @@ -34,36 +36,38 @@ import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST (Ann(..), AnnList(..)) +import Language.Haskell.Tools.AST (Ann(..), AnnList(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST import Debug.Trace -trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr r) +trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr (Dom r) RangeStage) -- correction for empty cases (TODO: put of and {} inside) trfExpr (L l cs@(HsCase expr (unLoc . mg_alts -> []))) - = addScopeInfo @n =<< annLoc (pure $ combineSrcSpans l (getLoc expr)) (trfExpr' cs) -trfExpr e = addScopeInfo @n =<< trfLoc trfExpr' e + = annLoc createScopeInfo (pure $ combineSrcSpans l (getLoc expr)) (trfExpr' cs) +trfExpr e = trfLoc trfExpr' createScopeInfo e -addScopeInfo :: forall n r . TransformName n r => Ann AST.Expr r -> Trf (Ann AST.Expr r) -addScopeInfo expr = do scope <- asks localsInScope - return $ AST.annotation .- addSemanticInfo (AST.ScopeInfo scope :: AST.SemanticInfo n) $ expr +createScopeInfo :: Trf AST.ScopeInfo +createScopeInfo = do scope <- asks localsInScope + return (AST.ScopeInfo scope) -trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr r) +trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr (Dom r) RangeStage) trfExpr' (HsVar name) = AST.Var <$> trfName name trfExpr' (HsRecFld fld) = AST.Var <$> (asks contRange >>= \l -> trfAmbiguousFieldName' l fld) -trfExpr' (HsIPVar (HsIPName ip)) = AST.Var <$> annCont (AST.NormalName <$> annCont (AST.nameFromList <$> trfNameStr (unpackFS ip))) -trfExpr' (HsOverLit (ol_val -> val)) = AST.Lit <$> annCont (trfOverloadedLit val) -trfExpr' (HsLit val) = AST.Lit <$> annCont (trfLiteral' val) +trfExpr' (HsIPVar (HsIPName ip)) = AST.Var <$> annContNoSema (AST.NormalName <$> annCont (createImplicitNameInfo (unpackFS ip)) (AST.nameFromList <$> trfNameStr (unpackFS ip))) +trfExpr' (HsOverLit (ol_val -> val)) = AST.Lit <$> annContNoSema (trfOverloadedLit val) +trfExpr' (HsLit val) = AST.Lit <$> annContNoSema (trfLiteral' val) trfExpr' (HsLam (unLoc . mg_alts -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] expr] (unLoc -> EmptyLocalBinds))])) = AST.Lambda <$> (trfAnnList " " trfPattern' pats) <*> addToScope pats (trfExpr expr) trfExpr' (HsLamCase _ (unLoc . mg_alts -> matches)) = AST.LamCase <$> trfAnnList " " trfAlt' matches trfExpr' (HsApp e1 e2) = AST.App <$> trfExpr e1 <*> trfExpr e2 trfExpr' (OpApp e1 (unLoc -> HsVar op) _ e2) = AST.InfixApp <$> trfExpr e1 <*> trfOperator op <*> trfExpr e2 -trfExpr' (NegApp e _) = AST.PrefixApp <$> annLoc loc (AST.NormalOp <$> annLoc loc (AST.nameFromList <$> trfNameStr "-")) +trfExpr' (NegApp e _) = AST.PrefixApp <$> annLocNoSema loc (AST.NormalOp <$> annLoc info loc (AST.nameFromList <$> trfNameStr "-")) <*> trfExpr e where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e)) + info = createNameInfo =<< (fromMaybe (error "minus operation is not found") <$> lift negateOpName) + negateOpName = getFromNameUsing (\n -> (\case Just (AnId id) -> Just id; _ -> Nothing) <$> lookupName n) negateName trfExpr' (HsPar (unLoc -> SectionL expr (unLoc -> HsVar op))) = AST.LeftSection <$> trfExpr expr <*> trfOperator op trfExpr' (HsPar (unLoc -> SectionR (unLoc -> HsVar op) expr)) = AST.RightSection <$> trfOperator op <*> trfExpr expr trfExpr' (HsPar expr) = AST.Paren <$> trfExpr expr @@ -75,10 +79,10 @@ (do locs <- elemLocs makeList ", " atTheEnd $ mapM trfTupSecElem (zip (map unLoc tupArgs) locs)) where wrap = if box == Boxed then AST.TupleSection else AST.UnboxedTupSec - trfTupSecElem :: forall n r . TransformName n r => (HsTupArg n, SrcSpan) -> Trf (Ann AST.TupSecElem r) + trfTupSecElem :: forall n r . TransformName n r => (HsTupArg n, SrcSpan) -> Trf (Ann AST.TupSecElem (Dom r) RangeStage) trfTupSecElem (Present e, l) - = annLoc (pure l) (AST.Present <$> (addScopeInfo @n =<< annCont (trfExpr' (unLoc e)))) - trfTupSecElem (Missing _, l) = annLoc (pure l) (pure AST.Missing) + = annLocNoSema (pure l) (AST.Present <$> (annCont createScopeInfo (trfExpr' (unLoc e)))) + trfTupSecElem (Missing _, l) = annLocNoSema (pure l) (pure AST.Missing) elemLocs :: Trf [SrcSpan] elemLocs = do r <- asks contRange @@ -96,12 +100,12 @@ trfExpr' (HsIf _ expr thenE elseE) = AST.If <$> trfExpr expr <*> trfExpr thenE <*> trfExpr elseE trfExpr' (HsMultiIf _ parts) = AST.MultiIf <$> trfAnnList "" trfGuardedCaseRhs' parts trfExpr' (HsLet (unLoc -> binds) expr) = addToScope binds (AST.Let <$> trfLocalBinds binds <*> trfExpr expr) -trfExpr' (HsDo DoExpr (unLoc -> stmts) _) = AST.Do <$> annLoc (tokenLoc AnnDo) (pure AST.DoKeyword) +trfExpr' (HsDo DoExpr (unLoc -> stmts) _) = AST.Do <$> annLocNoSema (tokenLoc AnnDo) (pure AST.DoKeyword) <*> makeNonemptyIndentedList (trfScopedSequence trfDoStmt stmts) trfExpr' (HsDo MDoExpr (unLoc -> [unLoc -> RecStmt { recS_stmts = stmts }, lastStmt]) _) - = AST.Do <$> annLoc (tokenLoc AnnMdo) (pure AST.MDoKeyword) + = AST.Do <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.MDoKeyword) <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt (stmts ++ [lastStmt]))) -trfExpr' (HsDo MDoExpr (unLoc -> stmts) _) = AST.Do <$> annLoc (tokenLoc AnnMdo) (pure AST.MDoKeyword) +trfExpr' (HsDo MDoExpr (unLoc -> stmts) _) = AST.Do <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.MDoKeyword) <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt stmts)) -- TODO: scoping trfExpr' (HsDo ListComp (unLoc -> stmts) _) @@ -129,74 +133,72 @@ trfExpr' (PArrSeq _ (FromThenTo from step to)) = AST.ParArrayEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> trfExpr to -- TODO: SCC, CORE, GENERATED annotations -trfExpr' (HsBracket brack) = AST.BracketExpr <$> annCont (trfBracket' brack) -trfExpr' (HsRnBracketOut brack _) = AST.BracketExpr <$> annCont (trfBracket' brack) -trfExpr' (HsTcBracketOut brack _) = AST.BracketExpr <$> annCont (trfBracket' brack) -trfExpr' (HsSpliceE qq@(HsQuasiQuote {})) = AST.QuasiQuoteExpr <$> annCont (trfQuasiQuotation' qq) -trfExpr' (HsSpliceE splice) = AST.Splice <$> annCont (trfSplice' splice) +trfExpr' (HsBracket brack) = AST.BracketExpr <$> annContNoSema (trfBracket' brack) +trfExpr' (HsSpliceE qq@(HsQuasiQuote {})) = AST.QuasiQuoteExpr <$> annContNoSema (trfQuasiQuotation' qq) +trfExpr' (HsSpliceE splice) = AST.Splice <$> annContNoSema (trfSplice' splice) trfExpr' (HsProc pat cmdTop) = AST.Proc <$> trfPattern pat <*> trfCmdTop cmdTop trfExpr' (HsStatic expr) = AST.StaticPtr <$> trfExpr expr trfExpr' (HsAppType expr typ) = AST.ExplTypeApp <$> trfExpr expr <*> trfType (hswc_body typ) trfExpr' t = error ("Illegal expression: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")") -trfFieldInits :: TransformName n r => HsRecFields n (LHsExpr n) -> Trf (AnnList AST.FieldUpdate r) +trfFieldInits :: TransformName n r => HsRecFields n (LHsExpr n) -> Trf (AnnList AST.FieldUpdate (Dom r) RangeStage) trfFieldInits (HsRecFields fields dotdot) = do cont <- asks contRange makeList ", " (before AnnCloseC) $ ((++) <$> mapM trfFieldInit (filter ((cont /=) . getLoc) fields) - <*> (if isJust dotdot then (:[]) <$> annLoc (tokenLoc AnnDotdot) - (pure AST.FieldWildcard) + <*> (if isJust dotdot then (:[]) <$> annLocNoSema (tokenLoc AnnDotdot) + (pure AST.FieldWildcard) else pure [])) -trfFieldInit :: TransformName n r => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.FieldUpdate r) -trfFieldInit = trfLoc $ \case +trfFieldInit :: TransformName n r => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.FieldUpdate (Dom r) RangeStage) +trfFieldInit = trfLocNoSema $ \case HsRecField id _ True -> AST.FieldPun <$> trfName (getFieldOccName id) HsRecField id val False -> AST.NormalFieldUpdate <$> trfName (getFieldOccName id) <*> trfExpr val -trfFieldUpdate :: TransformName n r => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.FieldUpdate r) +trfFieldUpdate :: TransformName n r => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.FieldUpdate (Dom r) RangeStage) trfFieldUpdate (HsRecField id _ True) = AST.FieldPun <$> trfAmbiguousFieldName id trfFieldUpdate (HsRecField id val False) = AST.NormalFieldUpdate <$> trfAmbiguousFieldName id <*> trfExpr val -trfAlt :: TransformName n r => Located (Match n (LHsExpr n)) -> Trf (Ann AST.Alt r) -trfAlt = trfLoc trfAlt' +trfAlt :: TransformName n r => Located (Match n (LHsExpr n)) -> Trf (Ann AST.Alt (Dom r) RangeStage) +trfAlt = trfLocNoSema trfAlt' -trfAlt' :: TransformName n r => Match n (LHsExpr n) -> Trf (AST.Alt r) +trfAlt' :: TransformName n r => Match n (LHsExpr n) -> Trf (AST.Alt (Dom r) RangeStage) trfAlt' = gTrfAlt' trfExpr -gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> Match n (Located (ge n)) -> Trf (AST.Alt' ae r) +gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Match n (Located (ge n)) -> Trf (AST.Alt' ae (Dom r) RangeStage) gTrfAlt' te (Match _ [pat] typ (GRHSs rhss (unLoc -> locBinds))) = AST.Alt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds locBinds -trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.CaseRhs r) +trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.CaseRhs (Dom r) RangeStage) trfCaseRhss = gTrfCaseRhss trfExpr -gTrfCaseRhss :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.CaseRhs' ae) r) -gTrfCaseRhss te [unLoc -> GRHS [] body] = annLoc (combineSrcSpans (getLoc body) <$> tokenLocBack AnnRarrow) +gTrfCaseRhss :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.CaseRhs' ae) (Dom r) RangeStage) +gTrfCaseRhss te [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> tokenLocBack AnnRarrow) (AST.UnguardedCaseRhs <$> te body) -gTrfCaseRhss te rhss = annLoc (pure $ collectLocs rhss) +gTrfCaseRhss te rhss = annLocNoSema (pure $ collectLocs rhss) (AST.GuardedCaseRhss <$> trfAnnList ";" (gTrfGuardedCaseRhs' te) rhss) -trfGuardedCaseRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedCaseRhs r) -trfGuardedCaseRhs = trfLoc trfGuardedCaseRhs' +trfGuardedCaseRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedCaseRhs (Dom r) RangeStage) +trfGuardedCaseRhs = trfLocNoSema trfGuardedCaseRhs' -trfGuardedCaseRhs' :: TransformName n r => GRHS n (LHsExpr n) -> Trf (AST.GuardedCaseRhs r) +trfGuardedCaseRhs' :: TransformName n r => GRHS n (LHsExpr n) -> Trf (AST.GuardedCaseRhs (Dom r) RangeStage) trfGuardedCaseRhs' = gTrfGuardedCaseRhs' trfExpr -gTrfGuardedCaseRhs' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> GRHS n (Located (ge n)) -> Trf (AST.GuardedCaseRhs' ae r) +gTrfGuardedCaseRhs' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> GRHS n (Located (ge n)) -> Trf (AST.GuardedCaseRhs' ae (Dom r) RangeStage) gTrfGuardedCaseRhs' te (GRHS guards body) = AST.GuardedCaseRhs <$> trfAnnList " " trfRhsGuard' guards <*> te body -trfCmdTop :: TransformName n r => Located (HsCmdTop n) -> Trf (Ann AST.Cmd r) +trfCmdTop :: TransformName n r => Located (HsCmdTop n) -> Trf (Ann AST.Cmd (Dom r) RangeStage) trfCmdTop (L _ (HsCmdTop cmd _ _ _)) = trfCmd cmd -trfCmd :: TransformName n r => Located (HsCmd n) -> Trf (Ann AST.Cmd r) -trfCmd = trfLoc trfCmd' +trfCmd :: TransformName n r => Located (HsCmd n) -> Trf (Ann AST.Cmd (Dom r) RangeStage) +trfCmd = trfLocNoSema trfCmd' -trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd r) +trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd (Dom r) RangeStage) trfCmd' (HsCmdArrApp left right _ typ dir) = AST.ArrowAppCmd <$> trfExpr left <*> op <*> trfExpr right - where op = case (typ, dir) of (HsFirstOrderApp, False) -> annLoc (tokenLoc Annrarrowtail) (pure AST.RightAppl) - (HsFirstOrderApp, True) -> annLoc (tokenLoc Annlarrowtail) (pure AST.LeftAppl) - (HsHigherOrderApp, False) -> annLoc (tokenLoc AnnRarrowtail) (pure AST.RightHighApp) - (HsHigherOrderApp, True) -> annLoc (tokenLoc AnnLarrowtail) (pure AST.LeftHighApp) + where op = case (typ, dir) of (HsFirstOrderApp, False) -> annLocNoSema (tokenLoc Annrarrowtail) (pure AST.RightAppl) + (HsFirstOrderApp, True) -> annLocNoSema (tokenLoc Annlarrowtail) (pure AST.LeftAppl) + (HsHigherOrderApp, False) -> annLocNoSema (tokenLoc AnnRarrowtail) (pure AST.RightHighApp) + (HsHigherOrderApp, True) -> annLocNoSema (tokenLoc AnnLarrowtail) (pure AST.LeftHighApp) -- FIXME: needs a before trfCmd' (HsCmdArrForm expr _ cmds) = AST.ArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds) trfCmd' (HsCmdApp cmd expr) = AST.AppCmd <$> trfCmd cmd <*> trfExpr expr @@ -204,7 +206,7 @@ = AST.LambdaCmd <$> trfAnnList " " trfPattern' pats <*> trfCmd body trfCmd' (HsCmdPar cmd) = AST.ParenCmd <$> trfCmd cmd trfCmd' (HsCmdCase expr (MG (unLoc -> alts) _ _ _)) - = AST.CaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLoc (gTrfAlt' trfCmd)) alts) + = AST.CaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfAlt' trfCmd)) alts) trfCmd' (HsCmdIf _ pred thenExpr elseExpr) = AST.IfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.LetCmd <$> trfLocalBinds binds <*> trfCmd cmd) -trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.DoCmd <$> makeNonemptyIndentedList (mapM (trfLoc (gTrfDoStmt' trfCmd)) stmts) +trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.DoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts) diff --git a/Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot b/Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot --- a/Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot +++ b/Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot @@ -7,10 +7,9 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.Base -import Language.Haskell.Tools.AST (Ann(..)) +import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr r) -trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr r) - -trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd r) +trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr (Dom r) RangeStage) +trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr (Dom r) RangeStage) +trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd (Dom r) RangeStage) diff --git a/Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs b/Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs --- a/Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs +++ b/Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs @@ -3,10 +3,14 @@ , FlexibleInstances , ScopedTypeVariables , ViewPatterns + , LambdaCase #-} module Language.Haskell.Tools.AST.FromGHC.GHCUtils where import Data.List +import qualified Data.Map as Map +import Data.Generics.Uniplate.Operations +import Data.Generics.Uniplate.Data import GHC import Bag @@ -15,9 +19,15 @@ import Name import Outputable import SrcLoc +import ConLike +import Id +import PatSyn +import Type +import TysWiredIn class OutputableBndr name => GHCName name where rdrName :: name -> RdrName + getFromNameUsing :: Applicative f => (Name -> Ghc (f Id)) -> Name -> Ghc (f name) getBindsAndSigs :: HsValBinds name -> ([LSig name], LHsBinds name) nameFromId :: Id -> name unpackPostRn :: RdrName -> PostRn name name -> name @@ -26,6 +36,7 @@ instance GHCName RdrName where rdrName = id + getFromNameUsing _ n = return $ pure (nameRdrName n) getBindsAndSigs (ValBindsIn binds sigs) = (sigs, binds) nameFromId = nameRdrName . getName unpackPostRn rdr _ = rdr @@ -37,6 +48,7 @@ instance GHCName GHC.Name where rdrName = nameRdrName + getFromNameUsing f n = fmap nameFromId <$> f n getBindsAndSigs (ValBindsOut bindGroups sigs) = (sigs, unionManyBags (map snd bindGroups)) nameFromId = getName unpackPostRn _ a = a @@ -48,6 +60,32 @@ getFieldOccName' :: GHCName n => FieldOcc n -> n getFieldOccName' (FieldOcc (L _ rdr) postRn) = unpackPostRn rdr postRn + + + +-- | Loading ids for top-level ghc names +getTopLevelId :: GHC.Name -> Ghc (Maybe GHC.Id) +getTopLevelId name = + lookupName name >>= \case + Just (AnId id) -> return (Just id) + Just (AConLike (RealDataCon dc)) -> return $ Just $ mkVanillaGlobal name (dataConUserType dc) + Just (AConLike (PatSynCon ps)) -> return $ Just $ mkVanillaGlobal name (createPatSynType ps) + Just (ATyCon tc) -> return $ Just $ mkVanillaGlobal name (tyConKind tc) + Nothing -> return Nothing + where createPatSynType patSyn = case patSynSig patSyn of (_, _, _, _, args, res) -> mkFunTys args res + +-- | Loading ids for local ghc names +getLocalId :: LHsBinds Id -> GHC.Name -> Ghc (Maybe GHC.Id) +getLocalId bnds name = case Map.lookup name mapping of + Just id -> return (Just id) + Nothing | isTyVarName name + -- unit type is for cases we don't know the kind + -> return $ Just $ mkVanillaGlobal name unitTy + Nothing -> return Nothing + where mapping = Map.fromList $ map (\id -> (getName id, id)) $ extractTypes bnds + extractTypes :: LHsBinds Id -> [Id] + extractTypes = concatMap universeBi . bagToList + class HsHasName a where diff --git a/Language/Haskell/Tools/AST/FromGHC/Kinds.hs b/Language/Haskell/Tools/AST/FromGHC/Kinds.hs --- a/Language/Haskell/Tools/AST/FromGHC/Kinds.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Kinds.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns + , TypeFamilies + #-} module Language.Haskell.Tools.AST.FromGHC.Kinds where import SrcLoc as GHC @@ -19,22 +21,22 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..)) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), Dom, RangeStage, SemanticInfo, NoSemanticInfo) import qualified Language.Haskell.Tools.AST as AST import Debug.Trace -trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybe AST.KindConstraint r) +trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybe AST.KindConstraint (Dom r) RangeStage) trfKindSig = trfMaybe "" "" trfKindSig' -trfKindSig' :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.KindConstraint r) -trfKindSig' k = annLoc (combineSrcSpans (getLoc k) <$> (tokenBefore (srcSpanStart (getLoc k)) AnnDcolon)) - (AST.KindConstraint <$> trfLoc trfKind' k) +trfKindSig' :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.KindConstraint (Dom r) RangeStage) +trfKindSig' k = annLocNoSema (combineSrcSpans (getLoc k) <$> (tokenBefore (srcSpanStart (getLoc k)) AnnDcolon)) + (AST.KindConstraint <$> trfLocNoSema trfKind' k) -trfKind :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.Kind r) -trfKind = trfLoc (trfKind' . cleanHsType) +trfKind :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.Kind (Dom r) RangeStage) +trfKind = trfLocNoSema (trfKind' . cleanHsType) -trfKind' :: TransformName n r => HsKind n -> Trf (AST.Kind r) +trfKind' ::TransformName n r => HsKind n -> Trf (AST.Kind (Dom r) RangeStage) trfKind' = trfKind'' . cleanHsType where trfKind'' (HsTyVar (rdrName . unLoc -> Exact n)) | isWiredInName n && occNameString (nameOccName n) == "*" @@ -48,12 +50,13 @@ trfKind'' (HsListTy kind) = AST.KindList <$> trfKind kind trfKind'' (HsAppsTy [unLoc -> HsAppPrefix t]) = trfKind' (unLoc t) trfKind'' (HsAppsTy [unLoc -> HsAppInfix n]) = AST.KindVar <$> trfName n - trfKind'' pt@(HsExplicitListTy {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) - trfKind'' pt@(HsExplicitTupleTy {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) - trfKind'' pt@(HsTyLit {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) + trfKind'' pt@(HsExplicitListTy {}) = AST.KindPromoted <$> annContNoSema (trfPromoted' trfKind' pt) + trfKind'' pt@(HsExplicitTupleTy {}) = AST.KindPromoted <$> annContNoSema (trfPromoted' trfKind' pt) + trfKind'' pt@(HsTyLit {}) = AST.KindPromoted <$> annContNoSema (trfPromoted' trfKind' pt) trfKind'' k = error ("Illegal kind: " ++ showSDocUnsafe (ppr k) ++ " (ctor: " ++ show (toConstr k) ++ ")") -trfPromoted' :: TransformName n r => (HsType n -> Trf (a r)) -> HsType n -> Trf (AST.Promoted a r) +trfPromoted' :: (TransformName n r, SemanticInfo (Dom r) a ~ NoSemanticInfo) + => (HsType n -> Trf (a (Dom r) RangeStage)) -> HsType n -> Trf (AST.Promoted a (Dom r) RangeStage) trfPromoted' f (HsTyLit (HsNumTy _ int)) = pure $ AST.PromotedInt int trfPromoted' f (HsTyLit (HsStrTy _ str)) = pure $ AST.PromotedString (unpackFS str) trfPromoted' f (HsTyVar name) = AST.PromotedCon <$> trfName name diff --git a/Language/Haskell/Tools/AST/FromGHC/Literals.hs b/Language/Haskell/Tools/AST/FromGHC/Literals.hs --- a/Language/Haskell/Tools/AST/FromGHC/Literals.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Literals.hs @@ -13,9 +13,10 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils +import Language.Haskell.Tools.AST (Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfLiteral' :: HsLit -> Trf (AST.Literal a) +trfLiteral' :: HsLit -> Trf (AST.Literal (Dom r) RangeStage) trfLiteral' (HsChar _ ch) = pure $ AST.CharLit ch trfLiteral' (HsCharPrim _ ch) = pure $ AST.PrimCharLit ch trfLiteral' (HsString _ str) = pure $ AST.StringLit (unpackFS str) @@ -30,7 +31,7 @@ trfLiteral' (HsFloatPrim frac) = pure $ AST.PrimFloatLit (fl_value frac) trfLiteral' (HsDoublePrim frac) = pure $ AST.PrimDoubleLit (fl_value frac) -trfOverloadedLit :: OverLitVal -> Trf (AST.Literal a) +trfOverloadedLit :: OverLitVal -> Trf (AST.Literal (Dom r) RangeStage) trfOverloadedLit (HsIntegral _ i) = pure $ AST.IntLit i trfOverloadedLit (HsFractional frac) = pure $ AST.FracLit (fl_value frac) trfOverloadedLit (HsIsString _ str) = pure $ AST.StringLit (unpackFS str) diff --git a/Language/Haskell/Tools/AST/FromGHC/Modules.hs b/Language/Haskell/Tools/AST/FromGHC/Modules.hs --- a/Language/Haskell/Tools/AST/FromGHC/Modules.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Modules.hs @@ -15,7 +15,7 @@ import Data.Data import Data.Generics.Uniplate.Operations import Data.Generics.Uniplate.Data -import Data.StructuralTraversal +import Control.Applicative import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State @@ -47,75 +47,55 @@ import DynFlags as GHC import Language.Haskell.TH.LanguageExtensions -import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), RangeWithName, RangeWithType, RangeInfo - , SemanticInfo(..), semanticInfo, sourceInfo, semantics, annotation, nameInfo, nodeSpan) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), Dom, IdDom, RangeStage, NoSemanticInfo(..), NameInfo(..), CNameInfo(..), ScopeInfo(..), ImportInfo(..), ModuleInfo(..) + , semanticInfo, sourceInfo, semantics, annotation, nameInfo, nodeSpan, semaTraverse) import qualified Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.FromGHC.Base import Language.Haskell.Tools.AST.FromGHC.Decls import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils - -addTypeInfos :: LHsBinds Id -> Ann AST.Module RangeWithName -> Ghc (Ann AST.Module RangeWithType) -addTypeInfos bnds mod = traverseDown (return ()) (return ()) replaceNodeInfo mod - where replaceNodeInfo :: RangeWithName -> Ghc RangeWithType - replaceNodeInfo = semanticInfo !~ replaceSemanticInfo - replaceSemanticInfo NoSemanticInfo = return NoSemanticInfo - replaceSemanticInfo (ScopeInfo sc) = return $ ScopeInfo sc - replaceSemanticInfo (AmbiguousNameInfo sc d rdr l) = return $ NameInfo sc d (locMapping ! l) - replaceSemanticInfo (ModuleInfo mod imps) = ModuleInfo mod <$> mapM getType' imps - replaceSemanticInfo (NameInfo sc def ni) = NameInfo sc def <$> getType' ni - replaceSemanticInfo (ImportInfo mod access used) = ImportInfo mod <$> mapM getType' access <*> mapM getType' used - - getType' :: GHC.Name -> Ghc GHC.Id - getType' name = fromMaybe (error $ "Type of name '" ++ showSDocUnsafe (ppr name) ++ "' cannot be found") <$> getType name - getType name - = lookupName name >>= \case - Just (AnId id) -> return (Just id) - Just (AConLike (RealDataCon dc)) -> return $ Just $ mkVanillaGlobal name (dataConUserType dc) - Just (AConLike (PatSynCon ps)) -> return $ Just $ mkVanillaGlobal name (createPatSynType ps) - Just (ATyCon tc) -> return $ Just $ mkVanillaGlobal name (tyConKind tc) - Nothing -> case Map.lookup name mapping of - Just id -> return (Just id) - Nothing | isTyVarName name - -- unit type is for cases we don't know the kind - -> return $ Just $ mkVanillaGlobal name unitTy - Nothing -> return Nothing - mapping = Map.fromList $ map (\id -> (getName id, id)) $ extractTypes bnds - locMapping = Map.fromList $ map (\(L l id) -> (l, id)) $ extractExprIds bnds - createPatSynType patSyn = case patSynSig patSyn of (_, _, _, _, args, res) -> mkFunTys args res - -getTypeVariables :: GHC.TyCon -> [Id] -getTypeVariables tc - = tyConTyVars tc ++ maybe [] (\case (ClosedSynFamilyTyCon ax) -> maybe [] (concatMap cab_tvs . fromBranches . co_ax_branches) ax - _ -> []) (famTyConFlav_maybe tc) +import Language.Haskell.Tools.AST.FromGHC.GHCUtils -extractTypes :: LHsBinds Id -> [Id] -extractTypes = concatMap universeBi . bagToList +addTypeInfos :: LHsBinds Id -> Ann AST.Module (Dom GHC.Name) RangeStage -> Ghc (Ann AST.Module IdDom RangeStage) +addTypeInfos bnds = semaTraverse + (AST.SemaTrf + (\case (NameInfo sc def ni) -> CNameInfo sc def <$> getType' ni + (AmbiguousNameInfo sc d rdr l) -> return $ CNameInfo sc d (locMapping ! l)) + pure + (\(ImportInfo mod access used) -> ImportInfo mod <$> mapM getType' access <*> mapM getType' used) + (\(ModuleInfo mod imps) -> ModuleInfo mod <$> mapM getType' imps) + pure) + where locMapping = Map.fromList $ map (\(L l id) -> (l, id)) $ extractExprIds bnds + getType' name = fromMaybe (error $ "Type of name '" ++ showSDocUnsafe (ppr name) ++ "' cannot be found") + <$> ((<|>) <$> getTopLevelId name <*> getLocalId bnds name) extractExprIds :: LHsBinds Id -> [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))) -> Just (L l n); _ -> Nothing) . concatMap universeBi . bagToList +createModuleInfo :: Module -> Trf (AST.ModuleInfo GHC.Name) +createModuleInfo mod = do prelude <- lift (xopt ImplicitPrelude . ms_hspp_opts <$> getModSummary (moduleName mod)) + (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (mod, []) + return $ AST.ModuleInfo mod preludeImports -trfModule :: Located (HsModule RdrName) -> Trf (Ann AST.Module RangeInfo) -trfModule = trfLocCorrect (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $ - \(HsModule name exports imports decls deprec _) -> - AST.Module <$> trfFilePragmas - <*> trfModuleHead name exports deprec - <*> trfImports imports - <*> trfDecls decls +trfModule :: Module -> Located (HsModule RdrName) -> Trf (Ann AST.Module (Dom RdrName) RangeStage) +trfModule mod = trfLocCorrect (createModuleInfo mod) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $ + \(HsModule name exports imports decls deprec _) -> + AST.Module <$> trfFilePragmas + <*> trfModuleHead name exports deprec + <*> trfImports imports + <*> trfDecls decls -trfModuleRename :: Module -> Ann AST.Module RangeInfo -> (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) -> Located (HsModule RdrName) -> Trf (Ann AST.Module RangeWithName) -trfModuleRename mod rangeMod (gr,imports,exps,_) hsMod = do - prelude <- lift (xopt ImplicitPrelude . ms_hspp_opts <$> getModSummary (moduleName mod)) - (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (mod, []) - let addModuleInfo :: Module -> Ann AST.Module RangeWithName -> Trf (Ann AST.Module RangeWithName) - addModuleInfo m = AST.semantics != ModuleInfo m preludeImports - addModuleInfo mod =<< trfLocCorrect (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) (trfModuleRename' preludeImports) hsMod - +trfModuleRename :: Module -> Ann AST.Module (Dom RdrName) RangeStage + -> (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) + -> Located (HsModule RdrName) + -> Trf (Ann AST.Module (Dom GHC.Name) RangeStage) +trfModuleRename mod rangeMod (gr,imports,exps,_) hsMod + = do info <- createModuleInfo mod + trfLocCorrect (pure info) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) (trfModuleRename' (info ^. AST.implicitNames)) hsMod where originalNames = Map.fromList $ catMaybes $ map getSourceAndInfo (rangeMod ^? biplateRef) - getSourceAndInfo :: Ann AST.SimpleName RangeInfo -> Maybe (SrcSpan, RdrName) + getSourceAndInfo :: Ann AST.SimpleName (Dom RdrName) RangeStage -> Maybe (SrcSpan, RdrName) getSourceAndInfo n = (,) <$> (n ^? annotation&sourceInfo&nodeSpan) <*> (n ^? semantics&nameInfo) trfModuleRename' preludeImports hsMod@(HsModule name exports _ decls deprec _) = do @@ -127,102 +107,102 @@ <*> return transformedImports <*> addToScope (concat @[] (transformedImports ^? AST.annList&semantics&AST.importedNames) ++ preludeImports) (trfDeclsGroup gr) -trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModuleHead r) +trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModuleHead (Dom r) RangeStage) trfModuleHead (Just mn) exports modPrag - = makeJust <$> (annLoc (tokensLoc [AnnModule, AnnWhere]) - (AST.ModuleHead <$> trfModuleName mn - <*> trfExportList (srcSpanEnd $ getLoc mn) exports - <*> trfModulePragma modPrag)) + = makeJust <$> (annLocNoSema (tokensLoc [AnnModule, AnnWhere]) + (AST.ModuleHead <$> trfModuleName mn + <*> trfExportList (srcSpanEnd $ getLoc mn) exports + <*> trfModulePragma modPrag)) trfModuleHead _ Nothing _ = nothing "" "" moduleHeadPos where moduleHeadPos = after AnnClose >>= \case loc@(RealSrcLoc _) -> return loc _ -> atTheStart -trfFilePragmas :: RangeAnnot a => Trf (AnnList AST.FilePragma a) +trfFilePragmas :: Trf (AnnList AST.FilePragma (Dom r) RangeStage) trfFilePragmas = do pragmas <- asks pragmaComms languagePragmas <- mapM trfLanguagePragma (fromMaybe [] $ (Map.lookup "LANGUAGE") pragmas) optionsPragmas <- mapM trfOptionsPragma (fromMaybe [] $ (Map.lookup "OPTIONS_GHC") pragmas) makeList "" atTheStart $ pure $ orderDefs $ languagePragmas ++ optionsPragmas -trfLanguagePragma :: RangeAnnot a => Located String -> Trf (Ann AST.FilePragma a) -trfLanguagePragma lstr@(L l str) = annLoc (pure l) (AST.LanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) - (mapM (trfLoc (pure . AST.LanguageExtension)) extensions)) +trfLanguagePragma :: Located String -> Trf (Ann AST.FilePragma (Dom r) RangeStage) +trfLanguagePragma lstr@(L l str) = annLocNoSema (pure l) (AST.LanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) + (mapM (trfLocNoSema (pure . AST.LanguageExtension)) extensions)) where pragmaElems = splitLocated lstr extensions = init $ drop 2 pragmaElems -trfOptionsPragma :: RangeAnnot a => Located String -> Trf (Ann AST.FilePragma a) -trfOptionsPragma (L l str) = annLoc (pure l) (AST.OptionsPragma <$> annCont (pure $ AST.StringNode str)) +trfOptionsPragma :: Located String -> Trf (Ann AST.FilePragma (Dom r) RangeStage) +trfOptionsPragma (L l str) = annLocNoSema (pure l) (AST.OptionsPragma <$> annContNoSema (pure $ AST.StringNode str)) -trfModulePragma :: RangeAnnot a => Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModulePragma a) -trfModulePragma = trfMaybeDefault " " "" (trfLoc $ \case WarningTxt _ txts -> AST.ModuleWarningPragma <$> trfAnnList " " trfText' txts - DeprecatedTxt _ txts -> AST.ModuleDeprecatedPragma <$> trfAnnList " " trfText' txts) +trfModulePragma :: Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModulePragma (Dom r) RangeStage) +trfModulePragma = trfMaybeDefault " " "" (trfLocNoSema $ \case WarningTxt _ txts -> AST.ModuleWarningPragma <$> trfAnnList " " trfText' txts + DeprecatedTxt _ txts -> AST.ModuleDeprecatedPragma <$> trfAnnList " " trfText' txts) (before AnnWhere) -trfText' :: RangeAnnot a => StringLiteral -> Trf (AST.StringNode a) +trfText' :: StringLiteral -> Trf (AST.StringNode (Dom r) RangeStage) trfText' = pure . AST.StringNode . unpackFS . sl_fs -trfExportList :: TransformName n r => SrcLoc -> Maybe (Located [LIE n]) -> Trf (AnnMaybe AST.ExportSpecList r) -trfExportList loc = trfMaybeDefault " " "" (trfLoc trfExportList') (pure loc) +trfExportList :: TransformName n r => SrcLoc -> Maybe (Located [LIE n]) -> Trf (AnnMaybe AST.ExportSpecList (Dom r) RangeStage) +trfExportList loc = trfMaybeDefault " " "" (trfLocNoSema trfExportList') (pure loc) -trfExportList' :: TransformName n r => [LIE n] -> Trf (AST.ExportSpecList r) +trfExportList' :: TransformName n r => [LIE n] -> Trf (AST.ExportSpecList (Dom r) RangeStage) trfExportList' exps = AST.ExportSpecList <$> (makeList ", " (after AnnOpenP) (orderDefs . catMaybes <$> (mapM trfExport exps))) -trfExport :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.ExportSpec r)) -trfExport = trfMaybeLoc $ \case +trfExport :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.ExportSpec (Dom r) RangeStage)) +trfExport = trfMaybeLocNoSema $ \case IEModuleContents n -> Just . AST.ModuleExport <$> (trfModuleName n) other -> do trf <- trfIESpec' other - fmap AST.DeclExport <$> (sequence $ fmap (annCont . return) trf) + fmap AST.DeclExport <$> (sequence $ fmap (annContNoSema . return) trf) -trfImports :: TransformName n r => [LImportDecl n] -> Trf (AnnList AST.ImportDecl r) +trfImports :: TransformName n r => [LImportDecl n] -> Trf (AnnList AST.ImportDecl (Dom r) RangeStage) trfImports (filter (not . ideclImplicit . unLoc) -> imps) = AnnList <$> importDefaultLoc <*> mapM trfImport imps - where importDefaultLoc = toIndentedListAnnot (if Data.List.null imps then "\n" else "") "" "\n" . srcSpanEnd + where importDefaultLoc = noSemaInfo . AST.ListPos (if Data.List.null imps then "\n" else "") "" "\n" True . srcSpanEnd <$> (combineSrcSpans <$> asks (srcLocSpan . srcSpanStart . contRange) <*> (srcLocSpan . srcSpanEnd <$> tokenLoc AnnWhere)) -trfImport :: forall n r . TransformName n r => LImportDecl n -> Trf (Ann AST.ImportDecl r) -trfImport = (addImportData @r @n <=<) $ trfLoc $ \(GHC.ImportDecl src name pkg isSrc isSafe isQual isImpl declAs declHiding) -> +trfImport :: TransformName n r => LImportDecl n -> Trf (Ann AST.ImportDecl (Dom r) RangeStage) +trfImport (L l (GHC.ImportDecl src name pkg isSrc isSafe isQual isImpl declAs declHiding)) = let -- default positions of optional parts of an import declaration annBeforeQual = if isSrc then AnnClose else AnnImport annBeforeSafe = if isQual then AnnQualified else annBeforeQual annBeforePkg = if isSafe then AnnSafe else annBeforeSafe atAsPos = if isJust declHiding then before AnnOpenP else atTheEnd - in AST.ImportDecl - <$> (if isSrc then makeJust <$> annLoc (tokensLoc [AnnOpen, AnnClose]) (pure AST.ImportSource) + in (\impdecl -> annLoc (createImportData =<< impdecl) (pure l) impdecl) $ AST.ImportDecl + <$> (if isSrc then makeJust <$> annLocNoSema (tokensLoc [AnnOpen, AnnClose]) (pure AST.ImportSource) else nothing " " "" (after AnnImport)) - <*> (if isQual then makeJust <$> (annLoc (tokenLoc AnnQualified) (pure AST.ImportQualified)) + <*> (if isQual then makeJust <$> (annLocNoSema (tokenLoc AnnQualified) (pure AST.ImportQualified)) else nothing " " "" (after annBeforeQual)) - <*> (if isSafe then makeJust <$> (annLoc (tokenLoc AnnSafe) (pure AST.ImportSafe)) + <*> (if isSafe then makeJust <$> (annLocNoSema (tokenLoc AnnSafe) (pure AST.ImportSafe)) else nothing " " "" (after annBeforeSafe)) <*> maybe (nothing " " "" (after annBeforePkg)) - (\str -> makeJust <$> (annLoc (tokenLoc AnnPackageName) (pure (AST.StringNode (unpackFS $ sl_fs str))))) pkg + (\str -> makeJust <$> (annLocNoSema (tokenLoc AnnPackageName) (pure (AST.StringNode (unpackFS $ sl_fs str))))) pkg <*> trfModuleName name <*> maybe (nothing " " "" atAsPos) (\mn -> makeJust <$> (trfRenaming mn)) declAs - <*> trfImportSpecs declHiding + <*> trfImportSpecs declHiding where trfRenaming mn - = annLoc (tokensLoc [AnnAs,AnnVal]) - (AST.ImportRenaming <$> (annLoc (tokenLoc AnnVal) - (trfModuleName' mn))) + = annLocNoSema (tokensLoc [AnnAs,AnnVal]) + (AST.ImportRenaming <$> (annLocNoSema (tokenLoc AnnVal) + (trfModuleName' mn))) -trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybe AST.ImportSpec r) +trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybe AST.ImportSpec (Dom r) RangeStage) trfImportSpecs (Just (True, l)) - = makeJust <$> trfLoc (\specs -> AST.ImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l + = makeJust <$> trfLocNoSema (\specs -> AST.ImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l trfImportSpecs (Just (False, l)) - = makeJust <$> trfLoc (\specs -> AST.ImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l + = makeJust <$> trfLocNoSema (\specs -> AST.ImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l trfImportSpecs Nothing = nothing " " "" atTheEnd -trfIESpec :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.IESpec r)) -trfIESpec = trfMaybeLoc trfIESpec' +trfIESpec :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.IESpec (Dom r) RangeStage)) +trfIESpec = trfMaybeLocNoSema trfIESpec' -trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.IESpec r)) +trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.IESpec (Dom r) RangeStage)) trfIESpec' (IEVar n) = Just <$> (AST.IESpec <$> trfName n <*> (nothing "(" ")" atTheEnd)) trfIESpec' (IEThingAbs n) = Just <$> (AST.IESpec <$> trfName n <*> (nothing "(" ")" atTheEnd)) trfIESpec' (IEThingAll n) - = Just <$> (AST.IESpec <$> trfName n <*> (makeJust <$> (annLoc (tokenLoc AnnDotdot) (pure AST.SubSpecAll)))) + = Just <$> (AST.IESpec <$> trfName n <*> (makeJust <$> (annLocNoSema (tokenLoc AnnDotdot) (pure AST.SubSpecAll)))) trfIESpec' (IEThingWith n _ ls _) = Just <$> (AST.IESpec <$> trfName n <*> (makeJust <$> between AnnOpenP AnnCloseP - (annCont $ AST.SubSpecList <$> makeList ", " (after AnnOpenP) (mapM trfName ls)))) + (annContNoSema $ AST.SubSpecList <$> makeList ", " (after AnnOpenP) (mapM trfName ls)))) trfIESpec' _ = pure Nothing diff --git a/Language/Haskell/Tools/AST/FromGHC/Patterns.hs b/Language/Haskell/Tools/AST/FromGHC/Patterns.hs --- a/Language/Haskell/Tools/AST/FromGHC/Patterns.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Patterns.hs @@ -25,17 +25,17 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..)) +import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfPattern :: TransformName n r => Located (Pat n) -> Trf (Ann AST.Pattern r) +trfPattern :: TransformName n r => Located (Pat n) -> Trf (Ann AST.Pattern (Dom r) RangeStage) -- field wildcards are not directly represented in GHC AST trfPattern (L l (ConPatIn name (RecCon (HsRecFields flds _)))) | any ((l ==) . getLoc) flds = do let (fromWC, notWC) = partition ((l ==) . getLoc) flds - normalFields <- mapM (trfLoc trfPatternField') notWC - wildc <- annLoc (tokenLoc AnnDotdot) (pure AST.FieldWildcardPattern) - annLoc (pure l) (AST.RecPat <$> trfName name <*> makeNonemptyList ", " (pure (normalFields ++ [wildc]))) -trfPattern p | otherwise = trfLoc trfPattern' (correctPatternLoc p) + normalFields <- mapM (trfLocNoSema trfPatternField') notWC + wildc <- annLocNoSema (tokenLoc AnnDotdot) (pure AST.FieldWildcardPattern) + annLocNoSema (pure l) (AST.RecPat <$> trfName name <*> makeNonemptyList ", " (pure (normalFields ++ [wildc]))) +trfPattern p | otherwise = trfLocNoSema trfPattern' (correctPatternLoc p) -- | Locations for right-associative infix patterns are incorrect in GHC AST correctPatternLoc :: Located (Pat n) -> Located (Pat n) @@ -43,7 +43,7 @@ = L (getLoc (correctPatternLoc left) `combineSrcSpans` getLoc (correctPatternLoc right)) p correctPatternLoc p = p -trfPattern' :: TransformName n r => Pat n -> Trf (AST.Pattern r) +trfPattern' :: TransformName n r => Pat n -> Trf (AST.Pattern (Dom r) RangeStage) trfPattern' (WildPat _) = pure AST.WildPat trfPattern' (VarPat name) = define $ AST.VarPat <$> trfName name trfPattern' (LazyPat pat) = AST.IrrPat <$> trfPattern pat @@ -57,14 +57,14 @@ trfPattern' (ConPatIn name (RecCon (HsRecFields flds _))) = AST.RecPat <$> trfName name <*> trfAnnList ", " trfPatternField' flds trfPattern' (ConPatIn name (InfixCon left right)) = AST.InfixPat <$> trfPattern left <*> trfOperator name <*> trfPattern right trfPattern' (ViewPat expr pat _) = AST.ViewPat <$> trfExpr expr <*> trfPattern pat -trfPattern' (SplicePat splice) = AST.SplicePat <$> annCont (trfSplice' splice) -trfPattern' (LitPat lit) = AST.LitPat <$> annCont (trfLiteral' lit) +trfPattern' (SplicePat splice) = AST.SplicePat <$> annContNoSema (trfSplice' splice) +trfPattern' (LitPat lit) = AST.LitPat <$> annContNoSema (trfLiteral' lit) trfPattern' (SigPatIn pat (hswc_body . hsib_body -> typ)) = AST.TypeSigPat <$> trfPattern pat <*> trfType typ -trfPattern' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.LitPat <$> annCont (trfOverloadedLit lit) -trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.NPlusKPat <$> define (trfName id) <*> annLoc (pure l) (trfOverloadedLit (ol_val lit)) +trfPattern' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.LitPat <$> annContNoSema (trfOverloadedLit lit) +trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.NPlusKPat <$> define (trfName id) <*> annLocNoSema (pure l) (trfOverloadedLit (ol_val lit)) -- coercion pattern introduced by GHC trfPattern' (CoPat _ pat _) = trfPattern' pat -trfPatternField' :: TransformName n r => HsRecField n (LPat n) -> Trf (AST.PatternField r) +trfPatternField' :: TransformName n r => HsRecField n (LPat n) -> Trf (AST.PatternField (Dom r) RangeStage) trfPatternField' (HsRecField id arg False) = AST.NormalFieldPattern <$> trfName (getFieldOccName id) <*> trfPattern arg trfPatternField' (HsRecField id _ True) = AST.FieldPunPattern <$> trfName (getFieldOccName id) diff --git a/Language/Haskell/Tools/AST/FromGHC/Stmts.hs b/Language/Haskell/Tools/AST/FromGHC/Stmts.hs --- a/Language/Haskell/Tools/AST/FromGHC/Stmts.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Stmts.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase , ViewPatterns + , TypeFamilies #-} module Language.Haskell.Tools.AST.FromGHC.Stmts where @@ -21,37 +22,36 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), AnnList(..), AnnMaybe(..)) +import Language.Haskell.Tools.AST (Ann(..), AnnList(..), AnnMaybe(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.Stmt r) -trfDoStmt = trfLoc trfDoStmt' +trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.Stmt (Dom r) RangeStage) +trfDoStmt = trfLocNoSema trfDoStmt' -trfDoStmt' :: TransformName n r => Stmt n (Located (HsExpr n)) -> Trf (AST.Stmt' AST.Expr r) +trfDoStmt' :: TransformName n r => Stmt n (Located (HsExpr n)) -> Trf (AST.Stmt' AST.Expr (Dom r) RangeStage) trfDoStmt' = gTrfDoStmt' trfExpr -gTrfDoStmt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> Stmt n (Located (ge n)) -> Trf (AST.Stmt' ae r) +gTrfDoStmt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Stmt n (Located (ge n)) -> Trf (AST.Stmt' ae (Dom r) RangeStage) gTrfDoStmt' et (BindStmt pat expr _ _ _) = AST.BindStmt <$> trfPattern pat <*> et expr gTrfDoStmt' et (BodyStmt expr _ _ _) = AST.ExprStmt <$> et expr gTrfDoStmt' et (LetStmt (unLoc -> binds)) = AST.LetStmt <$> addToScope binds (trfLocalBinds binds) gTrfDoStmt' et (LastStmt body _ _) = AST.ExprStmt <$> et body gTrfDoStmt' et (RecStmt { recS_stmts = stmts }) = AST.RecStmt <$> trfAnnList "," (gTrfDoStmt' et) stmts -trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnList AST.ListCompBody r) +trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnList AST.ListCompBody (Dom r) RangeStage) trfListCompStmts [unLoc -> ParStmt blocks _ _ _, unLoc -> (LastStmt {})] = nonemptyAnnList <$> trfScopedSequence (\(ParStmtBlock stmts _ _) -> - let ann = toNodeAnnot $ collectLocs $ getNormalStmts stmts - in Ann ann . AST.ListCompBody . AnnList ann . concat - <$> trfScopedSequence trfListCompStmt stmts + let ann = collectLocs $ getNormalStmts stmts + in annLocNoSema (pure ann) (AST.ListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt stmts)) ) blocks trfListCompStmts others = let ann = (collectLocs $ getNormalStmts others) - in AnnList (toNodeAnnot ann) . (:[]) - <$> annLoc (pure ann) - (AST.ListCompBody . AnnList (toNodeAnnot ann) . concat <$> trfScopedSequence trfListCompStmt others) + in makeList "|" (pure $ srcSpanStart ann) + ((:[]) <$> annLocNoSema (pure ann) + (AST.ListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt others))) -trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.CompStmt r] +trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.CompStmt (Dom r) RangeStage] trfListCompStmt (L l trst@(TransStmt { trS_stmts = stmts })) = (++) <$> (concat <$> local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanEnd (getLoc (last stmts))) }) (trfScopedSequence trfListCompStmt stmts)) <*> ((:[]) <$> extractActualStmt trst) @@ -59,15 +59,15 @@ trfListCompStmt (unLoc -> LastStmt _ _ _) = pure [] trfListCompStmt other = (:[]) <$> copyAnnot AST.CompStmt (trfDoStmt other) -extractActualStmt :: TransformName n r => Stmt n (LHsExpr n) -> Trf (Ann AST.CompStmt r) +extractActualStmt :: TransformName n r => Stmt n (LHsExpr n) -> Trf (Ann AST.CompStmt (Dom r) RangeStage) extractActualStmt = \case TransStmt { trS_form = ThenForm, trS_using = using, trS_by = by } -> addAnnotation by using (AST.ThenStmt <$> trfExpr using <*> trfMaybe "," "" trfExpr by) TransStmt { trS_form = GroupForm, trS_using = using, trS_by = by } -> addAnnotation by using (AST.GroupStmt <$> trfMaybe "," "" trfExpr by <*> (makeJust <$> trfExpr using)) where addAnnotation by using - = annLoc (combineSrcSpans (getLoc using) . combineSrcSpans (maybe noSrcSpan getLoc by) - <$> tokenLocBack AnnThen) + = annLocNoSema (combineSrcSpans (getLoc using) . combineSrcSpans (maybe noSrcSpan getLoc by) + <$> tokenLocBack AnnThen) getNormalStmts :: [Located (Stmt n (LHsExpr n))] -> [Located (Stmt n (LHsExpr n))] getNormalStmts (L _ (LastStmt body _ _) : rest) = getNormalStmts rest diff --git a/Language/Haskell/Tools/AST/FromGHC/TH.hs b/Language/Haskell/Tools/AST/FromGHC/TH.hs --- a/Language/Haskell/Tools/AST/FromGHC/TH.hs +++ b/Language/Haskell/Tools/AST/FromGHC/TH.hs @@ -18,24 +18,26 @@ import Language.Haskell.Tools.AST.FromGHC.Base import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST (Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote r) +trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote (Dom r) RangeStage) -- the lexer does not provide us with tokens '[', '|' and '|]' trfQuasiQuotation' (HsQuasiQuote id _ l str) - = AST.QuasiQuote <$> annLoc (pure quoterLoc) (trfName' id) - <*> annLoc (pure strLoc) (pure $ AST.QQString (unpackFS str)) + = AST.QuasiQuote <$> annLocNoSema (pure quoterLoc) (trfName' id) + <*> annLocNoSema (pure strLoc) (pure $ AST.QQString (unpackFS str)) where quoterLoc = mkSrcSpan (updateCol (subtract (1 + length (occNameString $ rdrNameOcc $ rdrName id))) (srcSpanStart l)) (updateCol (subtract 1) (srcSpanStart l)) strLoc = mkSrcSpan (srcSpanStart l) (updateCol (subtract 2) (srcSpanEnd l)) -trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.Splice r) +trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.Splice (Dom r) RangeStage) trfSplice' (HsTypedSplice _ expr) = AST.ParenSplice <$> trfExpr expr -trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket r) + +trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket (Dom r) RangeStage) trfBracket' (ExpBr expr) = AST.ExprBracket <$> trfExpr expr trfBracket' (TExpBr expr) = AST.ExprBracket <$> trfExpr expr -trfBracket' (VarBr _ expr) = AST.ExprBracket <$> annCont (AST.Var <$> (annCont (trfName' expr))) +trfBracket' (VarBr _ expr) = AST.ExprBracket <$> annCont createScopeInfo (AST.Var <$> (annContNoSema (trfName' expr))) trfBracket' (PatBr pat) = AST.PatternBracket <$> trfPattern pat trfBracket' (DecBrL decls) = AST.DeclsBracket <$> trfDecls decls trfBracket' (DecBrG decls) = AST.DeclsBracket <$> trfDeclsGroup decls diff --git a/Language/Haskell/Tools/AST/FromGHC/TH.hs-boot b/Language/Haskell/Tools/AST/FromGHC/TH.hs-boot --- a/Language/Haskell/Tools/AST/FromGHC/TH.hs-boot +++ b/Language/Haskell/Tools/AST/FromGHC/TH.hs-boot @@ -7,9 +7,9 @@ import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.Base -import Language.Haskell.Tools.AST (Ann(..)) +import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote r) -trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.Splice r) -trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket r) +trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote (Dom r) RangeStage) +trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.Splice (Dom r) RangeStage) +trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket (Dom r) RangeStage) diff --git a/Language/Haskell/Tools/AST/FromGHC/Types.hs b/Language/Haskell/Tools/AST/FromGHC/Types.hs --- a/Language/Haskell/Tools/AST/FromGHC/Types.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Types.hs @@ -33,10 +33,10 @@ import Debug.Trace -trfType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.Type r) -trfType = trfLoc trfType' +trfType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.Type (Dom r) RangeStage) +trfType = trfLocNoSema trfType' -trfType' :: TransformName n r => HsType n -> Trf (AST.Type r) +trfType' :: TransformName n r => HsType n -> Trf (AST.Type (Dom r) RangeStage) trfType' = trfType'' . cleanHsType where trfType'' (HsForAllTy [] typ) = trfType' (unLoc typ) trfType'' (HsForAllTy bndrs typ) = AST.TyForall <$> defineTypeVars (trfBindings bndrs) @@ -45,7 +45,7 @@ <*> trfType typ trfType'' (HsTyVar name) = AST.TyVar <$> transformingPossibleVar name (trfName name) trfType'' (HsAppsTy apps) | Just (head, args) <- getAppsTyHead_maybe apps - = foldl (\core t -> AST.TyApp <$> annLoc (pure $ getLoc head `combineSrcSpans` getLoc t) core <*> trfType t) (trfType' (unLoc head)) args + = foldl (\core t -> AST.TyApp <$> annLocNoSema (pure $ getLoc head `combineSrcSpans` getLoc t) core <*> trfType t) (trfType' (unLoc head)) args trfType'' (HsAppTy t1 t2) = AST.TyApp <$> trfType t1 <*> trfType t2 trfType'' (HsFunTy t1 t2) = AST.TyFun <$> trfType t1 <*> trfType t2 trfType'' (HsListTy typ) = AST.TyList <$> trfType typ @@ -61,46 +61,46 @@ trfType'' (HsBangTy (HsSrcBang _ SrcNoUnpack _) typ) = AST.TyNoUnpack <$> trfType typ trfType'' (HsBangTy (HsSrcBang _ _ SrcStrict) typ) = AST.TyBang <$> trfType typ trfType'' (HsBangTy (HsSrcBang _ _ SrcLazy) typ) = AST.TyLazy <$> trfType typ - trfType'' pt@(HsExplicitListTy {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) - trfType'' pt@(HsExplicitTupleTy {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) - trfType'' pt@(HsTyLit {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) + trfType'' pt@(HsExplicitListTy {}) = AST.TyPromoted <$> annContNoSema (trfPromoted' trfType' pt) + trfType'' pt@(HsExplicitTupleTy {}) = AST.TyPromoted <$> annContNoSema (trfPromoted' trfType' pt) + trfType'' pt@(HsTyLit {}) = AST.TyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' (HsWildCardTy _) = pure AST.TyWildcard -- TODO: named wildcards trfType'' t = error ("Illegal type: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")") -trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnList AST.TyVar r) +trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnList AST.TyVar (Dom r) RangeStage) trfBindings vars = trfAnnList "\n" trfTyVar' vars -trfTyVar :: TransformName n r => Located (HsTyVarBndr n) -> Trf (Ann AST.TyVar r) -trfTyVar = trfLoc trfTyVar' +trfTyVar :: TransformName n r => Located (HsTyVarBndr n) -> Trf (Ann AST.TyVar (Dom r) RangeStage) +trfTyVar = trfLocNoSema trfTyVar' -trfTyVar' :: TransformName n r => HsTyVarBndr n -> Trf (AST.TyVar r) +trfTyVar' :: TransformName n r => HsTyVarBndr n -> Trf (AST.TyVar (Dom r) RangeStage) trfTyVar' (UserTyVar name) = AST.TyVarDecl <$> typeVarTransform (trfName name) <*> (nothing " " "" atTheEnd) trfTyVar' (KindedTyVar name kind) = AST.TyVarDecl <$> typeVarTransform (trfName name) <*> trfKindSig (Just kind) -trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybe AST.Context r) +trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybe AST.Context (Dom r) RangeStage) trfCtx sp (L l []) = nothing " " "" sp trfCtx _ (L l [L _ (HsParTy t)]) - = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) - (AST.ContextMulti <$> trfAnnList ", " trfAssertion' [t]) + = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) + (AST.ContextMulti <$> trfAnnList ", " trfAssertion' [t]) trfCtx _ (L l [t]) - = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) - (AST.ContextOne <$> trfAssertion t) -trfCtx _ (L l ctx) = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) - (AST.ContextMulti <$> trfAnnList ", " trfAssertion' ctx) + = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) + (AST.ContextOne <$> trfAssertion t) +trfCtx _ (L l ctx) = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) + (AST.ContextMulti <$> trfAnnList ", " trfAssertion' ctx) -trfAssertion :: TransformName n r => LHsType n -> Trf (Ann AST.Assertion r) -trfAssertion = trfLoc trfAssertion' +trfAssertion :: TransformName n r => LHsType n -> Trf (Ann AST.Assertion (Dom r) RangeStage) +trfAssertion = trfLocNoSema trfAssertion' -trfAssertion' :: forall n r . TransformName n r => HsType n -> Trf (AST.Assertion r) +trfAssertion' :: forall n r . TransformName n r => HsType n -> Trf (AST.Assertion (Dom r) RangeStage) trfAssertion' (cleanHsType -> HsParTy t) = trfAssertion' (unLoc t) trfAssertion' (cleanHsType -> HsOpTy left op right) = AST.InfixAssert <$> trfType left <*> trfOperator op <*> trfType right trfAssertion' (cleanHsType -> t) = case cleanHsType base of HsTyVar name -> AST.ClassAssert <$> trfName name <*> trfAnnList " " trfType' args - HsEqTy t1 t2 -> AST.InfixAssert <$> trfType t1 <*> annLoc (tokenLoc AnnTilde) (trfOperator' typeEq) <*> trfType t2 + HsEqTy t1 t2 -> AST.InfixAssert <$> trfType t1 <*> annLocNoSema (tokenLoc AnnTilde) (trfOperator' typeEq) <*> trfType t2 t -> error ("Illegal trf assertion: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")") where (args, sp, base) = getArgs t getArgs :: HsType n -> ([LHsType n], Maybe SrcSpan, HsType n) diff --git a/Language/Haskell/Tools/AST/FromGHC/Utils.hs b/Language/Haskell/Tools/AST/FromGHC/Utils.hs --- a/Language/Haskell/Tools/AST/FromGHC/Utils.hs +++ b/Language/Haskell/Tools/AST/FromGHC/Utils.hs @@ -6,6 +6,8 @@ , MultiParamTypeClasses , FlexibleContexts , AllowAmbiguousTypes + , TypeApplications + , TypeFamilies #-} module Language.Haskell.Tools.AST.FromGHC.Utils where @@ -33,51 +35,34 @@ import Language.Haskell.Tools.AST.FromGHC.SourceMap import Debug.Trace --- | Annotations that is made up from ranges -class HasRange annot => RangeAnnot annot where - toNodeAnnot :: SrcSpan -> annot - toListAnnot :: String -> String -> String -> SrcLoc -> annot - toIndentedListAnnot :: String -> String -> String -> SrcLoc -> annot - toOptAnnot :: String -> String -> SrcLoc -> annot +-- | Creates a semantic information for a name +createNameInfo :: n -> Trf (NameInfo n) +createNameInfo name = do locals <- asks localsInScope + isDefining <- asks defining + return (NameInfo locals isDefining name) -instance RangeAnnot (NodeInfo (SemanticInfo n) SpanInfo) where - toNodeAnnot = NodeInfo NoSemanticInfo . NodeSpan - toListAnnot bef aft sep = NodeInfo NoSemanticInfo . ListPos bef aft sep False - toIndentedListAnnot bef aft sep = NodeInfo NoSemanticInfo . ListPos bef aft sep True - toOptAnnot bef aft = NodeInfo NoSemanticInfo . OptionalPos bef aft --- | Annotations that carry semantic information -class SemanticAnnot annot n where - addSemanticInfo :: SemanticInfo n -> annot -> annot - addScopeData :: annot -> Trf annot - addImportData :: Ann AST.ImportDecl annot -> Trf (Ann AST.ImportDecl annot) - -instance SemanticAnnot RangeWithName GHC.Name where - addSemanticInfo si = semanticInfo .= si - addScopeData = semanticInfo !~ (\case NoSemanticInfo -> do locals <- asks localsInScope - return $ ScopeInfo locals - inf -> return inf) - addImportData = addImportData' +-- | Creates a semantic information for an ambiguous name (caused by field disambiguation for example) +createAmbigousNameInfo :: RdrName -> SrcSpan -> Trf (NameInfo n) +createAmbigousNameInfo name span = do locals <- asks localsInScope + isDefining <- asks defining + return (AmbiguousNameInfo locals isDefining name span) -instance {-# OVERLAPPING #-} SemanticAnnot RangeInfo RdrName where - addSemanticInfo si = semanticInfo .= si - addScopeData = semanticInfo !~ (\case NoSemanticInfo -> do locals <- asks localsInScope - return $ ScopeInfo locals - inf -> return inf) - addImportData = pure +-- | Creates a semantic information for an implicit name +createImplicitNameInfo :: String -> Trf (NameInfo n) +createImplicitNameInfo name = do locals <- asks localsInScope + isDefining <- asks defining + return (ImplicitNameInfo locals isDefining name) -instance {-# OVERLAPPABLE #-} SemanticAnnot RangeInfo n where - addSemanticInfo si = id - addScopeData = pure - addImportData = pure - -- | Adds semantic information to an impord declaration. See ImportInfo. -addImportData' :: Ann AST.ImportDecl RangeWithName -> Trf (Ann AST.ImportDecl RangeWithName) -addImportData' imp = - do (mod,importedNames) <- getImportedNames (nameString $ imp ^. element&importModule&element) - (imp ^? element&importPkg&annJust&element&stringNodeStr) - names <- lift $ filterM (checkImportVisible (imp ^. element)) importedNames - return $ annotation .- addSemanticInfo (ImportInfo mod importedNames names) $ imp +createImportData :: (HsHasName n, GHCName n) => AST.ImportDecl (Dom n) stage -> Trf (ImportInfo n) +createImportData imp = + do (mod,importedNames) <- getImportedNames (imp ^. importModule&element&AST.moduleNameString) + (imp ^? importPkg&annJust&element&stringNodeStr) + names <- lift $ filterM (checkImportVisible imp) importedNames + lookedUpNames <- lift $ mapM (getFromNameUsing getTopLevelId) names + lookedUpImported <- lift $ mapM (getFromNameUsing getTopLevelId) importedNames + return $ ImportInfo mod (catMaybes lookedUpImported) (catMaybes lookedUpNames) -- | Get names that are imported from a given import getImportedNames :: String -> Maybe String -> Trf (GHC.Module, [GHC.Name]) @@ -92,108 +77,120 @@ return (mod, ifaceNames ++ loadedNames) -- | Check is a given name is imported from an import with given import specification. -checkImportVisible :: GhcMonad m => AST.ImportDecl RangeWithName -> GHC.Name -> m Bool +checkImportVisible :: (HsHasName n, GhcMonad m) => AST.ImportDecl (Dom n) stage -> GHC.Name -> m Bool checkImportVisible imp name | importIsExact imp - = or <$> mapM (`ieSpecMatches` name) (imp ^? importExacts :: [IESpec RangeWithName]) + = or @[] <$> mapM (`ieSpecMatches` name) (imp ^? importExacts) | importIsHiding imp - = not . or <$> mapM (`ieSpecMatches` name) (imp ^? importHidings :: [IESpec RangeWithName]) + = not . or @[] <$> mapM (`ieSpecMatches` name) (imp ^? importHidings) | otherwise = return True -ieSpecMatches :: GhcMonad m => AST.IESpec RangeWithName -> GHC.Name -> m Bool -ieSpecMatches (AST.IESpec ((^? element&simpleName&annotation&semanticInfo&nameInfo) -> Just n) ss) name +ieSpecMatches :: (HsHasName n, GhcMonad m) => AST.IESpec (Dom n) stage -> GHC.Name -> m Bool +ieSpecMatches (AST.IESpec (hsGetNames <=< (^? element&simpleName&semantics&nameInfo) -> [n]) ss) name | n == name = return True | isTyConName n = (\case Just (ATyCon tc) -> name `elem` map getName (tyConDataCons tc)) <$> lookupName n - | otherwise = return False +ieSpecMatches _ _ = return False +noSemaInfo :: src -> NodeInfo NoSemanticInfo src +noSemaInfo = NodeInfo NoSemanticInfo -- | Creates a place for a missing node with a default location -nothing :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf (AnnMaybe e a) -nothing bef aft pos = annNothing . toOptAnnot bef aft <$> pos +nothing :: String -> String -> Trf SrcLoc -> Trf (AnnMaybe e (Dom n) RangeStage) +nothing bef aft pos = annNothing . noSemaInfo . OptionalPos bef aft <$> pos -emptyList :: RangeAnnot a => String -> Trf SrcLoc -> Trf (AnnList e a) -emptyList sep ann = AnnList <$> (toListAnnot "" "" sep <$> ann) <*> pure [] +emptyList :: String -> Trf SrcLoc -> Trf (AnnList e (Dom n) RangeStage) +emptyList sep ann = AnnList <$> (noSemaInfo . ListPos "" "" sep False <$> ann) <*> pure [] -- | Creates a place for a list of nodes with a default place if the list is empty. -makeList :: RangeAnnot a => String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) -makeList sep ann ls = AnnList <$> (toListAnnot "" "" sep <$> ann) <*> ls +makeList :: String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) +makeList sep ann ls = AnnList <$> (noSemaInfo . ListPos "" "" sep False <$> ann) <*> ls -makeListBefore :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) +makeListBefore :: String -> String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) makeListBefore bef sep ann ls = do isEmpty <- null <$> ls - AnnList <$> (toListAnnot (if isEmpty then bef else "") "" sep <$> ann) <*> ls + AnnList <$> (noSemaInfo . ListPos (if isEmpty then bef else "") "" sep False <$> ann) <*> ls -makeListAfter :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) +makeListAfter :: String -> String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) makeListAfter aft sep ann ls = do isEmpty <- null <$> ls - AnnList <$> (toListAnnot "" (if isEmpty then aft else "") sep <$> ann) <*> ls + AnnList <$> (noSemaInfo . ListPos "" (if isEmpty then aft else "") sep False <$> ann) <*> ls -makeNonemptyList :: RangeAnnot a => String -> Trf [Ann e a] -> Trf (AnnList e a) -makeNonemptyList sep ls = AnnList (toListAnnot "" "" sep noSrcLoc) <$> ls +makeNonemptyList :: String -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) +makeNonemptyList sep ls = AnnList (noSemaInfo $ ListPos "" "" sep False noSrcLoc) <$> ls -- | Creates a place for an indented list of nodes with a default place if the list is empty. -makeIndentedList :: RangeAnnot a => Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) -makeIndentedList ann ls = AnnList <$> (toIndentedListAnnot "" "" "\n" <$> ann) <*> ls +makeIndentedList :: Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) +makeIndentedList ann ls = AnnList <$> (noSemaInfo . ListPos "" "" "\n" True <$> ann) <*> ls -makeIndentedListNewlineBefore :: RangeAnnot a => Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) +makeIndentedListNewlineBefore :: Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) makeIndentedListNewlineBefore ann ls = do isEmpty <- null <$> ls - AnnList <$> (toIndentedListAnnot (if isEmpty then "\n" else "") "" "\n" <$> ann) <*> ls + AnnList <$> (noSemaInfo . ListPos (if isEmpty then "\n" else "") "" "\n" True <$> ann) <*> ls -makeIndentedListBefore :: RangeAnnot a => String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a) +makeIndentedListBefore :: String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) makeIndentedListBefore bef sp ls = do isEmpty <- null <$> ls - AnnList <$> (toIndentedListAnnot (if isEmpty then bef else "") "" "\n" <$> sp) <*> ls + AnnList <$> (noSemaInfo . ListPos (if isEmpty then bef else "") "" "\n" True <$> sp) <*> ls -makeNonemptyIndentedList :: RangeAnnot a => Trf [Ann e a] -> Trf (AnnList e a) -makeNonemptyIndentedList ls = AnnList (toIndentedListAnnot "" "" "\n" noSrcLoc) <$> ls +makeNonemptyIndentedList :: Trf [Ann e (Dom n) RangeStage] -> Trf (AnnList e (Dom n) RangeStage) +makeNonemptyIndentedList ls = AnnList (noSemaInfo $ ListPos "" "" "\n" True noSrcLoc) <$> ls -- | Transform a located part of the AST by automatically transforming the location. -- Sets the source range for transforming children. -trfLoc :: RangeAnnot i => (a -> Trf (b i)) -> Located a -> Trf (Ann b i) -trfLoc = trfLocCorrect pure +trfLoc :: (a -> Trf (b (Dom n) RangeStage)) -> Trf (SemanticInfo (Dom n) b) -> Located a -> Trf (Ann b (Dom n) RangeStage) +trfLoc f sema = trfLocCorrect sema pure f +trfLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => (a -> Trf (b (Dom n) RangeStage)) -> Located a -> Trf (Ann b (Dom n) RangeStage) +trfLocNoSema f = trfLoc f (pure NoSemanticInfo) + -- | Transforms a possibly-missing node with the default location of the end of the focus. -trfMaybe :: RangeAnnot i => String -> String -> (Located a -> Trf (Ann e i)) -> Maybe (Located a) -> Trf (AnnMaybe e i) +trfMaybe :: String -> String -> (Located a -> Trf (Ann e (Dom n) RangeStage)) -> Maybe (Located a) -> Trf (AnnMaybe e (Dom n) RangeStage) trfMaybe bef aft f = trfMaybeDefault bef aft f atTheEnd -- | Transforms a possibly-missing node with a default location -trfMaybeDefault :: RangeAnnot i => String -> String -> (Located a -> Trf (Ann e i)) -> Trf SrcLoc -> Maybe (Located a) -> Trf (AnnMaybe e i) +trfMaybeDefault :: String -> String -> (Located a -> Trf (Ann e (Dom n) RangeStage)) -> Trf SrcLoc -> Maybe (Located a) -> Trf (AnnMaybe e (Dom n) RangeStage) trfMaybeDefault _ _ f _ (Just e) = makeJust <$> f e trfMaybeDefault bef aft _ loc Nothing = nothing bef aft loc -- | Transform a located part of the AST by automatically transforming the location -- with correction by applying the given function. Sets the source range for transforming children. -trfLocCorrect :: RangeAnnot i => (SrcSpan -> Trf SrcSpan) -> (a -> Trf (b i)) -> Located a -> Trf (Ann b i) -trfLocCorrect locF f (L l e) = annLoc (locF l) (f e) +trfLocCorrect :: Trf (SemanticInfo (Dom n) b) -> (SrcSpan -> Trf SrcSpan) -> (a -> Trf (b (Dom n) RangeStage)) -> Located a -> Trf (Ann b (Dom n) RangeStage) +trfLocCorrect sema locF f (L l e) = annLoc sema (locF l) (f e) -- | Transform a located part of the AST by automatically transforming the location. -- Sets the source range for transforming children. -trfMaybeLoc :: RangeAnnot i => (a -> Trf (Maybe (b i))) -> Located a -> Trf (Maybe (Ann b i)) -trfMaybeLoc f (L l e) = do fmap (Ann (toNodeAnnot l)) <$> local (\s -> s { contRange = l }) (f e) +trfMaybeLoc :: (a -> Trf (Maybe (b (Dom n) RangeStage))) -> SemanticInfo (Dom n) b -> Located a -> Trf (Maybe (Ann b (Dom n) RangeStage)) +trfMaybeLoc f sema (L l e) = do fmap (Ann (NodeInfo sema (NodeSpan l))) <$> local (\s -> s { contRange = l }) (f e) +trfMaybeLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => (a -> Trf (Maybe (b (Dom n) RangeStage))) -> Located a -> Trf (Maybe (Ann b (Dom n) RangeStage)) +trfMaybeLocNoSema f = trfMaybeLoc f NoSemanticInfo + -- | Creates a place for a list of nodes with the default place at the end of the focus if the list is empty. -trfAnnList :: RangeAnnot i => String -> (a -> Trf (b i)) -> [Located a] -> Trf (AnnList b i) +trfAnnList ::SemanticInfo (Dom n) b ~ NoSemanticInfo => String -> (a -> Trf (b (Dom n) RangeStage)) -> [Located a] -> Trf (AnnList b (Dom n) RangeStage) trfAnnList sep _ [] = makeList sep atTheEnd (pure []) -trfAnnList sep f ls = makeList sep (pure $ noSrcLoc) (mapM (trfLoc f) ls) +trfAnnList sep f ls = makeList sep (pure $ noSrcLoc) (mapM (trfLoc f (pure NoSemanticInfo)) ls) -trfAnnList' :: RangeAnnot i => String -> (Located a -> Trf (Ann b i)) -> [Located a] -> Trf (AnnList b i) +trfAnnList' :: String -> (Located a -> Trf (Ann b (Dom n) RangeStage)) -> [Located a] -> Trf (AnnList b (Dom n) RangeStage) trfAnnList' sep _ [] = makeList sep atTheEnd (pure []) trfAnnList' sep f ls = makeList sep (pure $ noSrcLoc) (mapM f ls) -- | Creates a place for a list of nodes that cannot be empty. -nonemptyAnnList :: RangeAnnot i => [Ann e i] -> AnnList e i -nonemptyAnnList = AnnList (toListAnnot "" "" "" noSrcLoc) +nonemptyAnnList :: [Ann e (Dom n) RangeStage] -> AnnList e (Dom n) RangeStage +nonemptyAnnList = AnnList (noSemaInfo $ ListPos "" "" "" False noSrcLoc) -- | Creates an optional node from an existing element -makeJust :: RangeAnnot a => Ann e a -> AnnMaybe e a -makeJust e = AnnMaybe (toOptAnnot "" "" noSrcLoc) (Just e) +makeJust :: Ann e (Dom n) RangeStage -> AnnMaybe e (Dom n) RangeStage +makeJust e = AnnMaybe (noSemaInfo $ OptionalPos "" "" noSrcLoc) (Just e) -- | Annotates a node with the given location and focuses on the given source span. -annLoc :: RangeAnnot a => Trf SrcSpan -> Trf (b a) -> Trf (Ann b a) -annLoc locm nodem = do loc <- locm - node <- focusOn loc nodem - return (Ann (toNodeAnnot loc) node) +annLoc :: Trf (SemanticInfo (Dom n) b) -> Trf SrcSpan -> Trf (b (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage) +annLoc semam locm nodem = do loc <- locm + node <- focusOn loc nodem + sema <- semam + return (Ann (NodeInfo sema (NodeSpan loc)) node) +annLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => Trf SrcSpan -> Trf (b (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage) +annLocNoSema = annLoc (pure NoSemanticInfo) + -- * Focus manipulation focusOn :: SrcSpan -> Trf a -> Trf a @@ -248,8 +245,8 @@ after tok = srcSpanEnd <$> tokenLoc tok -- | The element should span from the given token to the end of focus -annFrom :: RangeAnnot a => AnnKeywordId -> Trf (e a) -> Trf (Ann e a) -annFrom kw = annLoc (combineSrcSpans <$> tokenLoc kw <*> asks (srcLocSpan . srcSpanEnd . contRange)) +annFrom :: AnnKeywordId -> Trf (SemanticInfo (Dom n) e) -> Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage) +annFrom kw sema = annLoc sema (combineSrcSpans <$> tokenLoc kw <*> asks (srcLocSpan . srcSpanEnd . contRange)) -- | Gets the position at the beginning of the focus atTheStart :: Trf SrcLoc @@ -289,11 +286,15 @@ uniqueTokenAnywhere keyw = fromMaybe noSrcSpan <$> (getKeywordAnywhere keyw <$> asks srcMap) -- | Annotates the given element with the current focus as a location. -annCont :: RangeAnnot a => Trf (e a) -> Trf (Ann e a) -annCont = annLoc (asks contRange) +annCont :: Trf (SemanticInfo (Dom n) e) -> Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage) +annCont sema = annLoc sema (asks contRange) +annContNoSema :: SemanticInfo (Dom n) e ~ NoSemanticInfo => Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage) +annContNoSema = annCont (pure NoSemanticInfo) + -- | Annotates the element with the same annotation that is on the other element -copyAnnot :: (Ann a i -> b i) -> Trf (Ann a i) -> Trf (Ann b i) +copyAnnot :: SemanticInfo (Dom n) a ~ SemanticInfo (Dom n) b + => (Ann a (Dom n) RangeStage -> b (Dom n) RangeStage) -> Trf (Ann a (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage) copyAnnot f at = (\(Ann i a) -> Ann i (f (Ann i a))) <$> at -- | Combine source spans into one that contains them all @@ -315,11 +316,11 @@ collectLocs = foldLocs . map getLoc -- | Rearrange definitions to appear in the order they are defined in the source file. -orderDefs :: RangeAnnot i => [Ann e i] -> [Ann e i] -orderDefs = sortBy (compare `on` AST.ordSrcSpan . getRange . _annotation) +orderDefs :: [Ann e (Dom n) RangeStage] -> [Ann e (Dom n) RangeStage] +orderDefs = sortBy (compare `on` AST.ordSrcSpan . (^. AST.annotation & AST.sourceInfo & AST.nodeSpan)) -- | Orders a list of elements to the order they are defined in the source file. -orderAnnList :: RangeAnnot i => AnnList e i -> AnnList e i +orderAnnList :: AnnList e (Dom n) RangeStage -> AnnList e (Dom n) RangeStage orderAnnList (AnnList a ls) = AnnList a (orderDefs ls) diff --git a/haskell-tools-ast-fromghc.cabal b/haskell-tools-ast-fromghc.cabal --- a/haskell-tools-ast-fromghc.cabal +++ b/haskell-tools-ast-fromghc.cabal @@ -1,5 +1,5 @@ name: haskell-tools-ast-fromghc -version: 0.1.2.0 +version: 0.1.3.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 homepage: https://github.com/nboldi/haskell-tools @@ -29,16 +29,15 @@ , Language.Haskell.Tools.AST.FromGHC.Utils , Language.Haskell.Tools.AST.FromGHC.SourceMap - build-depends: base >=4.9 && <5.0 - , ghc >=8.0 && <8.1 - , haskell-tools-ast >=0.1 && <0.2 + build-depends: base >=4.9 && <5.0 + , ghc >=8.0 && <8.1 + , haskell-tools-ast >=0.1.3 && <0.2 , references >=0.3.2 && <1.0 - , bytestring >=0.10 && <1.0 - , safe >=0.3 - , uniplate >=1.6 && <2.0 - , containers >=0.5 && <0.6 - , mtl >=2.2 && <2.3 - , split >=0.2 && <0.3 - , structural-traversal >=0.1 && <0.2 - , template-haskell >=2.11 && <3.0 + , bytestring >=0.10 && <1.0 + , safe >=0.3 && <1.0 + , uniplate >=1.6 && <2.0 + , containers >=0.5 && <0.6 + , mtl >=2.2 && <2.3 + , split >=0.2 && <0.3 + , template-haskell >=2.11 && <3.0 default-language: Haskell2010