diff --git a/Language/Haskell/Tools/Refactor.hs b/Language/Haskell/Tools/Refactor.hs --- a/Language/Haskell/Tools/Refactor.hs +++ b/Language/Haskell/Tools/Refactor.hs @@ -4,6 +4,8 @@ , ScopedTypeVariables , BangPatterns , MultiWayIf + , FlexibleContexts + , TypeFamilies #-} module Language.Haskell.Tools.Refactor where @@ -36,7 +38,6 @@ import Data.List import Data.List.Split import GHC.Generics hiding (moduleName) -import Data.StructuralTraversal import qualified Data.Map as Map import Data.Maybe import Data.Typeable @@ -68,10 +69,6 @@ import Debug.Trace - -type TemplateWithNames = NodeInfo (SemanticInfo GHC.Name) SourceTemplate -type TemplateWithTypes = NodeInfo (SemanticInfo GHC.Id) SourceTemplate - data RefactorCommand = NoRefactor | OrganizeImports | GenerateExports @@ -80,7 +77,8 @@ | ExtractBinding RealSrcSpan String deriving Show -performCommand :: RefactorCommand -> Ann AST.Module TemplateWithTypes -> Ghc (Either String (Ann AST.Module TemplateWithTypes)) +performCommand :: (SemanticInfo' dom SameInfoModuleCls ~ AST.ModuleInfo n, DomGenerateExports dom, OrganizeImportsDomain dom n, DomainRenameDefinition dom, ExtractBindingDomain dom, GenerateSignatureDomain dom) + => RefactorCommand -> Ann AST.Module dom SrcTemplateStage -> Ghc (Either String (Ann AST.Module dom SrcTemplateStage)) performCommand rf mod = runRefactor mod $ selectCommand rf where selectCommand NoRefactor = return selectCommand OrganizeImports = organizeImports @@ -166,7 +164,7 @@ load LoadAllTargets getModSummary $ mkModuleName moduleName -parseTyped :: ModSummary -> Ghc (Ann AST.Module TemplateWithTypes) +parseTyped :: ModSummary -> Ghc (Ann AST.Module IdDom SrcTemplateStage) parseTyped modSum = do p <- parseModule modSum tc <- typecheckModule p @@ -174,20 +172,20 @@ srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p rangeToSource srcBuffer . cutUpRanges . fixRanges . placeComments (getNormalComments $ snd annots) <$> (addTypeInfos (typecheckedSource tc) - =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) + =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (ms_mod modSum) (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename (ms_mod $ modSum) parseTrf (fromJust $ tm_renamed_source tc) (pm_parsed_source p))) -parseRenamed :: ModSummary -> Ghc (Ann AST.Module TemplateWithNames) +parseRenamed :: ModSummary -> Ghc (Ann AST.Module (Dom GHC.Name) SrcTemplateStage) parseRenamed modSum = do p <- parseModule modSum tc <- typecheckModule p let annots = pm_annotations p srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p rangeToSource srcBuffer . cutUpRanges . fixRanges . placeComments (getNormalComments $ snd annots) - <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) + <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (ms_mod modSum) (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename (ms_mod $ modSum) parseTrf (fromJust $ tm_renamed_source tc) @@ -211,20 +209,22 @@ --liftIO $ putStrLn $ show (typecheckedSource t) liftIO $ putStrLn "=========== parsed:" --transformed <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) - parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (pm_parsed_source p) - liftIO $ putStrLn $ rangeDebug parseTrf + parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule (ms_mod modSum) (pm_parsed_source p) + liftIO $ putStrLn $ srcInfoDebug parseTrf liftIO $ putStrLn "=========== typed:" transformed <- addTypeInfos (typecheckedSource t) =<< (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename (ms_mod $ modSum) parseTrf (fromJust $ tm_renamed_source t) (pm_parsed_source p)) - liftIO $ putStrLn $ rangeDebug transformed + liftIO $ putStrLn $ srcInfoDebug transformed liftIO $ putStrLn "=========== ranges fixed:" let commented = fixRanges $ placeComments (getNormalComments $ snd annots) transformed - liftIO $ putStrLn $ rangeDebug commented + liftIO $ putStrLn $ srcInfoDebug commented liftIO $ putStrLn "=========== cut up:" let cutUp = cutUpRanges commented - liftIO $ putStrLn $ templateDebug cutUp + liftIO $ putStrLn $ srcInfoDebug cutUp + liftIO $ putStrLn $ show $ getLocIndices cutUp + liftIO $ putStrLn $ show $ mapLocIndices (fromJust $ ms_hspp_buf $ pm_mod_summary p) (getLocIndices cutUp) liftIO $ putStrLn "=========== sourced:" let sourced = rangeToSource (fromJust $ ms_hspp_buf $ pm_mod_summary p) cutUp - liftIO $ putStrLn $ sourceTemplateDebug sourced + liftIO $ putStrLn $ srcInfoDebug sourced liftIO $ putStrLn "=========== pretty printed:" let prettyPrinted = prettyPrint sourced liftIO $ putStrLn prettyPrinted @@ -232,7 +232,7 @@ case transformed of Right correctlyTransformed -> do liftIO $ putStrLn "=========== transformed AST:" - liftIO $ putStrLn $ sourceTemplateDebug correctlyTransformed + liftIO $ putStrLn $ srcInfoDebug correctlyTransformed liftIO $ putStrLn "=========== transformed & prettyprinted:" let prettyPrinted = prettyPrint correctlyTransformed liftIO $ putStrLn prettyPrinted @@ -241,13 +241,6 @@ liftIO $ putStrLn "===========" liftIO $ putStrLn transformProblem liftIO $ putStrLn "===========" - -printSemaInfo :: (StructuralTraversable node, Outputable n) => node (NodeInfo (SemanticInfo n) src) -> Ghc (node (NodeInfo (SemanticInfo n) src)) -printSemaInfo = traverseUp (return ()) (return ()) (\n@(NodeInfo s _) -> liftIO (print s) >> return n) - + deriving instance Generic SrcSpan deriving instance (Generic sema, Generic src) => Generic (NodeInfo sema src) -deriving instance Generic RangeTemplate -deriving instance Generic (SemanticInfo n) -deriving instance Generic SourceTemplate -deriving instance Generic SpanInfo diff --git a/Language/Haskell/Tools/Refactor/ASTDebug.hs b/Language/Haskell/Tools/Refactor/ASTDebug.hs --- a/Language/Haskell/Tools/Refactor/ASTDebug.hs +++ b/Language/Haskell/Tools/Refactor/ASTDebug.hs @@ -7,9 +7,11 @@ , TypeFamilies , TemplateHaskell , OverloadedStrings + , ConstraintKinds , LambdaCase , ViewPatterns , ScopedTypeVariables + , UndecidableInstances #-} -- | A module for displaying the AST in a tree view. module Language.Haskell.Tools.Refactor.ASTDebug where @@ -38,28 +40,51 @@ import Language.Haskell.Tools.Refactor.RangeDebug -data DebugNode a = TreeNode { _nodeLabel :: String - , _nodeSubtree :: TreeDebugNode a - } - | SimpleNode { _nodeLabel :: String - , _nodeValue :: String +data DebugNode dom = TreeNode { _nodeLabel :: String + , _nodeSubtree :: TreeDebugNode dom } - deriving Show + | SimpleNode { _nodeLabel :: String + , _nodeValue :: String + } -data TreeDebugNode a +deriving instance Domain dom => Show (DebugNode dom) + +data TreeDebugNode dom = TreeDebugNode { _nodeName :: String - , _nodeInfo :: a - , _children :: [DebugNode a] + , _nodeInfo :: SemanticInfoType dom + , _children :: [DebugNode dom] } - deriving Show +deriving instance Domain dom => Show (TreeDebugNode dom) + +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan + } + | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls + , semaInfoTypeRng :: SrcSpan + } + | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls + , semaInfoTypeRng :: SrcSpan + } + | ImportInfoType { semaInfoTypeImport :: SemanticInfo' dom SameInfoImportCls + , semaInfoTypeRng :: SrcSpan + } + | ModuleInfoType { semaInfoTypeModule :: SemanticInfo' dom SameInfoModuleCls + , semaInfoTypeRng :: SrcSpan + } + +deriving instance Domain dom => Show (SemanticInfoType dom) + makeReferences ''DebugNode makeReferences ''TreeDebugNode -astDebug :: (InspectableName n, HasRange a, ASTDebug e a, a ~ (NodeInfo (SemanticInfo n) src)) => e a -> String +type AssocSema dom = ( AssocData (SemanticInfo' dom SameInfoModuleCls), AssocData (SemanticInfo' dom SameInfoImportCls) + , AssocData (SemanticInfo' dom SameInfoNameCls), AssocData (SemanticInfo' dom SameInfoExprCls) ) + +astDebug :: (ASTDebug e dom st, AssocSema dom) => e dom st -> String astDebug ast = toList (astDebugToJson (astDebug' ast)) -astDebugToJson :: (InspectableName n, HasRange a, a ~ (NodeInfo (SemanticInfo n) src)) => [DebugNode a] -> Seq Char +astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes childrenJson = case map debugTreeNode treeNodes of @@ -68,15 +93,15 @@ debugTreeNode (TreeNode "" s) = astDebugElemJson s debugTreeNode (TreeNode (dropWhile (=='_') -> l) s) = astDebugElemJson (nodeName .- (("" ++ l ++ ": ") ++) $ s) -astDebugElemJson :: (InspectableName n, HasRange a, a ~ (NodeInfo (SemanticInfo n) src)) => TreeDebugNode a -> Seq Char +astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char astDebugElemJson (TreeDebugNode name info children) = fromList "{ \"text\" : \"" >< fromList name >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" - >< fromList (shortShowSpan (getRange info)) + >< fromList (shortShowSpan (semaInfoTypeRng info)) >< fromList "\", \"data-elems\" : \"" >< foldl (><) Seq.empty dataElems >< fromList "\", \"data-sema\" : \"" - >< fromList (showSema (info ^. semanticInfo)) + >< fromList (showSema info) >< fromList "\" }, \"children\" : " >< astDebugToJson children >< fromList " }" where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) @@ -88,25 +113,60 @@ assocName :: a -> String toAssoc :: a -> [(String, String)] -instance InspectableName n => AssocData (SemanticInfo n) where - assocName NoSemanticInfo = "NoSemanticInfo" +instance AssocSema dom => AssocData (SemanticInfoType dom) where + assocName s@(DefaultInfoType {}) = "NoSemanticInfo" + assocName s@(NameInfoType {}) = assocName (semaInfoTypeName s) + assocName s@(ExprInfoType {}) = assocName (semaInfoTypeExpr s) + assocName s@(ImportInfoType {}) = assocName (semaInfoTypeImport s) + assocName s@(ModuleInfoType {}) = assocName (semaInfoTypeModule s) + + toAssoc s@(DefaultInfoType {}) = [] + toAssoc s@(NameInfoType {}) = toAssoc (semaInfoTypeName s) + toAssoc s@(ExprInfoType {}) = toAssoc (semaInfoTypeExpr s) + toAssoc s@(ImportInfoType {}) = toAssoc (semaInfoTypeImport s) + toAssoc s@(ModuleInfoType {}) = toAssoc (semaInfoTypeModule s) + + +instance AssocData ScopeInfo where assocName (ScopeInfo {}) = "ScopeInfo" + toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] + +instance InspectableName n => AssocData (NameInfo n) where assocName (NameInfo {}) = "NameInfo" - assocName (ModuleInfo {}) = "ModuleInfo" - assocName (ImportInfo {}) = "ImportInfo" + assocName (AmbiguousNameInfo {}) = "AmbiguousNameInfo" + assocName (ImplicitNameInfo {}) = "ImplicitNameInfo" - toAssoc NoSemanticInfo = [] - toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] toAssoc (NameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) , ("isDefined", show defined) , ("namesInScope", inspectScope locals) ] - toAssoc (ModuleInfo mod imps) = [("moduleName", showSDocUnsafe (ppr mod)) - ,("implicitImports", concat (intersperse ", " (map inspect imps)))] + toAssoc (AmbiguousNameInfo locals defined name _) = [ ("name", inspect name) + , ("isDefined", show defined) + , ("namesInScope", inspectScope locals) + ] + toAssoc (ImplicitNameInfo locals defined name) = [ ("name", name) + , ("isDefined", show defined) + , ("namesInScope", inspectScope locals) + ] +instance AssocData CNameInfo where + assocName (CNameInfo {}) = "CNameInfo" + toAssoc (CNameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) + , ("isDefined", show defined) + , ("namesInScope", inspectScope locals) + ] + +instance InspectableName n => AssocData (ModuleInfo n) where + assocName (ModuleInfo {}) = "ModuleInfo" + toAssoc (ModuleInfo mod imps) = [ ("moduleName", showSDocUnsafe (ppr mod)) + , ("implicitImports", concat (intersperse ", " (map inspect imps))) + ] + +instance InspectableName n => AssocData (ImportInfo n) where + assocName (ImportInfo {}) = "ImportInfo" toAssoc (ImportInfo mod avail imported) = [ ("moduleName", showSDocUnsafe (ppr mod)) , ("availableNames", concat (intersperse ", " (map inspect avail))) , ("importedNames", concat (intersperse ", " (map inspect imported))) - ] + ] inspectScope :: InspectableName n => [[n]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) @@ -123,40 +183,41 @@ instance InspectableName GHC.Id where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "] :: " ++ showSDocOneLine unsafeGlobalDynFlags (ppr (idType name)) -class ASTDebug e a where - astDebug' :: e a -> [DebugNode a] - default astDebug' :: (GAstDebug (Rep (e a)) a, Generic (e a)) => e a -> [DebugNode a] +class (Domain dom, SourceInfo st) + => ASTDebug e dom st where + astDebug' :: e dom st -> [DebugNode dom] + default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] astDebug' = gAstDebug . from -class GAstDebug f a where - gAstDebug :: f p -> [DebugNode a] +class GAstDebug f dom where + gAstDebug :: f p -> [DebugNode dom] -instance GAstDebug V1 a where +instance GAstDebug V1 dom where gAstDebug _ = error "GAstDebug V1" -instance GAstDebug U1 a where +instance GAstDebug U1 dom where gAstDebug U1 = [] -instance (GAstDebug f a, GAstDebug g a) => GAstDebug (f :+: g) a where +instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where gAstDebug (L1 x) = gAstDebug x gAstDebug (R1 x) = gAstDebug x -instance (GAstDebug f a, GAstDebug g a) => GAstDebug (f :*: g) a where +instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where gAstDebug (x :*: y) = gAstDebug x ++ gAstDebug y -instance {-# OVERLAPPING #-} ASTDebug e a => GAstDebug (K1 i (e a)) a where +instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where gAstDebug (K1 x) = astDebug' x -instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) a where +instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where gAstDebug (K1 x) = [SimpleNode "" (show x)] -instance (GAstDebug f a, Constructor c) => GAstDebug (M1 C c f) a where +instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] -instance (GAstDebug f a, Selector s) => GAstDebug (M1 S s f) a where +instance (GAstDebug f dom, Selector s) => GAstDebug (M1 S s f) dom where gAstDebug s@(M1 x) = traversal&nodeLabel .= selName s $ gAstDebug x -- don't have to do anything with datatype metainfo -instance GAstDebug f a => GAstDebug (M1 D t f) a where +instance GAstDebug f dom => GAstDebug (M1 D t f) dom where gAstDebug (M1 x) = gAstDebug x diff --git a/Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs b/Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs --- a/Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs +++ b/Language/Haskell/Tools/Refactor/ASTDebug/Instances.hs @@ -4,6 +4,7 @@ , StandaloneDeriving , DeriveGeneric , UndecidableInstances + , TypeFamilies #-} module Language.Haskell.Tools.Refactor.ASTDebug.Instances where @@ -15,121 +16,135 @@ import Language.Haskell.Tools.AST -- Annotations -instance (ASTDebug e a, Show (e a)) => ASTDebug (Ann e) a where - astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= a $ astDebug' e - -instance (ASTDebug e a, Show (e a)) => ASTDebug (AnnList e) a where - astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" a (concatMap astDebug' ls))] - -instance (ASTDebug e a, Show (e a)) => ASTDebug (AnnMaybe e) a where - astDebug' (AnnMaybe a e) = [TreeNode "" (TreeDebugNode "?" a (maybe [] astDebug' e))] +instance {-# OVERLAPPING #-} (ASTDebug SimpleName dom st) => ASTDebug (Ann SimpleName) dom st where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (NameInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e + +instance {-# OVERLAPPING #-} (ASTDebug Expr dom st) => ASTDebug (Ann Expr) dom st where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ExprInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e + +instance {-# OVERLAPPING #-} (ASTDebug ImportDecl dom st) => ASTDebug (Ann ImportDecl) dom st where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ImportInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e + +instance {-# OVERLAPPING #-} (ASTDebug Module dom st) => ASTDebug (Ann Module) dom st where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ModuleInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e + +instance {-# OVERLAPPABLE #-} (ASTDebug e dom st) => ASTDebug (Ann e) dom st where + astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= DefaultInfoType (getRange (a ^. sourceInfo)) $ astDebug' e + +instance (ASTDebug e dom st) => ASTDebug (AnnList e) dom st where + astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] +instance (ASTDebug e dom st) => ASTDebug (AnnMaybe e) dom st where + astDebug' (AnnMaybe a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] + -- Modules -instance (Generic a, Show a) => ASTDebug Module a -instance (Generic a, Show a) => ASTDebug ModuleHead a -instance (Generic a, Show a) => ASTDebug ExportSpecList a -instance (Generic a, Show a) => ASTDebug ExportSpec a -instance (Generic a, Show a) => ASTDebug IESpec a -instance (Generic a, Show a) => ASTDebug SubSpec a -instance (Generic a, Show a) => ASTDebug ModulePragma a -instance (Generic a, Show a) => ASTDebug FilePragma a -instance (Generic a, Show a) => ASTDebug ImportDecl a -instance (Generic a, Show a) => ASTDebug ImportSpec a -instance (Generic a, Show a) => ASTDebug ImportQualified a -instance (Generic a, Show a) => ASTDebug ImportSource a -instance (Generic a, Show a) => ASTDebug ImportSafe a -instance (Generic a, Show a) => ASTDebug TypeNamespace a -instance (Generic a, Show a) => ASTDebug ImportRenaming a +instance (Domain dom, SourceInfo st) => ASTDebug Module dom st +instance (Domain dom, SourceInfo st) => ASTDebug ModuleHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug ExportSpecList dom st +instance (Domain dom, SourceInfo st) => ASTDebug ExportSpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug IESpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug SubSpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug ModulePragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug FilePragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportSpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportQualified dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportSource dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportSafe dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeNamespace dom st +instance (Domain dom, SourceInfo st) => ASTDebug ImportRenaming dom st -- Declarations -instance (Generic a, Show a) => ASTDebug Decl a -instance (Generic a, Show a) => ASTDebug ClassBody a -instance (Generic a, Show a) => ASTDebug ClassElement a -instance (Generic a, Show a) => ASTDebug DeclHead a -instance (Generic a, Show a) => ASTDebug InstBody a -instance (Generic a, Show a) => ASTDebug InstBodyDecl a -instance (Generic a, Show a) => ASTDebug GadtConDecl a -instance (Generic a, Show a) => ASTDebug GadtConType a -instance (Generic a, Show a) => ASTDebug GadtField a -instance (Generic a, Show a) => ASTDebug FunDeps a -instance (Generic a, Show a) => ASTDebug FunDep a -instance (Generic a, Show a) => ASTDebug ConDecl a -instance (Generic a, Show a) => ASTDebug FieldDecl a -instance (Generic a, Show a) => ASTDebug Deriving a -instance (Generic a, Show a) => ASTDebug InstanceRule a -instance (Generic a, Show a) => ASTDebug InstanceHead a -instance (Generic a, Show a) => ASTDebug TypeEqn a -instance (Generic a, Show a) => ASTDebug KindConstraint a -instance (Generic a, Show a) => ASTDebug TyVar a -instance (Generic a, Show a) => ASTDebug Type a -instance (Generic a, Show a) => ASTDebug Kind a -instance (Generic a, Show a) => ASTDebug Context a -instance (Generic a, Show a) => ASTDebug Assertion a -instance (Generic a, Show a) => ASTDebug Expr a -instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (Stmt' expr) a -instance (Generic a, Show a) => ASTDebug CompStmt a -instance (Generic a, Show a) => ASTDebug ValueBind a -instance (Generic a, Show a) => ASTDebug Pattern a -instance (Generic a, Show a) => ASTDebug PatternField a -instance (Generic a, Show a) => ASTDebug Splice a -instance (Generic a, Show a) => ASTDebug QQString a -instance (Generic a, Show a) => ASTDebug Match a -instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (Alt' expr) a -instance (Generic a, Show a) => ASTDebug Rhs a -instance (Generic a, Show a) => ASTDebug GuardedRhs a -instance (Generic a, Show a) => ASTDebug FieldUpdate a -instance (Generic a, Show a) => ASTDebug Bracket a -instance (Generic a, Show a) => ASTDebug TopLevelPragma a -instance (Generic a, Show a) => ASTDebug Rule a -instance (Generic a, Show a) => ASTDebug AnnotationSubject a -instance (Generic a, Show a) => ASTDebug MinimalFormula a -instance (Generic a, Show a) => ASTDebug ExprPragma a -instance (Generic a, Show a) => ASTDebug SourceRange a -instance (Generic a, Show a) => ASTDebug Number a -instance (Generic a, Show a) => ASTDebug QuasiQuote a -instance (Generic a, Show a) => ASTDebug RhsGuard a -instance (Generic a, Show a) => ASTDebug LocalBind a -instance (Generic a, Show a) => ASTDebug LocalBinds a -instance (Generic a, Show a) => ASTDebug FixitySignature a -instance (Generic a, Show a) => ASTDebug TypeSignature a -instance (Generic a, Show a) => ASTDebug ListCompBody a -instance (Generic a, Show a) => ASTDebug TupSecElem a -instance (Generic a, Show a) => ASTDebug TypeFamily a -instance (Generic a, Show a) => ASTDebug TypeFamilySpec a -instance (Generic a, Show a) => ASTDebug InjectivityAnn a -instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (CaseRhs' expr) a -instance (Generic a, Show a, ASTDebug expr a, Show (expr a), Generic (expr a)) => ASTDebug (GuardedCaseRhs' expr) a -instance (Generic a, Show a) => ASTDebug PatternSynonym a -instance (Generic a, Show a) => ASTDebug PatSynRhs a -instance (Generic a, Show a) => ASTDebug PatSynLhs a -instance (Generic a, Show a) => ASTDebug PatSynWhere a -instance (Generic a, Show a) => ASTDebug PatternTypeSignature a -instance (Generic a, Show a) => ASTDebug Role a -instance (Generic a, Show a) => ASTDebug Cmd a -instance (Generic a, Show a) => ASTDebug LanguageExtension a -instance (Generic a, Show a) => ASTDebug MatchLhs a +instance (Domain dom, SourceInfo st) => ASTDebug Decl dom st +instance (Domain dom, SourceInfo st) => ASTDebug ClassBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug ClassElement dom st +instance (Domain dom, SourceInfo st) => ASTDebug DeclHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug InstBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug InstBodyDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug GadtConDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug GadtConType dom st +instance (Domain dom, SourceInfo st) => ASTDebug GadtField dom st +instance (Domain dom, SourceInfo st) => ASTDebug FunDeps dom st +instance (Domain dom, SourceInfo st) => ASTDebug FunDep dom st +instance (Domain dom, SourceInfo st) => ASTDebug ConDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug FieldDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug Deriving dom st +instance (Domain dom, SourceInfo st) => ASTDebug InstanceRule dom st +instance (Domain dom, SourceInfo st) => ASTDebug InstanceHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeEqn dom st +instance (Domain dom, SourceInfo st) => ASTDebug KindConstraint dom st +instance (Domain dom, SourceInfo st) => ASTDebug TyVar dom st +instance (Domain dom, SourceInfo st) => ASTDebug Type dom st +instance (Domain dom, SourceInfo st) => ASTDebug Kind dom st +instance (Domain dom, SourceInfo st) => ASTDebug Context dom st +instance (Domain dom, SourceInfo st) => ASTDebug Assertion dom st +instance (Domain dom, SourceInfo st) => ASTDebug Expr dom st +instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Expr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Cmd) dom st +instance (Domain dom, SourceInfo st) => ASTDebug CompStmt dom st +instance (Domain dom, SourceInfo st) => ASTDebug ValueBind dom st +instance (Domain dom, SourceInfo st) => ASTDebug Pattern dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatternField dom st +instance (Domain dom, SourceInfo st) => ASTDebug Splice dom st +instance (Domain dom, SourceInfo st) => ASTDebug QQString dom st +instance (Domain dom, SourceInfo st) => ASTDebug Match dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (Alt' expr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug Rhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug GuardedRhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug FieldUpdate dom st +instance (Domain dom, SourceInfo st) => ASTDebug Bracket dom st +instance (Domain dom, SourceInfo st) => ASTDebug TopLevelPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug Rule dom st +instance (Domain dom, SourceInfo st) => ASTDebug AnnotationSubject dom st +instance (Domain dom, SourceInfo st) => ASTDebug MinimalFormula dom st +instance (Domain dom, SourceInfo st) => ASTDebug ExprPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug SourceRange dom st +instance (Domain dom, SourceInfo st) => ASTDebug Number dom st +instance (Domain dom, SourceInfo st) => ASTDebug QuasiQuote dom st +instance (Domain dom, SourceInfo st) => ASTDebug RhsGuard dom st +instance (Domain dom, SourceInfo st) => ASTDebug LocalBind dom st +instance (Domain dom, SourceInfo st) => ASTDebug LocalBinds dom st +instance (Domain dom, SourceInfo st) => ASTDebug FixitySignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeSignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug ListCompBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug TupSecElem dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeFamily dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeFamilySpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug InjectivityAnn dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (CaseRhs' expr) dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (GuardedCaseRhs' expr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatternSynonym dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatSynRhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatSynLhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatSynWhere dom st +instance (Domain dom, SourceInfo st) => ASTDebug PatternTypeSignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug Role dom st +instance (Domain dom, SourceInfo st) => ASTDebug Cmd dom st +instance (Domain dom, SourceInfo st) => ASTDebug LanguageExtension dom st +instance (Domain dom, SourceInfo st) => ASTDebug MatchLhs dom st -- Literal -instance (Generic a, Show a) => ASTDebug Literal a -instance (Generic a, Show a, ASTDebug k a, Show (k a), Generic (k a)) => ASTDebug (Promoted k) a +instance (Domain dom, SourceInfo st) => ASTDebug Literal dom st +instance (Domain dom, SourceInfo st, ASTDebug k dom st, Generic (k dom st)) => ASTDebug (Promoted k) dom st -- Base -instance (Generic a, Show a) => ASTDebug Operator a -instance (Generic a, Show a) => ASTDebug Name a -instance (Generic a, Show a) => ASTDebug SimpleName a -instance (Generic a, Show a) => ASTDebug UnqualName a -instance (Generic a, Show a) => ASTDebug StringNode a -instance (Generic a, Show a) => ASTDebug DataOrNewtypeKeyword a -instance (Generic a, Show a) => ASTDebug DoKind a -instance (Generic a, Show a) => ASTDebug TypeKeyword a -instance (Generic a, Show a) => ASTDebug OverlapPragma a -instance (Generic a, Show a) => ASTDebug CallConv a -instance (Generic a, Show a) => ASTDebug ArrowAppl a -instance (Generic a, Show a) => ASTDebug Safety a -instance (Generic a, Show a) => ASTDebug ConlikeAnnot a -instance (Generic a, Show a) => ASTDebug Assoc a -instance (Generic a, Show a) => ASTDebug Precedence a -instance (Generic a, Show a) => ASTDebug LineNumber a -instance (Generic a, Show a) => ASTDebug PhaseControl a -instance (Generic a, Show a) => ASTDebug PhaseNumber a -instance (Generic a, Show a) => ASTDebug PhaseInvert a +instance (Domain dom, SourceInfo st) => ASTDebug Operator dom st +instance (Domain dom, SourceInfo st) => ASTDebug Name dom st +instance (Domain dom, SourceInfo st) => ASTDebug SimpleName dom st +instance (Domain dom, SourceInfo st) => ASTDebug ModuleName dom st +instance (Domain dom, SourceInfo st) => ASTDebug UnqualName dom st +instance (Domain dom, SourceInfo st) => ASTDebug StringNode dom st +instance (Domain dom, SourceInfo st) => ASTDebug DataOrNewtypeKeyword dom st +instance (Domain dom, SourceInfo st) => ASTDebug DoKind dom st +instance (Domain dom, SourceInfo st) => ASTDebug TypeKeyword dom st +instance (Domain dom, SourceInfo st) => ASTDebug OverlapPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug CallConv dom st +instance (Domain dom, SourceInfo st) => ASTDebug ArrowAppl dom st +instance (Domain dom, SourceInfo st) => ASTDebug Safety dom st +instance (Domain dom, SourceInfo st) => ASTDebug ConlikeAnnot dom st +instance (Domain dom, SourceInfo st) => ASTDebug Assoc dom st +instance (Domain dom, SourceInfo st) => ASTDebug Precedence dom st +instance (Domain dom, SourceInfo st) => ASTDebug LineNumber dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseControl dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseNumber dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseInvert dom st diff --git a/Language/Haskell/Tools/Refactor/DebugGhcAST.hs b/Language/Haskell/Tools/Refactor/DebugGhcAST.hs --- a/Language/Haskell/Tools/Refactor/DebugGhcAST.hs +++ b/Language/Haskell/Tools/Refactor/DebugGhcAST.hs @@ -7,6 +7,7 @@ import Language.Haskell.Tools.Refactor.RangeDebug import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST (shortShowSpan) import GHC import HsSyn @@ -33,8 +34,6 @@ instance Show a => Show (Located a) where show (L l a) = "L(" ++ shortShowSpan l ++ ") (" ++ show a ++ ")" - - deriving instance Show (ABExport RdrName) deriving instance Show (AmbiguousFieldOcc RdrName) diff --git a/Language/Haskell/Tools/Refactor/ExtractBinding.hs b/Language/Haskell/Tools/Refactor/ExtractBinding.hs --- a/Language/Haskell/Tools/Refactor/ExtractBinding.hs +++ b/Language/Haskell/Tools/Refactor/ExtractBinding.hs @@ -1,8 +1,11 @@ {-# LANGUAGE ViewPatterns + , ScopedTypeVariables , RankNTypes , FlexibleContexts , TypeApplications + , ConstraintKinds + , TypeFamilies #-} module Language.Haskell.Tools.Refactor.ExtractBinding where @@ -25,34 +28,38 @@ import Debug.Trace -type STWithId = STWithNames GHC.Id +type Ann' e dom = Ann e dom SrcTemplateStage +type AnnMaybe' e dom = AnnMaybe e dom SrcTemplateStage -extractBinding' :: RealSrcSpan -> String -> Ann Module STWithId -> RefactoredModule GHC.Id +type ExtractBindingDomain dom = ( Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls) + , HasScopeInfo (SemanticInfo' dom SameInfoExprCls) ) + +extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> Ann' Module dom -> RefactoredModule dom extractBinding' sp name mod = if isValidBindingName name then extractBinding (nodesContaining sp) (nodesContaining sp) name mod else refactError "The given name is not a valid for the extracted binding" -extractBinding :: Simple Traversal (Ann Module STWithId) (Ann ValueBind STWithId) - -> Simple Traversal (Ann ValueBind STWithId) (Ann Expr STWithId) - -> String -> Ann Module STWithId -> RefactoredModule GHC.Id +extractBinding :: forall dom . ExtractBindingDomain dom => Simple Traversal (Ann' Module dom) (Ann' ValueBind dom) + -> Simple Traversal (Ann' ValueBind dom) (Ann' Expr dom) + -> String -> Ann' Module dom -> RefactoredModule dom extractBinding selectDecl selectExpr name mod - = let conflicting = any @[] (isConflicting name) (mod ^? selectDecl & biplateRef) - exprRange = head (mod ^? selectDecl & selectExpr & annotation & sourceInfo & sourceTemplateRange) + = let conflicting = any (isConflicting name) (mod ^? selectDecl & biplateRef :: [Ann' SimpleName dom]) + exprRange = getRange $ head (mod ^? selectDecl & selectExpr & annotation & sourceInfo) decl = last (mod ^? selectDecl) - declRange = last (mod ^? selectDecl & annotation & sourceInfo & sourceTemplateRange) + declRange = getRange $ last (mod ^? selectDecl & annotation & sourceInfo) in if conflicting then refactError "The given name causes name conflict." else do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind name (head $ decl ^? actualContainingExpr exprRange) $ mod) Nothing case st of Just def -> return $ evalState (selectDecl&element !~ addLocalBinding declRange exprRange def $ res) False Nothing -> refactError "There is no applicable expression to extract." -isConflicting :: String -> Ann SimpleName STWithId -> Bool +isConflicting :: ExtractBindingDomain dom => String -> Ann' SimpleName dom -> Bool isConflicting name used - = (used ^? semantics & isDefined) == Just True - && (GHC.occNameString . GHC.getOccName <$> (used ^? semantics & nameInfo)) == Just name + = semanticsDefining (used ^. semantics) + && (GHC.occNameString . GHC.getOccName <$> semanticsName (used ^. semantics)) == Just name -- Replaces the selected expression with a call and generates the called binding. -extractThatBind :: String -> Ann Expr STWithId -> Ann Expr STWithId -> StateT (Maybe (Ann ValueBind STWithId)) (Refactor GHC.Id) (Ann Expr STWithId) +extractThatBind :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (Refactor dom) (Ann' Expr dom) extractThatBind name cont e = do ret <- get if (isJust ret) then return e @@ -64,7 +71,7 @@ el -> doExtract name cont e where hasParameter = not (null (getExternalBinds cont e)) -addLocalBinding :: SrcSpan -> SrcSpan -> Ann ValueBind STWithId -> ValueBind STWithId -> State Bool (ValueBind STWithId) +addLocalBinding :: SrcSpan -> SrcSpan -> Ann' ValueBind dom -> ValueBind dom SrcTemplateStage -> State Bool (ValueBind dom SrcTemplateStage) addLocalBinding declRange exprRange local bind = do done <- get if not done then do put True @@ -75,7 +82,7 @@ doAddBinding declRng (RealSrcSpan rng) local fb@(FunBind {}) = funBindMatches & annList & filtered (isInside rng) & element & matchBinds .- insertLocalBind declRng local $ fb -insertLocalBind :: SrcSpan -> Ann ValueBind STWithId -> AnnMaybe LocalBinds STWithId -> AnnMaybe LocalBinds STWithId +insertLocalBind :: SrcSpan -> Ann' ValueBind dom -> AnnMaybe' LocalBinds dom -> AnnMaybe' LocalBinds dom insertLocalBind declRng toInsert locals | isAnnNothing locals , RealSrcSpan rng <- declRng = -- creates the new where clause indented 2 spaces from the declaration @@ -83,7 +90,7 @@ | otherwise = annJust & element & localBinds .- insertWhere (mkLocalValBind toInsert) (const True) isNothing $ locals -- | All expressions that are bound stronger than function application. -isParenLikeExpr :: Expr a -> Bool +isParenLikeExpr :: Expr dom st -> Bool isParenLikeExpr (If {}) = True isParenLikeExpr (Paren {}) = True isParenLikeExpr (List {}) = True @@ -101,7 +108,7 @@ isParenLikeExpr (QuasiQuoteExpr {}) = True isParenLikeExpr _ = False -doExtract :: String -> Ann Expr STWithId -> Ann Expr STWithId -> StateT (Maybe (Ann ValueBind STWithId)) (Refactor GHC.Id) (Ann Expr STWithId) +doExtract :: ExtractBindingDomain dom => String -> Ann' Expr dom -> Ann' Expr dom -> StateT (Maybe (Ann' ValueBind dom)) (Refactor dom) (Ann' Expr dom) doExtract name cont e@((^. element) -> lam@(Lambda {})) = do let params = getExternalBinds cont e put (Just (generateBind name (map mkVarPat params ++ (lam ^? exprBindings&annList)) (fromJust $ lam ^? exprInner))) @@ -112,42 +119,42 @@ return (generateCall name params) -- | Gets the values that have to be passed to the extracted definition -getExternalBinds :: Ann Expr STWithId -> Ann Expr STWithId -> [Ann Name STWithId] +getExternalBinds :: ExtractBindingDomain dom => Ann' Expr dom -> Ann' Expr dom -> [Ann' Name dom] getExternalBinds cont expr = map exprToName $ keepFirsts $ filter isApplicableName (expr ^? uniplateRef) - where isApplicableName name@(fmap GHC.varName . getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm + where isApplicableName name@(getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm isApplicableName _ = False - getExprNameInfo :: Ann Expr STWithId -> Maybe GHC.Var - getExprNameInfo expr = (listToMaybe $ expr ^? element & (exprName&element&simpleName &+& exprOperator&element&operatorName) - & semantics&nameInfo) + getExprNameInfo :: ExtractBindingDomain dom => Ann' Expr dom -> Maybe GHC.Name + getExprNameInfo expr = semanticsName =<< (listToMaybe $ expr ^? element & (exprName&element&simpleName &+& exprOperator&element&operatorName) + & semantics) -- | Creates the parameter value to pass the name (operators are passed in parentheses) - exprToName :: Ann Expr STWithId -> Ann Name STWithId + exprToName :: Ann' Expr dom -> Ann' Name dom exprToName e | Just n <- e ^? element & exprName = n | Just op <- e ^? element & exprOperator & element & operatorName = mkParenName op notInScopeForExtracted :: GHC.Name -> Bool - notInScopeForExtracted n = notElem @[] n (cont ^? semantics & scopedLocals & traversal & traversal) + notInScopeForExtracted n = notElem @[] n (semanticsScope (cont ^. semantics) ^? traversal & traversal) inScopeForOriginal :: GHC.Name -> Bool - inScopeForOriginal n = elem @[] n (expr ^? semantics & scopedLocals & traversal & traversal) + inScopeForOriginal n = elem @[] n (semanticsScope (expr ^. semantics) ^? traversal & traversal) keepFirsts (e:rest) = e : keepFirsts (filter (/= e) rest) keepFirsts [] = [] -actualContainingExpr :: SrcSpan -> Simple Traversal (Ann ValueBind STWithId) (Ann Expr STWithId) +actualContainingExpr :: SourceInfo st => SrcSpan -> Simple Traversal (Ann ValueBind dom st) (Ann Expr dom st) actualContainingExpr (RealSrcSpan rng) = element & accessRhs & element & accessExpr - where accessRhs :: Simple Traversal (ValueBind STWithId) (Ann Rhs STWithId) + where accessRhs :: SourceInfo st => Simple Traversal (ValueBind dom st) (Ann Rhs dom st) accessRhs = valBindRhs &+& funBindMatches & annList & filtered (isInside rng) & element & matchRhs - accessExpr :: Simple Traversal (Rhs STWithId) (Ann Expr STWithId) + accessExpr :: SourceInfo st => Simple Traversal (Rhs dom st) (Ann Expr dom st) accessExpr = rhsExpr &+& rhsGuards & annList & filtered (isInside rng) & element & guardExpr -- | Generates the expression that calls the local binding -generateCall :: String -> [Ann Name STWithId] -> Ann Expr STWithId +generateCall :: String -> [Ann' Name dom] -> Ann' Expr dom generateCall name args = foldl (\e a -> mkApp e (mkVar a)) (mkVar $ mkNormalName $ mkSimpleName name) args -- | Generates the local binding for the selected expression -generateBind :: String -> [Ann Pattern STWithId] -> Ann Expr STWithId -> Ann ValueBind STWithId +generateBind :: String -> [Ann' Pattern dom] -> Ann' Expr dom -> Ann' ValueBind dom generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing generateBind name args e = mkFunctionBind [mkMatch (mkNormalMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] diff --git a/Language/Haskell/Tools/Refactor/GenerateExports.hs b/Language/Haskell/Tools/Refactor/GenerateExports.hs --- a/Language/Haskell/Tools/Refactor/GenerateExports.hs +++ b/Language/Haskell/Tools/Refactor/GenerateExports.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections + , ConstraintKinds + , TypeFamilies + , FlexibleContexts + #-} module Language.Haskell.Tools.Refactor.GenerateExports where import Control.Reference hiding (element) @@ -12,36 +16,38 @@ import Language.Haskell.Tools.AST.Gen import Language.Haskell.Tools.Refactor.RefactorBase +type DomGenerateExports dom = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls)) + -- | Creates an export list that imports standalone top-level definitions with all of their contained definitions -generateExports :: GHC.NamedThing n => Ann Module (STWithNames n) -> RefactoredModule n +generateExports :: DomGenerateExports dom => Ann Module dom SrcTemplateStage -> RefactoredModule dom generateExports mod = return (element & modHead & annJust & element & mhExports & annMaybe .= Just (createExports (getTopLevels mod)) $ mod) -- | Get all the top-level definitions with flags that mark if they can contain other top-level definitions -- (classes and data declarations). -getTopLevels :: Ann Module (STWithNames n) -> [(n, Bool)] +getTopLevels :: DomGenerateExports dom => Ann Module dom SrcTemplateStage -> [(GHC.Name, Bool)] getTopLevels mod = catMaybes $ map (\d -> fmap (,exportContainOthers d) (getTopLevelDeclName d)) (mod ^? element & modDecl & annList & element) - where exportContainOthers :: Decl (STWithNames n) -> Bool + where exportContainOthers :: Decl dom SrcTemplateStage -> Bool exportContainOthers (DataDecl {}) = True exportContainOthers (ClassDecl {}) = True exportContainOthers _ = False -- | Get all the standalone top level definitions (their GHC unique names) in a module. -- You could also do getting all the names with a biplate reference and select the top-level ones, but this is more efficient. -getTopLevelDeclName :: Decl (NodeInfo (SemanticInfo n) src) -> Maybe n -getTopLevelDeclName (d @ TypeDecl {}) = listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ TypeFamilyDecl {}) = listToMaybe (d ^? declTypeFamily & element & tfHead & dhNames) -getTopLevelDeclName (d @ ClosedTypeFamilyDecl {}) = listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ DataDecl {}) = listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ GDataDecl {}) = listToMaybe (d ^? declHead & dhNames) -getTopLevelDeclName (d @ ClassDecl {}) = listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName :: DomGenerateExports dom => Decl dom SrcTemplateStage -> Maybe GHC.Name +getTopLevelDeclName (d @ TypeDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ TypeFamilyDecl {}) = semanticsName =<< listToMaybe (d ^? declTypeFamily & element & tfHead & dhNames) +getTopLevelDeclName (d @ ClosedTypeFamilyDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ DataDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ GDataDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) +getTopLevelDeclName (d @ ClassDecl {}) = semanticsName =<< listToMaybe (d ^? declHead & dhNames) getTopLevelDeclName (d @ PatternSynonymDecl {}) - = listToMaybe (d ^? declPatSyn & element & patLhs & element & (patName & element & simpleName &+& patSynOp & element & operatorName) & semantics & nameInfo) -getTopLevelDeclName (d @ ValueBinding {}) = listToMaybe (d ^? declValBind & bindingName) -getTopLevelDeclName (d @ ForeignImport {}) = listToMaybe (d ^? declName & element & simpleName & semantics & nameInfo) + = semanticsName =<< listToMaybe (d ^? declPatSyn & element & patLhs & element & (patName & element & simpleName &+& patSynOp & element & operatorName) & semantics) +getTopLevelDeclName (d @ ValueBinding {}) = semanticsName =<< listToMaybe (d ^? declValBind & bindingName) +getTopLevelDeclName (d @ ForeignImport {}) = semanticsName =<< listToMaybe (d ^? declName & element & simpleName & semantics) getTopLevelDeclName _ = Nothing -- | Create the export for a give name. -createExports :: GHC.NamedThing n => [(n, Bool)] -> Ann ExportSpecList (STWithNames n) +createExports :: DomGenerateExports dom => [(GHC.Name, Bool)] -> Ann ExportSpecList dom SrcTemplateStage createExports elems = mkExportSpecList $ map (mkExportSpec . createExport) elems where createExport (n, False) = mkIeSpec (mkUnqualName' (GHC.getName n)) Nothing createExport (n, True) = mkIeSpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) diff --git a/Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs b/Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs --- a/Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs +++ b/Language/Haskell/Tools/Refactor/GenerateTypeSignature.hs @@ -2,8 +2,11 @@ , FlexibleContexts , ScopedTypeVariables , RankNTypes + , TypeApplications + , TypeFamilies + , ConstraintKinds #-} -module Language.Haskell.Tools.Refactor.GenerateTypeSignature (generateTypeSignature, generateTypeSignature') where +module Language.Haskell.Tools.Refactor.GenerateTypeSignature (generateTypeSignature, generateTypeSignature', GenerateSignatureDomain) where import GHC hiding (Module) import Type as GHC @@ -26,34 +29,36 @@ import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.Refactor.RefactorBase -type RefactorId = Refactor GHC.Id -type STWithId = STWithNames GHC.Id +type Ann' e dom = Ann e dom SrcTemplateStage +type AnnList' e dom = AnnList e dom SrcTemplateStage +type GenerateSignatureDomain dom = ( Domain dom, HasIdInfo (SemanticInfo' dom SameInfoNameCls), Eq (SemanticInfo' dom SameInfoNameCls) + , SemanticInfo' dom SameInfoImportCls ~ ImportInfo Id ) -generateTypeSignature' :: RealSrcSpan -> Ann Module STWithId -> RefactoredModule GHC.Id +generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> Ann' Module dom -> RefactoredModule dom generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) -- | Perform the refactoring on either local or top-level definition -generateTypeSignature :: Simple Traversal (Ann Module STWithId) (AnnList Decl STWithId) +generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Ann' Module dom) (AnnList' Decl dom) -- ^ Access for a top-level definition if it is the selected definition - -> Simple Traversal (Ann Module STWithId) (AnnList LocalBind STWithId) + -> Simple Traversal (Ann' Module dom) (AnnList' LocalBind dom) -- ^ Access for a definition list if it contains the selected definition - -> (forall d . (Show (d (NodeInfo STWithId SourceTemplate)), Data (d STWithId), Typeable d, BindingElem d) - => AnnList d STWithId -> Maybe (Ann ValueBind STWithId)) + -> (forall d . (Show (d dom SrcTemplateStage), Data (d dom SrcTemplateStage), Typeable d, BindingElem d) + => AnnList' d dom -> Maybe (Ann' ValueBind dom)) -- ^ Selector for either local or top-level declaration in the definition list - -> Ann Module STWithId -> RefactoredModule GHC.Id + -> Ann' Module dom -> RefactoredModule dom generateTypeSignature topLevelRef localRef vbAccess = flip evalStateT False . (topLevelRef !~ genTypeSig vbAccess <=< localRef !~ genTypeSig vbAccess) -genTypeSig :: (Show (d (NodeInfo (SemanticInfo Id) SourceTemplate)), BindingElem d) => (AnnList d STWithId -> Maybe (Ann ValueBind STWithId)) - -> AnnList d STWithId -> StateT Bool RefactorId (AnnList d STWithId) +genTypeSig :: (GenerateSignatureDomain dom, BindingElem d) => (AnnList' d dom -> Maybe (Ann' ValueBind dom)) + -> AnnList' d dom -> StateT Bool (Refactor dom) (AnnList' d dom) genTypeSig vbAccess ls | Just vb <- vbAccess ls , not (typeSignatureAlreadyExist ls vb) = do let id = getBindingName vb isTheBind (Just ((^.element) -> decl)) - = isBinding decl && (decl ^? bindName) == (vb ^? bindingName :: [GHC.Id]) + = isBinding decl && map semanticsId (decl ^? bindName) == map semanticsId (vb ^? bindingName) isTheBind _ = False alreadyGenerated <- get @@ -65,11 +70,11 @@ | otherwise = return ls -generateTSFor :: GHC.Name -> GHC.Type -> RefactorId (Ann TypeSignature STWithId) +generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> Refactor dom (Ann' TypeSignature dom) generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) -- | Generates the source-level type for a GHC internal type -generateTypeFor :: Int -> GHC.Type -> RefactorId (Ann AST.Type STWithId) +generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> Refactor dom (Ann' AST.Type dom) generateTypeFor prec t -- context | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t @@ -112,25 +117,25 @@ | (tvs@(_:_), t') <- splitForAllTys t = wrapParen (-1) <$> (mkTyForall (mkTypeVarList (map getName tvs)) <$> generateTypeFor 0 t') | otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t)) - where wrapParen :: Int -> Ann AST.Type STWithId -> Ann AST.Type STWithId + where wrapParen :: Int -> Ann' AST.Type dom -> Ann' AST.Type dom wrapParen prec' node = if prec' < prec then mkTyParen node else node getTCId :: GHC.TyCon -> GHC.Id getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) - generateAssertionFor :: GHC.Type -> RefactorId (Ann AST.Assertion STWithId) + generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> Refactor dom (Ann' AST.Assertion dom) generateAssertionFor t | Just (tc, types) <- splitTyConApp_maybe t = mkClassAssert <$> referenceName (getTCId tc) <*> mapM (generateTypeFor 0) types -- TODO: infix things -- | Check whether the definition already has a type signature -typeSignatureAlreadyExist :: forall d . BindingElem d => AnnList d STWithId -> Ann ValueBind STWithId -> Bool +typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList' d dom -> Ann' ValueBind dom -> Bool typeSignatureAlreadyExist ls vb = - getBindingName vb `elem` concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element) + getBindingName vb `elem` catMaybes (map semanticsId $ concatMap (^? bindName) (filter isTypeSig $ ls ^? annList&element)) -getBindingName :: Ann ValueBind STWithId -> GHC.Id -getBindingName vb = case nub $ vb ^? bindingName of +getBindingName :: GenerateSignatureDomain dom => Ann' ValueBind dom -> GHC.Id +getBindingName vb = case catMaybes $ map semanticsId $ nub $ vb ^? bindingName of [n] -> n [] -> error "Trying to generate a signature for a binding with no name" _ -> error "Trying to generate a signature for a binding with multiple names" diff --git a/Language/Haskell/Tools/Refactor/OrganizeImports.hs b/Language/Haskell/Tools/Refactor/OrganizeImports.hs --- a/Language/Haskell/Tools/Refactor/OrganizeImports.hs +++ b/Language/Haskell/Tools/Refactor/OrganizeImports.hs @@ -1,7 +1,10 @@ {-# LANGUAGE LambdaCase , ScopedTypeVariables + , FlexibleContexts + , TypeFamilies + , ConstraintKinds #-} -module Language.Haskell.Tools.Refactor.OrganizeImports (organizeImports) where +module Language.Haskell.Tools.Refactor.OrganizeImports (organizeImports, OrganizeImportsDomain) where import SrcLoc import Name hiding (Name) @@ -10,7 +13,7 @@ import TyCon import ConLike import DataCon -import Outputable (ppr, showSDocUnsafe) +import Outputable (Outputable(..), ppr, showSDocUnsafe) import Control.Reference hiding (element) import Control.Monad @@ -21,7 +24,7 @@ import Data.Data import Data.List import Data.Generics.Uniplate.Data -import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.FromGHC import Language.Haskell.Tools.AnnTrf.SourceTemplate import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers @@ -31,27 +34,32 @@ import Language.Haskell.Tools.Refactor.RefactorBase import Debug.Trace -organizeImports :: forall n . (NamedThing n, Data n) => Ann Module (STWithNames n) -> RefactoredModule n +type OrganizeImportsDomain dom n = (Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, NamedThing n) + +organizeImports :: forall n dom . OrganizeImportsDomain dom n + => Ann Module dom SrcTemplateStage -> RefactoredModule dom organizeImports mod = element&modImports&annListElems !~ narrowImports usedNames . sortImports $ mod where usedNames = map getName $ catMaybes - $ map (^? (annotation&semanticInfo&nameInfo)) - $ (universeBi (mod ^. element&modHead) ++ universeBi (mod ^. element&modDecl) :: [Ann SimpleName (STWithNames n)]) + $ map (semanticsName . (^. (annotation&semanticInfo))) + $ (universeBi (mod ^. element&modHead) ++ universeBi (mod ^. element&modDecl) :: [Ann SimpleName dom SrcTemplateStage]) -- | Sorts the imports in alphabetical order -sortImports :: [Ann ImportDecl (STWithNames n)] -> [Ann ImportDecl (STWithNames n)] -sortImports = sortBy (ordByOccurrence `on` (^. element&importModule&element)) +sortImports :: [Ann ImportDecl dom SrcTemplateStage] -> [Ann ImportDecl dom SrcTemplateStage] +sortImports = sortBy (compare `on` (^. element&importModule&element&AST.moduleNameString)) -- | Modify an import to only import names that are used. -narrowImports :: forall n . NamedThing n => [GHC.Name] -> [Ann ImportDecl (STWithNames n)] -> Refactor n [Ann ImportDecl (STWithNames n)] +narrowImports :: forall n dom . OrganizeImportsDomain dom n + => [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] -> Refactor dom [Ann ImportDecl dom SrcTemplateStage] narrowImports usedNames imps = foldM (narrowOneImport usedNames) imps imps - where narrowOneImport :: [GHC.Name] -> [Ann ImportDecl (STWithNames n)] -> Ann ImportDecl (STWithNames n) -> Refactor n [Ann ImportDecl (STWithNames n)] + where narrowOneImport :: [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] -> Ann ImportDecl dom SrcTemplateStage -> Refactor dom [Ann ImportDecl dom SrcTemplateStage] narrowOneImport names all one = (\case Just x -> map (\e -> if e == one then x else e) all Nothing -> delete one all) <$> narrowImport names (map (^. semantics) all) one -narrowImport :: NamedThing n => [GHC.Name] -> [SemanticInfo n] -> Ann ImportDecl (STWithNames n) - -> Refactor n (Maybe (Ann ImportDecl (STWithNames n))) +narrowImport :: OrganizeImportsDomain dom n + => [GHC.Name] -> [ImportInfo n] -> Ann ImportDecl dom SrcTemplateStage + -> Refactor dom (Maybe (Ann ImportDecl dom SrcTemplateStage)) narrowImport usedNames otherModules imp | importIsExact (imp ^. element) = Just <$> (element&importSpec&annJust&element&importSpecList !~ narrowImportSpecs usedNames $ imp) @@ -65,29 +73,30 @@ Just importedMod = imp ^? annotation&semanticInfo&importedModule -- | Narrows the import specification (explicitely imported elements) -narrowImportSpecs :: forall n . NamedThing n => [GHC.Name] -> AnnList IESpec (STWithNames n) -> Refactor n (AnnList IESpec (STWithNames n)) +narrowImportSpecs :: forall dom n . OrganizeImportsDomain dom n + => [GHC.Name] -> AnnList IESpec dom SrcTemplateStage -> Refactor dom (AnnList IESpec dom SrcTemplateStage) narrowImportSpecs usedNames = (annList&element !~ narrowSpecSubspec usedNames) >=> return . filterList isNeededSpec - where narrowSpecSubspec :: [GHC.Name] -> IESpec (STWithNames n) -> Refactor n (IESpec (STWithNames n)) + where narrowSpecSubspec :: [GHC.Name] -> IESpec dom SrcTemplateStage -> Refactor dom (IESpec dom SrcTemplateStage) narrowSpecSubspec usedNames spec - = do let Just specName = spec ^? ieName&element&simpleName&annotation&semanticInfo&nameInfo + = do let Just specName = semanticsName =<< (spec ^? ieName&element&simpleName&annotation&semanticInfo) Just tt <- GHC.lookupName (getName specName) let subspecsInScope = case tt of ATyCon tc | not (isClassTyCon tc) -> map getName (tyConDataCons tc) `intersect` usedNames _ -> usedNames ieSubspec&annJust !- narrowImportSubspecs subspecsInScope $ spec - isNeededSpec :: Ann IESpec (STWithNames n) -> Bool + isNeededSpec :: Ann IESpec dom SrcTemplateStage -> Bool isNeededSpec ie = -- if the name is used, it is needed - fmap getName (ie ^? element&ieName&element&simpleName&annotation&semanticInfo&nameInfo) `elem` map Just usedNames + fmap getName (semanticsName =<< (ie ^? element&ieName&element&simpleName&annotation&semanticInfo)) `elem` map Just usedNames -- if the name is not used, but some of its constructors are used, it is needed || ((ie ^? element&ieSubspec&annJust&element&essList&annList) /= []) || (case ie ^? element&ieSubspec&annJust&element of Just SubSpecAll -> True; _ -> False) -narrowImportSubspecs :: NamedThing n => [GHC.Name] -> Ann SubSpec (STWithNames n) -> Ann SubSpec (STWithNames n) +narrowImportSubspecs :: OrganizeImportsDomain dom n => [GHC.Name] -> Ann SubSpec dom SrcTemplateStage -> Ann SubSpec dom SrcTemplateStage narrowImportSubspecs [] (Ann _ SubSpecAll) = mkSubList [] narrowImportSubspecs _ ss@(Ann _ SubSpecAll) = ss narrowImportSubspecs usedNames ss@(Ann _ (SubSpecList _)) - = element&essList .- filterList (\n -> fmap getName (n ^? element&simpleName&annotation&semanticInfo&nameInfo) `elem` map Just usedNames) $ ss + = element&essList .- filterList (\n -> fmap getName (semanticsName =<< (n ^? element&simpleName&annotation&semanticInfo)) `elem` map Just usedNames) $ ss diff --git a/Language/Haskell/Tools/Refactor/RangeDebug.hs b/Language/Haskell/Tools/Refactor/RangeDebug.hs --- a/Language/Haskell/Tools/Refactor/RangeDebug.hs +++ b/Language/Haskell/Tools/Refactor/RangeDebug.hs @@ -18,63 +18,36 @@ import Language.Haskell.Tools.AnnTrf.RangeTemplate import Language.Haskell.Tools.AnnTrf.SourceTemplate -rangeDebug :: (a ~ NodeInfo sema SpanInfo, TreeDebug e a) => e a -> String -rangeDebug = treeDebug' (shortShowSpanInfo . (^. sourceInfo)) 0 - -shortShowSpanInfo :: SpanInfo -> String -shortShowSpanInfo (NodeSpan sp) = shortShowSpan sp -shortShowSpanInfo (OptionalPos bef aft loc) = "?" ++ show bef ++ " " ++ show aft ++ " " ++ shortShowLoc loc -shortShowSpanInfo (ListPos bef aft sep _ loc) = "*" ++ show bef ++ " " ++ show sep ++ " " ++ show aft ++ " " ++ shortShowLoc loc - -shortShowSpan :: SrcSpan -> String -shortShowSpan (UnhelpfulSpan _) = "??-??" -shortShowSpan sp@(RealSrcSpan _) - = shortShowLoc (srcSpanStart sp) ++ "-" ++ shortShowLoc (srcSpanEnd sp) - -shortShowLoc :: SrcLoc -> String -shortShowLoc (UnhelpfulLoc _) = "??" -shortShowLoc (RealSrcLoc loc) = show (srcLocLine loc) ++ ":" ++ show (srcLocCol loc) - -templateDebug :: TreeDebug e (NodeInfo sema RangeTemplate) => e (NodeInfo sema RangeTemplate) -> String -templateDebug = treeDebug' (shortShowRangeTemplate . (^. sourceInfo)) 0 - -shortShowRangeTemplate (RangeTemplate _ rngs) = "ˇ" ++ concatMap showRangeTemplateElem rngs ++ "ˇ" - where showRangeTemplateElem (RangeElem sp) = "[" ++ shortShowSpan (RealSrcSpan sp) ++ "]" - showRangeTemplateElem (RangeChildElem) = "." - showRangeTemplateElem r = show r - -sourceTemplateDebug :: TreeDebug e (NodeInfo sema SourceTemplate) => e (NodeInfo sema SourceTemplate) -> String -sourceTemplateDebug = treeDebug' (shortShowSourceTemplate . (^. sourceInfo)) 0 - -shortShowSourceTemplate temp = "ˇ" ++ (concatMap show $ temp ^. sourceTemplateElems) ++ "ˇ" +srcInfoDebug :: TreeDebug e dom st => e dom st -> String +srcInfoDebug = treeDebug' 0 -class TreeDebug e a where - treeDebug' :: (a -> String) -> Int -> e a -> String - default treeDebug' :: (GTreeDebug (Rep (e a)) a, Generic (e a)) => (a -> String) -> Int -> e a -> String - treeDebug' f i = gTreeDebug f i . from +class (SourceInfo st, Domain dom, Show (e dom st)) + => TreeDebug e dom st where + treeDebug' :: Int -> e dom st -> String + default treeDebug' :: (GTreeDebug (Rep (e dom st)), Generic (e dom st), Domain dom) => Int -> e dom st -> String + treeDebug' i = gTreeDebug i . from -class GTreeDebug f a where - gTreeDebug :: (a -> String) -> Int -> f p -> String +class GTreeDebug f where + gTreeDebug :: Int -> f p -> String -instance GTreeDebug V1 a where - gTreeDebug _ _ _ = error "GTreeDebug V1" +instance GTreeDebug V1 where + gTreeDebug _ = error "GTreeDebug V1" -instance GTreeDebug U1 a where - gTreeDebug _ _ U1 = "" +instance GTreeDebug U1 where + gTreeDebug _ U1 = "" -instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :+: g) a where - gTreeDebug f i (L1 x) = gTreeDebug f i x - gTreeDebug f i (R1 x) = gTreeDebug f i x +instance (GTreeDebug f, GTreeDebug g) => GTreeDebug (f :+: g) where + gTreeDebug i (L1 x) = gTreeDebug i x + gTreeDebug i (R1 x) = gTreeDebug i x -instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :*: g) a where - gTreeDebug f i (x :*: y) - = gTreeDebug f i x ++ gTreeDebug f i y +instance (GTreeDebug f, GTreeDebug g) => GTreeDebug (f :*: g) where + gTreeDebug i (x :*: y) = gTreeDebug i x ++ gTreeDebug i y -instance {-# OVERLAPPING #-} TreeDebug e a => GTreeDebug (K1 i (e a)) a where - gTreeDebug f i (K1 x) = treeDebug' f i x +instance {-# OVERLAPPING #-} TreeDebug e dom st => GTreeDebug (K1 i (e dom st)) where + gTreeDebug i (K1 x) = treeDebug' i x -instance {-# OVERLAPPABLE #-} GTreeDebug (K1 i c) a where - gTreeDebug f i (K1 x) = "" +instance {-# OVERLAPPABLE #-} GTreeDebug (K1 i c) where + gTreeDebug i (K1 x) = "" -instance GTreeDebug f a => GTreeDebug (M1 i t f) a where - gTreeDebug f i (M1 x) = gTreeDebug f i x +instance GTreeDebug f => GTreeDebug (M1 i t f) where + gTreeDebug i (M1 x) = gTreeDebug i x diff --git a/Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs b/Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs --- a/Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs +++ b/Language/Haskell/Tools/Refactor/RangeDebug/Instances.hs @@ -10,128 +10,130 @@ import Language.Haskell.Tools.Refactor.RangeDebug import GHC.Generics +import Control.Reference import Language.Haskell.Tools.AST -- Annotations -instance (TreeDebug e a, Show (e a)) => TreeDebug (Ann e) a where - treeDebug' f i (Ann a e) = identLine i ++ f a ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' f (i+1) e +instance TreeDebug e dom st => TreeDebug (Ann e) dom st where + treeDebug' i (Ann a e) = identLine i ++ show (a ^. sourceInfo) ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' (i+1) e identLine :: Int -> String identLine i = "\n" ++ replicate (i*2) ' ' -instance (TreeDebug e a, Show (e a)) => TreeDebug (AnnList e) a where - treeDebug' f i (AnnList a ls) = identLine i ++ f a ++ " <*>" ++ concatMap (treeDebug' f (i + 1)) ls +instance TreeDebug e dom st => TreeDebug (AnnList e) dom st where + treeDebug' i (AnnList a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls -instance (TreeDebug e a, Show (e a)) => TreeDebug (AnnMaybe e) a where - treeDebug' f i (AnnMaybe a e) = identLine i ++ f a ++ " " ++ maybe "" (\e -> treeDebug' f (i + 1) e) e +instance TreeDebug e dom st => TreeDebug (AnnMaybe e) dom st where + treeDebug' i (AnnMaybe a e) = identLine i ++ show (a ^. sourceInfo) ++ " " ++ maybe "" (\e -> treeDebug' (i + 1) e) e -- Modules -instance (Generic a, Show a) => TreeDebug Module a -instance (Generic a, Show a) => TreeDebug ModuleHead a -instance (Generic a, Show a) => TreeDebug ExportSpecList a -instance (Generic a, Show a) => TreeDebug ExportSpec a -instance (Generic a, Show a) => TreeDebug IESpec a -instance (Generic a, Show a) => TreeDebug SubSpec a -instance (Generic a, Show a) => TreeDebug ModulePragma a -instance (Generic a, Show a) => TreeDebug FilePragma a -instance (Generic a, Show a) => TreeDebug ImportDecl a -instance (Generic a, Show a) => TreeDebug ImportSpec a -instance (Generic a, Show a) => TreeDebug ImportQualified a -instance (Generic a, Show a) => TreeDebug ImportSource a -instance (Generic a, Show a) => TreeDebug ImportSafe a -instance (Generic a, Show a) => TreeDebug TypeNamespace a -instance (Generic a, Show a) => TreeDebug ImportRenaming a +instance (SourceInfo st, Domain dom) => TreeDebug Module dom st +instance (SourceInfo st, Domain dom) => TreeDebug ModuleHead dom st +instance (SourceInfo st, Domain dom) => TreeDebug ExportSpecList dom st +instance (SourceInfo st, Domain dom) => TreeDebug ExportSpec dom st +instance (SourceInfo st, Domain dom) => TreeDebug IESpec dom st +instance (SourceInfo st, Domain dom) => TreeDebug SubSpec dom st +instance (SourceInfo st, Domain dom) => TreeDebug ModulePragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug FilePragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportDecl dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportSpec dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportQualified dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportSource dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportSafe dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeNamespace dom st +instance (SourceInfo st, Domain dom) => TreeDebug ImportRenaming dom st -- Declarations -instance (Generic a, Show a) => TreeDebug Decl a -instance (Generic a, Show a) => TreeDebug ClassBody a -instance (Generic a, Show a) => TreeDebug ClassElement a -instance (Generic a, Show a) => TreeDebug DeclHead a -instance (Generic a, Show a) => TreeDebug InstBody a -instance (Generic a, Show a) => TreeDebug InstBodyDecl a -instance (Generic a, Show a) => TreeDebug GadtConDecl a -instance (Generic a, Show a) => TreeDebug GadtConType a -instance (Generic a, Show a) => TreeDebug GadtField a -instance (Generic a, Show a) => TreeDebug FunDeps a -instance (Generic a, Show a) => TreeDebug FunDep a -instance (Generic a, Show a) => TreeDebug ConDecl a -instance (Generic a, Show a) => TreeDebug FieldDecl a -instance (Generic a, Show a) => TreeDebug Deriving a -instance (Generic a, Show a) => TreeDebug InstanceRule a -instance (Generic a, Show a) => TreeDebug InstanceHead a -instance (Generic a, Show a) => TreeDebug TypeEqn a -instance (Generic a, Show a) => TreeDebug KindConstraint a -instance (Generic a, Show a) => TreeDebug TyVar a -instance (Generic a, Show a) => TreeDebug Type a -instance (Generic a, Show a) => TreeDebug Kind a -instance (Generic a, Show a) => TreeDebug Context a -instance (Generic a, Show a) => TreeDebug Assertion a -instance (Generic a, Show a) => TreeDebug Expr a -instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (Stmt' expr) a -instance (Generic a, Show a) => TreeDebug CompStmt a -instance (Generic a, Show a) => TreeDebug ValueBind a -instance (Generic a, Show a) => TreeDebug Pattern a -instance (Generic a, Show a) => TreeDebug PatternField a -instance (Generic a, Show a) => TreeDebug Splice a -instance (Generic a, Show a) => TreeDebug QQString a -instance (Generic a, Show a) => TreeDebug Match a -instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (Alt' expr) a -instance (Generic a, Show a) => TreeDebug Rhs a -instance (Generic a, Show a) => TreeDebug GuardedRhs a -instance (Generic a, Show a) => TreeDebug FieldUpdate a -instance (Generic a, Show a) => TreeDebug Bracket a -instance (Generic a, Show a) => TreeDebug TopLevelPragma a -instance (Generic a, Show a) => TreeDebug Rule a -instance (Generic a, Show a) => TreeDebug AnnotationSubject a -instance (Generic a, Show a) => TreeDebug MinimalFormula a -instance (Generic a, Show a) => TreeDebug ExprPragma a -instance (Generic a, Show a) => TreeDebug SourceRange a -instance (Generic a, Show a) => TreeDebug Number a -instance (Generic a, Show a) => TreeDebug QuasiQuote a -instance (Generic a, Show a) => TreeDebug RhsGuard a -instance (Generic a, Show a) => TreeDebug LocalBind a -instance (Generic a, Show a) => TreeDebug LocalBinds a -instance (Generic a, Show a) => TreeDebug FixitySignature a -instance (Generic a, Show a) => TreeDebug TypeSignature a -instance (Generic a, Show a) => TreeDebug ListCompBody a -instance (Generic a, Show a) => TreeDebug TupSecElem a -instance (Generic a, Show a) => TreeDebug TypeFamily a -instance (Generic a, Show a) => TreeDebug TypeFamilySpec a -instance (Generic a, Show a) => TreeDebug InjectivityAnn a -instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (CaseRhs' expr) a -instance (Generic a, Show a, TreeDebug expr a, Show (expr a), Generic (expr a)) => TreeDebug (GuardedCaseRhs' expr) a -instance (Generic a, Show a) => TreeDebug PatternSynonym a -instance (Generic a, Show a) => TreeDebug PatSynRhs a -instance (Generic a, Show a) => TreeDebug PatSynLhs a -instance (Generic a, Show a) => TreeDebug PatSynWhere a -instance (Generic a, Show a) => TreeDebug PatternTypeSignature a -instance (Generic a, Show a) => TreeDebug Role a -instance (Generic a, Show a) => TreeDebug Cmd a -instance (Generic a, Show a) => TreeDebug LanguageExtension a -instance (Generic a, Show a) => TreeDebug MatchLhs a +instance (SourceInfo st, Domain dom) => TreeDebug Decl dom st +instance (SourceInfo st, Domain dom) => TreeDebug ClassBody dom st +instance (SourceInfo st, Domain dom) => TreeDebug ClassElement dom st +instance (SourceInfo st, Domain dom) => TreeDebug DeclHead dom st +instance (SourceInfo st, Domain dom) => TreeDebug InstBody dom st +instance (SourceInfo st, Domain dom) => TreeDebug InstBodyDecl dom st +instance (SourceInfo st, Domain dom) => TreeDebug GadtConDecl dom st +instance (SourceInfo st, Domain dom) => TreeDebug GadtConType dom st +instance (SourceInfo st, Domain dom) => TreeDebug GadtField dom st +instance (SourceInfo st, Domain dom) => TreeDebug FunDeps dom st +instance (SourceInfo st, Domain dom) => TreeDebug FunDep dom st +instance (SourceInfo st, Domain dom) => TreeDebug ConDecl dom st +instance (SourceInfo st, Domain dom) => TreeDebug FieldDecl dom st +instance (SourceInfo st, Domain dom) => TreeDebug Deriving dom st +instance (SourceInfo st, Domain dom) => TreeDebug InstanceRule dom st +instance (SourceInfo st, Domain dom) => TreeDebug InstanceHead dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeEqn dom st +instance (SourceInfo st, Domain dom) => TreeDebug KindConstraint dom st +instance (SourceInfo st, Domain dom) => TreeDebug TyVar dom st +instance (SourceInfo st, Domain dom) => TreeDebug Type dom st +instance (SourceInfo st, Domain dom) => TreeDebug Kind dom st +instance (SourceInfo st, Domain dom) => TreeDebug Context dom st +instance (SourceInfo st, Domain dom) => TreeDebug Assertion dom st +instance (SourceInfo st, Domain dom) => TreeDebug Expr dom st +instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (Stmt' expr) dom st +instance (SourceInfo st, Domain dom) => TreeDebug CompStmt dom st +instance (SourceInfo st, Domain dom) => TreeDebug ValueBind dom st +instance (SourceInfo st, Domain dom) => TreeDebug Pattern dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatternField dom st +instance (SourceInfo st, Domain dom) => TreeDebug Splice dom st +instance (SourceInfo st, Domain dom) => TreeDebug QQString dom st +instance (SourceInfo st, Domain dom) => TreeDebug Match dom st +instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (Alt' expr) dom st +instance (SourceInfo st, Domain dom) => TreeDebug Rhs dom st +instance (SourceInfo st, Domain dom) => TreeDebug GuardedRhs dom st +instance (SourceInfo st, Domain dom) => TreeDebug FieldUpdate dom st +instance (SourceInfo st, Domain dom) => TreeDebug Bracket dom st +instance (SourceInfo st, Domain dom) => TreeDebug TopLevelPragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug Rule dom st +instance (SourceInfo st, Domain dom) => TreeDebug AnnotationSubject dom st +instance (SourceInfo st, Domain dom) => TreeDebug MinimalFormula dom st +instance (SourceInfo st, Domain dom) => TreeDebug ExprPragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug SourceRange dom st +instance (SourceInfo st, Domain dom) => TreeDebug Number dom st +instance (SourceInfo st, Domain dom) => TreeDebug QuasiQuote dom st +instance (SourceInfo st, Domain dom) => TreeDebug RhsGuard dom st +instance (SourceInfo st, Domain dom) => TreeDebug LocalBind dom st +instance (SourceInfo st, Domain dom) => TreeDebug LocalBinds dom st +instance (SourceInfo st, Domain dom) => TreeDebug FixitySignature dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeSignature dom st +instance (SourceInfo st, Domain dom) => TreeDebug ListCompBody dom st +instance (SourceInfo st, Domain dom) => TreeDebug TupSecElem dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeFamily dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeFamilySpec dom st +instance (SourceInfo st, Domain dom) => TreeDebug InjectivityAnn dom st +instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (CaseRhs' expr) dom st +instance (SourceInfo st, Domain dom, TreeDebug expr dom st, Generic (expr dom st)) => TreeDebug (GuardedCaseRhs' expr) dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatternSynonym dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatSynRhs dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatSynLhs dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatSynWhere dom st +instance (SourceInfo st, Domain dom) => TreeDebug PatternTypeSignature dom st +instance (SourceInfo st, Domain dom) => TreeDebug Role dom st +instance (SourceInfo st, Domain dom) => TreeDebug Cmd dom st +instance (SourceInfo st, Domain dom) => TreeDebug LanguageExtension dom st +instance (SourceInfo st, Domain dom) => TreeDebug MatchLhs dom st -- Literal -instance (Generic a, Show a) => TreeDebug Literal a -instance (Generic a, Show a, TreeDebug k a, Show (k a), Generic (k a)) => TreeDebug (Promoted k) a +instance (SourceInfo st, Domain dom) => TreeDebug Literal dom st +instance (SourceInfo st, Domain dom, TreeDebug k dom st, Generic (k dom st)) => TreeDebug (Promoted k) dom st -- Base -instance (Generic a, Show a) => TreeDebug Operator a -instance (Generic a, Show a) => TreeDebug Name a -instance (Generic a, Show a) => TreeDebug SimpleName a -instance (Generic a, Show a) => TreeDebug UnqualName a -instance (Generic a, Show a) => TreeDebug StringNode a -instance (Generic a, Show a) => TreeDebug DataOrNewtypeKeyword a -instance (Generic a, Show a) => TreeDebug DoKind a -instance (Generic a, Show a) => TreeDebug TypeKeyword a -instance (Generic a, Show a) => TreeDebug OverlapPragma a -instance (Generic a, Show a) => TreeDebug CallConv a -instance (Generic a, Show a) => TreeDebug ArrowAppl a -instance (Generic a, Show a) => TreeDebug Safety a -instance (Generic a, Show a) => TreeDebug ConlikeAnnot a -instance (Generic a, Show a) => TreeDebug Assoc a -instance (Generic a, Show a) => TreeDebug Precedence a -instance (Generic a, Show a) => TreeDebug LineNumber a -instance (Generic a, Show a) => TreeDebug PhaseControl a -instance (Generic a, Show a) => TreeDebug PhaseNumber a -instance (Generic a, Show a) => TreeDebug PhaseInvert a +instance (SourceInfo st, Domain dom) => TreeDebug Operator dom st +instance (SourceInfo st, Domain dom) => TreeDebug Name dom st +instance (SourceInfo st, Domain dom) => TreeDebug SimpleName dom st +instance (SourceInfo st, Domain dom) => TreeDebug ModuleName dom st +instance (SourceInfo st, Domain dom) => TreeDebug UnqualName dom st +instance (SourceInfo st, Domain dom) => TreeDebug StringNode dom st +instance (SourceInfo st, Domain dom) => TreeDebug DataOrNewtypeKeyword dom st +instance (SourceInfo st, Domain dom) => TreeDebug DoKind dom st +instance (SourceInfo st, Domain dom) => TreeDebug TypeKeyword dom st +instance (SourceInfo st, Domain dom) => TreeDebug OverlapPragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug CallConv dom st +instance (SourceInfo st, Domain dom) => TreeDebug ArrowAppl dom st +instance (SourceInfo st, Domain dom) => TreeDebug Safety dom st +instance (SourceInfo st, Domain dom) => TreeDebug ConlikeAnnot dom st +instance (SourceInfo st, Domain dom) => TreeDebug Assoc dom st +instance (SourceInfo st, Domain dom) => TreeDebug Precedence dom st +instance (SourceInfo st, Domain dom) => TreeDebug LineNumber dom st +instance (SourceInfo st, Domain dom) => TreeDebug PhaseControl dom st +instance (SourceInfo st, Domain dom) => TreeDebug PhaseNumber dom st +instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st diff --git a/Language/Haskell/Tools/Refactor/RefactorBase.hs b/Language/Haskell/Tools/Refactor/RefactorBase.hs --- a/Language/Haskell/Tools/Refactor/RefactorBase.hs +++ b/Language/Haskell/Tools/Refactor/RefactorBase.hs @@ -21,6 +21,7 @@ import Control.Reference hiding (element) import Data.Function (on) import Data.List +import Data.List.Split import Data.Maybe import Data.Char import Control.Monad.Reader @@ -28,25 +29,26 @@ import Control.Monad.Writer -- | The information a refactoring can use -data RefactorCtx a = RefactorCtx { refModuleName :: GHC.Module - , refCtxImports :: [Ann ImportDecl a] - } +data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module + , refCtxImports :: [Ann ImportDecl dom SrcTemplateStage] + } -- | Performs the given refactoring, transforming it into a Ghc action -runRefactor :: (a ~ STWithNames n, TemplateAnnot a) => Ann Module a -> (Ann Module a -> Refactor n (Ann Module a)) -> Ghc (Either String (Ann Module a)) +runRefactor :: (SemanticInfo' dom SameInfoModuleCls ~ ModuleInfo n) + => Ann Module dom SrcTemplateStage -> (Ann Module dom SrcTemplateStage -> RefactoredModule dom) -> Ghc (Either String (Ann Module dom SrcTemplateStage)) runRefactor mod trf = let init = RefactorCtx (fromJust $ mod ^? semantics&defModuleName) (mod ^? element&modImports&annList) in runExceptT $ runReaderT (addGeneratedImports (runWriterT (fromRefactorT $ trf mod))) init -- | Adds the imports that bring names into scope that are needed by the refactoring -addGeneratedImports :: (TemplateAnnot a, Monad m) => ReaderT (RefactorCtx a) m (Ann Module a, [GHC.Name]) -> ReaderT (RefactorCtx a) m (Ann Module a) +addGeneratedImports :: (Monad m) => ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage, [GHC.Name]) -> ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage) addGeneratedImports = fmap (\(m,names) -> element&modImports&annListElems .- (++ addImports names) $ m) - where addImports :: TemplateAnnot a => [GHC.Name] -> [Ann ImportDecl a] + where addImports :: [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage] addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ nub $ sort names -- TODO: group names like constructors into correct IESpecs - createImport :: TemplateAnnot a => [GHC.Name] -> Ann ImportDecl a - createImport names = mkImportDecl False False False Nothing (mkSimpleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names) + createImport :: [GHC.Name] -> Ann ImportDecl dom SrcTemplateStage + createImport names = mkImportDecl False False False Nothing (mkModuleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names) Nothing (Just $ mkImportSpecList (map (\n -> mkIeSpec (mkUnqualName' n) Nothing) names)) instance (GhcMonad m, Monoid s) => GhcMonad (WriterT s m) where @@ -75,21 +77,19 @@ -- | Input and output information for the refactoring -newtype RefactorT ann m ast = RefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx ann) m) ast } - deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx ann), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) +newtype RefactorT dom m a = RefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx dom) m) a } + deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx dom), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad) -instance MonadTrans (RefactorT ann) where +instance MonadTrans (RefactorT dom) where lift = RefactorT . lift . lift refactError :: String -> Refactor n a refactError = lift . throwE -- | The refactoring monad -type Refactor n = RefactorT (STWithNames n) (ExceptT String Ghc) - -type STWithNames n = NodeInfo (SemanticInfo n) SourceTemplate +type Refactor dom = RefactorT dom (ExceptT String Ghc) -type RefactoredModule n = Refactor n (Ann Module (STWithNames n)) +type RefactoredModule dom = Refactor dom (Ann Module dom SrcTemplateStage) registeredNamesFromPrelude :: [GHC.Name] registeredNamesFromPrelude = GHC.basicKnownKeyNames ++ map GHC.tyConName GHC.wiredInTyCons @@ -105,14 +105,17 @@ Just mod -> GHC.moduleNameString (GHC.moduleName mod) ++ "." ++ GHC.occNameString (GHC.nameOccName name) Nothing -> GHC.occNameString (GHC.nameOccName name) -referenceName :: (Eq n, GHC.NamedThing n) => n -> Refactor n (Ann Name (STWithNames n)) +referenceName :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) + => n -> Refactor dom (Ann Name dom SrcTemplateStage) referenceName = referenceName' mkQualName' -referenceOperator :: (Eq n, GHC.NamedThing n) => n -> Refactor n (Ann Operator (STWithNames n)) +referenceOperator :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) + => n -> Refactor dom (Ann Operator dom SrcTemplateStage) referenceOperator = referenceName' mkQualOp' -- | Create a name that references the definition. Generates an import if the definition is not yet imported. -referenceName' :: (Eq n, GHC.NamedThing n) => ([String] -> GHC.Name -> Ann nt (STWithNames n)) -> n -> Refactor n (Ann nt (STWithNames n)) +referenceName' :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n) + => ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> n -> Refactor dom (Ann nt dom SrcTemplateStage) referenceName' makeName n@(GHC.getName -> name) | name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude = return $ makeName [] name -- imported from prelude @@ -127,16 +130,16 @@ else return $ referenceBy makeName name possibleImports -- use it according to the best available import -- | Reference the name by the shortest suitable import -referenceBy :: (TemplateAnnot a) => ([String] -> GHC.Name -> Ann nt a) -> GHC.Name -> [Ann ImportDecl a] -> Ann nt a +referenceBy :: ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> [Ann ImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage referenceBy makeName name imps = let prefixes = map importQualifier imps in makeName (minimumBy (compare `on` (length . concat)) prefixes) name - where importQualifier :: Ann ImportDecl a -> [String] + where importQualifier :: Ann ImportDecl dom SrcTemplateStage -> [String] importQualifier imp = if isJust (imp ^? element&importQualified&annJust) then case imp ^? element&importAs&annJust&element&importRename&element of - Nothing -> nameElements (imp ^. element&importModule&element) -- fully qualified import - Just asName -> nameElements asName -- the name given by as clause + Nothing -> splitOn "." (imp ^. element&importModule&element&moduleNameString) -- fully qualified import + Just asName -> splitOn "." (asName ^. moduleNameString) -- the name given by as clause else [] -- unqualified import -- | Different classes of definitions that have different kind of names. @@ -147,7 +150,7 @@ | SynonymOperator -- ^ Type definitions with operator-like names -- | Get which category does a given name belong to -classifyName :: GHC.Name -> Refactor n NameClass +classifyName :: GHC.Name -> Refactor dom NameClass classifyName n = lookupName n >>= return . \case Just (AnId id) | isop -> ValueOperator Just (AnId id) -> Variable diff --git a/Language/Haskell/Tools/Refactor/RenameDefinition.hs b/Language/Haskell/Tools/Refactor/RenameDefinition.hs --- a/Language/Haskell/Tools/Refactor/RenameDefinition.hs +++ b/Language/Haskell/Tools/Refactor/RenameDefinition.hs @@ -1,16 +1,23 @@ {-# LANGUAGE ScopedTypeVariables , LambdaCase , MultiWayIf + , TypeApplications + , ConstraintKinds + , TypeFamilies + , FlexibleContexts + , ViewPatterns #-} -module Language.Haskell.Tools.Refactor.RenameDefinition (renameDefinition, renameDefinition') where +module Language.Haskell.Tools.Refactor.RenameDefinition (renameDefinition, renameDefinition', DomainRenameDefinition) where import Name hiding (Name) import GHC (Ghc, TyThing(..), lookupName) import qualified GHC import OccName import SrcLoc +import Outputable import Control.Reference hiding (element) +import qualified Control.Reference as Ref import Control.Monad.State import Control.Monad.Trans.Except import Data.Data @@ -23,13 +30,16 @@ import Debug.Trace -renameDefinition' :: forall n . (NamedThing n, Data n) => RealSrcSpan -> String -> Ann Module (STWithNames n) -> RefactoredModule n +type DomainRenameDefinition dom = ( Domain dom, HasNameInfo (SemanticInfo' dom SameInfoNameCls), Data (SemanticInfo' dom SameInfoNameCls) + , HasScopeInfo (SemanticInfo' dom SameInfoNameCls), HasDefiningInfo (SemanticInfo' dom SameInfoNameCls) ) + +renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Ann Module dom SrcTemplateStage -> RefactoredModule dom renameDefinition' sp str mod - = case (getNodeContaining sp mod :: Maybe (Ann SimpleName (STWithNames n))) >>= (fmap getName . (^? semantics&nameInfo)) of + = case (getNodeContaining sp mod :: Maybe (Ann SimpleName dom SrcTemplateStage)) >>= (fmap getName . (semanticsName =<<) . (^? semantics)) of Just n -> renameDefinition n str mod Nothing -> refactError "No name is selected" -renameDefinition :: forall n . (NamedThing n, Data n) => GHC.Name -> String -> Ann Module (STWithNames n) -> RefactoredModule n +renameDefinition :: DomainRenameDefinition dom => GHC.Name -> String -> Ann Module dom SrcTemplateStage -> RefactoredModule dom renameDefinition toChange newName mod = do nameCls <- classifyName toChange (res,defFound) <- runStateT (biplateRef !~ changeName toChange newName $ mod) False @@ -37,19 +47,20 @@ | not defFound -> refactError "The definition to rename was not found" | otherwise -> return res where - changeName :: GHC.Name -> String -> Ann SimpleName (STWithNames n) -> StateT Bool (Refactor n) (Ann SimpleName (STWithNames n)) + changeName :: DomainRenameDefinition dom => GHC.Name -> String -> Ann SimpleName dom SrcTemplateStage -> StateT Bool (Refactor dom) (Ann SimpleName dom SrcTemplateStage) changeName toChange str elem - = if | fmap getName (elem ^? semantics&nameInfo) == Just toChange - && (elem ^? semantics&isDefined) == Just False - && any ((str ==) . occNameString . getOccName) (maybe [] head (elem ^? semantics & scopedLocals)) + = if | fmap getName (semanticsName (elem ^. semantics)) == Just toChange + && semanticsDefining (elem ^. semantics) == False + && any @[] ((str ==) . occNameString . getOccName) (semanticsScope (elem ^. semantics) ^? Ref.element 0 & traversal) -> lift $ refactError "The definition clashes with an existing one" -- name clash with an external definition - | fmap getName (elem ^? semantics&nameInfo) == Just toChange - -> do modify (|| fromMaybe False (elem ^? semantics&isDefined)) + | fmap getName (semanticsName (elem ^. semantics)) == Just toChange + -> do modify (|| semanticsDefining (elem ^. semantics)) return $ element & unqualifiedName .= mkNamePart str $ elem - | let namesInScope = fromMaybe [] (elem ^? semantics & scopedLocals) - actualName = maybe toChange getName (elem ^? semantics & nameInfo) - in str == occNameString (getOccName actualName) && sameNamespace toChange actualName - && conflicts toChange actualName namesInScope + | let namesInScope = semanticsScope (elem ^. semantics) + in case semanticsName (elem ^. semantics) of + Just (getName -> exprName) -> str == occNameString (getOccName exprName) && sameNamespace toChange exprName + && conflicts toChange exprName namesInScope + Nothing -> False -- ambiguous names -> lift $ refactError "The definition clashes with an existing one" -- local name clash | otherwise -> return elem diff --git a/haskell-tools-refactor.cabal b/haskell-tools-refactor.cabal --- a/haskell-tools-refactor.cabal +++ b/haskell-tools-refactor.cabal @@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 0.1.2.0 +version: 0.1.3.0 synopsis: Refactoring Tool for Haskell description: Contains a set of refactorings based on the Haskell-Tools framework to easily transform a Haskell program. For the descriptions of the implemented refactorings, see the homepage. homepage: https://github.com/haskell-tools/haskell-tools @@ -37,12 +37,11 @@ , time >=1.5 && <2.0 , filepath >=1.4 && <2.0 , either >=4.0 && <5.0 - , haskell-tools-ast >=0.1.2 && <0.2 - , haskell-tools-ast-fromghc >=0.1.2 && <0.2 - , haskell-tools-ast-gen >=0.1.2 && <0.2 - , haskell-tools-ast-trf >=0.1.2 && <0.2 - , haskell-tools-prettyprint >=0.1.2 && <0.2 - , structural-traversal >=0.1 && <0.2 + , haskell-tools-ast >=0.1.3 && <0.2 + , haskell-tools-ast-fromghc >=0.1.3 && <0.2 + , haskell-tools-ast-gen >=0.1.3 && <0.2 + , haskell-tools-ast-trf >=0.1.3 && <0.2 + , haskell-tools-prettyprint >=0.1.3 && <0.2 , template-haskell >=2.0 && <3.0 default-language: Haskell2010