HaRe 0.7.2.0 → 0.7.2.1
raw patch · 10 files changed
+493/−62 lines, 10 filesdep ~ghc-mod
Dependency ranges changed: ghc-mod
Files
- ChangeLog +7/−0
- HaRe.cabal +7/−4
- src/Language/Haskell/Refact/API.hs +8/−2
- src/Language/Haskell/Refact/Refactoring/MoveDef.hs +340/−15
- src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +11/−0
- src/Language/Haskell/Refact/Utils/Layout.hs +42/−32
- src/Language/Haskell/Refact/Utils/Monad.hs +2/−0
- src/Language/Haskell/Refact/Utils/TokenUtils.hs +2/−3
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +73/−2
- src/Language/Haskell/Refact/Utils/Utils.hs +1/−4
ChangeLog view
@@ -1,3 +1,10 @@+2014-04-01 v0.7.2.1+ * limit ghc-mod to <= 3.1.7, new version 4.0 does not deal with+ FFI exports. This does not stop ghc-mod >= 4.0 being used in the+ editor, it is just the library linked into ghc-hare+ * Added disclaimer that API is subject to change without notice+ * liftToTopLevel now brings along an updated type signature,+ provided there are no constraints on any of the types 2014-03-23 v0.7.2.0 * Reorganised package structure to have Language.Haskell.Refact.HaRe which provides all the functions
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.7.2.0+Version: 0.7.2.1 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha@@ -52,7 +52,8 @@ , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 3.1.6+ -- , ghc-mod >= 4.0+ , ghc-mod >= 3.1.6 && <= 3.1.7 -- , lens , mtl , old-time@@ -118,7 +119,8 @@ , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 3.1.6+ -- , ghc-mod >= 4.0+ , ghc-mod >= 3.1.6 && <= 3.1.7 -- , lens , mtl , old-time@@ -169,7 +171,8 @@ , ghc-paths == 0.1.* , ghc-prim , ghc-syb-utils- , ghc-mod >= 3.1.6+ -- , ghc-mod >= 4.0+ , ghc-mod >= 3.1.6 && <= 3.1.7 , hspec , mtl , old-time
src/Language/Haskell/Refact/API.hs view
@@ -1,3 +1,6 @@+-- | This module should provide all that is required to write further+-- refactorings.+-- NOTE: it is currently unstable, and may change without notice on minor version number bumps module Language.Haskell.Refact.API ( -- * from `Language.Haskell.Refact.Utils.Monad`@@ -23,7 +26,6 @@ , logm -- * from `Language.Haskell.Refact.Utils.Utils`- , sameOccurrence -- ** Managing the GHC / project environment -- , loadModuleGraphGhc@@ -241,6 +243,8 @@ ,findPNT,findPN,findAllNameOccurences ,findPNs, findEntity, findEntity' ,sameOccurrence+ , findIdForName+ , getTypeForName ,defines, definesP,definesTypeSig -- , isTypeSigOf -- ,HasModName(hasModName), HasNameSpace(hasNameSpace) ,sameBind@@ -283,7 +287,8 @@ ,nameToString {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat {- ,definingDecls -}, definedPNs- ,definingDeclsNames, definingDeclsNames', definingSigsNames+ , definingDeclsNames, definingDeclsNames', definingSigsNames+ , definingTyClDeclsNames , allNames -- ,simplifyDecl @@ -359,6 +364,7 @@ , showGhc , prettyprint , prettyprint2+ , ppType , lexStringToRichTokens , getDataConstructors , setGhcContext
src/Language/Haskell/Refact/Refactoring/MoveDef.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,10 +13,15 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB +-- import qualified DynFlags as GHC import qualified Exception as GHC-import qualified GHC+import qualified FastString as GHC+import qualified GHC as GHC import qualified Name as GHC import qualified Outputable as GHC+import qualified TyCon as GHC+import qualified TypeRep as GHC+import qualified Var as Var import Control.Exception import Control.Monad.State@@ -252,6 +258,8 @@ -} let liftedDecls = definingDeclsNames [n] parent True True declaredPns = nub $ concatMap definedPNs liftedDecls+ liftedSigs = definingSigsNames [n] parent+ mLiftedSigs = listToMaybe liftedSigs -- TODO: what about declarations between this -- one and the top level that are used in this one?@@ -265,12 +273,13 @@ logm $ "liftToMod:(ddd)=" ++ (showGhc dd) -- drawTokenTree "liftToMod.a"+ drawTokenTreeDetailed "liftToMod.a" if pns==[] then do -- TODO: change the order, first move the decls then add params, -- else the liftedDecls get mangled while still in the parent- (parent',liftedDecls',_paramAdded) <- addParamsToParentAndLiftedDecl n dd parent liftedDecls+ (parent',liftedDecls',_mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' -- else liftedDecls' @@ -278,10 +287,10 @@ -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns) -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls') - -- error ("liftToMod:newBinds=" ++ (showGhc (replaceBinds declsr (before++parent'++after)))) -- ++AZ++-- void $ moveDecl1 (replaceBinds renamed (before++parent'++after))- (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent'))))+ let renamed' = replaceBinds renamed (before++parent'++after)+ defName = (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))+ void $ moveDecl1 renamed'+ (Just defName) [GHC.unLoc pn] (Just liftedDecls') declaredPns True -- drawTokenTree "liftToMod.b"@@ -697,8 +706,8 @@ logm $ "MoveDef.worker: pns=" ++ (showGhc pns) if pns==[] then do- (parent',liftedDecls',_paramAdded)<-addParamsToParentAndLiftedDecl n dd- parent liftedDecls+ (parent',liftedDecls',_mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd+ parent liftedDecls Nothing --True means the new decl will be at the same level with its parant. dest' <- moveDecl1 (replaceBinds dest (before++parent'++after)) (Just (ghead "worker" (definedPNs (ghead "worker" parent'))))@@ -735,8 +744,8 @@ logm $ "MoveDef.worker1: pns=" ++ (showGhc pns) if pns==[] then do- (parent',liftedDecls',_paramAdded)- <- addParamsToParentAndLiftedDecl n dd dest liftedDecls+ (parent',liftedDecls',_mLiftedSigs')+ <- addParamsToParentAndLiftedDecl n dd dest liftedDecls Nothing --True means the new decl will be at the same level with its parant. parent'' <- moveDecl1 parent' Nothing [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move@@ -761,15 +770,16 @@ -> [GHC.Name] -- ^Declared names in parent -> t -- ^parent -> [GHC.LHsBind GHC.Name] -- ^decls being lifted- -> RefactGhc (t, [GHC.LHsBind GHC.Name], Bool)-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+ -> Maybe (GHC.LSig GHC.Name) -- ^ lifted decls signature if present+ -> RefactGhc (t, [GHC.LHsBind GHC.Name], Maybe (GHC.LSig GHC.Name))+addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs =do (ef,_) <- hsFreeAndDeclaredPNs parent (lf,_) <- hsFreeAndDeclaredPNs liftedDecls -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent) -- parameters to be added to pn because of lifting- let newParams=((nub lf) \\ (nub ef)) \\ dd+ let newParams= ((nub lf) \\ (nub ef)) \\ dd logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd)) @@ -783,9 +793,324 @@ liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True - return (parent', liftedDecls',True)- else return (parent,liftedDecls,False)+ mLiftedSigs' <- addParamsToSigs newParams mLiftedSigs + logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs'++ return (parent',liftedDecls', mLiftedSigs')+ else return (parent,liftedDecls,mLiftedSigs)++-- ---------------------------------------------------------------------++-- TODO: perhaps move this to TypeUtils+addParamsToSigs :: [GHC.Name] -> Maybe (GHC.LSig GHC.Name) -> RefactGhc (Maybe (GHC.LSig GHC.Name))+addParamsToSigs _ Nothing = return Nothing+addParamsToSigs [] ms = return ms+addParamsToSigs newParams (Just (GHC.L l (GHC.TypeSig lns ltyp@(GHC.L lt _)))) = do+ mts <- mapM getTypeForName newParams+ let ts = catMaybes mts+ -- Note : the '::' symbol lies between the lns and the ltyp. Hence+ -- construct a new location covering this gap, to insert the mew+ -- params. This span has been specifically inserted into the+ -- TokenTree when it is initially loaded.+ let ne = GHC.srcSpanEnd $ GHC.getLoc $ glast "addParamsToSigs" lns+ ls = GHC.srcSpanStart $ lt+ replaceSpan = GHC.mkSrcSpan ne ls+ newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> "+ logm $ "addParamsToSigs:replaceSpan=" ++ showGhc replaceSpan+ logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]"+ newToks <- liftIO $ basicTokenise newStr+ putToksForSpan replaceSpan newToks+ let typ' = foldl addOneType ltyp ts+ sigOk <- isNewSignatureOk ts+ logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr)+ if sigOk+ then return $ Just (GHC.L l (GHC.TypeSig lns typ'))+ else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n"+ where+ addOneType :: GHC.LHsType GHC.Name -> GHC.Type -> GHC.LHsType GHC.Name+ addOneType et t = GHC.noLoc (GHC.HsFunTy (GHC.noLoc hst) et)+ where+ hst = typeToHsType t++addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls)++-- ---------------------------------------------------------------------++printSigComponent :: GHC.Type -> String+printSigComponent x = ppType x++-- ---------------------------------------------------------------------++-- |Fail any signature having a forall in it.+-- TODO: this is unnecesarily restrictive, but needs+-- a) proper reversing of GHC.Type to GHC.LhsType+-- b) some serious reverse type inference to ensure that the+-- constraints are modified properly to merge the old signature+-- part and the new.+isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool+isNewSignatureOk types = do+ -- NOTE: under some circumstances enabling Rank2Types or RankNTypes+ -- can resolve the type conflict, this can potentially be checked+ -- for.+ -- NOTE2: perhaps proceed and reload the tentative refactoring into+ -- the GHC session and accept it only if it type checks+ let+ r = SYB.everythingStaged SYB.TypeChecker (++) []+ ([] `SYB.mkQ` usesForAll) types+ usesForAll (GHC.ForAllTy _ _) = [1::Int]+ usesForAll _ = []++ -- logm $ "isNewSignatureOk:r=" ++ show r+ return $ emptyList r++-- ---------------------------------------------------------------------++-- TODO: perhaps move this to TypeUtils+-- TODO: complete this+typeToHsType :: GHC.Type -> GHC.HsType GHC.Name+typeToHsType (GHC.TyVarTy v) = GHC.HsTyVar (Var.varName v)+typeToHsType (GHC.AppTy t1 t2) = GHC.HsAppTy (GHC.noLoc $ typeToHsType t1)+ (GHC.noLoc $ typeToHsType t2)++typeToHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t++typeToHsType (GHC.FunTy t1 t2) = GHC.HsFunTy (GHC.noLoc $ typeToHsType t1)+ (GHC.noLoc $ typeToHsType t2)+#if __GLASGOW_HASKELL__ > 704+typeToHsType (GHC.ForAllTy v t) = GHC.HsForAllTy GHC.Explicit (GHC.HsQTvs [] []) (GHC.noLoc []) (GHC.noLoc $ typeToHsType t)+#else+typeToHsType (GHC.ForAllTy v t) = GHC.HsForAllTy GHC.Explicit [] (GHC.noLoc []) (GHC.noLoc $ typeToHsType t)+#endif++#if __GLASGOW_HASKELL__ > 704+typeToHsType (GHC.LitTy (GHC.NumTyLit i)) = GHC.HsTyLit (GHC.HsNumTy i)+typeToHsType (GHC.LitTy (GHC.StrTyLit s)) = GHC.HsTyLit (GHC.HsStrTy s)+#endif++{-+data Type+ = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)++ | AppTy -- See Note [AppTy invariant]+ Type+ Type -- ^ Type application to something other than a 'TyCon'. Parameters:+ --+ -- 1) Function: must /not/ be a 'TyConApp',+ -- must be another 'AppTy', or 'TyVarTy'+ --+ -- 2) Argument type++ | TyConApp -- See Note [AppTy invariant]+ TyCon+ [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+ -- Invariant: saturated appliations of 'FunTyCon' must+ -- use 'FunTy' and saturated synonyms must use their own+ -- constructors. However, /unsaturated/ 'FunTyCon's+ -- do appear as 'TyConApp's.+ -- Parameters:+ --+ -- 1) Type constructor being applied to.+ --+ -- 2) Type arguments. Might not have enough type arguments+ -- here to saturate the constructor.+ -- Even type synonyms are not necessarily saturated;+ -- for example unsaturated type synonyms+ -- can appear as the right hand side of a type synonym.++ | FunTy+ Type+ Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@+ -- See Note [Equality-constrained types]++ | ForAllTy+ Var -- Type or kind variable+ Type -- ^ A polymorphic type++ | LitTy TyLit -- ^ Type literals are simillar to type constructors.++-}++tyConAppToHsType :: GHC.Type -> GHC.HsType GHC.Name+tyConAppToHsType t@(GHC.TyConApp tc _ts)+ | GHC.isFunTyCon tc = r "isFunTyCon"+ | GHC.isAlgTyCon tc = r "isAlgTyCon"+ | GHC.isTupleTyCon tc = r "isTupleTyCon"+ | GHC.isSynTyCon tc = r "isSynTyCon"+ | GHC.isPrimTyCon tc = r "isPrimTyCon"+#if __GLASGOW_HASKELL__ > 704+ | GHC.isPromotedDataCon tc = r "isPromotedDataTyCon"+ | GHC.isPromotedTyCon tc = r "isPromotedTyCon"+#endif+ where++#if __GLASGOW_HASKELL__ > 704+ r str = GHC.HsTyLit (GHC.HsStrTy $ GHC.mkFastString str)+#else+ r str = error $ "tyConAppToHsType: " ++ str ++ " unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t)+#endif++tyConAppToHsType t@(GHC.TyConApp _tc _ts)+ = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t)++{-+HsType+HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name)+HsTyVar name+HsAppTy (LHsType name) (LHsType name)+HsFunTy (LHsType name) (LHsType name)+HsListTy (LHsType name)+HsPArrTy (LHsType name)+HsTupleTy HsTupleSort [LHsType name]+HsOpTy (LHsType name) (LHsTyOp name) (LHsType name)+HsParTy (LHsType name)+HsIParamTy HsIPName (LHsType name)+HsEqTy (LHsType name) (LHsType name)+HsKindSig (LHsType name) (LHsKind name)+HsQuasiQuoteTy (HsQuasiQuote name)+HsSpliceTy (HsSplice name) FreeVars PostTcKind+HsDocTy (LHsType name) LHsDocString+HsBangTy HsBang (LHsType name)+HsRecTy [ConDeclField name]+HsCoreTy Type+HsExplicitListTy PostTcKind [LHsType name]+HsExplicitTupleTy [PostTcKind] [LHsType name]+HsTyLit HsTyLit+HsWrapTy HsTyWrapper (HsType name)+-}+++++{-+ = -- | The function type constructor, @(->)@+ FunTyCon {+ tyConUnique :: Unique,+ tyConName :: Name,+ tc_kind :: Kind,+ tyConArity :: Arity+ }++ -- | Algebraic type constructors, which are defined to be those+ -- arising @data@ type and @newtype@ declarations. All these+ -- constructors are lifted and boxed. See 'AlgTyConRhs' for more+ -- information.+ | AlgTyCon {+ tyConUnique :: Unique,+ tyConName :: Name,+ tc_kind :: Kind,+ tyConArity :: Arity,++ tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor.+ -- Invariant: length tyvars = arity+ -- Precisely, this list scopes over:+ --+ -- 1. The 'algTcStupidTheta'+ -- 2. The cached types in 'algTyConRhs.NewTyCon'+ -- 3. The family instance types if present+ --+ -- Note that it does /not/ scope over the data constructors.+ tyConCType :: Maybe CType, -- The C type that should be used+ -- for this type when using the FFI+ -- and CAPI++ algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax?+ -- If so, that doesn't mean it's a true GADT;+ -- only that the "where" form was used.+ -- This field is used only to guide pretty-printing++ algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type+ -- (always empty for GADTs).+ -- A \"stupid theta\" is the context to the left+ -- of an algebraic type declaration,+ -- e.g. @Eq a@ in the declaration+ -- @data Eq a => T a ...@.++ algTcRhs :: AlgTyConRhs, -- ^ Contains information about the+ -- data constructors of the algebraic type++ algTcRec :: RecFlag, -- ^ Tells us whether the data type is part+ -- of a mutually-recursive group or not++ algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon'+ -- for derived 'TyCon's representing class+ -- or family instances, respectively.+ -- See also 'synTcParent'+ }++ -- | Represents the infinite family of tuple type constructors,+ -- @()@, @(a,b)@, @(# a, b #)@ etc.+ | TupleTyCon {+ tyConUnique :: Unique,+ tyConName :: Name,+ tc_kind :: Kind,+ tyConArity :: Arity,+ tyConTupleSort :: TupleSort,+ tyConTyVars :: [TyVar],+ dataCon :: DataCon -- ^ Corresponding tuple data constructor+ }++ -- | Represents type synonyms+ | SynTyCon {+ tyConUnique :: Unique,+ tyConName :: Name,+ tc_kind :: Kind,+ tyConArity :: Arity,++ tyConTyVars :: [TyVar], -- Bound tyvars++ synTcRhs :: SynTyConRhs, -- ^ Contains information about the+ -- expansion of the synonym++ synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon'+ -- of 'TyCon's representing family instances++ }++ -- | Primitive types; cannot be defined in Haskell. This includes+ -- the usual suspects (such as @Int#@) as well as foreign-imported+ -- types and kinds+ | PrimTyCon {+ tyConUnique :: Unique,+ tyConName :: Name,+ tc_kind :: Kind,+ tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance+ -- of the arity of a primtycon is!++ primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are+ -- boxed (represented by pointers). This 'PrimRep'+ -- holds that information.+ -- Only relevant if tc_kind = *++ isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted+ -- (may not contain bottom)+ -- but foreign-imported ones may be lifted++ tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types,+ -- holds the name of the imported thing+ }++ -- | Represents promoted data constructor.+ | PromotedDataCon { -- See Note [Promoted data constructors]+ tyConUnique :: Unique, -- ^ Same Unique as the data constructor+ tyConName :: Name, -- ^ Same Name as the data constructor+ tyConArity :: Arity,+ tc_kind :: Kind, -- ^ Translated type of the data constructor+ dataCon :: DataCon -- ^ Corresponding data constructor+ }++ -- | Represents promoted type constructor.+ | PromotedTyCon {+ tyConUnique :: Unique, -- ^ Same Unique as the type constructor+ tyConName :: Name, -- ^ Same Name as the type constructor+ tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times+ tc_kind :: Kind, -- ^ Always TysPrim.superKind+ ty_con :: TyCon -- ^ Corresponding type constructor+ }++ deriving Typeable++-} --------------------------------End of Lifting-----------------------------------------
src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs view
@@ -7,6 +7,7 @@ showGhc , prettyprint , prettyprint2+ , ppType , lexStringToRichTokens , getDataConstructors , setGhcContext@@ -51,6 +52,16 @@ #else prettyprint2 x = GHC.renderWithStyle (GHC.ppr x) (GHC.cmdlineParserStyle) #endif++-- ---------------------------------------------------------------------++ppType :: GHC.Type -> String+#if __GLASGOW_HASKELL__ > 704+ppType x = GHC.renderWithStyle GHC.tracingDynFlags (GHC.pprParendType x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay)+#else+ppType x = GHC.renderWithStyle (GHC.pprParendType x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay)+#endif+ -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/Layout.hs view
@@ -1305,13 +1305,23 @@ allocSig :: GHC.LSig GHC.RdrName -> [PosToken] -> [LayoutTree] allocSig (GHC.L l (GHC.TypeSig names t@(GHC.L lt _))) toks = r where+ -- TODO: make sure a grouped span completely covers the gap+ -- between the names and the type, so it can be replaced later (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,nameToks,toks'') = splitToksForList names bindToks (s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks'' nameLayout = allocList names nameToks allocLocated typeLayout = allocType t typeToks- r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ nameLayout ++ (makeLeafFromToks s3) ++ typeLayout+ -- The nameLayout cannot have leading and/or trailing comment Nodes, based on the way the tokens are split.+ nsub = ghead "allocSig.1" nameLayout+ tsub = ghead "allocSig.2" typeLayout+ (_,ne) = treeStartEnd nsub+ (tb,_) = treeStartEnd tsub+ gap = (ne,tb)+ gapLayout = [Node (Entry gap NoChange []) (makeLeafFromToks s3)]+ r = [makeGroup (strip $ (makeLeafFromToks s1)+ ++ (makeLeafFromToks s2)+ ++ nameLayout ++ gapLayout ++ typeLayout ++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks'))] allocSig (GHC.L l (GHC.GenericSig names t@(GHC.L lt _))) toks = r where@@ -1403,9 +1413,9 @@ ctxLayout = allocHsContext ctx ctxToks typLayout = allocType typ toks3 - r = strip $ (makeLeafFromToks s1) ++ varsLayout+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ varsLayout ++ (makeLeafFromToks s2) ++ ctxLayout- ++ typLayout ++ (makeLeafFromToks toks')+ ++ typLayout ++ (makeLeafFromToks toks')] allocType n@(GHC.L _l (GHC.HsTyVar _) ) toks = allocLocated n toks allocType (GHC.L l (GHC.HsAppTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r where@@ -1413,36 +1423,36 @@ (s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks t1Layout = allocType t1 t1Toks t2Layout = allocType t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsFunTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks t1Layout = allocType t1 t1Toks t2Layout = allocType t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsListTy t1@(GHC.L l1 _)) ) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks t1Layout = allocType t1 t1Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsPArrTy t1@(GHC.L l1 _)) ) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks t1Layout = allocType t1 t1Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsTupleTy _sort types)) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks typesLayout = allocList types typeToks allocType- r = strip $ (makeLeafFromToks s1)- ++ typesLayout ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1)+ ++ typesLayout ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsOpTy t1@(GHC.L l1 _) _op t2@(GHC.L l2 _))) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks@@ -1451,20 +1461,20 @@ t1Layout = allocType t1 t1Toks -- opLayout = allocLocated op opToks t2Layout = allocType t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ t1Layout -- ++ (makeLeafFromToks s3) {- ++ opLayout -} ++ (makeLeafFromToks s4) ++ t2Layout ++ (makeLeafFromToks toks4)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks')] allocType n@(GHC.L _l (GHC.HsParTy _) ) toks = allocLocated n toks allocType (GHC.L l (GHC.HsIParamTy _ typ@(GHC.L lt _)) ) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1 typLayout = allocType typ typToks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ typLayout ++ (makeLeafFromToks toks2)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsEqTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks@@ -1472,10 +1482,10 @@ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2 t1Layout = allocType t1 t1Toks t2Layout = allocType t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ t1Layout ++ (makeLeafFromToks s3) ++ t2Layout ++ (makeLeafFromToks toks3)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsKindSig t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks@@ -1483,25 +1493,25 @@ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2 t1Layout = allocType t1 t1Toks t2Layout = allocType t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ t1Layout ++ (makeLeafFromToks s3) ++ t2Layout ++ (makeLeafFromToks toks3)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote _n _lq _)) ) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks quoteLayout = makeLeafFromToks toks1- r = strip $ (makeLeafFromToks s1)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ quoteLayout- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks') ] allocType (GHC.L l (GHC.HsSpliceTy (GHC.HsSplice _n e@(GHC.L le _)) _fv _k) ) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,eToks,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1 eLayout = allocExpr e eToks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ eLayout ++ (makeLeafFromToks toks2)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks') ] allocType (GHC.L l (GHC.HsDocTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r where (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks@@ -1509,25 +1519,25 @@ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2 t1Layout = allocType t1 t1Toks t2Layout = allocLocated t2 t2Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) ++ t1Layout ++ (makeLeafFromToks s3) ++ t2Layout ++ (makeLeafFromToks toks3)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsBangTy _ t1@(GHC.L l1 _)) ) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks t1Layout = allocType t1 t1Toks- r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)- ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] allocType (GHC.L l (GHC.HsRecTy decls) ) toks = r where (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks (declsLayout,toks1) = allocConDeclFieldList decls typeToks- r = strip $ (makeLeafFromToks s1)+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ declsLayout ++ (makeLeafFromToks toks1)- ++ (makeLeafFromToks toks')+ ++ (makeLeafFromToks toks') ] allocType n@(GHC.L _l (GHC.HsCoreTy _) ) toks = allocLocated n toks allocType (GHC.L _l (GHC.HsExplicitListTy _ ts) ) toks = allocList ts toks allocType allocType (GHC.L _l (GHC.HsExplicitTupleTy _ ts) ) toks = allocList ts toks allocType
src/Language/Haskell/Refact/Utils/Monad.hs view
@@ -236,6 +236,8 @@ getCabalAllTargets cradle cabal = do currentDir <- getCurrentDirectory let cabalDir = gfromJust "getCabalAllTargets" (cradleCabalDir cradle)+ -- let cabalDir = cradleRootDir cradle+ setCurrentDirectory cabalDir (libs,exes,tests,benches) <- liftIO $ cabalAllTargets cabal
src/Language/Haskell/Refact/Utils/TokenUtils.hs view
@@ -14,7 +14,7 @@ module Language.Haskell.Refact.Utils.TokenUtils( -- * Creating- initTokenCache+ initTokenCache , initTokenCacheLayout , mkTreeFromTokens , mkTreeFromSpanTokens@@ -87,7 +87,6 @@ , containsStart, containsMiddle, containsEnd , doSplitTree, splitSubtree, splitSubToks , nonCommentSpan- -- , lookupSrcSpan , invariantOk , invariant , showForest@@ -121,7 +120,7 @@ , insertLenChangedInSrcSpan , insertVersionsInSrcSpan , srcSpanToForestSpan- , nullSpan,nullPos+ , nullSpan, nullPos , simpPosToForestSpan , srcPosToSimpPos , showForestSpan
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -67,6 +67,8 @@ ,usedWithoutQualR {- ,canBeQualified, hasFreeVars -},isUsedInRhs ,findPNT,findPN,findAllNameOccurences ,findPNs, findEntity, findEntity'+ , findIdForName+ , getTypeForName ,sameOccurrence ,defines, definesP,definesTypeSig -- , isTypeSigOf -- ,HasModName(hasModName), HasNameSpace(hasNameSpace)@@ -80,7 +82,7 @@ , getModule -- ** Locations- ,defineLoc, useLoc, locToExp -- , getStartEndLoc+ ,defineLoc, useLoc, locToExp ,locToName, locToRdrName ,getName @@ -110,7 +112,8 @@ ,nameToString {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat {- ,definingDecls -}, definedPNs- ,definingDeclsNames, definingDeclsNames', definingSigsNames+ , definingDeclsNames, definingDeclsNames', definingSigsNames+ , definingTyClDeclsNames , allNames -- ,simplifyDecl @@ -168,6 +171,7 @@ import qualified SrcLoc as GHC import qualified UniqSet as GHC import qualified Unique as GHC+import qualified Var as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB@@ -2493,6 +2497,50 @@ -- --------------------------------------------------------------------- +-- |Find those declarations which define the specified GHC.Names.+definingTyClDeclsNames:: (SYB.Data t)+ => [GHC.Name] -- ^ The specified identifiers.+ -> t -- ^ A collection of declarations.+ ->[GHC.LTyClDecl GHC.Name] -- ^ The result.+definingTyClDeclsNames pns t = defining t+ where+ defining decl+ = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl+ where+ defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name]+ defines' decl'@(GHC.L _ (GHC.ForeignType (GHC.L _ pname) _ ))+ |isJust (find (==(pname)) pns) = [decl']++ -- NOTE: GHC 7.4.2 returns family instances as TyData, GHC 7.6.3+ -- returns them as a separate FamInstDecl++ defines' decl'@(GHC.L _ (GHC.TyFamily _ (GHC.L _ pname) _ _))+ |isJust (find (==(pname)) pns) = [decl']++#if __GLASGOW_HASKELL__ > 704+ defines' decl'@(GHC.L _ (GHC.TyDecl (GHC.L _ pname) _ _ _))+#else+ defines' decl'@(GHC.L _ (GHC.TyData _ _ (GHC.L _ pname) _ _ _ __ _))+#endif+ |isJust (find (==(pname)) pns) = [decl']++#if __GLASGOW_HASKELL__ > 704+#else+ defines' decl'@(GHC.L _ (GHC.TySynonym (GHC.L _ pname) _ _ _))+ |isJust (find (==(pname)) pns) = [decl']+#endif++#if __GLASGOW_HASKELL__ > 704+ defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _))+#else+ defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _))+#endif+ |isJust (find (==(pname)) pns) = [decl']++ defines' _ = []++-- ---------------------------------------------------------------------+ -- TODO: AZ: pretty sure this can be simplified, depends if we need to -- manage transformed stuff too though. @@ -4353,6 +4401,29 @@ worker (n::GHC.Name) | elem (GHC.nameUnique n) uns = Just True worker _ = Nothing++-- | Return the type checked `GHC.Id` corresponding to the given+-- `GHC.Name`++-- TODO: there has to be a simpler way, using the appropriate GHC internals+findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id)+findIdForName n = do+ tm <- getTypecheckedModule+ let t = GHC.tm_typechecked_source tm+ let r = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t+ worker (i::GHC.Id)+ | (GHC.nameUnique n) == (GHC.varUnique i) = Just i+ worker _ = Nothing+ return r++-- ---------------------------------------------------------------------++getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type)+getTypeForName n = do+ mId <- findIdForName n+ case mId of+ Nothing -> return Nothing+ Just i -> return $ Just (GHC.varType i) -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/Utils.hs view
@@ -7,11 +7,8 @@ module Language.Haskell.Refact.Utils.Utils (- sameOccurrence- -- * Managing the GHC / project environment- -- , loadModuleGraphGhc- , getModuleGhc+ getModuleGhc , parseSourceFileGhc , activateModule , getModuleDetails