haskell-tools-refactor 1.0.1.2 → 1.1.0.0
raw patch · 18 files changed
+389/−140 lines, 18 filesdep ~basedep ~ghcdep ~haskell-tools-ast
Dependency ranges changed: base, ghc, haskell-tools-ast, haskell-tools-backend-ghc, haskell-tools-prettyprint, haskell-tools-rewrite, template-haskell
Files
- Language/Haskell/Tools/Refactor.hs +33/−50
- Language/Haskell/Tools/Refactor/Monad.hs +2/−1
- Language/Haskell/Tools/Refactor/Prepare.hs +9/−5
- Language/Haskell/Tools/Refactor/Querying.hs +60/−14
- Language/Haskell/Tools/Refactor/Refactoring.hs +1/−1
- Language/Haskell/Tools/Refactor/Representation.hs +2/−1
- Language/Haskell/Tools/Refactor/Utils/AST.hs +2/−1
- Language/Haskell/Tools/Refactor/Utils/BindingElem.hs +2/−1
- Language/Haskell/Tools/Refactor/Utils/Debug.hs +41/−0
- Language/Haskell/Tools/Refactor/Utils/Extensions.hs +25/−6
- Language/Haskell/Tools/Refactor/Utils/Helpers.hs +22/−2
- Language/Haskell/Tools/Refactor/Utils/Maybe.hs +13/−1
- Language/Haskell/Tools/Refactor/Utils/Monadic.hs +4/−1
- Language/Haskell/Tools/Refactor/Utils/NameLookup.hs +61/−8
- Language/Haskell/Tools/Refactor/Utils/Type.hs +5/−1
- Language/Haskell/Tools/Refactor/Utils/TypeLookup.hs +89/−31
- haskell-tools-refactor.cabal +16/−15
- test/Main.hs +2/−1
Language/Haskell/Tools/Refactor.hs view
@@ -1,58 +1,41 @@ -- | Defines the API for refactorings module Language.Haskell.Tools.Refactor - ( module Language.Haskell.Tools.AST.SemaInfoClasses - , module Language.Haskell.Tools.Rewrite - , module Language.Haskell.Tools.AST.References - , module Language.Haskell.Tools.AST.Helpers - , module Language.Haskell.Tools.Refactor.Utils.Monadic - , module Language.Haskell.Tools.Refactor.Utils.Helpers - , module Language.Haskell.Tools.Rewrite.ElementTypes - , module Language.Haskell.Tools.Refactor.Prepare - , module Language.Haskell.Tools.Refactor.Utils.Lists - , module Language.Haskell.Tools.Refactor.Utils.BindingElem - , module Language.Haskell.Tools.Refactor.Utils.Indentation - , module Language.Haskell.Tools.Refactor.Querying - , module Language.Haskell.Tools.Refactor.Refactoring - , module Language.Haskell.Tools.Refactor.Utils.Name - , module Language.Haskell.Tools.Refactor.Representation - , module Language.Haskell.Tools.Refactor.Monad - , module Language.Haskell.Tools.Refactor.Utils.Type - , module Language.Haskell.Tools.Refactor.Utils.TypeLookup - , module Language.Haskell.Tools.Refactor.Utils.NameLookup - , Ann, HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain, Dom, IdDom - , shortShowSpan, shortShowSpanWithFile, SrcTemplateStage, SourceInfoTraversal(..) - -- elements of source templates - , sourceTemplateNodeRange, sourceTemplateNodeElems - , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators - , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter - , SourceTemplateTextElem(..), sourceTemplateText - , UnsupportedExtension(..), SpliceInsertionProblem(..), ConvertionProblem(..) - , TransformationProblem(..), BreakUpProblem(..), PrettyPrintProblem(..) - ) where + ( module X + , Ann, HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain, Dom, IdDom + , shortShowSpan, shortShowSpanWithFile, SrcTemplateStage, SourceInfoTraversal(..) + -- elements of source templates + , sourceTemplateNodeRange, sourceTemplateNodeElems + , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators + , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + , SourceTemplateTextElem(..), sourceTemplateText + , UnsupportedExtension(..), SpliceInsertionProblem(..), ConvertionProblem(..) + , TransformationProblem(..), BreakUpProblem(..), PrettyPrintProblem(..) + ) where -- Important: Haddock doesn't support the rename all exported modules and export them at once hack -import Language.Haskell.Tools.AST.Helpers -import Language.Haskell.Tools.AST.References -import Language.Haskell.Tools.AST.SemaInfoClasses -import Language.Haskell.Tools.PrettyPrint.Prepare -import Language.Haskell.Tools.Refactor.Monad -import Language.Haskell.Tools.Refactor.Prepare hiding (ModuleName) -import Language.Haskell.Tools.Refactor.Refactoring -import Language.Haskell.Tools.Refactor.Representation -import Language.Haskell.Tools.Refactor.Utils.BindingElem -import Language.Haskell.Tools.Refactor.Utils.Helpers -import Language.Haskell.Tools.Refactor.Utils.Indentation -import Language.Haskell.Tools.Refactor.Utils.Lists -import Language.Haskell.Tools.Refactor.Utils.Maybe -import Language.Haskell.Tools.Refactor.Utils.Monadic -import Language.Haskell.Tools.Refactor.Utils.Name -import Language.Haskell.Tools.Refactor.Utils.NameLookup -import Language.Haskell.Tools.Refactor.Utils.Type -import Language.Haskell.Tools.Refactor.Utils.TypeLookup -import Language.Haskell.Tools.Refactor.Querying -import Language.Haskell.Tools.Rewrite -import Language.Haskell.Tools.Rewrite.ElementTypes +import Language.Haskell.Tools.AST.Helpers as X +import Language.Haskell.Tools.AST.References as X +import Language.Haskell.Tools.AST.SemaInfoClasses as X +import Language.Haskell.Tools.PrettyPrint.Prepare as X +import Language.Haskell.Tools.Refactor.Monad as X +import Language.Haskell.Tools.Refactor.Prepare as X hiding (ModuleName) +import Language.Haskell.Tools.Refactor.Refactoring as X +import Language.Haskell.Tools.Refactor.Representation as X +import Language.Haskell.Tools.Refactor.Querying as X +import Language.Haskell.Tools.Refactor.Utils.BindingElem as X +import Language.Haskell.Tools.Refactor.Utils.Debug as X +import Language.Haskell.Tools.Refactor.Utils.Helpers as X +import Language.Haskell.Tools.Refactor.Utils.Indentation as X +import Language.Haskell.Tools.Refactor.Utils.Lists as X +import Language.Haskell.Tools.Refactor.Utils.Maybe as X +import Language.Haskell.Tools.Refactor.Utils.Monadic as X +import Language.Haskell.Tools.Refactor.Utils.Name as X +import Language.Haskell.Tools.Refactor.Utils.NameLookup as X +import Language.Haskell.Tools.Refactor.Utils.Type as X +import Language.Haskell.Tools.Refactor.Utils.TypeLookup as X +import Language.Haskell.Tools.Rewrite as X +import Language.Haskell.Tools.Rewrite.ElementTypes as X import Language.Haskell.Tools.AST.Ann import Language.Haskell.Tools.BackendGHC (SpliceInsertionProblem(..), ConvertionProblem(..))
Language/Haskell/Tools/Refactor/Monad.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Types and instances for monadic refactorings. The refactoring monad provides automatic -- importing, keeping important source fragments (such as preprocessor pragmas), and providing
Language/Haskell/Tools/Refactor/Prepare.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Defines utility methods that prepare Haskell modules for refactoring module Language.Haskell.Tools.Refactor.Prepare where @@ -13,7 +14,7 @@ import System.Directory (canonicalizePath) import System.FilePath -import CmdLineParser (CmdLineP(..), processArgs) +import CmdLineParser (CmdLineP(..), processArgs, Warn(..), Err(..)) import DynFlags import FastString (mkFastString) import GHC hiding (loadModule, ModuleName) @@ -21,7 +22,7 @@ import GHC.Paths ( libdir ) import GhcMonad import HscTypes -import Outputable (Outputable(..), showSDocUnsafe) +import Outputable (Outputable(..), showSDocUnsafe, cat, (<>)) import Packages (initPackages) import SrcLoc import StringBuffer (hGetStringBuffer) @@ -68,12 +69,15 @@ let change = runCmdLine $ processArgs flagsAll lArgs let ((leftovers, errs, warnings), newDynFlags) = change dynflags unless (null warnings) - $ liftIO $ putStrLn $ showSDocUnsafe $ ppr warnings + $ liftIO $ putStrLn $ showSDocUnsafe $ cat $ map pprWarning warnings unless (null errs) - $ liftIO $ putStrLn $ showSDocUnsafe $ ppr errs + $ liftIO $ putStrLn $ showSDocUnsafe $ cat $ map pprErr errs void $ setSessionDynFlags newDynFlags when (any ("-package-db" `isSuffixOf`) args) reloadPkgDb return (map unLoc leftovers, snd . change) + +pprWarning (Warn reason msg) = ppr reason Outputable.<> ppr msg +pprErr (Err msg) = ppr msg -- | Reloads the package database based on the session flags reloadPkgDb :: Ghc ()
Language/Haskell/Tools/Refactor/Querying.hs view
@@ -1,23 +1,49 @@+{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + module Language.Haskell.Tools.Refactor.Querying where import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.List ((++), map, find) -import Data.Aeson (Value) +import Data.Aeson +import FastString (unpackFS) +import SrcLoc + import GHC (RealSrcSpan, Ghc) +import GHC.Generics (Generic) -import Language.Haskell.Tools.AST () -import Language.Haskell.Tools.Refactor.Monad (ProjectRefactoring, Refactoring) +import Language.Haskell.Tools.AST (shortShowSpanWithFile) import Language.Haskell.Tools.Refactor.Prepare (correctRefactorSpan, readSrcSpan) -import Language.Haskell.Tools.Refactor.Representation (RefactorChange, ModuleDom) - -data QueryChoice = LocationQuery - { queryName :: String - , locationQuery :: RealSrcSpan -> ModuleDom -> [ModuleDom] -> QueryMonad Value - } +import Language.Haskell.Tools.Refactor.Representation (ModuleDom) +type QueryType = String type QueryMonad = ExceptT String Ghc +data QueryValue = GeneralQuery Value + | MarkerQuery [Marker] + deriving (Generic, Show, Eq) + +data QueryChoice + = LocationQuery { queryName :: String + , locationQuery :: RealSrcSpan -> ModuleDom -> [ModuleDom] -> QueryMonad QueryValue + } + | GlobalQuery { queryName :: String + , globalQuery :: ModuleDom -> [ModuleDom] -> QueryMonad QueryValue + } + +data Marker = Marker { location :: SrcSpan + , severity :: Severity + , message :: String + } deriving (Generic, Eq) + +data Severity = Error | Warning | Info + deriving (Show, Generic, Eq) + +decompQuery :: QueryValue -> (QueryType, Value) +decompQuery (GeneralQuery x) = ("GeneralQuery", x) +decompQuery (MarkerQuery x) = ("MarkerQuery" , toJSON x) + queryCommands :: [QueryChoice] -> [String] queryCommands = map queryName @@ -28,13 +54,33 @@ -> [String] -- ^ The query command -> Either FilePath ModuleDom -- ^ The module in which the refactoring is performed -> [ModuleDom] -- ^ Other modules - -> Ghc (Either String Value) -performQuery queries (name:args) mod mods = - case (query, mod, args) of + -> Ghc (Either String (QueryType, Value)) +performQuery queries (name:args) modOrPath mods = + case (query, modOrPath, args) of (Just (LocationQuery _ query), Right mod, sp:_) - -> runExceptT $ query (correctRefactorSpan (snd mod) $ readSrcSpan sp) mod mods - (Just (LocationQuery _ query), _, _) + -> runExceptT $ decompQuery <$> query (correctRefactorSpan (snd mod) $ readSrcSpan sp) mod mods + (Just (LocationQuery _ _), _, _) -> return $ Left $ "The query '" ++ name ++ "' needs one argument: a source range" + (Just (GlobalQuery _ query), Right mod, _) + -> runExceptT $ decompQuery <$> query mod mods (Nothing, _, _) -> return $ Left $ "Unknown command: " ++ name where query = find ((== name) . queryName) queries + + +instance ToJSON Marker +instance ToJSON Severity +instance ToJSON QueryValue + +instance ToJSON SrcSpan where + toJSON (RealSrcSpan sp) = object [ "file" .= unpackFS (srcSpanFile sp) + , "startRow" .= srcLocLine (realSrcSpanStart sp) + , "startCol" .= srcLocCol (realSrcSpanStart sp) + , "endRow" .= srcLocLine (realSrcSpanEnd sp) + , "endCol" .= srcLocCol (realSrcSpanEnd sp) + ] + toJSON _ = Null + + +instance Show Marker where + show marker = show (severity marker) ++ " at " ++ shortShowSpanWithFile (location marker) ++ ": " ++ message marker
Language/Haskell/Tools/Refactor/Refactoring.hs view
@@ -4,7 +4,7 @@ import Control.Monad.Trans.Except (runExceptT) import Data.List ((++), map, find) -import Data.Aeson (Value) +import Data.Aeson() import GHC (RealSrcSpan, Ghc)
Language/Haskell/Tools/Refactor/Representation.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} -- | Representation of modules, their collections, refactoring changes and exceptions. module Language.Haskell.Tools.Refactor.Representation where
Language/Haskell/Tools/Refactor/Utils/AST.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE AllowAmbiguousTypes, LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} -- | Operations for changing the AST module Language.Haskell.Tools.Refactor.Utils.AST (removeChild, removeSeparator) where
Language/Haskell/Tools/Refactor/Utils/BindingElem.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} -- | Utilities for transformations that work on both top-level and local definitions module Language.Haskell.Tools.Refactor.Utils.BindingElem where
+ Language/Haskell/Tools/Refactor/Utils/Debug.hs view
@@ -0,0 +1,41 @@+ + + +module Language.Haskell.Tools.Refactor.Utils.Debug + ( module Language.Haskell.Tools.Refactor.Utils.Debug + , module Debug.Trace + ) where + +import Data.Maybe (isJust) +import Control.Monad.Trans.Maybe +import Control.Reference ((^.), (&)) + +import Debug.Trace +import qualified Outputable as GHC + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Rewrite + + +debugM :: (Monad m, Show a) => m a -> m a +debugM m = do + x <- m + traceShow x m + +debug :: Show a => a -> a +debug x = traceShow x x + +-- | Displays True iff the wrapped value is a Just +debugMaybeT :: Monad m => MaybeT m a -> MaybeT m a +debugMaybeT m = MaybeT $ do + x <- runMaybeT m + traceShow (isJust x) (return x) + +showOutputable :: GHC.Outputable a => a -> String +showOutputable = GHC.showSDocUnsafe . GHC.ppr + +showName :: Name -> String +showName = (^. simpleName & unqualifiedName & simpleNameStr) + +showOp :: Operator -> String +showOp = (^. operatorName & unqualifiedName & simpleNameStr)
Language/Haskell/Tools/Refactor/Utils/Extensions.hs view
@@ -5,6 +5,8 @@ , GHC.Extension(..) ) where +import Data.Maybe (fromMaybe) + import Control.Reference ((^.), _1, _2, _3) import Language.Haskell.Extension (KnownExtension(..)) import qualified Language.Haskell.TH.LanguageExtensions as GHC (Extension(..)) @@ -60,13 +62,30 @@ , (GHC.Strict, turnOn, GHC.StrictData) ] --- | Canonicalize extensions +-- | These extensions' GHC representation name differs from their actual name +irregularExtensions :: [(String,String)] +irregularExtensions = [ ("CPP", "Cpp") + , ("Rank2Types", "RankNTypes") + , ("NamedFieldPuns", "RecordPuns") + , ("GeneralisedNewtypeDeriving", "GeneralizedNewtypeDeriving") + ] + +-- | Canonicalize extensions. +-- This is a helper function for parsing extensions +-- This way we can say @read . canonExt@ to parse any extension string canonExt :: String -> String -canonExt "CPP" = "Cpp" -canonExt "Rank2Types" = "RankNTypes" -canonExt "NamedFieldPuns" = "RecordPuns" -canonExt "GeneralisedNewtypeDeriving" = "GeneralizedNewtypeDeriving" -canonExt e = e +canonExt x = fromMaybe x (lookup x irregularExtensions) + +-- | Serializes the extension's GHC name into its LANGUAGE pragma name. +-- Should be always used in composition with show (@seriealizeExt . show@) +-- when refactoring extensions. +-- This function also replaces depracted extensions with their new versions. +serializeExt :: String -> String +serializeExt "Cpp" = "CPP" +serializeExt "Rank2Types" = "RankNTypes" +serializeExt "RecordPuns" = "NamedFieldPuns" +serializeExt x = x + -- * Mapping of Cabal haskell extensions to their GHC counterpart
Language/Haskell/Tools/Refactor/Utils/Helpers.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts, LambdaCase, RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} -- | Helper functions for defining refactorings. module Language.Haskell.Tools.Refactor.Utils.Helpers where @@ -6,7 +8,7 @@ import Control.Monad.State () import Control.Reference import Data.Function (on) -import Data.List (sortBy, nubBy) +import Data.List (sortBy, nubBy, groupBy) import Data.Maybe (Maybe(..)) import Language.Haskell.Tools.AST as AST @@ -45,3 +47,21 @@ -- | Puts the elements in the orginal order and remove duplicates (elements with the same source range) normalizeElements :: [Ann e dom SrcTemplateStage] -> [Ann e dom SrcTemplateStage] normalizeElements elems = nubBy ((==) `on` getRange) $ sortBy (compare `on` srcSpanStart . getRange) elems + +-- | Groups elements together into equivalence groups. +groupElemsBy :: Ord k => (a -> k) -> [a] -> [[a]] +groupElemsBy f = map (map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map ((,) <$> f <*> id) + +-- | Chooses a representative element for each equivalence group, +-- and pairs them with their corresponding group. +reprElems :: [[a]] -> [(a,[a])] +reprElems = map ((,) <$> head <*> id) + +-- | Sorts the elements of a list into equivalence groups based on a function, +-- then chooses a representative element for each group, +-- and pairs them with their corresponding group. +equivalenceGroupsBy :: Ord k => (a -> k) -> [a] -> [(a,[a])] +equivalenceGroupsBy f = reprElems . groupElemsBy f
Language/Haskell/Tools/Refactor/Utils/Maybe.hs view
@@ -8,8 +8,20 @@ import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..)) -liftMaybe :: (Monad m) => Maybe a -> MaybeT m a +isJustT :: Monad m => MaybeT m a -> m Bool +isJustT m = liftM isJust . runMaybeT $ m + +isNothingT :: Monad m => MaybeT m a -> m Bool +isNothingT m = liftM isNothing . runMaybeT $ m + +liftMaybe :: Monad m => Maybe a -> MaybeT m a liftMaybe = MaybeT . return + +fromMaybeT :: Monad m => a -> MaybeT m a -> m a +fromMaybeT def = maybeT def id + +fromMaybeTM :: Monad m => m a -> MaybeT m a -> m a +fromMaybeTM def = maybeTM def return maybeT :: Monad m => b -> (a -> b) -> MaybeT m a -> m b maybeT def f x = liftM (maybe def f) (runMaybeT x)
Language/Haskell/Tools/Refactor/Utils/Monadic.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE FlexibleContexts, MonoLocalBinds, MultiWayIf, TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} -- | Basic utilities and types for defining refactorings. module Language.Haskell.Tools.Refactor.Utils.Monadic where
Language/Haskell/Tools/Refactor/Utils/NameLookup.hs view
@@ -1,26 +1,79 @@+{-# LANGUAGE FlexibleInstances #-} + module Language.Haskell.Tools.Refactor.Utils.NameLookup where -import GHC (GhcMonad) import qualified GHC +import Data.Maybe (maybeToList) + import Control.Reference ((^.)) import Language.Haskell.Tools.AST import Language.Haskell.Tools.Rewrite -import Language.Haskell.Tools.Refactor.Utils.Maybe +import Language.Haskell.Tools.Refactor.Utils.Maybe() -opSemName :: GhcMonad m => Operator -> MaybeT m GHC.Name -opSemName = liftMaybe . semanticsName . (^. operatorName) +instance HasNameInfo' GHC.Name where + semanticsName = Just <$> id -declHeadSemName :: GhcMonad m => DeclHead -> MaybeT m GHC.Name -declHeadSemName (NameDeclHead n) = liftMaybe . semanticsName $ n +instance HasNameInfo' Operator where + semanticsName = opSemName + +instance HasNameInfo' DeclHead where + semanticsName = declHeadSemName + +instance HasNameInfo' InstanceHead where + semanticsName = instHeadSemName + + +opSemName :: Operator -> Maybe GHC.Name +opSemName = semanticsName . (^. operatorName) + +declHeadQName :: DeclHead -> QualifiedName +declHeadQName (NameDeclHead n) = n ^. simpleName +declHeadQName (ParenDeclHead dh) = declHeadQName dh +declHeadQName (DeclHeadApp dh _) = declHeadQName dh +declHeadQName (InfixDeclHead _ op _) = op ^. operatorName + +declHeadSemName :: DeclHead -> Maybe GHC.Name +declHeadSemName (NameDeclHead n) = semanticsName n declHeadSemName (ParenDeclHead dh) = declHeadSemName dh declHeadSemName (DeclHeadApp dh _) = declHeadSemName dh declHeadSemName (InfixDeclHead _ op _) = opSemName op -instHeadSemName :: GhcMonad m => InstanceHead -> MaybeT m GHC.Name -instHeadSemName (InstanceHead n) = liftMaybe . semanticsName $ n +instHeadSemName :: InstanceHead -> Maybe GHC.Name +instHeadSemName (InstanceHead n) = semanticsName n instHeadSemName (InfixInstanceHead _ op) = opSemName op instHeadSemName (ParenInstanceHead ih) = instHeadSemName ih instHeadSemName (AppInstanceHead ih _) = instHeadSemName ih + +-- | Collects the qualified names of the class heads in an assertion. +assertionQNames :: Assertion -> [QualifiedName] +assertionQNames (ClassAssert n _) = [n ^. simpleName] +assertionQNames (InfixAssert _ op _) = [op ^. operatorName] +assertionQNames (ImplicitAssert n _) = [n ^. simpleName] +assertionQNames (TupleAssert xs) = concatMap assertionQNames xs +assertionQNames _ = [] + +-- | Collects the semantic names of the class heads in an assertion. +assertionSemNames :: Assertion -> [GHC.Name] +assertionSemNames (ClassAssert n _) = maybeToList . semanticsName $ n +assertionSemNames (InfixAssert _ op _) = maybeToList . opSemName $ op +assertionSemNames (ImplicitAssert n _) = maybeToList . semanticsName $ n +assertionSemNames (TupleAssert xs) = concatMap assertionSemNames xs +assertionSemNames _ = [] + +-- | Extracts the name of a type. +-- In case of a type application, it finds the type being applied. +-- It works only for unambiguous types, so it won't work for tuples. +nameFromType :: Type -> Maybe Name +nameFromType (TypeApp f _) = nameFromType f +nameFromType (ParenType x) = nameFromType x +nameFromType (ListType t) = nameFromType t +nameFromType (KindedType t _) = nameFromType t +nameFromType (BangType t) = nameFromType t +nameFromType (LazyType t) = nameFromType t +nameFromType (UnpackType t) = nameFromType t +nameFromType (NoUnpackType t) = nameFromType t +nameFromType (VarType x) = Just x +nameFromType _ = Nothing
Language/Haskell/Tools/Refactor/Utils/Type.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleContexts, MonoLocalBinds, RankNTypes, ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Language.Haskell.Tools.Refactor.Utils.Type (typeExpr, appTypeMatches, literalType) where
Language/Haskell/Tools/Refactor/Utils/TypeLookup.hs view
@@ -1,22 +1,32 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Tools.Refactor.Utils.TypeLookup where import qualified TyCoRep as GHC (Type(..), TyThing(..)) -import qualified Kind as GHC (isConstraintKind, typeKind) +import qualified Kind as GHC (isConstraintKind) import qualified ConLike as GHC (ConLike(..)) import qualified DataCon as GHC (dataConUserType, isVanillaDataCon) +import qualified Kind as GHC (isConstraintKind) +import qualified Name as GHC (isTyVarName) import qualified PatSyn as GHC (patSynBuilder) +import qualified TyCon as GHC (isClosedSynFamilyTyConWithAxiom_maybe, isClassTyCon) +import qualified TyCoRep as GHC (Type(..), TyThing(..)) +import qualified Type as GHC (eqType, typeKind) import qualified Var as GHC (varType) +import qualified CoAxiom as GHC import qualified GHC hiding (typeKind) import GHC (GhcMonad) -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.Rewrite -import Language.Haskell.Tools.Refactor.Utils.NameLookup -import Language.Haskell.Tools.Refactor.Utils.Maybe +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.Rewrite as AST +import Language.Haskell.Tools.Refactor.Utils.NameLookup as AST +import Language.Haskell.Tools.Refactor.Utils.Maybe as AST +instance Eq GHC.Type where + (==) = GHC.eqType +type ClosedTyFam = GHC.CoAxiom GHC.Branched + hasConstraintKind :: GHC.Type -> Bool hasConstraintKind = GHC.isConstraintKind . GHC.typeKind @@ -87,14 +97,14 @@ -- NOTE: Returns false if the type is certainly not a newtype -- Returns true if it is a newtype or it could not have been looked up -isNewtype :: GhcMonad m => Type -> m Bool +isNewtype :: GhcMonad m => AST.Type -> m Bool isNewtype t = do tycon <- runMaybeT . lookupType $ t return $! maybe True isNewtypeTyCon tycon -lookupType :: GhcMonad m => Type -> MaybeT m GHC.TyThing +lookupType :: GhcMonad m => AST.Type -> MaybeT m GHC.TyThing lookupType t = do name <- liftMaybe . nameFromType $ t sname <- liftMaybe . semanticsName $ name @@ -110,45 +120,93 @@ GHC.ATyCon tc | GHC.isClassTyCon tc -> liftMaybe . GHC.tyConClass_maybe $ tc _ -> fail "TypeLookup.lookupClassWith: Argument does not contain a class type constructor" +lookupClass :: (GhcMonad m, HasNameInfo' n) => n -> MaybeT m GHC.Class +lookupClass = lookupClassWith (liftMaybe . semanticsName) + lookupClassFromInstance :: GhcMonad m => InstanceHead -> MaybeT m GHC.Class -lookupClassFromInstance = lookupClassWith instHeadSemName +lookupClassFromInstance = lookupClassWith (liftMaybe . instHeadSemName) lookupClassFromDeclHead :: GhcMonad m => DeclHead -> MaybeT m GHC.Class -lookupClassFromDeclHead = lookupClassWith declHeadSemName +lookupClassFromDeclHead = lookupClassWith (liftMaybe . declHeadSemName) -- | Looks up the right-hand side (GHC representation) -- of a Haskell Tools Type corresponding to a type synonym -semanticsTypeSynRhs :: GhcMonad m => Type -> MaybeT m GHC.Type +semanticsTypeSynRhs :: GhcMonad m => AST.Type -> MaybeT m GHC.Type semanticsTypeSynRhs ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeSynRhs -- | Converts a global Haskell Tools type to a GHC type -semanticsType :: GhcMonad m => Type -> MaybeT m GHC.Type +semanticsType :: GhcMonad m => AST.Type -> MaybeT m GHC.Type semanticsType ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeFromGlobalName --- | Extracts the name of a type --- In case of a type application, it finds the type being applied -nameFromType :: Type -> Maybe Name -nameFromType (TypeApp f _) = nameFromType f -nameFromType (ParenType x) = nameFromType x -nameFromType (KindedType t _) = nameFromType t -nameFromType (BangType t) = nameFromType t -nameFromType (LazyType t) = nameFromType t -nameFromType (UnpackType t) = nameFromType t -nameFromType (NoUnpackType t) = nameFromType t -nameFromType (VarType x) = Just x -nameFromType _ = Nothing - isNewtypeTyCon :: GHC.TyThing -> Bool isNewtypeTyCon (GHC.ATyCon tycon) = GHC.isNewTyCon tycon isNewtypeTyCon _ = False --- | Decides whether a given name is a standard Haskell98 data constructor. --- Fails if not given a proper name. -isVanillaDataConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool -isVanillaDataConNameM name = do +-- | Looks up the given name, extracts something out of it. +-- If the extraction is not succesful, it returns False, +-- if it is successful, then checks the result against the predicate. +-- The reasoning behind this, is that the predicate can only be +-- satisfied by a proper name. +satisfies :: (HasNameInfo' n, GhcMonad m) => + (GHC.TyThing -> Maybe a) -> (a -> Bool) -> n -> MaybeT m Bool +satisfies extract pred name = do sname <- liftMaybe . semanticsName $ name tt <- MaybeT . GHC.lookupName $ sname - dc <- liftMaybe . extractDataCon $ tt - return . GHC.isVanillaDataCon $ dc + return $ maybe False pred (extract tt) + +-- | Decides whether a given name is a type family constructor. +-- Fails if the lookup is not successful. +isClassTyConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool +isClassTyConNameM = satisfies extractTyCon GHC.isClassTyCon + where extractTyCon (GHC.ATyCon tc) = Just tc + extractTyCon _ = Nothing + +-- | Decides whether a given name is a standard Haskell98 data constructor. +-- Fails if the lookup is not successful. +isVanillaDataConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool +isVanillaDataConNameM = satisfies extractDataCon GHC.isVanillaDataCon where extractDataCon (GHC.AConLike (GHC.RealDataCon dc)) = Just dc extractDataCon _ = Nothing + +-- | Looks up a closed type family from a name. +lookupClosedTyFam :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m ClosedTyFam +lookupClosedTyFam name = do + sname <- liftMaybe . semanticsName $ name + tt <- MaybeT . GHC.lookupName $ sname + liftMaybe . coAxiomFromTyThing $ tt + +-- | Extract the CoAxioms from a TyThing representing a closed type family. +coAxiomFromTyThing :: GHC.TyThing -> Maybe (GHC.CoAxiom GHC.Branched) +coAxiomFromTyThing (GHC.ATyCon tc) = GHC.isClosedSynFamilyTyConWithAxiom_maybe tc +coAxiomFromTyThing (GHC.ACoAxiom ax) = Just ax +coAxiomFromTyThing _ = Nothing + +-- | Determines whether a Type itself has a type variable head. +hasTyVarHead :: Type -> Bool +hasTyVarHead (ForallType _ t) = hasTyVarHead t +hasTyVarHead (CtxType _ t) = hasTyVarHead t +hasTyVarHead FunctionType{} = False +hasTyVarHead TupleType{} = False +hasTyVarHead UnboxedTupleType{} = False +hasTyVarHead ListType{} = False +hasTyVarHead ParArrayType{} = False +hasTyVarHead (TypeApp f _) = hasTyVarHead f +hasTyVarHead InfixTypeApp{} = False +hasTyVarHead (ParenType t) = hasTyVarHead t +hasTyVarHead (VarType n) = maybe False GHC.isTyVarName (semanticsName n) +hasTyVarHead (KindedType t _) = hasTyVarHead t +hasTyVarHead (BangType t) = hasTyVarHead t +hasTyVarHead (LazyType t) = hasTyVarHead t +hasTyVarHead (UnpackType t) = hasTyVarHead t +hasTyVarHead (NoUnpackType t) = hasTyVarHead t +hasTyVarHead WildcardType{} = False +hasTyVarHead NamedWildcardType{} = False +hasTyVarHead SpliceType{} = False +hasTyVarHead QuasiQuoteType{} = False +hasTyVarHead PromotedIntType{} = False +hasTyVarHead PromotedStringType{} = False +hasTyVarHead PromotedConType{} = False +hasTyVarHead PromotedListType{} = False +hasTyVarHead PromotedTupleType{} = False +hasTyVarHead PromotedUnitType{} = False +hasTyVarHead UnboxedSumType{} = False
haskell-tools-refactor.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-refactor -version: 1.0.1.2 +version: 1.1.0.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 @@ -35,6 +35,7 @@ , Language.Haskell.Tools.Refactor.Representation , Language.Haskell.Tools.Refactor.Utils.AST , Language.Haskell.Tools.Refactor.Utils.BindingElem + , Language.Haskell.Tools.Refactor.Utils.Debug , Language.Haskell.Tools.Refactor.Utils.Extensions , Language.Haskell.Tools.Refactor.Utils.Helpers , Language.Haskell.Tools.Refactor.Utils.Indentation @@ -47,7 +48,7 @@ , Language.Haskell.Tools.Refactor.Utils.TypeLookup , Language.Haskell.Tools.Refactor.Querying - build-depends: base >= 4.10 && < 4.11 + build-depends: base >= 4.11 && < 4.12 , aeson >= 1.0 && < 1.4 , mtl >= 2.2 && < 2.3 , uniplate >= 1.6 && < 1.7 @@ -58,13 +59,13 @@ , references >= 0.3 && < 0.4 , split >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 - , template-haskell >= 2.12 && < 2.13 - , ghc >= 8.2 && < 8.3 + , template-haskell >= 2.13 && < 2.14 + , ghc >= 8.4 && < 8.5 , Cabal >= 2.0 && < 2.3 - , haskell-tools-ast >= 1.0 && < 1.1 - , haskell-tools-backend-ghc >= 1.0 && < 1.1 - , haskell-tools-rewrite >= 1.0 && < 1.1 - , haskell-tools-prettyprint >= 1.0 && < 1.1 + , haskell-tools-ast >= 1.1 && < 1.2 + , haskell-tools-backend-ghc >= 1.1 && < 1.2 + , haskell-tools-rewrite >= 1.1 && < 1.2 + , haskell-tools-prettyprint >= 1.1 && < 1.2 default-language: Haskell2010 test-suite haskell-tools-builtin-refactorings-test @@ -72,7 +73,7 @@ ghc-options: -with-rtsopts=-M2g hs-source-dirs: test main-is: Main.hs - build-depends: base >= 4.10 && < 4.11 + build-depends: base >= 4.11 && < 4.12 , tasty >= 0.11 && < 1.1 , tasty-hunit >= 0.9 && < 0.11 , transformers >= 0.5 && < 0.6 @@ -85,14 +86,14 @@ , references >= 0.3 && < 0.4 , split >= 0.2 && < 0.3 , time >= 1.8 && < 1.9 - , template-haskell >= 2.12 && < 2.13 - , ghc >= 8.2 && < 8.3 + , template-haskell >= 2.13 && < 2.14 + , ghc >= 8.4 && < 8.5 , ghc-paths >= 0.1 && < 0.2 , Cabal >= 2.0 && < 2.3 - , haskell-tools-ast >= 1.0 && < 1.1 - , haskell-tools-backend-ghc >= 1.0 && < 1.1 - , haskell-tools-rewrite >= 1.0 && < 1.1 - , haskell-tools-prettyprint >= 1.0 && < 1.1 + , haskell-tools-ast >= 1.1 && < 1.2 + , haskell-tools-backend-ghc >= 1.1 && < 1.2 + , haskell-tools-rewrite >= 1.1 && < 1.2 + , haskell-tools-prettyprint >= 1.1 && < 1.2 , haskell-tools-refactor -- libraries used by the examples , old-time >= 1.1 && < 1.2
test/Main.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase, MonoLocalBinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} module Main where