diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -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 diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -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----------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs --- a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +++ b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs @@ -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 + -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Layout.hs b/src/Language/Haskell/Refact/Utils/Layout.hs --- a/src/Language/Haskell/Refact/Utils/Layout.hs +++ b/src/Language/Haskell/Refact/Utils/Layout.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/Monad.hs b/src/Language/Haskell/Refact/Utils/Monad.hs --- a/src/Language/Haskell/Refact/Utils/Monad.hs +++ b/src/Language/Haskell/Refact/Utils/Monad.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/TokenUtils.hs b/src/Language/Haskell/Refact/Utils/TokenUtils.hs --- a/src/Language/Haskell/Refact/Utils/TokenUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TokenUtils.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -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) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -7,11 +7,8 @@ module Language.Haskell.Refact.Utils.Utils ( - sameOccurrence - -- * Managing the GHC / project environment - -- , loadModuleGraphGhc - , getModuleGhc + getModuleGhc , parseSourceFileGhc , activateModule , getModuleDetails