diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2014-07-16 v0.7.2.5 + Fix incompatibility with haskell-token-utils 0.0.0.3, closing + issue #14 2014-07-03 v0.7.2.4 Re-architect to split out haskell-token-utils as a separate package, usable with haskell-src-exts too diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.2.4 +Version: 0.7.2.5 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -41,7 +41,7 @@ extra-source-files: ChangeLog Library - Build-Depends: base >= 4.0 && < 4.7 + Build-Depends: base >= 4.0 && < 4.8 , containers , directory @@ -66,7 +66,7 @@ , Strafunski-StrategyLib , syz - , haskell-token-utils + , haskell-token-utils >= 0.0.0.3 GHC-Options: -Wall @@ -80,6 +80,7 @@ , Language.Haskell.Refact.Refactoring.MoveDef , Language.Haskell.Refact.Refactoring.Renaming , Language.Haskell.Refact.Refactoring.SwapArgs + , Language.Haskell.Refact.Utils.Binds , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph , Language.Haskell.Refact.Utils.GhcUtils @@ -88,7 +89,6 @@ , Language.Haskell.Refact.Utils.Monad , Language.Haskell.Refact.Utils.MonadFunctions , Language.Haskell.Refact.Utils.TokenUtils - , Language.Haskell.Refact.Utils.TokenUtilsTypes , Language.Haskell.Refact.Utils.TypeSyn , Language.Haskell.Refact.Utils.TypeUtils , Language.Haskell.Refact.Utils.Utils @@ -104,7 +104,7 @@ -- GHC-Options: -prof -fprof-auto -rtsopts -caf-all Hs-Source-Dirs: ./src - Build-Depends: base >= 4.0 && < 4.7 + Build-Depends: base >= 4.0 && < 4.8 , array , containers , directory @@ -152,7 +152,7 @@ -- src test build-depends: - base >= 4.0 && < 4.7 + base >= 4.0 && < 4.8 , Diff >= 0.3.0 -- , HUnit == 1.2.* , HUnit @@ -194,7 +194,7 @@ -- type: exitcode-stdio-1.0 -- ghc-options: -threaded -- main-is: doctests.hs --- build-depends: base >= 4.0 && < 4.7 +-- build-depends: base >= 4.0 && < 4.8 -- , doctest >= 0.8 -- , ghc-mod -- Hs-Source-Dirs: 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 @@ -72,12 +72,12 @@ , putToksForSpan , putDeclToksForSpan , getToksForSpan - , getToksForSpanNoInv - , getToksForSpanWithIntros + -- , getToksForSpanNoInv + -- , getToksForSpanWithIntros , getToksBeforeSpan , putToksForPos - , putToksAfterSpan - , putToksAfterPos + , addToksAfterSpan + , addToksAfterPos , putDeclToksAfterSpan , removeToksForSpan , removeToksForPos @@ -312,7 +312,7 @@ , getParsedForRenamedLocated -- , allPNT -- , allPNTLens - , newNameTok + -- , newNameTok , stripLeadingSpaces -- , lookupNameGhc @@ -375,6 +375,7 @@ , ghcSrcSpanToForestSpan ) where +import Language.Haskell.Refact.Utils.Binds import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils diff --git a/src/Language/Haskell/Refact/Utils/Binds.hs b/src/Language/Haskell/Refact/Utils/Binds.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Binds.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-------------------------------------------------------------------------------- +-- Module : TypeUtils + +-- Maintainer : refactor-fp\@kent.ac.uk +-- | +-- +-- This module contains a collection of program analysis and +-- transformation functions (the API) that work over the Type +-- Decorated AST. Most of the functions defined in the module are +-- taken directly from the API, but in some cases are modified to work +-- with the type decorated AST. +-- +-- In particular some new functions have been added to make type +-- decorated AST traversals easier. +-- +-- In HaRe, in order to preserve the comments and layout of refactored +-- programs, a refactoring modifies not only the AST but also the +-- token stream, and the program source after the refactoring is +-- extracted from the token stream rather than the AST, for the +-- comments and layout information is kept in the token steam instead +-- of the AST. As a consequence, a program transformation function +-- from this API modifies both the AST and the token stream (unless +-- explicitly stated). So when you build your own program +-- transformations, try to use the API to do the transformation, as +-- this can liberate you from caring about the token stream. +-- +-- This type decorated API is still in development. Any suggestions +-- and comments are very much welcome. + + +-------------------------------------------------------------------------------- +module Language.Haskell.Refact.Utils.Binds + ( + hsBinds + , replaceBinds + , getValBindSigs + , emptyValBinds + -- , unionBinds + , HsValBinds(..) + ) where + +-- import Control.Monad.IO.Class () +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.TokenUtils.Utils + +-- Modules from GHC +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified GHC as GHC + +import qualified Data.Generics as SYB + +-- --------------------------------------------------------------------- + +getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name] +getValBindSigs binds = case binds of + GHC.ValBindsIn _ sigs -> sigs + GHC.ValBindsOut _ sigs -> sigs + +emptyValBinds :: GHC.HsValBinds GHC.Name +emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) [] + +unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name +unionBinds [] = emptyValBinds +unionBinds [x] = x +unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs) + where + mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name + mergeBinds (GHC.ValBindsIn b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsIn (GHC.unionBags b1 b2) (s1++s2)) + mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2)) + mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 + mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2)) + +-- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after + +hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] +hsBinds t = case hsValBinds t of + GHC.ValBindsIn binds _sigs -> GHC.bagToList binds + GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs + +replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t +-- replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) []) +replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs) + where + sigs = case hsValBinds t of + GHC.ValBindsIn _ s -> s + GHC.ValBindsOut _ s -> s + +-- This class replaces the HsDecls one +class (SYB.Data t) => HsValBinds t where + + -- | Return the binds that are directly enclosed in the + -- given syntax phrase. + -- hsValBinds :: t -> [GHC.LHsBind GHC.Name] + hsValBinds :: t -> GHC.HsValBinds GHC.Name + + -- | Replace the directly enclosed bind list by the given + -- bind list. Note: This function does not modify the + -- token stream. + -- replaceBinds :: t -> [GHC.LHsBind GHC.Name] -> t + replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t + + -- | Return True if the specified identifier is declared in the + -- given syntax phrase. + -- isDeclaredIn :: GHC.Name -> t -> Bool + + -- | Return the type class definitions that are directly enclosed + -- in the given syntax phrase. Note: only makes sense for + -- GHC.RenamedSource + hsTyDecls :: t -> [[GHC.LTyClDecl GHC.Name]] + + +instance HsValBinds (GHC.RenamedSource) where + hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) + + replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs) + where + grp' = grp {GHC.hs_valds = binds} + + hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp) + + +instance HsValBinds (GHC.HsValBinds GHC.Name) where + hsValBinds vb = vb + replaceValBinds _old new = new + hsTyDecls _ = [] + +instance HsValBinds (GHC.HsGroup GHC.Name) where + hsValBinds grp = (GHC.hs_valds grp) + + replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds + = (GHC.HsGroup b' t i d f de fo w a r v doc) + where b' = replaceValBinds b binds + + hsTyDecls _ = [] + +instance HsValBinds (GHC.HsLocalBinds GHC.Name) where + hsValBinds lb = case lb of + GHC.HsValBinds b -> b + GHC.HsIPBinds _ -> emptyValBinds + GHC.EmptyLocalBinds -> emptyValBinds + + replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new) + replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds" + replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new) + + hsTyDecls _ = [] + +instance HsValBinds (GHC.GRHSs GHC.Name) where + hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb + + replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new)) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.MatchGroup GHC.Name) where + hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches + + replaceValBinds (GHC.MatchGroup matches a) newBinds + = (GHC.MatchGroup (replaceValBinds matches newBinds) a) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LMatch GHC.Name] where + hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms + + replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]" + replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LMatch GHC.Name) where + hsValBinds m = hsValBinds $ GHC.unLoc m + + replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds)) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + + +instance HsValBinds (GHC.Match GHC.Name) where + hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs + + replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds + = (GHC.Match p t (GHC.GRHSs rhs binds')) + where + binds' = (GHC.HsValBinds newBinds) + + hsTyDecls _ = [] + +instance HsValBinds (GHC.HsBind GHC.Name) where + hsValBinds (GHC.PatBind _p rhs _typ _fvs _) = hsValBinds rhs + + -- TODO: ++AZ++ added for compatibility with hsDecls. + hsValBinds (GHC.FunBind _ _ matches _ _ _) = hsValBinds matches + hsValBinds other = error $ "hsValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc other) + + replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds + = (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt) + where + binds' = (GHC.HsValBinds newBinds) + replaceValBinds x _newBinds + = error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x) + + hsTyDecls _ = [] + +instance HsValBinds (GHC.HsExpr GHC.Name) where + hsValBinds (GHC.HsLet ds _) = hsValBinds ds + hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x + + replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex) + replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old) + + hsTyDecls _ = [] + +instance HsValBinds (GHC.Stmt GHC.Name) where + hsValBinds (GHC.LetStmt ds) = hsValBinds ds + hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other) + replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new)) + replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LHsBinds GHC.Name) where + hsValBinds binds = hsValBinds $ GHC.bagToList binds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LHsBind GHC.Name) where + hsValBinds (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsValBinds matches + hsValBinds (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsValBinds rhs + hsValBinds (GHC.L _ (GHC.VarBind _ rhs _)) = hsValBinds rhs + hsValBinds (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsValBinds binds + + + replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds + = (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e)) + replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds + = (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d)) + replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds + = (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b)) + replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds + = (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds))) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds ([GHC.LHsBind GHC.Name]) where + -- hsValBinds xs = concatMap hsValBinds xs -- As in original + hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) [] + + replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b + replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds + + -- replaceValBinds old new = error ("replaceValBinds (old,new)=" ++ (showGhc (old,new))) + + hsTyDecls _ = [] + +instance HsValBinds (GHC.LHsExpr GHC.Name) where + hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds + hsValBinds _ = emptyValBinds + + replaceValBinds (GHC.L l (GHC.HsLet binds ex)) newBinds + = (GHC.L l (GHC.HsLet (replaceValBinds binds newBinds) ex)) + replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old) + + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LGRHS GHC.Name] where + hsValBinds xs = unionBinds $ map hsValBinds xs + replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LGRHS GHC.Name) where + hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts + replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LStmt GHC.Name] where + hsValBinds xs = unionBinds $ map hsValBinds xs + replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LStmt GHC.Name) where + hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LPat GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LPat GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.SyntaxExpr GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LTyClDecl GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LTyClDecl GHC.Name) where + hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths" + replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LInstDecl GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LInstDecl GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LHsType GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds [GHC.LSig GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.LSig GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 704 +instance HsValBinds [GHC.LFamInstDecl GHC.Name] where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old) + hsTyDecls _ = [] +#endif + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 704 +instance HsValBinds (GHC.LFamInstDecl GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] +#endif + +-- --------------------------------------------------------------------- + +instance HsValBinds (GHC.HsIPBinds GHC.Name) where + hsValBinds _ = emptyValBinds + replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old) + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/LocUtils.hs b/src/Language/Haskell/Refact/Utils/LocUtils.hs --- a/src/Language/Haskell/Refact/Utils/LocUtils.hs +++ b/src/Language/Haskell/Refact/Utils/LocUtils.hs @@ -33,7 +33,8 @@ , lengthOfLastLine , getToks -- , replaceToks,replaceTok - ,replaceTokNoReAlign,deleteToks,doRmWhites -- ,doAddWhites + -- ,replaceTokNoReAlign + ,deleteToks,doRmWhites -- ,doAddWhites , srcLocs , getSrcSpan, getAllSrcLocs -- , ghcSrcLocs -- Test version @@ -98,7 +99,7 @@ , mkZeroToken , markToken , isMarked - , matchTokenPos + -- , matchTokenPos , rmOffsetFromToks ) where @@ -381,7 +382,7 @@ -- error $ "getToks:startPos=" ++ (show startPos) ++ ",endPos=" ++ (show endPos) ++ ",toks21=" ++ (showToks toks21) -- ++AZ++ debug -- --------------------------------------------------------------------- - +{- -- |Replace a single token in the token stream by a new token, without -- adjusting the layout. -- Note1: does not re-align, else other later replacements may fail. @@ -396,13 +397,13 @@ oldTok = if (emptyList toks2) then newTok else (ghead "replaceTokNoReAlign" toks2) -- newTok' = markToken $ matchTokenPos oldTok newTok newTok' = matchTokenPos oldTok newTok - +-} -- --------------------------------------------------------------------- - +{- -- |Transfer the location information from the first param to the second matchTokenPos :: PosToken -> PosToken -> PosToken matchTokenPos (GHC.L l _,_) (GHC.L _ t,s) = (GHC.L l t,s) - +-} -- --------------------------------------------------------------------- -- | Get the start of the line before the pos, 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 @@ -225,11 +225,12 @@ -- graph <- gets rsGraph -- liftIO $ warningM "HaRe" $ "initGhcSession:graph=" ++ show graph return () +{- where options opt | rsetExpandSplice opt = "-w:" : rsetGhcOpts opt | otherwise = "-Wall" : rsetGhcOpts opt - +-} -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -11,12 +11,9 @@ ( -- * Conveniences for state access - -- fetchToksFinal - -- , fetchPprFinal fetchLinesFinal , fetchOrigToks , fetchToks -- Deprecated - -- , putToks -- ^Deprecated, destroys token tree , getTypecheckedModule , getRefactStreamModified , getRefactInscopes @@ -32,12 +29,11 @@ , putToksForSpan , putDeclToksForSpan , getToksForSpan - , getToksForSpanNoInv - , getToksForSpanWithIntros + -- , getToksForSpanWithIntros , getToksBeforeSpan , putToksForPos - , putToksAfterSpan - , putToksAfterPos + , addToksAfterSpan + , addToksAfterPos , putDeclToksAfterSpan , removeToksForSpan , removeToksForPos @@ -107,17 +103,6 @@ logm $ "fetchToks (not showing toks" return toks -{- --- |fetch the final tokens -fetchToksFinal :: RefactGhc [PosToken] -fetchToksFinal = do - Just tm <- gets rsModule - let toks = retrieveTokensFinal $ (tkCache $ rsTokenCache tm) Map.! mainTid - -- logm $ "fetchToks" ++ (showToks toks) - logm $ "fetchToksFinal (not showing toks)" - return toks --} - -- |fetch the final tokens in Ppr format fetchLinesFinal :: RefactGhc [Line PosToken] fetchLinesFinal = do @@ -139,56 +124,19 @@ st <- get let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st let Just tm = rsModule st - let forest = getTreeFromCache sspan (rsTokenCache tm) - -- let (forest',toks) = getTokensFor checkInv forest sspan - let (forest',toks) = getTokensForNoIntros checkInv forest (ss2s sspan) - let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm - let rsModule' = Just (tm {rsTokenCache = tk'}) - put $ st { rsModule = rsModule' } - logm $ "getToksForSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) - return toks - --- |Get the current tokens for a given GHC.SrcSpan, without checking --- the invariant. --- TODO: this should not be necessary -getToksForSpanNoInv :: GHC.SrcSpan -> RefactGhc [PosToken] -getToksForSpanNoInv sspan = do - st <- get - let checkInv = False - let Just tm = rsModule st - let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensFor checkInv forest (ss2s sspan) - -- let (forest',toks) = getTokensForNoIntros checkInv forest sspan - let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm + let (tk',toks) = getTokensNoIntrosFromCache checkInv (rsTokenCache tm) (gs2ss sspan) let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } logm $ "getToksForSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) return toks --- |Get the current tokens for a given GHC.SrcSpan, leaving out any --- leading 'then', 'else', 'of', 'do' or 'in' tokens -getToksForSpanWithIntros :: GHC.SrcSpan -> RefactGhc [PosToken] -getToksForSpanWithIntros sspan = do - st <- get - let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st - let Just tm = rsModule st - let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensFor checkInv forest (ss2s sspan) - let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm - let rsModule' = Just (tm {rsTokenCache = tk'}) - put $ st { rsModule = rsModule' } - logm $ "getToksForSpanNoIntros " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) - return toks - -- |Get the current tokens preceding a given GHC.SrcSpan. getToksBeforeSpan :: GHC.SrcSpan -> RefactGhc (ReversedToks PosToken) getToksBeforeSpan sspan = do st <- get let Just tm = rsModule st - let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensBefore forest (ss2s sspan) - let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm + let (tk', toks) = getTokensBeforeFromCache (rsTokenCache tm) (gs2ss sspan) let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } logm $ "getToksBeforeSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) @@ -202,7 +150,7 @@ st <- get let Just tm = rsModule st - let tk' = replaceTokenInCache (rsTokenCache tm) (ss2s sspan) tok + let tk' = replaceTokenInCache (rsTokenCache tm) (gs2ss sspan) tok let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } return () @@ -215,10 +163,10 @@ st <- get let Just tm = rsModule st - let (tk',newSpan) = putToksInCache (rsTokenCache tm) (ss2s sspan) toks + let (tk',newSpan) = putToksInCache (rsTokenCache tm) (gs2ss sspan) toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } - return (s2ss newSpan) + return (ss2gs newSpan) -- |Replace the tokens for a given GHC.SrcSpan, return new GHC.SrcSpan -- delimiting new tokens, and update the AST fragment to reflect it @@ -240,42 +188,36 @@ logm $ "putToksForPos " ++ (show pos) ++ (showToks toks) st <- get let Just tm = rsModule st - let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - let sspan = posToSrcSpan mainForest pos - let (tk',newSpan) = putToksInCache (rsTokenCache tm) (ss2s sspan) toks + let (tk',newSpan) = putToksInCache (rsTokenCache tm) pos toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } -- drawTokenTree "" - return (s2ss newSpan) + return (ss2gs newSpan) -- |Add tokens after a designated GHC.SrcSpan -putToksAfterSpan :: GHC.SrcSpan -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan -putToksAfterSpan oldSpan pos toks = do +addToksAfterSpan :: GHC.SrcSpan -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan +addToksAfterSpan oldSpan pos toks = do logm $ "putToksAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (showSrcSpanF oldSpan) ++ " at " ++ (show pos) ++ ":" ++ (showToks toks) st <- get let Just tm = rsModule st - let forest = getTreeFromCache oldSpan (rsTokenCache tm) - let (forest',newSpan) = addToksAfterSrcSpan forest (ss2s oldSpan) pos toks - let tk' = replaceTreeInCache oldSpan forest' $ rsTokenCache tm + let (tk',newSpan) = addTokensAfterSpanInCache (rsTokenCache tm) (gs2ss oldSpan) pos toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } - return (s2ss newSpan) + return (ss2gs newSpan) -- |Add tokens after a designated position -putToksAfterPos :: (SimpPos,SimpPos) -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan -putToksAfterPos pos position toks = do +addToksAfterPos :: (SimpPos,SimpPos) -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan +addToksAfterPos pos position toks = do logm $ "putToksAfterPos " ++ (show pos) ++ " at " ++ (show position) ++ ":" ++ (show toks) st <- get let Just tm = rsModule st - let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - let sspan = posToSrcSpan mainForest pos - let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',newSpan) = addToksAfterSrcSpan forest (ss2s sspan) position toks - let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm + -- let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid + -- let sspan = posToSrcSpan mainForest pos + let (tk',newSpan) = addTokensAfterSpanInCache (rsTokenCache tm) pos position toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } -- logm $ "putToksAfterPos result:" ++ (show forest') ++ "\ntree:\n" ++ (drawTreeEntry forest') - return (s2ss newSpan) + return (ss2gs newSpan) -- |Add tokens after a designated GHC.SrcSpan, and update the AST -- fragment to reflect it @@ -284,9 +226,9 @@ logm $ "putDeclToksAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (show (showSrcSpanF oldSpan,pos,toks)) st <- get let Just tm = rsModule st - let forest = getTreeFromCache oldSpan (rsTokenCache tm) + let forest = getTreeFromCache (gs2ss oldSpan) (rsTokenCache tm) let (forest',_newSpan, t') = addDeclToksAfterSrcSpan forest oldSpan pos toks t - let tk' = replaceTreeInCache oldSpan forest' (rsTokenCache tm) + let tk' = replaceTreeInCache (gs2ss oldSpan) forest' (rsTokenCache tm) let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } return t' @@ -297,7 +239,7 @@ logm $ "removeToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) st <- get let Just tm = rsModule st - let tk' = removeToksFromCache (rsTokenCache tm) (ss2s sspan) + let tk' = removeToksFromCache (rsTokenCache tm) (gs2ss sspan) let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } return () @@ -310,7 +252,7 @@ let Just tm = rsModule st let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid let sspan = posToSrcSpan mainForest pos - let tk' = removeToksFromCache (rsTokenCache tm) (ss2s sspan) + let tk' = removeToksFromCache (rsTokenCache tm) (gs2ss sspan) let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } -- drawTokenTree "removeToksForPos result" @@ -323,8 +265,6 @@ drawTokenTree msg = do st <- get let Just tm = rsModule st - -- let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - -- logm $ msg ++ "\ncurrent token tree:\n" ++ (drawTreeEntry mainForest) logm $ msg ++ "\ncurrent token tree:\n" ++ (drawTokenCache (rsTokenCache tm)) return () @@ -350,19 +290,10 @@ -- --------------------------------------------------------------------- -{- --- |Get the Ppr structure for debug prurposes -showPprDebug :: String -> RefactGhc () -showPprDebug msg = do - ppr <- fetchPprFinal - logm $ msg ++ "\ncurrent ppr tree:\n" ++ (showGhc ppr) - return () --} - showLinesDebug :: String -> RefactGhc () showLinesDebug msg = do - ppr <- fetchLinesFinal - logm $ msg ++ "\ncurrent [Line]:\n" ++ (showGhc ppr) + pprVal <- fetchLinesFinal + logm $ msg ++ "\ncurrent [Line]:\n" ++ (showGhc pprVal) return () -- --------------------------------------------------------------------- @@ -494,9 +425,9 @@ initRefactModule tm toks = Just (RefMod { rsTypecheckedMod = tm , rsOrigTokenStream = toks - -- , rsTokenCache = initTokenCache toks - , rsTokenCache = initTokenCacheLayout (initTokenLayout - (GHC.pm_parsed_source $ GHC.tm_parsed_module tm) + -- , rsTokenCache = initTokenCacheLayout (initTokenLayout + , rsTokenCache = initTokenCacheLayout (allocTokens + (GHC.pm_parsed_source $ GHC.tm_parsed_module tm) toks) , rsStreamModified = False }) @@ -511,7 +442,7 @@ -> RefactGhc () -- ^ Updates the RefactState updateToks (GHC.L sspan _) newAST printFun addTrailingNl = do - logm $ "updateToks " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan)) + logm $ "updateToks " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan)) newToks <- liftIO $ basicTokenise (printFun newAST) let newToks' = if addTrailingNl then newToks ++ [newLnToken (last newToks)] 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 @@ -13,2271 +13,238 @@ -- modules, it should probably never be used directly in a refactoring. module Language.Haskell.Refact.Utils.TokenUtils ( -{- - -- * Creating - initTokenCache - , initTokenCacheLayout - , mkTreeFromTokens - , mkTreeFromSpanTokens --} - -- * Operations at 'TokenCache' level - putToksInCache - , putDeclToksInCache - , replaceTokenInCache - -- , removeToksFromCache - , getTreeFromCache - , replaceTreeInCache - , syncAstToLatestCache - - -- * Operations at 'Tree' 'Entry' level - -- , getTokensFor - -- , getTokensForNoIntros - -- , getTokensBefore - -- , replaceTokenForSrcSpan - -- , updateTokensForSrcSpan - -- , insertSrcSpan - -- , removeSrcSpan - -- , getSrcSpanFor - -- , getSrcSpanForDeep - -- , addNewSrcSpanAndToksAfter - , addToksAfterSrcSpan - , addDeclToksAfterSrcSpan - , syncAST - , indentDeclToks - , Positioning(..) - - -- * Retrieving tokens - -- , retrieveTokensFinal - -- , retrieveTokensPpr - -- , renderPpr - -- , adjustLinesForDeleted - , retrieveTokensInterim - -- , retrieveTokens' -- temporary for debug - - -- * Token Tree Selection - , treeIdFromForestSpan - - -- * Token marking and re-alignment - -- , reAlignMarked - - -- * Utility - , posToSrcSpan - , posToSrcSpanTok - , fileNameFromTok - , treeStartEnd - -- , spanStartEnd - , sf - , fs - , ss2f,f2ss - , ss2s,s2ss - , forestSpanFromEntry - -- , combineSpans - - -- * A token stream with last tokens first, and functions to manipulate it - -- , ReversedToks(..) - -- , reverseToks - -- , unReverseToks - -- , reversedToks - - -- * Internal, for testing - -- , placeToksForSpan - -- , limitPrevToks - -- , reIndentToks - -- , reAlignOneLine - -- , reAlignToks - -- , splitForestOnSpan - -- , spanContains - -- , containsStart, containsMiddle, containsEnd - -- , doSplitTree, splitSubtree, splitSubToks - , nonCommentSpan - -- , invariantOk - -- , invariant - -- , showForest - , showTree - , showSrcSpan - , showSrcSpanF - , ghcSpanStartEnd - -- , insertNodeAfter - -- , retrievePrevLineToks - -- , getTreeSpansAsList - -- , openZipperToNode - -- , openZipperToNodeDeep - -- , openZipperToSpan - -- , openZipperToSpanDeep - -- , openZipperToSpanAdded - -- , openZipperToSpanOrig - , forestSpanToSimpPos - , forestSpanToGhcPos - - , ghcLineToForestLine - , stripForestLineFromGhc - , forestLineToGhcLine - , forestSpanToGhcSrcSpan - -- , forestPosVersionSet - -- , forestPosVersionNotSet - -- , forestSpanLenChanged - , forestSpanVersions - , forestSpanVersionSet - -- , forestSpanVersionNotSet - , insertForestLineInSrcSpan - -- , insertLenChangedInSrcSpan - -- , insertVersionsInSrcSpan - , ghcSrcSpanToForestSpan - , nullForestSpan, nullForestPos - -- , simpPosToForestSpan - , srcPosToSimpPos - , showForestSpan - , deleteGapsToks - -- , deleteGapsToks' - -- , calcEndGap - -- , stripForestLines - - -- * Based on Data.Tree - , drawTreeEntry - -- , drawTokenCache - -- , drawTokenCacheDetailed - , drawForestEntry - -- , drawEntry - , drawTreeCompact - - ) where - -import qualified FastString as GHC -import qualified GHC as GHC --- import qualified SrcLoc as GHC - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - --- import qualified Data.Foldable as F - -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.TypeSyn - -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.Utils - --- import Data.Bits --- import Data.List -import Data.Tree -import qualified Data.Map as Map --- import qualified Data.Tree.Zipper as Z - - --- import Debug.Trace --- debug = flip trace - --- --------------------------------------------------------------------- - -{- - -Structure is to be indexed by SrcSpan. - -Memo-ised. - -Must be recursive, so if one srcspan is requested that contains a -modified sub-src span, the modified one is returned. - -When initialising, split the tokens according to the binds, including -the leading and following comments. And perhaps a preamble and -postamble. - -The token start and end loc does not necessarily coincide with the -associated srcloc, due to leading / trailing comments - -SrcSpans are nested in one another according to the structure of the -AST. - -Store it in some kind of tree structure, memoised. - -Invariants: - 1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= []. - 2. The trees making up the subForest of a given node fully include the parent SrcSpan. - i.e. the leaves contain all the tokens for a given SrcSpan. - 3. A given SrcSpan can only appear (or be included) in a single tree of the forest. - --} - -{- - -NOTE: To break a cyclical import, this definition is in its own file - --- TODO: turn this into a record, with named accessors --- | An entry in the data structure for a particular srcspan. -data Entry = Entry GHC.SrcSpan -- ^The source span contained in this Node - [PosToken] -- ^The tokens for the SrcSpan if subtree is empty - deriving (Show) --} - -{- - -Note : Need to - -1. Re-locate tokens according to their surrounding context. i.e. match - indent of enclosing structure, add leading/trailing newlines - -2. Required by 1: Sync the SrcSpans to the AST, in the context of layout - - --} -{- - -NOTE: Token stream has zero-length string tokens in it, - - ITvocurly - ITsemi - ITvccurly - -These are inserted by GHC at points where a '{', ';' or '}' belongs in -the code, were it not implied by layout. - -This can perhaps be used to choose appropriate token boundaries. - --} - - --- deriving instance Show Entry - -{- moved to haskell-token-utils -instance Ord LayoutTree where - compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b) --} - -{- moved to haskell-token-utils -instance Eq Entry where - (Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2) - = fs1 == fs2 && lay1 == lay2 - && (show toks1) == (show toks2) - - (Deleted fs1 pg1 lay1) == (Deleted fs2 pg2 lay2) - = fs1 == fs2 && pg1 == pg2 && lay1 == lay2 - - (==) _ _ = False --} - --- --------------------------------------------------------------------- -{- --- |Keep track of when tokens are reversed, to avoid confusion -data ReversedToks = RT [PosToken] - deriving (Show) - -reverseToks :: [PosToken] -> ReversedToks -reverseToks toks = RT $ reverse toks - -unReverseToks :: ReversedToks -> [PosToken] -unReverseToks (RT toks) = reverse toks - -reversedToks :: ReversedToks -> [PosToken] -reversedToks (RT toks) = toks - - --- |How new SrcSpans should be inserted in the Token tree, relative to --- the prior span -data Positioning = PlaceAdjacent -- ^Only a single space between the - -- end of the prior span and the new one - | PlaceAbsolute !Int !Int -- ^Start at the specified - -- line and col - | PlaceAbsCol !Int !Int !Int -- ^Line offset and - -- absolute Col. Mainly - -- for forcing start at - -- left margin, number - -- of lines to add at - -- the end - | PlaceOffset !Int !Int !Int -- ^Line and Col offset for - -- start, num lines to add at the end - -- relative to the indent level of the prior span - | PlaceIndent !Int !Int !Int -- ^Line and Col offset for - -- start, num lines to add at the end - -- relative to the indent level of the prior line - deriving (Show) --} --- --------------------------------------------------------------------- - -{- --- ++AZ++ TODO: will we actually need these? --- | Operations on the structure -data Operations = OpAdded Entry -- ^The entry that was added - | OpRemoved Entry -- ^The Entry that was removed - | OpReplaced Entry Entry -- ^The first is old, second is new Entry - --} - --- --------------------------------------------------------------------- - --- A data type for the line entries in a SrcSpan. This has the --- following properties --- --- 1. It can be converted to and from the underlying Int in the --- original SrcSpan --- 2. It allows the insertion of an arbitrary line as the start of a --- new SrcSpan --- 3. It has an ordering relation, which honours the inserts which --- were made. --- 4. It can keep track of tokens that have been removed from the main --- AST, which can be edited outside of it and then inserted again --- --- This is achieved by adding two fields to the SrcSpan, one to --- indicate which AST fragment it is in, and the other to indicate its --- insert relationship, encoded as 0 for the original, 1 for the --- first, 2 for the second and so on. --- --- This field is converted to and from the original line by being --- multiplied by a very large number and added to the original. --- --- The guaranteed max value in Haskell for an Int is 2^29 - 1. --- This evaluates to 536,870,911,or 536.8 million. --- --- However, as pointed out on #haskell, the GHC compiler (which this --- implemtation explicitly targets) provides the full 32 bits (at --- least, can be 64), so we have --- maxBound :: Int = 2,147,483,647 --- --- Schema:max pos value is 0x7fffffff (31 bits) --- 1 bit for LenChanged --- 5 bits for tree : 32 values --- 5 bits for version : 32 values --- 20 bits for line number: 1048576 values - --- forestLineMask :: Int --- forestVersionMask :: Int --- forestTreeMask :: Int --- forestLenChangedMask :: Int --- forestLineMask = 0xfffff -- bottom 20 bits --- forestVersionMask = 0x1f00000 -- next 5 bits --- forestTreeMask = 0x3e000000 -- next 5 bits --- forestLenChangedMask = 0x40000000 -- top (non-sign) bit - --- forestVersionShift :: Int --- forestVersionShift = 20 - --- forestTreeShift :: Int --- forestTreeShift = 25 - -{- -This has been moved to TokenUtilsTypes - -data ForestLine = ForestLine - { flSpanLengthChanged :: Bool -- ^The length of the - -- span may have - -- changed due to - -- updated tokens. - , flTreeSelector :: Int - , flInsertVersion :: Int - , flLine :: Int - } deriving (Eq) --} - -{- moved to haskell-token-utils --- | Extract an encoded ForestLine from a GHC line -ghcLineToForestLine :: Int -> ForestLine -ghcLineToForestLine l = ForestLine ch tr v l' - where - l' = l .&. forestLineMask - v = shiftR (l .&. forestVersionMask) forestVersionShift - tr = shiftR (l .&. forestTreeMask) forestTreeShift - ch = (l .&. forestLenChangedMask) /= 0 --} - -{- moved to haskell-token-utils --- TODO: check that the components are in range -forestLineToGhcLine :: ForestLine -> Int -forestLineToGhcLine fl = (if (flSpanLengthChanged fl) then forestLenChangedMask else 0) - + (shiftL (flTreeSelector fl) forestTreeShift) - + (shiftL (flInsertVersion fl) forestVersionShift) - + (flLine fl) --} - -forestSpanToGhcSrcSpan :: ForestSpan -> GHC.SrcSpan -forestSpanToGhcSrcSpan ((fls,sc),(fle,ec)) = sspan - where - lineStart = forestLineToGhcLine fls - lineEnd = forestLineToGhcLine fle - locStart = GHC.mkSrcLoc (GHC.mkFastString "foo") lineStart sc - locEnd = GHC.mkSrcLoc (GHC.mkFastString "foo") lineEnd ec - sspan = GHC.mkSrcSpan locStart locEnd - - -{- moved to haskell-token-utils -instance Ord ForestLine where - -- Use line as the primary comparison, but break any ties with the - -- version - -- Tree is ignored, as it is only a marker on the topmost element - -- Ignore sizeChanged flag, it will only be relevant in the - -- invariant check - compare (ForestLine _sc1 _ v1 l1) (ForestLine _sc2 _ v2 l2) = - if (l1 == l2) - then compare v1 v2 - else compare l1 l2 --} -{- --- |Gets the version numbers -forestSpanVersions :: ForestSpan -> (Int,Int) -forestSpanVersions ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = (sv,ev) --} -{- --- |Gets the AST tree numbers -forestSpanAstVersions :: ForestSpan -> (Int,Int) -forestSpanAstVersions ((ForestLine _ trs _ _,_),(ForestLine _ tre _ _,_)) = (trs,tre) - --- |Gets the SpanLengthChanged flags -forestSpanLenChangedFlags :: ForestSpan -> (Bool,Bool) -forestSpanLenChangedFlags ((ForestLine chs _ _ _,_),(ForestLine che _ _ _,_)) = (chs,che) --} -{- moved to haskell-token-utils --- |Checks if the version is non-zero in either position -forestSpanVersionSet :: ForestSpan -> Bool -forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0 --} -{- --- |Checks if the version is zero in both positions -forestSpanVersionNotSet :: ForestSpan -> Bool -forestSpanVersionNotSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv == 0 && ev == 0 - --- |Checks if the version is non-zero -forestPosVersionSet :: ForestPos -> Bool -forestPosVersionSet (ForestLine _ _ v _,_) = v /= 0 - --- |Checks if the AST version is non-zero -forestPosAstVersionSet :: ForestPos -> Bool -forestPosAstVersionSet (ForestLine _ tr _ _,_) = tr /= 0 - --- |Checks if the version is zero -forestPosVersionNotSet :: ForestPos -> Bool -forestPosVersionNotSet (ForestLine _ _ v _,_) = v == 0 - -forestSpanLenChanged :: ForestSpan -> Bool -forestSpanLenChanged (s,e) = (forestPosLenChanged s) || (forestPosLenChanged e) --} --- forestPosLenChanged :: ForestPos -> Bool --- forestPosLenChanged (ForestLine ch _ _ _,_) = ch -{- --- |Puts a TreeId into a forestSpan -treeIdIntoForestSpan :: TreeId -> ForestSpan -> ForestSpan -treeIdIntoForestSpan (TId sel) ((ForestLine chs _ sv sl,sc),(ForestLine che _ ev el,ec)) - = ((ForestLine chs sel sv sl,sc),(ForestLine che sel ev el,ec)) --} - -{- moved to haskell-token-utils --- |Strip out the version markers -forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos) -forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec)) --} -{- --- |Strip out the version markers -forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos) -forestSpanToGhcPos ((fls,sc),(fle,ec)) - = ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec)) --} -{- -simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan -simpPosToForestSpan ((sr,sc),(er,ec)) - = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec)) --} -{- moved to haskell-token-utils -srcPosToSimpPos :: (Int,Int) -> (Int,Int) -srcPosToSimpPos (sr,c) = (l,c) - where - (ForestLine _ _ _ l) = ghcLineToForestLine sr --} -{- -forestSpanStart :: ForestSpan -> ForestPos -forestSpanStart (start,_) = start - -forestSpanEnd :: ForestSpan -> ForestPos -forestSpanEnd (_,end) = end --} -{- -nullForestSpan :: ForestSpan -nullForestSpan = (nullForestPos,nullForestPos) - -nullForestPos :: ForestPos -nullForestPos = (ForestLine False 0 0 0,0) --} -{- -showForestSpan :: ForestSpan -> String -showForestSpan ((sr,sc),(er,ec)) - = show ((flToNum sr,sc),(flToNum er,ec)) - where - flToNum (ForestLine ch tr v l) = (if ch then 10000000000::Integer else 0) - + ((fromIntegral tr) * 100000000::Integer) - + ((fromIntegral v) * 1000000::Integer) - + (fromIntegral l) --} --- --------------------------------------------------------------------- - --- | Replace any ForestLine flags already in a SrcSpan with the given ones -insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan -insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss' - where - lineStart = forestLineToGhcLine fl - (_,(ForestLine _ _ _ le,_)) = ghcSrcSpanToForestSpan (GHC.RealSrcSpan ss) - lineEnd = forestLineToGhcLine (ForestLine ch tr v le) - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) - ss' = GHC.mkSrcSpan locStart locEnd - -insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) - --- --------------------------------------------------------------------- -{- -insertVersionsInSrcSpan :: Int -> Int -> GHC.SrcSpan -> GHC.SrcSpan -insertVersionsInSrcSpan vs ve rss@(GHC.RealSrcSpan ss) = ss' - where - (chs,che) = forestSpanLenChangedFlags $ ghcSrcSpanToForestSpan rss - (trs,tre) = forestSpanAstVersions $ ghcSrcSpanToForestSpan rss - lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss)) - lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss)) - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) - ss' = GHC.mkSrcSpan locStart locEnd - -insertVersionsInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) --} --- --------------------------------------------------------------------- -{- -insertLenChangedInSrcSpan :: Bool -> Bool -> GHC.SrcSpan -> GHC.SrcSpan -insertLenChangedInSrcSpan chs che rss@(GHC.RealSrcSpan ss) = ss' - where - (sl,_sc) = getGhcLoc rss - (el,_ec) = getGhcLocEnd rss - sl' = if chs then sl .|. forestLenChangedMask - else sl .&. (complement forestLenChangedMask) - - el' = if che then el .|. forestLenChangedMask - else el .&. (complement forestLenChangedMask) - - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) sl' (GHC.srcSpanStartCol ss) - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) el' (GHC.srcSpanEndCol ss) - - -- (vs,ve) = forestSpanVersions $ ghcSrcSpanToForestSpan rss - -- (trs,tre) = forestSpanAstVersions $ ghcSrcSpanToForestSpan rss - -- lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss)) - -- lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss)) - -- locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) - -- locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) - ss' = GHC.mkSrcSpan locStart locEnd - -insertLenChangedInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) --} --- --------------------------------------------------------------------- -{- -insertVersionsInForestSpan :: Int -> Int -> ForestSpan -> ForestSpan -insertVersionsInForestSpan vsNew veNew ((ForestLine chs trs _vs ls,cs),(ForestLine che tre _ve le,ce)) - = ((ForestLine chs trs vsNew ls,cs),(ForestLine che tre veNew le,ce)) - --- --------------------------------------------------------------------- - -insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan -insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce)) - = ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce)) --} --- --------------------------------------------------------------------- - -ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan -ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) - where - (startRow,startCol) = getGhcLoc sspan - (endRow,endCol) = getGhcLocEnd sspan - --- -------------------------------------------------------------------- -{- -treeIdFromForestSpan :: ForestSpan -> TreeId -treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr --} --- --------------------------------------------------------------------- -{- -initTokenCache :: [PosToken] -> TokenCache PosToken -initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0) - -initTokenCacheLayout :: Tree (Entry PosToken) -> TokenCache PosToken -initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0) --} --- --------------------------------------------------------------------- -{- -treeIdIntoTree :: TreeId -> Tree (Entry PosToken) -> Tree (Entry PosToken) -treeIdIntoTree tid (Node (Entry fspan lay toks) subTree) = tree' - where - fs' = treeIdIntoForestSpan tid fspan - tree' = Node (Entry fs' lay toks) subTree -treeIdIntoTree tid (Node (Deleted fspan pg eg) subTree) = tree' - where - fs' = treeIdIntoForestSpan tid fspan - tree' = Node (Deleted fs' pg eg) subTree --} --- --------------------------------------------------------------------- -{- -stash :: TokenCache PosToken -> Tree (Entry PosToken) -> TokenCache PosToken -stash tk oldTree = tk' - where - (TId lastTreeId) = tkLastTreeId tk - lastTreeId' = TId (lastTreeId + 1) - oldTree' = treeIdIntoTree lastTreeId' oldTree - cache' = Map.insert lastTreeId' oldTree' (tkCache tk) - tk' = tk {tkLastTreeId = lastTreeId', tkCache = cache' } --} --- --------------------------------------------------------------------- -{- -replaceTokenInCache :: TokenCache PosToken -> GHC.SrcSpan -> PosToken -> TokenCache PosToken -replaceTokenInCache tk sspan tok = tk' - where - forest = getTreeFromCache sspan tk - forest' = replaceTokenForSrcSpan forest sspan tok - tk' = replaceTreeInCache sspan forest' tk --} --- --------------------------------------------------------------------- -{- -putToksInCache :: TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> (TokenCache PosToken,GHC.SrcSpan) -putToksInCache tk sspan toks = (tk'',newSpan) - where - forest = getTreeFromCache sspan tk - (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks - tk' = replaceTreeInCache sspan forest' tk - tk'' = stash tk' oldTree --} --- --------------------------------------------------------------------- - -putDeclToksInCache :: (SYB.Data t) => - TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> GHC.Located t - -> (TokenCache PosToken,GHC.SrcSpan,GHC.Located t) -putDeclToksInCache tk sspan toks t = (tk'',s2ss newSpan,t') - where - (tk'',newSpan) = putToksInCache tk (ss2s sspan) toks - t' = syncAST t (sf newSpan) - --- --------------------------------------------------------------------- -{- -removeToksFromCache :: TokenCache PosToken -> GHC.SrcSpan -> TokenCache PosToken -removeToksFromCache tk sspan = tk'' - where - forest = getTreeFromCache sspan tk - (forest',oldTree) = removeSrcSpan forest (ghcSrcSpanToForestSpan sspan) - tk' = replaceTreeInCache sspan forest' tk - tk'' = stash tk' oldTree --} --- --------------------------------------------------------------------- - -getTreeFromCache :: GHC.SrcSpan -> TokenCache PosToken -> Tree (Entry PosToken) -getTreeFromCache sspan tk = (tkCache tk) Map.! tid - where - tid = treeIdFromForestSpan $ ghcSrcSpanToForestSpan sspan - --- --------------------------------------------------------------------- - -replaceTreeInCache :: GHC.SrcSpan -> Tree (Entry PosToken) -> TokenCache PosToken -> TokenCache PosToken -replaceTreeInCache sspan tree tk = tk' - where - tid = treeIdFromForestSpan $ ghcSrcSpanToForestSpan sspan - -- tree' = treeIdIntoTree tid tree - tree' = putTidInTree tid tree - tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) } - -putTidInTree :: TreeId -> Tree (Entry PosToken) -> Tree (Entry PosToken) -putTidInTree tid (Node (Deleted fspan pg eg) subs) = (Node (Deleted fs' pg eg) subs) - where fs' = treeIdIntoForestSpan tid fspan -putTidInTree tid (Node (Entry fspan lay toks) subs) = tree' - where - subs' = map (putTidInTree tid) subs - fs' = treeIdIntoForestSpan tid fspan - tree' = Node (Entry fs' lay toks) subs' - --- --------------------------------------------------------------------- - --- |Assuming most recent operation has stashed the old tokens, sync --- the given AST to the most recent stash entry -syncAstToLatestCache :: (SYB.Data t) => TokenCache PosToken -> GHC.Located t -> GHC.Located t -syncAstToLatestCache tk t = t' - where - mainForest = (tkCache tk) Map.! mainTid - (Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) - pos = forestSpanToGhcPos fspan - sspan = posToSrcSpan mainForest pos - t' = syncAST t (ss2f sspan) - --- --------------------------------------------------------------------- -{- --- |Get the (possible cached) tokens for a given source span, and --- cache their being fetched. --- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC. -getTokensFor :: Bool -> Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),[PosToken]) -getTokensFor checkInvariant forest sspan = (forest'', tokens) - where - forest' = if (not checkInvariant) || invariantOk forest - -- short circuit eval - then forest - else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest) - (forest'',tree) = getSrcSpanFor forest' (ghcSrcSpanToForestSpan sspan) - - tokens = retrieveTokensInterim tree - --- --------------------------------------------------------------------- - --- |Get the (possible cached) tokens for a given source span, and --- cache their being fetched. --- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC. -getTokensForNoIntros :: Bool -> Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),[PosToken]) -getTokensForNoIntros checkInvariant forest sspan = (forest', tokens') - where - (forest',tokens) = getTokensFor checkInvariant forest sspan - -- (lead,rest) = break (not . isWhiteSpaceOrIgnored) tokens - (lead,rest) = break (not . isIgnoredNonComment) tokens - tokens' = (filter (not . isIgnored) lead) ++ rest --} --- --------------------------------------------------------------------- -{- --- |Get the tokens preceding a given 'SrcSpan' -getTokensBefore :: Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),ReversedToks PosToken) -getTokensBefore forest sspan = (forest', prevToks') - where - (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) - - z = openZipperToSpan (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest' - - prevToks = case (retrievePrevLineToks z) of - RT [] -> reverseToks $ retrieveTokensInterim tree - xs -> xs - - (_,rtoks) = break (\t->tokenPos t < (getGhcLoc sspan)) $ reversedToks prevToks - prevToks' = RT rtoks --} --- --------------------------------------------------------------------- -{- --- |Replace a single token in a token tree, without changing the --- structure of the tree --- NOTE: the GHC.SrcSpan may have been used to select the appropriate --- forest in the first place, and is required to select the correct --- span in the tree, due to the ForestLine annotations that may be present - --- TODO: work at the token level, not the sspan level --- TODO: Use start of token span only, with length 1. -replaceTokenForSrcSpan :: Tree (Entry PosToken) -> GHC.SrcSpan -> PosToken -> Tree (Entry PosToken) -replaceTokenForSrcSpan forest sspan tok = forest' - where - (GHC.L tl _,_) = tok - -- First open to the sspan, making use of any Forestline annotations - z = openZipperToSpanDeep (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest - - -- Then drill down to the specific subtree containing the token - -- z' = openZipperToSpan (ghcSrcSpanToForestSpan tl) z - z' = z -- No, pass in original token span as sspan. - - -- Note: with LayoutTree, the full tree matching the AST has been - -- built, still need to drill down to the nearest enclosing span - (tspan,lay,toks) = case Z.tree z' of - (Node (Entry ss ly tks) []) -> (ss,ly,tks) - (Node (Entry _ _ _nullToks) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting tokens, found: " ++ (show $ Z.tree z') - (Node (Deleted _ _ _) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting Entry, found: " ++ (show $ Z.tree z') - - ((row,col),_) = forestSpanToSimpPos $ ghcSrcSpanToForestSpan tl - toks' = replaceTokNoReAlign toks (row,col) tok - - zf = Z.setTree (Node (Entry tspan lay toks') []) z' - forest' = Z.toTree zf - - -- forest' = forest --} --- --------------------------------------------------------------------- -{- --- |Replace the tokens for a given SrcSpan with new ones. The SrcSpan --- will be inserted into the tree if it is not already there. --- If the SrcSpan changes size, replace the SrcSpan with a new one --- (marked), and return it, as well as the old one --- TODO: What about trailing comments? Preserve or replace? -updateTokensForSrcSpan :: Tree (Entry PosToken) -> GHC.SrcSpan -> [PosToken] -> (Tree (Entry PosToken),GHC.SrcSpan,Tree (Entry PosToken)) -updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree) - where - (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) - prevToks = retrieveTokensInterim tree - - endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks - startComments = takeWhile isWhiteSpaceOrIgnored $ toks - - newTokStart = if (emptyList prevToks) - then mkZeroToken - else ghead "updateTokensForSrcSpan.1" prevToks - - toks'' = if (nonEmptyList startComments || nonEmptyList endComments) - then -- toks have comments, discard originals - reIndentToks (PlaceAbsolute (tokenRow newTokStart) (tokenCol newTokStart)) prevToks toks - else -- Must reuse any pre-existing start or end comments, and - -- resync the tokens across all three. - let - origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks - origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks - - ((startRow,startCol),_) = forestSpanToGhcPos $ ghcSrcSpanToForestSpan sspan - core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks - trail = if (emptyList origEndComments) - then [] - else addOffsetToToks (lineOffset,colOffset) origEndComments - where - lineOffset = 0 -- tokenRow (head origEndComments) - tokenRow (head origEndComments) - colOffset = 0 -- tokenCol (head origEndComments) - - toks' = origStartComments ++ core ++ trail - in toks' - - (startPos,endPos) = nonCommentSpan toks'' - - -- if the original sspan had a ForestLine version, preserve it - (((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = ghcSrcSpanToForestSpan sspan - -- Note: adding one to end version, so invariant won't fail - -- newSpan = insertVersionsInSrcSpan vs ve $ posToSrcSpan forest (startPos,endPos) - newSpan = insertLenChangedInSrcSpan True True - $ insertVersionsInSrcSpan vs ve $ posToSrcSpan forest (startPos,endPos) - - zf = openZipperToNode tree $ Z.fromTree forest' - - zf' = Z.setTree (Node (Entry (ghcSrcSpanToForestSpan newSpan) NoChange toks'') []) zf - forest'' = Z.toTree zf' - - oldTree = tree --} -{- --- --------------------------------------------------------------------- --- |Retrieve a path to the tree containing a ForestSpan from the forest, --- inserting it if not already present -getSrcSpanFor :: Tree (Entry PosToken) -> ForestSpan -> (Tree (Entry PosToken), Tree (Entry PosToken)) -getSrcSpanFor forest sspan = (forest',tree) - where - forest' = insertSrcSpan forest sspan -- Will NO-OP if already - -- there - z = openZipperToSpan sspan $ Z.fromTree forest' - tree = Z.tree z --} -{- --- --------------------------------------------------------------------- --- |Retrieve a path to the tree containing a ForestSpan from the forest, --- inserting it if not already present. --- In the case where there is a nested series of spans as in an --- 'Above' layout, return the deepest one -getSrcSpanForDeep :: Tree (Entry PosToken) -> ForestSpan -> (Tree (Entry PosToken), Tree (Entry PosToken)) -getSrcSpanForDeep forest sspan = (forest',tree) - where - forest' = insertSrcSpan forest sspan -- Will NO-OP if already - -- there - z = openZipperToSpanDeep sspan $ Z.fromTree forest' - - tree = Z.tree z - --- --------------------------------------------------------------------- --- |Insert a ForestSpan into the forest, if it is not there already. --- Assumes the forest was populated with the tokens containing the --- ForestSpan already -insertSrcSpan :: Tree (Entry PosToken) -> ForestSpan -> Tree (Entry PosToken) -insertSrcSpan forest sspan = forest' - where - z = openZipperToSpan sspan $ Z.fromTree forest - forest' = if treeStartEnd (Z.tree z) == sspan - then forest -- Already in, exactly - -- else error $ "insertSrcSpan:span not in tree " ++ show sspan - - else if (Z.isLeaf z) - then -- TODO: This should be in splitSubToks - let - -- If we are at a leaf, retrieve the toks - (Entry _ _ toks) = Z.label z - - (tokStartPos,tokEndPos) = forestSpanToSimpPos sspan - - -- Tokens here, must introduce sub-spans with split, taking - -- cognizance of start and end comments - -- TODO: does startEndLocIncComments' give the same boundary - -- if approached from one side as the other? - (startLoc,endLoc) = startEndLocIncComments' toks (tokStartPos,tokEndPos) - - (startToks,middleToks,endToks) = splitToks (startLoc,endLoc) toks - - tree1 = if (nonCommentSpan startToks == ((0,0),(0,0))) - then [] - else [mkTreeFromTokens startToks] - tree2 = [mkTreeFromSpanTokens sspan middleToks] - - tree3 = if (nonCommentSpan endToks == ((0,0),(0,0))) - then [] - else [mkTreeFromTokens endToks] - - subTree = tree1 ++ tree2 ++ tree3 - subTree' = filter (\t -> treeStartEnd t /= nullForestSpan) subTree - -- (Entry sspan2 _ _) = Z.label z - sspan2 = case Z.label z of - (Entry ss _ _) -> ss - (Deleted ss _ _) -> ss - - - -- z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z - z' = case Z.label z of - (Entry _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTree') z - (Deleted _ _ _) -> Z.setTree (Node (Entry sspan2 NoChange []) subTreeD) z - where - (tb,tm,te) = splitSubToks (Z.tree z) sspan - subTreeD = tb ++ tm ++ te - - forest'' = Z.toTree z' - in forest'' - else - let - (before,middle,end) = doSplitTree (Z.tree z) sspan - newTree = case middle of - [x] -> x - _xs -> (Node (Entry sspan NoChange []) middle) - subTree' = before ++ [newTree] ++ end - (Entry sspan2 _ _) = Z.label z - - z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z - forest'' = Z.toTree z' - in - forest'' - - --- --------------------------------------------------------------------- - -doSplitTree :: - Tree (Entry PosToken) -> ForestSpan - -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) -doSplitTree tree@(Node (Deleted _ss _ _) []) sspan = splitSubToks tree sspan -- ++AZ+ What is correct? -doSplitTree tree@(Node (Entry _ss _ _toks) []) sspan = splitSubToks tree sspan -doSplitTree tree sspan = (b'',m'',e'') - -- error $ "doSplitTree:(sspan,tree,(b1,m1,e1))=" ++ (show (sspan,tree,(b1,m1,e1))) - where - (b1,m1,e1) = splitSubtree tree sspan - (b,m,e) = case m1 of - [] -> -- NOTE: This may have happened through a span being - -- deleted from the tree - -- Hence, correct solution is to kick it up a level and - -- rebuild using tokens etc - error $ "doSplitTree:no middle:(tree,sspan,b1,m1,e1)=" ++ (show (tree,sspan,b1,m1,e1)) - [x] -> -- only one tree - doSplitTree x sspan - - xx -> -- more than one tree - (b',m',e') - where - (bb,mb,_eb) = case (doSplitTree (ghead "doSplitTree.2" xx) sspan) of - (x,y,[]) -> (x,y,[]) - xxx -> error $ "doSplitTree:eb populated:" ++ (show (sspan,tree,xxx)) - - - ( [],me,ee) = doSplitTree (glast "doSplitTree.2" xx) sspan - - mm = tail $ init xx -- xx = (head xx) ++ mm ++ (last xx) - - b' = bb - m' = mb ++ mm ++ me - e' = ee - (b'',m'',e'') = (b1++b,m,e++e1) - - --- --------------------------------------------------------------------- - --- TODO: The Bool is horrible -mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree (Entry PosToken)] -mkTreeListFromTokens [] _sspan _ = [] -mkTreeListFromTokens toks sspan useOriginalSpan = res - where - (Node (Entry tspan NoChange treeToks) sub) = mkTreeFromTokens toks - - ((ForestLine chs ts vs _, _),(ForestLine che te ve _, _)) = sspan - ((ForestLine _ _ _ ls,cs),(ForestLine _ _ _ le,ce)) = tspan - - span' = ((ForestLine chs ts vs ls, cs),(ForestLine che te ve le, ce)) - - res = if nonCommentSpan toks == ((0,0),(0,0)) - then [] - else if useOriginalSpan - then [(Node (Entry sspan NoChange treeToks) sub)] - else [(Node (Entry span' NoChange treeToks) sub)] - --- --------------------------------------------------------------------- - -splitSubToks :: - Tree (Entry PosToken) - -> (ForestPos, ForestPos) - -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) -splitSubToks n@(Node (Deleted (treeStart,treeEnd) _pg _eg) []) (sspanStart,sspanEnd) = (b',m',e') - where - egs = (0,0) -- TODO: calculate this - ege = (0,0) -- TODO: calculate this - pg = 0 -- TODO: calculate this - b' = if sspanStart > treeStart - then [Node (Deleted (treeStart,treeStart) pg egs) []] - else [] - m' = [n] - e' = if treeEnd > sspanEnd - then [Node (Deleted (sspanEnd,treeEnd) pg ege) []] - else [] - -splitSubToks tree sspan = (b',m',e') - -- error $ "splitSubToks:(sspan,tree)=" ++ (show (sspan,tree)) - where - (Node (Entry ss@(treeStart,treeEnd) _lay toks) []) = tree - (sspanStart,sspanEnd) = sspan - -- TODO: ignoring comment boundaries to start - - -- There are three possibilities - -- 1. The span starts only in these tokens - -- 2. The span starts and ends in these tokens - -- 3. The span ends only in these tokens - (b',m',e') = case (containsStart ss sspan,containsEnd ss sspan) of - (True, False) -> (b'',m'',e'') -- Start only - -- error $ "splitSubToks:StartOnly:(sspan,tree,(b'',m''))=" ++ (show (sspan,tree,(b'',m''))) - where - (_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullForestPos,sspanStart)) toks --- b'' = if (emptyList toksb) then [] else [Node (Entry (treeStart, sspanEnd) toksb) []] - b'' = if (emptyList toksb || nonCommentSpan toksb == ((0,0),(0,0))) - then [] - else [mkTreeFromTokens toksb] -- Need to get end from actual toks - m'' = let - (ForestLine _ch _ts _v le,ce) = sspanEnd - tl = - if (treeStart == sspanStart) -- Eq does not compare all flags - then mkTreeListFromTokens toksm (treeStart, treeEnd) False - else mkTreeListFromTokens toksm (sspanStart,treeEnd) False - _tl' = if emptyList tl - then [] - else [Node (Entry (st,(ForestLine ch ts v le,ce)) lay tk) []] - where [Node (Entry (st,(ForestLine ch ts v _l,_c)) lay tk) []] = tl - in - -- tl' - tl - e'' = [] - - (True, True) -> (b'',m'',e'') -- Start and End - where - (toksb,toksm,tokse) = splitToks (forestSpanToSimpPos (sspanStart,sspanEnd)) toks - b'' = mkTreeListFromTokens toksb (treeStart, sspanStart) False - m'' = mkTreeListFromTokens toksm (sspanStart, sspanEnd) True - e'' = mkTreeListFromTokens tokse (sspanEnd, treeEnd) False - - (False,True) -> (b'',m'',e'') -- End only - where - (_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullForestPos,sspanEnd)) toks - b'' = [] - m'' = let -- If the last span is changed, make sure it stays - -- as it was - tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False - tl' = if emptyList tl - then [] - else [Node (Entry (st,sspanEnd) lay tk) []] - where [Node (Entry (st,_en) lay tk) []] = mkTreeListFromTokens toksm (treeStart,sspanEnd) False - in - tl' - e'' = mkTreeListFromTokens tokse (sspanEnd,treeEnd) False - - (False,False) -> if (containsMiddle ss sspan) - then ([],[tree],[]) - else error $ "splitSubToks: error (ss,sspan)=" ++ (show (ss,sspan)) - --- --------------------------------------------------------------------- - --- |True if the start of the second param lies in the span of the first -containsStart :: ForestSpan -> ForestSpan -> Bool -containsStart (nodeStart,nodeEnd) (startPos,_endPos) - = (startPos >= nodeStart && startPos <= nodeEnd) - --- |True if the start of the second param lies before the first, and --- ends after or on the second -containsMiddle :: ForestSpan -> ForestSpan -> Bool -containsMiddle (nodeStart,nodeEnd) (startPos,endPos) - = (startPos <= nodeStart) && (endPos >= nodeEnd) - --- |True if the end of the second param lies in the span of the first -containsEnd :: ForestSpan -> ForestSpan -> Bool -containsEnd (nodeStart,nodeEnd) (_startPos,endPos) - = (endPos >= nodeStart && endPos <= nodeEnd) - --- --------------------------------------------------------------------- - --- |Split a given tree into a possibly empty part that lies before the --- srcspan, the part that is wholly included in the srcspan and the --- part the lies outside of it at the end. -splitSubtree :: - Tree (Entry PosToken) -> ForestSpan - -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) -splitSubtree tree sspan = (before,middle,end) - -- error $ "splitSubtree:(sspan,tree,middle',end')=" ++ (show (sspan,tree,middle',end')) - where - containsStart' t = containsStart (treeStartEnd t) sspan - containsMiddle' t = containsMiddle (treeStartEnd t) sspan - containsEnd' t = containsEnd (treeStartEnd t) sspan - - cond t = containsStart' t || containsMiddle' t || containsEnd' t - - (Node _entry children) = tree - (before,rest) = break (\x -> cond x) children - (endr,middler) = break (\x -> cond x) $ reverse rest - - (middle,end) = (reverse middler,reverse endr) - - --} --- --------------------------------------------------------------------- -{- --- | Removes a ForestSpan and its tokens from the forest. -removeSrcSpan :: Tree (Entry PosToken) -> ForestSpan - -> (Tree (Entry PosToken),Tree (Entry PosToken)) -- ^Updated forest, removed span -removeSrcSpan forest sspan = (forest'', delTree) - where - forest' = insertSrcSpan forest sspan -- Make sure span is actually - -- in the tree - z = openZipperToSpan sspan $ Z.fromTree forest' - zp = gfromJust "removeSrcSpan" $ Z.parent z - - ((pg,_),eg) = calcPriorAndEndGap forest' sspan - - pt = Z.tree zp - - subTree = map (\t -> if (treeStartEnd t == sspan) then (Node (Deleted sspan pg eg) []) else t) $ subForest pt - - z' = Z.setTree (pt { subForest = subTree}) zp - forest'' = Z.toTree z' - - delTree = Z.tree z - -- forest'' = error $ "removeSrcSpan: forest'=" ++ drawTreeCompact forest' --} --- --------------------------------------------------------------------- -{- --- |For a span about to be deleted, calculate the gap between the end --- of the span being deleted and the start of the next one, at a token --- level. -calcPriorAndEndGap :: Tree (Entry PosToken) -> ForestSpan -> (SimpPos,SimpPos) -calcPriorAndEndGap tree sspan = (pg,eg) - where - ((spanStartRow,spanStartCol),(spanRow,spanCol)) = forestSpanToSimpPos sspan - (spanStart,spanEnd) = sspan - entries = retrieveTokens' tree - -- NOTE: the entries are the fringe of the tree, the sspan in - -- question may be represented by several entries - (before,rest) = span (\e -> (forestSpanStart $ forestSpanFromEntry e) < spanStart) entries - (rafter,rmiddle) = break (\e -> (forestSpanEnd $ forestSpanFromEntry e) <= spanEnd) $ reverse rest - _middle = reverse rmiddle - after = reverse rafter - -- last element of before should be the sspan we care about, first - -- of after is the one we are looking for. - - -- NOTE: `after` may contain zero or more Deleted segments in the - -- front. These get merged later in mergeDeletes - (tokRow,tokCol) = if emptyList after - then (spanRow + 2,spanCol) - else (r,c) - where - (r,c) = case ghead ("calcEndGap:after="++(show after)) after of - (Entry _ _ toks) -> (tokenRow t,tokenCol t) - where t = ghead "calcEndGap" toks - (Deleted ss _ _) -> fst $ forestSpanToSimpPos ss - - eg = (tokRow - spanRow, tokCol - spanCol) - -- eg = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after))) - - (tokRowPg,tokColPg) = if emptyList before - then (spanStartRow - 1,spanStartCol) - else (r,c) - where - (r,c) = case glast ("calcEndGap:before="++(show before)) before of - (Entry _ _ toks) -> (tokenRow t,tokenCol t) - where t = glast "calcEndGap pg" toks - (Deleted ss _ _) -> snd $ forestSpanToSimpPos ss - - -- TODO: what about comments before the span? spanStartRow may be off - pg = (spanStartRow - tokRowPg, spanStartCol - tokColPg) - - --- --------------------------------------------------------------------- - --- TODO: delete this, superseded by calcPriorAndEndGap --- |For a span about to be deleted, calculate the gap between the end --- of the span being deleted and the start of the next one, at a token --- level. -calcEndGap :: Tree (Entry PosToken) -> ForestSpan -> SimpPos -calcEndGap tree sspan = gap - where - (_sspanStart,(spanRow,spanCol)) = forestSpanToSimpPos sspan - (spanStart,spanEnd) = sspan - entries = retrieveTokens' tree - -- NOTE: the entries are the fringe of the tree, the sspan in - -- question may be represented by several entries - (_before,rest) = span (\e -> (forestSpanStart $ forestSpanFromEntry e) < spanStart) entries - (rafter,rmiddle) = break (\e -> (forestSpanEnd $ forestSpanFromEntry e) <= spanEnd) $ reverse rest - _middle = reverse rmiddle - after = reverse rafter - -- last element of before should be the sspan we care about, first - -- of after is the one we are looking for. - - -- NOTE: `after` may contain zero or more Deleted segments in the - -- front. These get merged later in mergeDeletes - (tokRow,tokCol) = if emptyList after - then (spanRow + 2,spanCol) - else (r,c) - where - (r,c) = case ghead ("calcEndGap:after="++(show after)) after of - (Entry _ _ toks) -> (tokenRow t,tokenCol t) - where t = ghead "calcEndGap" toks - (Deleted ss _ _) -> fst $ forestSpanToSimpPos ss - - gap = (tokRow - spanRow, tokCol - spanCol) - -- gap = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after))) --} --- --------------------------------------------------------------------- -{- --- |Retrieve all the tokens at the leaves of the tree, in order. --- Marked tokens are re-aligned, and gaps are closed. -retrieveTokensFinal :: Tree (Entry PosToken) -> [PosToken] -retrieveTokensFinal forest = monotonicLineToks $ stripForestLines $ reAlignMarked - $ deleteGapsToks $ retrieveTokens' forest - --- --------------------------------------------------------------------- - --- TODO: deprecated, doing this at the Ppr level now -adjustLinesForDeleted :: Tree (Entry PosToken) -> Tree (Entry PosToken) -adjustLinesForDeleted forest = forest' - where - (_,forest') = go (0,0) forest - - go :: (Int,Int) -> Tree (Entry PosToken) -> ((Int,Int),Tree (Entry PosToken)) - go (ro,co) (n@(Node (Entry _ss _lay _toks) [])) = ((ro,co),applyOffsetToTreeShallow (ro,co) n) - go (ro,co) (n@(Node (Deleted _ _ (gr,_gc)) _nullSubs)) = ((ro-gr,co),n) - go (ro,co) (n@(Node (Entry _ss _lay []) _subs)) = ((ro',co'),Node (Entry ss lay []) subs') - where - (Node (Entry ss lay []) subs) = applyOffsetToTreeShallow (ro,co) n - ((ro',co'),subs') = foldl' go' ((ro,co),[]) subs - - go (_ro,_co) (n@(Node (Entry _ss _lay _toks) _subs)) - = error $ "adjustLinesForDeleted: Entry with toks and subs:" ++ (show n) - - go' ((ro,co),acc) tree = ((ro',co'),acc++[tree']) - where - ((ro',co'),tree') = go (ro,co) tree - --- --------------------------------------------------------------------- - -applyOffsetToTreeShallow :: (Int,Int) -> Tree (Entry PosToken) -> Tree (Entry PosToken) -applyOffsetToTreeShallow (ro,co) (Node (Entry sspan lay toks) subs) - = (Node (Entry sspan' lay toks') subs') - where - sspan' = addOffsetToForestSpan (ro,co) sspan - toks' = addOffsetToToks (ro,co) toks - subs' = subs -applyOffsetToTreeShallow _ n@(Node (Deleted _ _ _) _) = n --} --- --------------------------------------------------------------------- -{- --- |Retrieve all the tokens at the leaves of the tree, in order. No --- adjustments are made to address gaps or re-alignment of the tokens -retrieveTokensInterim :: Tree (Entry PosToken) -> [PosToken] -retrieveTokensInterim forest = monotonicLineToks $ stripForestLines {- reAlignMarked -} - $ concat $ map (\t -> F.foldl accum [] t) [forest] - where - accum :: [PosToken] -> (Entry PosToken) -> [PosToken] - accum acc (Entry _ _ []) = acc - accum acc (Entry _ _ toks) = acc ++ toks - accum acc (Deleted _ _ _) = acc - - -retrieveTokens' :: Tree (Entry PosToken) -> [Entry PosToken] -retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest] - where - accum :: [Entry PosToken] -> Entry PosToken -> [Entry PosToken] - accum acc (Entry _ _ []) = acc - accum acc e@(Entry _ _ _toks) = acc ++ [e] - accum acc e@(Deleted _ _ _) = acc ++ [e] - --- |Merge adjacent Deleted entries -mergeDeletes :: [Entry PosToken] -> [Entry PosToken] -mergeDeletes [] = [] -mergeDeletes [x] = [x] -mergeDeletes ((Deleted ss1 pg1 (r1,_)):(Deleted ss2 _ (r2,c2)):xs) = (Deleted ss pg1 o):xs - where - (start,_) = ss1 - (_, end) = ss2 - ss = (start,end) - o = (r1+r2,c2) -mergeDeletes (x:xs) = x:mergeDeletes xs --} --- --------------------------------------------------------------------- - --- | Process the leaf nodes of a tree to remove all deleted spans -deleteGapsToks :: [Entry PosToken] -> [PosToken] -deleteGapsToks toks = goDeleteGapsToks (0,0) toks - -goDeleteGapsToks :: SimpPos -> [Entry PosToken] -> [PosToken] -goDeleteGapsToks _ [] = [] -goDeleteGapsToks offset [Entry _ _ t] = map (increaseSrcSpan offset) t -goDeleteGapsToks _ [Deleted _ _ _] = [] -goDeleteGapsToks offset (Deleted _ _ _:ts) = goDeleteGapsToks offset ts -goDeleteGapsToks offset [Entry _ _ t,Deleted _ _ _] = map (increaseSrcSpan offset) t -goDeleteGapsToks offset (Entry _ _ t1:e@(Entry _ _ _):ts) = (map (increaseSrcSpan offset) t1) ++goDeleteGapsToks offset (e:ts) -goDeleteGapsToks (fr,fc) (Entry ss _lay1 t1:Deleted _ _ eg:t2:ts) - = t1' ++ goDeleteGapsToks offset' (t2:ts) - where - -- TODO: use actual first and last toks, may be comments - -- TODO: what about deletion within a line? - - (deltaR,_deltaC) = eg - (_,(sr,_sc)) = forestSpanToSimpPos ss - ((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2 - offset' = (fr + (sr - dr) + deltaR, fc) - - t1' = map (increaseSrcSpan (fr,fc)) t1 - --- --------------------------------------------------------------------- -{- --- |Starting from a point in the zipper, retrieve all tokens backwards --- until the line changes for a non-comment/non-empty token or --- beginning of file. -retrievePrevLineToks :: Z.TreePos Z.Full (Entry PosToken) -> ReversedToks -retrievePrevLineToks z = RT res' -- error $ "retrievePrevLineToks:done notWhite=" ++ (show (done notWhite)) -- ++AZ++ - where - -- Assuming the zipper has been opened to the span we care about, - -- we will start with the tokens in the current tree, and work - -- back. - -- prevToks = retrieveTokens $ Z.tree z - prevToks = retrieveTokensInterim $ Z.tree z - - -- Next one is the usual one - -- res' = reverse $ (concat (go z)) ++ prevToks - res' = reverse $ concat $ reverse (prevToks : (go z)) - - -- TODO: ++AZ++ what is this actually doing? - go :: Z.TreePos Z.Full (Entry PosToken) -> [[PosToken]] - go zz - | not (Z.isRoot zz) = toks : (go $ gfromJust "retrievePrevLineToks" (Z.parent zz)) - | otherwise = [toks] - where - toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz - -- toks = concat $ map retrieveTokensInterim $ Z.before zz - --} --- --------------------------------------------------------------------- -{- -stripForestLines :: [PosToken] -> [PosToken] -stripForestLines toks = map doOne toks - where - doOne (GHC.L l t,s) = (GHC.L l' t,s) - where - ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l - l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l --} --- --------------------------------------------------------------------- - -stripForestLineFromGhc :: GHC.SrcSpan -> GHC.SrcSpan -stripForestLineFromGhc l = l' - where - ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l - l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l - --- --------------------------------------------------------------------- -{- -reAlignMarked :: [PosToken] -> [PosToken] -reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks - where - -- alignOne toksl = unmarked ++ (reAlignToks marked) - alignOne toksl = unmarked ++ (reAlignOneLine marked) - where - (unmarked,marked) = break isMarked toksl - --- --------------------------------------------------------------------- - --- | Some tokens are marked if they belong to identifiers which have --- been renamed. When the renaming takes place, no layout adjustment --- is done. This function adjusts the spacing for the rest of the line --- to match as far as possible the original spacing, except for the --- name change. -reAlignOneLine :: [PosToken] -> [PosToken] -reAlignOneLine toks = go (0,0) toks - where - go _ [] = [] - go (l,c) (t:ts) = (increaseSrcSpan (l,c) t') : (go (l,c') ts) - where - (t',dc) = adjustToken t - c' = c + dc - - adjustToken tt@(_,"") = (tt,0) - adjustToken tt@(lt@(GHC.L _ t),s) = ((GHC.L newL t,s),deltac) - where - (sl,sc) = getLocatedStart lt - (el,ec) = getLocatedEnd lt - deltac = (length s) - (ec - sc) - - filename = fileNameFromTok tt - newL = GHC.mkSrcSpan (GHC.mkSrcLoc filename sl sc) - (GHC.mkSrcLoc filename el (ec + deltac)) - - -reAlignToks :: [PosToken] -> [PosToken] -reAlignToks [] = [] -reAlignToks [t] = [t] -reAlignToks (tok1@(_,""):ts) = tok1 : reAlignToks ts -reAlignToks (tok1@((GHC.L l1 _t1),_s1):tok2@((GHC.L l2 t2),s2):ts) - = tok1:reAlignToks (tok2':ts) - where - ((_sr1,_sc1),(er1,ec1)) = (getGhcLoc l1,getGhcLocEnd l1) - (( sr2, sc2),(er2,ec2)) = (getGhcLoc l2,getGhcLocEnd l2) - - ((sr,sc),(er,ec)) = if (er1 == sr2 && ec1 >= sc2) - then ((sr2,ec1+1),(er2,ec1+1 + tokenLen tok2)) - else ((sr2,sc2),(er2,ec2)) - - fname = case l2 of - GHC.RealSrcSpan ss -> GHC.srcSpanFile ss - _ -> GHC.mkFastString "foo" - l2' = GHC.mkRealSrcSpan (GHC.mkRealSrcLoc fname sr sc) - (GHC.mkRealSrcLoc fname er ec) - tok2' = ((GHC.L (GHC.RealSrcSpan l2') t2),s2) --} --- --------------------------------------------------------------------- -{- --- |Add a new SrcSpan and Tokens after a given one in the token stream --- and forest. This will be given a unique SrcSpan in return, which --- specifically indexes into the forest. -addNewSrcSpanAndToksAfter :: - Tree (Entry PosToken) -- ^The forest to update - -> GHC.SrcSpan -- ^The new span comes after this one - -> GHC.SrcSpan -- ^Existing span for the tokens - -> Positioning - -> [PosToken] -- ^The new tokens belonging to the new SrcSpan - -> (Tree (Entry PosToken) -- Updated forest with the new span - , GHC.SrcSpan) -- ^Unique SrcSpan allocated in the forest to - -- identify this span in its position -addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan') - where - (forest',tree) = getSrcSpanForDeep forest (ghcSrcSpanToForestSpan oldSpan) - - (ghcl,_c) = getGhcLoc newSpan - (ForestLine ch tr v l) = ghcLineToForestLine ghcl - newSpan' = insertForestLineInSrcSpan (ForestLine ch tr (v+1) l) newSpan - - toks' = placeToksForSpan forest' oldSpan tree pos toks - - newNode = Node (Entry (ghcSrcSpanToForestSpan newSpan') NoChange toks') [] - - forest'' = insertNodeAfter tree newNode forest' - --- --------------------------------------------------------------------- - -placeToksForSpan :: - Tree (Entry PosToken) - -> GHC.SrcSpan - -> Tree (Entry PosToken) - -> Positioning - -> [PosToken] - -> [PosToken] -placeToksForSpan forest oldSpan tree pos toks = toks' - where - z = openZipperToSpanDeep (ghcSrcSpanToForestSpan oldSpan) $ Z.fromTree forest - prevToks = case (retrievePrevLineToks z) of - RT [] -> reverseToks $ retrieveTokensInterim tree - xs -> xs - - prevToks' = limitPrevToks prevToks oldSpan - toks' = reIndentToks pos (unReverseToks prevToks') toks - -- toks' = error $ "placeToksForSpan: prevToks'=" ++ (show prevToks') - -- toks' = error $ "placeToksForSpan: prevToks=" ++ (show prevToks) - --- --------------------------------------------------------------------- - --- |Add new tokens after the given SrcSpan, constructing a new SrcSpan --- in the process -addToksAfterSrcSpan :: - Tree (Entry PosToken) -- ^TokenTree to be modified - -> GHC.SrcSpan -- ^Preceding location for new tokens - -> Positioning - -> [PosToken] -- ^New tokens to be added - -> (Tree (Entry PosToken), GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for - -- the new tokens in the TokenTree -addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan') - where - (fwithspan,tree) = getSrcSpanForDeep forest (ghcSrcSpanToForestSpan oldSpan) - - toks'' = placeToksForSpan fwithspan oldSpan tree pos toks - - (startPos,endPos) = nonCommentSpan toks'' - - newSpan = posToSrcSpan forest (startPos,endPos) - - (forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks --} --- --------------------------------------------------------------------- -{- -limitPrevToks :: ReversedToks -> GHC.SrcSpan -> ReversedToks -limitPrevToks prevToks sspan = reverseToks prevToks'' - where - ((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = ghcSrcSpanToForestSpan sspan - - -- Make sure the toks do not extend past where we are - prevToks' = dropWhile (\t -> tokenRow t > endRow) $ unReverseToks prevToks - - -- Only use the toks for the given oldspan - -- prevToks'' = dropWhile (\t -> tokenPos t < (startRow,startCol)) prevToks' - prevToks'' = dropWhile (\t -> tokenRow t < startRow) prevToks' --} --- --------------------------------------------------------------------- - --- |Add new tokens belonging to an AST fragment after a given SrcSpan, --- and re-sync the AST fragment to match the new location -addDeclToksAfterSrcSpan :: (SYB.Data t) => - Tree (Entry PosToken) -- ^TokenTree to be modified - -> GHC.SrcSpan -- ^Preceding location for new tokens - -> Positioning - -> [PosToken] -- ^New tokens to be added - -> GHC.Located t -- ^Declaration the tokens belong to, to be synced - -> (Tree (Entry PosToken), GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for - -- -> (Tree (Entry PosToken), GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for - -- the new tokens in the TokenTree, and - -- updated AST element -addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest',(s2ss newSpan),t') - where - (forest',newSpan) = addToksAfterSrcSpan forest (ss2s oldSpan) pos toks - t' = syncAST t (sf newSpan) - --- --------------------------------------------------------------------- -{- - -reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken] -reIndentToks _ _ [] = [] -reIndentToks pos prevToks toks = toks'' - where - newTokStart = ghead "reIndentToks.1" - $ dropWhile (\tok -> isComment tok || isEmpty tok) $ toks - - firstTok = ghead "reIndentToks.2" toks - lastTok = glast "reIndentToks.1" prevToks - - lastNonCommentTok = ghead "reIndentToks.3" - $ dropWhile (\tok -> isComment tok || isEmpty tok) $ reverse prevToks - - prevOffset = getIndentOffset prevToks (tokenPos (glast "reIndentToks.2" prevToks)) - - (lastTokEndLine,_) = tokenPosEnd lastTok - - - (lineOffset,colOffset,endNewlines) = case pos of - PlaceAdjacent -> (lineOffset',colOffset',0) - where - colStart = (tokenColEnd (lastTok)) + 1 - lineStart = (tokenRow (lastTok)) - - lineOffset' = lineStart - (tokenRow firstTok) - colOffset' = colStart - (tokenCol newTokStart) - - PlaceAbsolute row col -> (lineOffset', colOffset', 0) - where - lineOffset' = row - (tokenRow firstTok) - colOffset' = col - (tokenCol firstTok) - - PlaceAbsCol rowIndent col numLines -> (lineOffset', colOffset', numLines) - where - colOffset' = col - (tokenCol firstTok) - lineStart = (tokenRow (lastTok)) -- + 1 - - lineOffset' = rowIndent + lineStart - (tokenRow firstTok) - - PlaceOffset rowIndent colIndent numLines -> (lineOffset',colOffset',numLines) - where - -- TODO: Should this not be prevOffset? - colStart = tokenCol $ ghead "reIndentToks.4" - $ dropWhile isWhiteSpaceOrIgnored prevToks - - lineStart = (tokenRow (lastTok)) -- + 1 - - lineOffset' = rowIndent + lineStart - (tokenRow firstTok) - colOffset' = colIndent + colStart - (tokenCol newTokStart) - -- colOffset' = error $ "reIndentToks:placeOffset lineOffset=" ++ show lineOffset - - PlaceIndent rowIndent colIndent numLines -> (lineOffset',colOffset',numLines) - where - colStart = prevOffset - lineStart = if ((isComment lastTok) && (tokenRow lastNonCommentTok /= lastTokEndLine)) - then (tokenRow (lastTok)) + 1 - else (tokenRow (lastTok)) - - lineOffset' = rowIndent + lineStart - (tokenRow firstTok) - colOffset' = colIndent + colStart - (tokenCol newTokStart) + 1 -- ++AZ++ Why +1? - - toks' = addOffsetToToks (lineOffset,colOffset) toks - toks'' = if endNewlines > 0 - then toks' ++ [(newLinesToken (endNewlines - 1) $ glast "reIndentToks.3" toks')] - else toks' --} --- --------------------------------------------------------------------- -{- --- |Extract the start and end position of a span, without any leading --- or trailing comments -nonCommentSpan :: [PosToken] -> (SimpPos,SimpPos) -nonCommentSpan [] = ((0,0),(0,0)) -nonCommentSpan toks = (startPos,endPos) - where - stripped = dropWhile isIgnoredNonComment $ toks - (startPos,endPos) = case stripped of - [] -> ((0,0),(0,0)) - _ -> (tokenPos startTok,tokenPosEnd endTok) - where - startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks - endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks --} --- --------------------------------------------------------------------- - --- |Convert a simple (start,end) position to a SrcSpan belonging to --- the file in the tree -posToSrcSpan :: Tree (Entry PosToken) -> (SimpPos,SimpPos) -> GHC.SrcSpan -posToSrcSpan forest ((rs,cs),(re,ce)) = sspan - where - (GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest -- ++AZ++ Ouch, performance?? - sspan = case l of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce - in - GHC.mkSrcSpan locStart locEnd - _ -> error "posToSrcSpan: invalid SrcSpan in first tok" - --- --------------------------------------------------------------------- - --- |Convert a simple (start,end) position to a SrcSpan belonging to --- the file in the given token -posToSrcSpanTok :: PosToken -> (SimpPos,SimpPos) -> GHC.SrcSpan -posToSrcSpanTok tok ((rs,cs),(re,ce)) = sspan - where - (GHC.L l _,_) = tok - sspan = case l of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce - in - GHC.mkSrcSpan locStart locEnd - _ -> error "posToSrcSpan: invalid SrcSpan in first tok" - - --- --------------------------------------------------------------------- -{- --- |Insert a new node after the designated one in the tree -insertNodeAfter - :: Tree (Entry PosToken) -> Tree (Entry PosToken) -> Tree (Entry PosToken) -> Tree (Entry PosToken) -insertNodeAfter oldNode newNode forest = forest' - where - zf = openZipperToNodeDeep oldNode $ Z.fromTree forest - - zp = gfromJust ("insertNodeAfter:" ++ (show (oldNode,newNode,forest))) $ Z.parent zf - tp = Z.tree zp - - -- now go through the children of the parent tree, and find the - -- right spot for the new node - (f,s) = break (\t -> treeStartEnd t == treeStartEnd oldNode) $ subForest tp - (f',s') = (f++[ghead "insertNodeAfter" s],tail s) -- break does not include the found point - subForest' = f' ++ [newNode] ++ s' - - tp' = tp { subForest = subForest' } - forest' = Z.toTree $ Z.setTree tp' zp --} --- --------------------------------------------------------------------- -{- --- |Open a zipper so that its focus is the given node --- NOTE: the node must already be in the tree -openZipperToNode - :: Tree (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToNode (Node (Entry sspan _ _) _) z - = openZipperToSpan sspan z -openZipperToNode (Node (Deleted sspan _ _) _) z - = openZipperToSpan sspan z - --- |Open a zipper so that its focus is the given node --- NOTE: the node must already be in the tree -openZipperToNodeDeep - :: Tree (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToNodeDeep (Node (Entry sspan _ _) _) z - = openZipperToSpanDeep sspan z -openZipperToNodeDeep (Node (Deleted sspan _ _) _) z - = openZipperToSpanDeep sspan z - - -getChildrenAsZ :: Z.TreePos Z.Full a -> [Z.TreePos Z.Full a] -getChildrenAsZ z = go [] (Z.firstChild z) - where - go acc Nothing = acc - go acc (Just zz) = go (acc ++ [zz]) (Z.next zz) --} --- --------------------------------------------------------------------- -{- --- |Does the first span contain the second? Takes cognisance of the --- various flags a ForestSpan can have. --- NOTE: This function relies on the Eq instance for ForestLine -spanContains :: ForestSpan -> ForestSpan -> Bool -spanContains span1 span2 = (startPos <= nodeStart && endPos >= nodeEnd) - where - -- TODO: This looks like a no-op? - (tvs,_tve) = forestSpanVersions $ span1 - (nvs,_nve) = forestSpanVersions $ span2 - (startPos,endPos) = insertVersionsInForestSpan tvs tvs span1 - (nodeStart,nodeEnd) = insertVersionsInForestSpan nvs nvs span2 --} --- --------------------------------------------------------------------- -{- --- |Open a zipper so that its focus has the given SrcSpan in its --- subtree, or the location where the SrcSpan should go, if it is not --- in the tree -openZipperToSpan - :: ForestSpan - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToSpan sspan z - | hasVersions = openZipperToSpanAdded sspan z - | otherwise = openZipperToSpanOrig sspan z - where - (vs,_ve) = forestSpanVersions sspan - hasVersions = vs /= 0 - - --- --------------------------------------------------------------------- - --- |Open a zipper so that its focus has the given SrcSpan in its --- subtree, or the location where the SrcSpan should go, if it is not --- in the tree -openZipperToSpanOrig - :: ForestSpan - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToSpanOrig sspan z - = if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z) - then z - else z' - where - -- go through all of the children to find the one that - -- either is what we are looking for, or contains it - - -- childrenAsZ = go [] (Z.firstChild z) - childrenAsZ = getChildrenAsZ z - z' = case (filter contains childrenAsZ) of - [] -> z -- Not directly in a subtree, this is as good as - -- it gets - [x] -> -- exactly one, drill down - openZipperToSpan sspan x - - xx -> case (filter (\zt -> (treeStartEnd $ Z.tree zt) == sspan) xx) of - [] -> -- more than one matches, see if we can get - -- rid of the ones that have been lengthened - case (filter (not .forestSpanLenChanged . treeStartEnd . Z.tree) xx) of - [] -> z -- we tried... - [w] -> openZipperToSpan sspan w - -- ww -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,ww)) - ww -> -- more than one candidate, break - -- the tie on version match - case (filter (\zt -> matchVersions sspan zt) ww) of - [v] -> openZipperToSpan sspan v - _ -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,map (\zt -> treeStartEnd $ Z.tree zt) ww)) - [y] -> openZipperToSpan sspan y - yy -> -- Multiple, check if we can separate out by - -- version - case (filter (\zt -> (fst $ forestSpanVersions $ treeStartEnd $ Z.tree zt) == (fst $ forestSpanVersions sspan)) xx) of - -- [] -> z - [] -> error $ "openZipperToSpan:no version match:(sspan,yy)=" ++ (show (sspan,yy)) -- ++AZ++ - [w] -> openZipperToSpan sspan w - _ww -> error $ "openZipperToSpan:multiple version match:" ++ (show (sspan,yy)) -- ++AZ++ - - contains zn = spanContains (treeStartEnd $ Z.tree zn) sspan - - matchVersions span1 z2 = isMatch - where - span2 = treeStartEnd $ Z.tree z2 - isMatch = forestSpanVersions span1 == forestSpanVersions span2 - --- --------------------------------------------------------------------- - --- |Open a zipper so that its focus has the given SrcSpan in its --- subtree, or the location where the SrcSpan should go, if it is not --- in the tree. --- In the case of an 'Above' layout with the same SrcSpan below, --- return that instead -openZipperToSpanDeep - :: ForestSpan - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToSpanDeep sspan z = zf - where - z' = openZipperToSpan sspan z - - zf = case Z.tree z' of - (Node (Entry _ (Above _ _ _ _) _) _) -> - case getChildrenAsZ z' of - [] -> z' - [x] -> if (treeStartEnd (Z.tree x) == sspan) then x else z' - _ -> z' - _ -> z' - - --- --------------------------------------------------------------------- - --- |Open a zipper to a SrcSpan that has been added in the tree, and --- thus does not necessarily fall in the logical hierarchy of the tree -openZipperToSpanAdded - :: ForestSpan - -> Z.TreePos Z.Full (Entry PosToken) - -> Z.TreePos Z.Full (Entry PosToken) -openZipperToSpanAdded sspan z = zf - where - treeAsList = getTreeSpansAsList $ Z.tree z - - -- True if first span contains the second - myMatch (((ForestLine _ _ vs1 rs1),cs1),((ForestLine _ _ ve1 re1),ce1)) - (((ForestLine _ _ vs2 rs2),cs2),((ForestLine _ _ ve2 re2),ce2)) - = vs1 == vs2 && ve1 == ve2 && ((rs1,cs1) <= (rs2,cs2)) && ((re1,ce1) >= (re2,ce2)) - tl2 = dropWhile (\(_,s) -> not (myMatch s sspan)) $ reverse treeAsList - - fff [] _ = [] - fff acc@((cd,_cs):_) (v,sspan') = if v < cd then (v,sspan'):acc - else acc - - tl3 = foldl' fff [(head tl2)] tl2 - -- tl3 now contains the chain of ForestSpans to open in order in the zipper - - zf = foldl' (flip openZipperToSpanOrig) z $ map snd tl3 - --- --------------------------------------------------------------------- - -getTreeSpansAsList :: Tree (Entry PosToken) -> [(Int,ForestSpan)] -getTreeSpansAsList = getTreeSpansAsList' 0 - -getTreeSpansAsList' :: Int -> Tree (Entry PosToken) -> [(Int,ForestSpan)] -getTreeSpansAsList' level (Node (Deleted sspan _pg _eg ) _ ) = [(level,sspan)] -getTreeSpansAsList' level (Node (Entry sspan _lay _toks) ts0) = (level,sspan) - : (concatMap (getTreeSpansAsList' (level + 1)) ts0) - - --- --------------------------------------------------------------------- - --- |Split a forest of trees into a (begin,middle,end) according to a --- ForestSpan, such that no tokens are included in begin or end belonging --- to the ForestSpan, and all of middle has some part of the ForestSpan -splitForestOnSpan :: Forest (Entry PosToken) -> ForestSpan - -> ([Tree (Entry PosToken)],[Tree (Entry PosToken)],[Tree (Entry PosToken)]) -splitForestOnSpan forest sspan = (beginTrees,middleTrees,endTrees) - where - (spanStart,spanEnd) = sspan - - (beginTrees,rest) = break (\t -> not $ inBeginTrees t) forest - (middleTrees,endTrees) = break (\t -> inEndTrees t) rest - - inBeginTrees tree = spanStart >= treeEnd - where - (_treeStart,treeEnd) = treeStartEnd tree - - inEndTrees tree = spanEnd <= treeStart - where - (treeStart,_treeEnd) = treeStartEnd tree - - - - --} --- --------------------------------------------------------------------- -{- --- |Utility function to either return True or throw an error to report the problem -invariantOk :: Tree (Entry PosToken) -> Bool -invariantOk forest = ok - where - inv = invariant forest - ok = case inv of - [] -> True - _ -> error $ "Token Tree invariant fails:" ++ (intercalate "\n" inv) - --- --------------------------------------------------------------------- --- |Check the invariant for the token cache. Returns list of any errors found. --- Invariants: --- 1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= []. --- 2a. The trees making up the subForest of a given node fully include the parent SrcSpan. --- i.e. the leaves contain all the tokens for a given SrcSpan. --- 2b. The subForest is in SrcSpan order --- 3. A given SrcSpan can only appear (or be included) in a single tree of the forest. --- 4. The parent link for all sub-trees does exist, and actually points to the parent. --- 5. There are no nullForestSpan entries in the tree --- NOTE: the tokens may extend before or after the SrcSpan, due to comments only --- NOTE2: this will have to be revisited when edits to the tokens are made -invariant :: Tree (Entry PosToken) -> [String] -invariant forest = rsub - where - rsub = F.foldl checkOneTree [] [forest] - - checkOneTree :: [String] -> Tree (Entry PosToken) -> [String] - checkOneTree acc tree = acc ++ r - where - r = checkNode [] tree - - checkNode :: [String] -> Tree (Entry PosToken) -> [String] - checkNode _acc (Node (Deleted _sspan _ _) []) = [] - checkNode _acc node@(Node (Deleted _sspan _ _) _sub) - = ["FAIL: deleted node with subtree: " ++ (prettyshow node)] - checkNode acc node@(Node (Entry sspan _lay toks) sub) = acc ++ r ++ rinc ++ rsubs ++ rnull - where - r = if ( emptyList toks && nonEmptyList sub) || - (nonEmptyList toks && emptyList sub) - then [] - else ["FAIL: exactly one of toks or subforest must be empty: " ++ (prettyshow node)] - rsubs = foldl' checkNode [] sub - - rinc = checkInclusion node - - rnull = if (sspan == nullForestSpan) - then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)] - else [] - - -- |Check invariant 2, assuming 1 ok - -- NOTE: check that the subtree spans do not go outside the node - -- span, they do not need to completely fill it, because some may - -- have been removed during manipulation - checkInclusion (Node _ []) = [] - checkInclusion (Node (Deleted _ _ _) _) = [] - checkInclusion node@(Node (Entry _sspan _lay _toks) sub) = rs ++ rseq - where - (start,end) = treeStartEnd node - subs = map treeStartEnd sub - (sstart, _) = ghead "invariant" subs - (_, send) = last subs - -- Do not count any custom added srcspans at the end for this - -- test - -- TODO: is this a reasonable approach? - - rs = if ((start <= sstart) && - ((end >= send) || (forestPosVersionSet send) || (forestPosAstVersionSet send))) - || (forestPosLenChanged start) - || (forestPosLenChanged sstart) - || (forestPosLenChanged send) - - then [] - else ["FAIL: subForest start and end does not match entry: " ++ (prettyshow node)] - -- else ["FAIL: subForest start and end does not match entry: " ++ (show node)] - - rseq = checkSequence node subs - - checkSequence :: Tree (Entry PosToken) -> [ForestSpan] -> [String] - checkSequence _ [] = [] - checkSequence _ [_x] = [] - checkSequence node' ((_s1,e1):s@(s2,_e2):ss) - = r ++ checkSequence node' (s:ss) - where - -- r = if e1 <= s2 - r = if (before e1 s2) || (sizeChanged e1) {- ++AZ++ -} || (sizeChanged s2) - then [] - else ["FAIL: subForest not in order: " ++ - show e1 ++ " not < " ++ show s2 ++ - ":" ++ prettyshow node'] - - -- |Compare end of one span with beginning of another - before (ForestLine _chs _trs ve er,ec) (ForestLine _che _tre vs sr,sc) - = case (ve /= 0, vs /= 0) of - (False, False) -> (er,ec) <= (sr,sc) -- e.g. (10,3) <= (11,5) - (False, True) -> True -- e.g. (10,3) <= (100011,5) - (True, False) -> True -- e.g. (100010,3) <= (11,5) - (True, True) -> if vs < ve -- both have version, lowest wins - then False - else True - - sizeChanged (ForestLine ch _ _ _,_) = ch - -{- - cs ce - True _ -> True - False _ -> before - --} --} --- --------------------------------------------------------------------- - -{- moved to haskell-token-utils --- |Get the start and end position of a Tree --- treeStartEnd :: Tree (Entry PosToken) -> (SimpPos,SimpPos) --- treeStartEnd (Node (Entry sspan _) _) = (getGhcLoc sspan,getGhcLocEnd sspan) -treeStartEnd :: Tree (Entry PosToken) -> ForestSpan -treeStartEnd (Node (Entry sspan _ _) _) = sspan -treeStartEnd (Node (Deleted sspan _ _) _) = sspan --} - --- |Get the start and end position of a SrcSpan --- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos) --- spanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) -spanStartEnd :: GHC.SrcSpan -> ForestSpan -spanStartEnd sspan = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec)) - where - ((sr,sc),(er,ec)) = (getGhcLoc sspan,getGhcLocEnd sspan) - --- --------------------------------------------------------------------- -{- --- showForest :: Forest Entry -> String -showForest forest = map (showSubTree 0) forest - where - -- showSubTree :: Int -> Tree (Entry PosToken) -> String - showSubTree indent tree@(Node (Entry sspan toks mp) sub) - = (take indent (repeat ' ')) - ++ (show (getGhcLoc sspan, getGhcLocEnd sspan)) ++ " " - ++ (case toks of - [] -> showSubTree (indent+2) sub - _ -> "toks") --} -{- -showForest :: [Tree (Entry PosToken)] -> [String] -showForest forest = map showTree forest - --- --------------------------------------------------------------------- - --- |Call drawTreeEntry on the entire token cache -drawTokenCache :: TokenCache PosToken -> String -drawTokenCache tk = Map.foldlWithKey' doOne "" (tkCache tk) - where - doOne :: String -> TreeId -> Tree (Entry PosToken) -> String - doOne s key val = s ++ "tree " ++ (show key) ++ ":\n" - ++ (drawTreeEntry val) - --- --------------------------------------------------------------------- - --- |Call drawTreeEntry on the entire token cache -drawTokenCacheDetailed :: TokenCache PosToken -> String -drawTokenCacheDetailed tk = Map.foldlWithKey' doOne "" (tkCache tk) - where - doOne :: String -> TreeId -> Tree (Entry PosToken) -> String - doOne s key val = s ++ "tree " ++ (show key) ++ ":\n" - ++ (show val) - --- --------------------------------------------------------------------- --- | Neat 2-dimensional drawing of a tree. -drawTreeEntry :: Tree (Entry PosToken) -> String -drawTreeEntry = unlines . drawEntry - --- | Neat 2-dimensional drawing of a forest. -drawForestEntry :: Forest (Entry PosToken) -> String -drawForestEntry = unlines . map drawTreeEntry - -drawEntry :: Tree (Entry PosToken) -> [String] -drawEntry (Node (Deleted sspan _pg eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"] -drawEntry (Node (Entry sspan lay _toks) ts0) = ((showForestSpan sspan) ++ (showLayout lay)): drawSubTrees ts0 - where - drawSubTrees [] = [] - drawSubTrees [t] = - "|" : shft "`- " " " (drawEntry t) - drawSubTrees (t:ts) = - "|" : shft "+- " "| " (drawEntry t) ++ drawSubTrees ts - - shft first other = zipWith (++) (first : repeat other) - -showLayout :: Layout -> String -showLayout NoChange = "" -showLayout (Above so p1 (r,c) eo) = "(Above "++ show so ++ " " ++ show p1 ++ " " ++ show (r,c) ++ " " ++ show eo ++ ")" --- showLayout (Offset r c) = "(Offset " ++ show r ++ " " ++ show c ++ ")" - --- --------------------------------------------------------------------- - -drawTreeCompact :: Tree (Entry PosToken) -> String -drawTreeCompact = unlines . drawTreeCompact' 0 - -drawTreeCompact' :: Int -> Tree (Entry PosToken) -> [String] -drawTreeCompact' level (Node (Deleted sspan _pg eg ) _ ) = [(show level) ++ ":" ++ (showForestSpan sspan) ++ (show eg) ++ "D"] -drawTreeCompact' level (Node (Entry sspan lay _toks) ts0) = ((show level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay)) - : (concatMap (drawTreeCompact' (level + 1)) ts0) --} --- --------------------------------------------------------------------- -{- -showTree :: Tree (Entry PosToken) -> String -showTree = prettyshow - --- |Represent a tree in a more concise/pretty way -prettyshow :: Tree (Entry PosToken) -> String -prettyshow (Node (Deleted sspan _pg eg) _nullSubs) - = "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")" -prettyshow (Node (Entry sspan _lay toks) sub) - = "Node (Entry " ++ (showForestSpan sspan) ++ " " - ++ (prettyToks toks) ++ ") " - -- ++ show (map prettyshow sub) - ++ "[" ++ intercalate "," (map prettyshow sub) ++ "]" - -prettyToks :: [PosToken] -> String -prettyToks [] = "[]" -prettyToks toks@[_x] = showToks toks -prettyToks toks@[_t1,_t2] = showToks toks -prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks] --} --- --------------------------------------------------------------------- -{- --- |Make a tree representing a particular set of tokens -mkTreeFromTokens :: [PosToken] -> Tree (Entry PosToken) -mkTreeFromTokens [] = Node (Entry nullForestSpan NoChange []) [] -mkTreeFromTokens toks = Node (Entry sspan NoChange toks) [] - where - (startLoc',endLoc') = nonCommentSpan toks - sspan = if (startLoc',endLoc') == ((0,0),(0,0)) - then error $ "mkTreeFromTokens:null span for:" ++ (show toks) - else simpPosToForestSpan (startLoc',endLoc') - --- --------------------------------------------------------------------- - --- |Make a tree representing a particular set of tokens -mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree (Entry PosToken) -mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) [] --} --- --------------------------------------------------------------------- - -ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) -ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) - --- --------------------------------------------------------------------- - --- |Synchronise a located AST fragment to use a newly created SrcSpan --- in the token tree. --- TODO: Should this indent the tokens as well? -syncAST :: (SYB.Data t) - => GHC.Located t -- ^The AST (or fragment) - -> ForestSpan -- ^The SrcSpan created in the Tree (Entry PosToken) - -> (GHC.Located t) -- ^Updated AST and tokens -syncAST ast@(GHC.L l _t) fspan = GHC.L sspan xx - where - sspan = f2ss fspan - (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l - ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan - - rowOffset = nsr - sr - colOffset = nsc - sc - - -- TODO: take cognizance of the ForestLines encoded in srcspans - -- when calculating the offsets etc - syncSpan s = addOffsetToSrcSpan (rowOffset,colOffset) s - - (GHC.L _s xx) = everywhereStaged SYB.Renamer ( - SYB.mkT hsbindlr - `SYB.extT` sig - `SYB.extT` ty - `SYB.extT` name - `SYB.extT` lhsexpr - `SYB.extT` lpat - `SYB.extT` limportdecl - `SYB.extT` lmatch - ) ast - - hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name) - sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name - ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name) - name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name - lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name - lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name - limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name - lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name - --- --------------------------------------------------------------------- -{- --- | indent the tree and tokens by the given offset, and sync the AST --- to the tree too. -indentDeclToks :: (SYB.Data t) - => GHC.Located t -- ^The AST (or fragment) - -> Tree (Entry PosToken) -- ^Existing token tree - -> Int -- ^ (signed) number of columns to indent/dedent - -> (GHC.Located t, Tree (Entry PosToken)) -- ^Updated AST and tokens -indentDeclToks decl@(GHC.L sspan _) forest offset = (decl',forest'') - where - -- make sure the span is in the forest - (forest',tree) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) - - z = openZipperToSpan (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest' - - tree' = go tree - -- The invariant will fail if we do not propagate this change - -- upward. But it needs to sync with the AST, which we do not have - -- the upward version of. - -- Instead, set the lengthChanged flag, in the parent. - - -- sss = forestSpanFromEntry entry - -- sss' = insertLenChangedInForestSpan True sss - -- tree'' = Node (putForestSpanInEntry entry sss') subs - - markLenChanged (Node entry subs) = (Node entry' subs) - where - sss = forestSpanFromEntry entry - sss' = insertLenChangedInForestSpan True sss - entry' = putForestSpanInEntry entry sss' - - z' = Z.setTree tree' z - -- forest'' = Z.toTree (Z.setTree tree'' z) - - forest'' = case Z.parent z' of - Nothing -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z' ) z' ) - Just z'' -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z'') z'') - - - decl' = syncAST decl (addOffsetToSpan off sspan) tree - - off = (0,offset) - - -- Pretty sure this could be a fold of some kind - go (Node (Deleted ss pg eg) sub) = (Node (Deleted (addOffsetToForestSpan off ss) pg eg) sub) - go (Node (Entry ss lay []) sub) = (Node (Entry (addOffsetToForestSpan off ss) lay []) (map go sub)) - go (Node (Entry ss lay toks) []) = (Node (Entry (addOffsetToForestSpan off ss) lay (addOffsetToToks off toks)) []) - go n = error $ "indentDeclToks:strange node:" ++ (show n) --} --- --------------------------------------------------------------------- -{- -addOffsetToForestSpan :: (Int,Int) -> ForestSpan -> ForestSpan -addOffsetToForestSpan (lineOffset,colOffset) fspan = fspan' - where - ((ForestLine sch str sv sl,sc),(ForestLine ech etr ev el,ec)) = fspan - fspan' = ((ForestLine sch str sv (sl+lineOffset),sc+colOffset), - (ForestLine ech etr ev (el+lineOffset),ec+colOffset)) --} --- --------------------------------------------------------------------- - -addOffsetToSrcSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan -addOffsetToSrcSpan (lineOffset,colOffset) sspan = sspan' - where - sspan' = case sspan of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss) - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss) - in - GHC.mkSrcSpan locStart locEnd - _ -> sspan - --- --------------------------------------------------------------------- - -showSrcSpan :: GHC.SrcSpan -> String -showSrcSpan sspan = show (getGhcLoc sspan, (r,c)) - where - (r,c) = getGhcLocEnd sspan - -showSrcSpanF :: GHC.SrcSpan -> String -showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce)) - where - ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = ghcSrcSpanToForestSpan sspan - -- chsn = if chs then 1 else 0 - -- chen = if che then 1 else 0 - - --- --------------------------------------------------------------------- - -ss2f :: GHC.SrcSpan -> ForestSpan -ss2f = ghcSrcSpanToForestSpan - -f2ss :: ForestSpan -> GHC.SrcSpan -f2ss = forestSpanToGhcSrcSpan - -ss2s :: GHC.SrcSpan -> Span -ss2s ss = Span (getGhcLoc ss) (getGhcLocEnd ss) - -s2ss :: Span -> GHC.SrcSpan -s2ss (Span (sr,sc) (er,ec)) = GHC.mkSrcSpan locStart locEnd - where - fname = GHC.mkFastString "foo" - locStart = GHC.mkSrcLoc fname sr sc - locEnd = GHC.mkSrcLoc fname er ec -{- --- | ForestSpan version of GHC combineSrcSpans -combineSpans :: ForestSpan -> ForestSpan -> ForestSpan -combineSpans fs1 fs2 = fs' - where - [lowFs,highFs] = sort [fs1,fs2] - ((ForestLine chls trls vls lls ,cls),(ForestLine _chle _trle _vle _lle,_cle)) = lowFs - ((ForestLine _chhs _trhs _vhs _lhs,_chs),(ForestLine chhe trhe vhe lhe, che)) = highFs - - fs' = ((ForestLine chls trls vls lls,cls),(ForestLine chhe trhe vhe lhe,che)) --} + -- * Operations at 'TokenCache' level + putDeclToksInCache + , syncAstToLatestCache + + -- * Operations at 'Tree' 'Entry' level + , addDeclToksAfterSrcSpan + , syncAST + + -- * Utility + , posToSrcSpan + , posToSrcSpanTok + + -- * Internal, for testing + , nonCommentSpan + , showSrcSpan + , showSrcSpanF + , ghcSpanStartEnd + , stripForestLineFromGhc + , ghcSrcSpanToForestSpan + , deleteGapsToks + ) where + +-- import qualified FastString as GHC +import qualified GHC as GHC + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import Language.Haskell.Refact.Utils.GhcUtils +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.TypeSyn + +import Language.Haskell.TokenUtils.GHC.Layout +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.Utils + +import Data.Tree +import qualified Data.Map as Map + +-- import Debug.Trace +-- debug = flip trace + +-- --------------------------------------------------------------------- + +ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan +ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) + where + (startRow,startCol) = getGhcLoc sspan + (endRow,endCol) = getGhcLocEnd sspan + +-- --------------------------------------------------------------------- + +putDeclToksInCache :: (SYB.Data t) => + TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> GHC.Located t + -> (TokenCache PosToken,GHC.SrcSpan,GHC.Located t) +putDeclToksInCache tk sspan toks t = (tk'',ss2gs newSpan,t') + where + (tk'',newSpan) = putToksInCache tk (gs2ss sspan) toks + t' = syncAST t (ss2f newSpan) + +-- --------------------------------------------------------------------- + +-- |Assuming most recent operation has stashed the old tokens, sync +-- the given AST to the most recent stash entry +syncAstToLatestCache :: (SYB.Data t) => TokenCache PosToken -> GHC.Located t -> GHC.Located t +syncAstToLatestCache tk t = t' + where + mainForest = (tkCache tk) Map.! mainTid + (Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) + pos = forestSpanToGhcPos fspan + sspan = posToSrcSpan mainForest pos + t' = syncAST t (gs2f sspan) + +-- --------------------------------------------------------------------- + +-- | Process the leaf nodes of a tree to remove all deleted spans +deleteGapsToks :: [Entry PosToken] -> [PosToken] +deleteGapsToks toks = goDeleteGapsToks (0,0) toks + +goDeleteGapsToks :: SimpPos -> [Entry PosToken] -> [PosToken] +goDeleteGapsToks _ [] = [] +goDeleteGapsToks offset [Entry _ _ t] = map (increaseSrcSpan offset) t +goDeleteGapsToks _ [Deleted _ _ _] = [] +goDeleteGapsToks offset (Deleted _ _ _:ts) = goDeleteGapsToks offset ts +goDeleteGapsToks offset [Entry _ _ t,Deleted _ _ _] = map (increaseSrcSpan offset) t +goDeleteGapsToks offset (Entry _ _ t1:e@(Entry _ _ _):ts) = (map (increaseSrcSpan offset) t1) ++goDeleteGapsToks offset (e:ts) +goDeleteGapsToks (fr,fc) (Entry ss _lay1 t1:Deleted _ _ eg:t2:ts) + = t1' ++ goDeleteGapsToks offset' (t2:ts) + where + -- TODO: use actual first and last toks, may be comments + -- TODO: what about deletion within a line? + + (deltaR,_deltaC) = eg + (_,(sr,_sc)) = forestSpanToSimpPos ss + ((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2 + offset' = (fr + (sr - dr) + deltaR, fc) + + t1' = map (increaseSrcSpan (fr,fc)) t1 + +-- --------------------------------------------------------------------- + +stripForestLineFromGhc :: GHC.SrcSpan -> GHC.SrcSpan +stripForestLineFromGhc l = l' + where + ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l + l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l + +-- --------------------------------------------------------------------- + +-- |Add new tokens belonging to an AST fragment after a given SrcSpan, +-- and re-sync the AST fragment to match the new location +addDeclToksAfterSrcSpan :: (SYB.Data t) => + Tree (Entry PosToken) -- ^TokenTree to be modified + -> GHC.SrcSpan -- ^Preceding location for new tokens + -> Positioning + -> [PosToken] -- ^New tokens to be added + -> GHC.Located t -- ^Declaration the tokens belong to, to be synced + -> (Tree (Entry PosToken), GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for + -- -> (Tree (Entry PosToken), GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for + -- the new tokens in the TokenTree, and + -- updated AST element +addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest',(ss2gs newSpan),t') + where + (forest',newSpan) = addToksAfterSrcSpan forest (gs2ss oldSpan) pos toks + t' = syncAST t (ss2f newSpan) + +-- --------------------------------------------------------------------- + +-- |Convert a simple (start,end) position to a SrcSpan belonging to +-- the file in the tree +posToSrcSpan :: Tree (Entry PosToken) -> (SimpPos,SimpPos) -> GHC.SrcSpan +posToSrcSpan forest ((rs,cs),(re,ce)) = sspan + where + (GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest -- ++AZ++ Ouch, performance?? + sspan = case l of + GHC.RealSrcSpan ss -> + let + locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs + locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce + in + GHC.mkSrcSpan locStart locEnd + _ -> error "posToSrcSpan: invalid SrcSpan in first tok" + +-- --------------------------------------------------------------------- + +-- |Convert a simple (start,end) position to a SrcSpan belonging to +-- the file in the given token +posToSrcSpanTok :: PosToken -> (SimpPos,SimpPos) -> GHC.SrcSpan +posToSrcSpanTok tok ((rs,cs),(re,ce)) = sspan + where + (GHC.L l _,_) = tok + sspan = case l of + GHC.RealSrcSpan ss -> + let + locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs + locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce + in + GHC.mkSrcSpan locStart locEnd + _ -> error "posToSrcSpan: invalid SrcSpan in first tok" + +-- --------------------------------------------------------------------- +{- +-- |Get the start and end position of a SrcSpan +-- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos) +-- spanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) +spanStartEnd :: GHC.SrcSpan -> ForestSpan +spanStartEnd sspan = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec)) + where + ((sr,sc),(er,ec)) = (getGhcLoc sspan,getGhcLocEnd sspan) +-} +-- --------------------------------------------------------------------- + +ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) +ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) + +-- --------------------------------------------------------------------- + +-- |Synchronise a located AST fragment to use a newly created SrcSpan +-- in the token tree. +-- TODO: Should this indent the tokens as well? +syncAST :: (SYB.Data t) + => GHC.Located t -- ^The AST (or fragment) + -> ForestSpan -- ^The SrcSpan created in the Tree (Entry PosToken) + -> (GHC.Located t) -- ^Updated AST and tokens +syncAST ast@(GHC.L l _t) fspan = GHC.L sspan xx + where + sspan = f2gs fspan + (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l + ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan + + rowOffset = nsr - sr + colOffset = nsc - sc + + -- TODO: take cognizance of the ForestLines encoded in srcspans + -- when calculating the offsets etc + syncSpan s = addOffsetToSrcSpan (rowOffset,colOffset) s + + (GHC.L _s xx) = everywhereStaged SYB.Renamer ( + SYB.mkT hsbindlr + `SYB.extT` sig + `SYB.extT` ty + `SYB.extT` name + `SYB.extT` lhsexpr + `SYB.extT` lpat + `SYB.extT` limportdecl + `SYB.extT` lmatch + ) ast + + hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name) + sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name + ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name) + name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name + lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name + lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name + limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name + lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name + +-- --------------------------------------------------------------------- + +addOffsetToSrcSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan +addOffsetToSrcSpan (lineOffset,colOffset) sspan = sspan' + where + sspan' = case sspan of + GHC.RealSrcSpan ss -> + let + locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss) + locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss) + in + GHC.mkSrcSpan locStart locEnd + _ -> sspan + +-- --------------------------------------------------------------------- -- EOF diff --git a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs b/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +++ /dev/null @@ -1,188 +0,0 @@ --- | --- --- This module contains types shared between TokenUtils and Monad, and --- exists to break import cycles --- --- - -module Language.Haskell.Refact.Utils.TokenUtilsTypes( -{- - -- * The cache of trees comprising the manipulated tokens - TokenCache(..) - , TreeId(..) - , mainTid - -- * Structure of each tree - , Entry(..) - , Layout(..) - , EndOffset(..) - , RowOffset - , ColOffset - , Row - , Col - , ForestLine(..) - , ForestPos - , ForestSpan --} - PprOrigin(..) - , Ppr(..) - -- , HDoc(..) - ) where - -import Language.Haskell.TokenUtils.Types - --- import Outputable - --- --------------------------------------------------------------------- - -{- - -Structure is to be indexed by SrcSpan. - -Must be recursive, so if one srcspan is requested that contains a -modified sub-src span, the modified one is returned. - -When initialising, split the tokens according to the binds, including -the leading and following comments. And perhaps a preamble and -postamble. - -The token start and end loc does not necessarily coincide with the -associated srcloc, due to leading / trailing comments - -SrcSpans are nested in one another according to the structure of the -AST. - -Store it in some kind of tree structure. - -Invariants: - 1. For each tree, either the rootLabel has a SrcSpan only, or the subForest /= []. - 2. The trees making up the subForest of a given node fully include the parent SrcSpan. - i.e. the leaves contain all the tokens for a given SrcSpan. - 3. A given SrcSpan can only appear (or be included) in a single tree of the forest. - -There are conflicting requirements for access to the tokens. On the -one hand the tokens need to be moved around (mainly in columns) to -support changing layout as e.g. a token is renamed. On the other, the -originals need to be preserved, so they can tie up with the positions -in the SrcSpans and for renaming. - -Question: is the latter statement valid? ++AZ++ - --} - -{- --- TODO: turn this into a record, with named accessors --- | An entry in the data structure for a particular srcspan. -data Entry = Entry !ForestSpan -- The source span contained in this - -- Node - !Layout -- How the sub-elements nest - ![PosToken] -- ^The tokens for the SrcSpan if - -- subtree is empty - | Deleted !ForestSpan -- The source span has been deleted - RowOffset -- prior gap in lines - SimpPos -- ^The gap between this span end and - -- the start of the next in the - -- fringe of the tree. --- deriving (Show) --} -{- -type RowOffset = Int -type ColOffset = Int -type Row = Int -type Col = Int --} -{- -data Layout = Above EndOffset (Row,Col) (Row,Col) EndOffset - -- ^ Initial offset from token before the - -- stacked list of items, the (r,c) of the first - -- non-comment token, the (r,c) of the end of the last non-comment - -- token in the stacked list to be able to calculate the - -- (RowOffset,ColOffset) between the last token and the - -- start of the next item. - | NoChange - deriving (Show,Eq) --} -{- -data EndOffset = None - | SameLine ColOffset - | FromAlignCol (RowOffset, ColOffset) - deriving (Show,Eq) --} - --- --------------------------------------------------------------------- -{- -data ForestLine = ForestLine - { flSpanLengthChanged :: !Bool -- ^The length of the - -- span may have - -- changed due to - -- updated tokens. - , flTreeSelector :: !Int - , flInsertVersion :: !Int - , flLine :: !Int - } -- deriving (Eq) --} -{- -instance Eq ForestLine where - -- TODO: make this undefined, and patch all broken code to use the - -- specific fun here directly instead. - (ForestLine _ s1 v1 l1) == (ForestLine _ s2 v2 l2) = s1 == s2 && v1 == v2 && l1 == l2 - -instance Show ForestLine where - show s = "(ForestLine " ++ (show $ flSpanLengthChanged s) - ++ " " ++ (show $ flTreeSelector s) - ++ " " ++ (show $ flInsertVersion s) - ++ " " ++ (show $ flLine s) - ++ ")" - -instance Outputable ForestLine where - ppr fl = text (show fl) --} - --- --------------------------------------------------------------------- -{- -type ForestPos = (ForestLine,Int) - - --- |Match a SrcSpan, using a ForestLine as the marker -type ForestSpan = (ForestPos,ForestPos) --} --- --------------------------------------------------------------------- - -{- -data TreeId = TId !Int deriving (Eq,Ord,Show) - --- |Identifies the tree carrying the main tokens, not any work in --- progress or deleted ones -mainTid :: TreeId -mainTid = TId 0 --} -{- -data TokenCache = TK - { tkCache :: !(Map.Map TreeId (Tree Entry)) - , tkLastTreeId :: !TreeId - } --} --- --------------------------------------------------------------------- - -data PprOrigin = Original -- ^ Original tokens - | Added -- ^ Added tokens - deriving (Eq,Show) - --- --------------------------------------------------------------------- - --- |A data structure to make the ppr process visible -data Ppr = PprText Row Col PprOrigin String - -- ^Original row and col of the tokens making up the string - | PprAbove EndOffset (Row,Col) EndOffset [Ppr] - -- ^ Offset of start of embedded parts, coords of last token, - -- offset to start of next part, relative to the column of - -- the start - | PprDeleted Row Col RowOffset RowOffset RowOffset -- String - -- ^ Marks lines that have been deleted together with the - -- original gap before, how many lines were originally - -- included, and gap after. - -- And a note field for debugging - deriving (Eq,Show) - --- --------------------------------------------------------------------- - --- EOF diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -21,8 +21,6 @@ -- type InScopes=((Relations.Rel Names.QName (Ents.Ent PosName.Id))) type InScopes = [GHC.Name] --- type SimpPos = (Int,Int) -- Line, column - -- Additions for GHC type PosToken = (GHC.Located GHC.Token, String) @@ -89,25 +87,6 @@ -- --------------------------------------------------------------------- -type HsModuleP = GHC.Located (GHC.HsModule GHC.RdrName) - --- --------------------------------------------------------------------- --- Putting these here for the time being, to avoid import loops -{- -ghead :: String -> [a] -> a -ghead info [] = error $ "ghead "++info++" []" -ghead _info (h:_) = h - -glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h - -gtail :: String -> [a] -> [a] -gtail info [] = error $ "gtail " ++ info ++ " []" -gtail _info h = tail h +-- type HsModuleP = GHC.Located (GHC.HsModule GHC.RdrName) -gfromJust :: [Char] -> Maybe a -> a -gfromJust _info (Just h) = h -gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" --} -- --------------------------------------------------------------------- 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 @@ -38,39 +38,40 @@ ( -- * Program Analysis -- ** Imports and exports - inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames - -- , hsQualifier, {-This function should be removed-} rmPrelude - {-,exportInfo -}, isExported, isExplicitlyExported, modIsExported + inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames + , isExported, isExplicitlyExported, modIsExported -- ** Variable analysis , isFieldName , isClassName , isInstanceName - ,hsPNs -- ,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls - {- ,hsClassMembers -} , hsBinds, replaceBinds, HsValBinds(..) + ,hsPNs ,isDeclaredIn - ,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings + ,hsFreeAndDeclaredPNsOld + ,hsFreeAndDeclaredNameStrings ,hsFreeAndDeclaredPNs ,hsFreeAndDeclaredGhc ,getDeclaredTypes - ,getFvs, getFreeVars, getDeclaredVars -- These two should replace hsFreeAndDeclaredPNs - - ,hsVisiblePNs {- , hsVisiblePNsOld -}, hsVisibleNames + ,getFvs, getFreeVars, getDeclaredVars + ,hsVisiblePNs, hsVisibleNames ,hsFDsFromInside, hsFDNamesFromInside ,hsVisibleDs -- ** Property checking - ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT - ,isQualifiedPN {- , isFunName, isPatName-}, isFunOrPatName {-,isTypeCon-} ,isTypeSig + ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName + ,isQualifiedPN, isFunOrPatName, isTypeSig ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind - ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR -- ,isClassDecl,isInstDecl -- ,isDirectRecursiveDef - ,usedWithoutQualR {- ,canBeQualified, hasFreeVars -},isUsedInRhs + ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR + ,usedWithoutQualR,isUsedInRhs + + -- ** Getting ,findPNT,findPN,findAllNameOccurences ,findPNs, findEntity, findEntity' - , findIdForName - , getTypeForName + ,findIdForName + ,getTypeForName + ,sameOccurrence - ,defines, definesP,definesTypeSig -- , isTypeSigOf + ,defines, definesP,definesTypeSig -- ,HasModName(hasModName), HasNameSpace(hasNameSpace) ,sameBind {- ,usedByRhs -},UsedByRhs(..) @@ -88,8 +89,8 @@ -- * Program transformation -- ** Adding - ,addDecl, addItemsToImport, addHiding --, rmItemsFromImport, addItemsToExport - ,addParamsToDecls, addActualParamsToRhs {- , addGuardsToRhs-}, addImportDecl, duplicateDecl -- , moveDecl + ,addDecl, addItemsToImport, addHiding + ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- ** Removing ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) @@ -137,18 +138,20 @@ , getParsedForRenamedLocated -- , allPNT -- , allPNTLens - , newNameTok + -- , newNameTok , stripLeadingSpaces -- , lookupNameGhc ) where -import Control.Monad.IO.Class () +-- import Control.Monad.IO.Class () import Control.Monad.State import Data.Char import Data.List import Data.Maybe import Data.Monoid import Exception + +import Language.Haskell.Refact.Utils.Binds import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils @@ -156,16 +159,18 @@ import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.TokenUtils import Language.Haskell.Refact.Utils.TypeSyn + +import Language.Haskell.TokenUtils.GHC.Layout import Language.Haskell.TokenUtils.TokenUtils import Language.Haskell.TokenUtils.Types import Language.Haskell.TokenUtils.Utils -- Modules from GHC import qualified Bag as GHC -import qualified BasicTypes as GHC +-- import qualified BasicTypes as GHC import qualified FastString as GHC import qualified GHC as GHC -import qualified Lexer as GHC hiding (getSrcLoc) +-- import qualified Lexer as GHC hiding (getSrcLoc) import qualified Module as GHC import qualified Name as GHC import qualified NameSet as GHC @@ -233,20 +238,7 @@ GHC.Qual modName _occName -> Just modName _ -> Nothing - -- getEntInfo (qual, ent@(Ent modName ident _)) - -- =(identToName ident, hasNameSpace ent, modName, getQualifier qual) -{- --- | Process the export relation returned from the parsing and module analysis pass, and --- return a list of trhee-element tuples. Each tuple contains an identifier name, the --- identifier's namespace info, and the identifier's define module. -exportInfo::Exports -- ^ The export relation. - -> [(String, NameSpace, ModuleName)] -- ^ The result -exportInfo exports = nub $ map getEntInfo exports - where - getEntInfo (_, ent@(Ent modName ident _)) - =(identToName ident, hasNameSpace ent, modName) --} -- | Return True if the identifier is inscope and can be used without -- a qualifier. @@ -450,40 +442,7 @@ -- 3. if so, if the new module is exported unqualified -- or belongs to the current module -- then it will cause a clash -{- -modNames capture potential clashes e.g. - -@ -module Exports (head) where - -import Data.Text (head) -@ - -So if the new name was 'head', then the modNames would be - [Data.Text] - --} - - -{- ++AZ++ Original - --- Note that in the abstract representation of exps, there is no qualified entities. -causeNameClashInExports pn newName mod exps - = let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName - then [modName] - else []) exps) - in (isExplicitlyExported pn mod) && - ( any (modIsUnQualifedImported mod) modNames - || elem (let (SN modName1 _) =hsModName mod - in modName1) modNames) - where - modIsUnQualifedImported mod modName - =let imps =hsModImports mod - in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h)->modName==modName1 && (not qualify)) imps - --} - -- --------------------------------------------------------------------- -- | Collect the free and declared variables (in the GHC.Name format) -- in a given syntax phrase t. In the result, the first list contains @@ -865,7 +824,7 @@ ltydecl (GHC.L _ (GHC.TyDecl (GHC.L _ n) _bndrs _defn fvs)) = return (FN (GHC.nameSetToList fvs),DN [n]) #else - ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs)) + ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs)) = return (FN [],DN [n]) -- TODO: calc fvs for cons ltydecl (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) = return (FN [],DN [n]) -- TODO fvs? @@ -1327,7 +1286,7 @@ dsn = getHsTyDefn defn #else -- data, -getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs)) +getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs)) = nub $ [n] ++ cs where getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n2) _ _ _ _ _ _ _)) = n2 @@ -1938,29 +1897,8 @@ isFunOrPatBindR::GHC.LHsBind t -> Bool isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl -{- --- | Return True if a declaration is a Class declaration. -isClassDecl :: HsDeclP ->Bool -isClassDecl (TiDecorate.Dec (HsClassDecl _ _ _ _ _)) = True -isClassDecl _ = False - --- | Return True if a declaration is a Class instance declaration. -isInstDecl :: HsDeclP -> Bool -isInstDecl (TiDecorate.Dec (HsInstDecl _ _ _ _ _)) = True -isInstDecl _ = False --} -{- --- | Return True if a function is a directly recursive function. -isDirectRecursiveDef::HsDeclP->Bool -isDirectRecursiveDef (TiDecorate.Dec (HsFunBind loc ms)) - = any isUsedInDef ms - where - isUsedInDef (HsMatch loc1 fun pats rhs ds) - = findEntity (pNTtoPN fun) rhs -isDirectRecursiveDef _ = False --} ------------------------------------------------------------------------------- - +{- getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name] getValBindSigs binds = case binds of GHC.ValBindsIn _ sigs -> sigs @@ -1979,9 +1917,10 @@ mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2)) mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2)) +-} -- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after - +{- hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] hsBinds t = case hsValBinds t of GHC.ValBindsIn binds _sigs -> GHC.bagToList binds @@ -1994,7 +1933,8 @@ sigs = case hsValBinds t of GHC.ValBindsIn _ s -> s GHC.ValBindsOut _ s -> s - +-} +{- -- This class replaces the HsDecls one class (SYB.Data t) => HsValBinds t where @@ -2017,12 +1957,12 @@ -- in the given syntax phrase. Note: only makes sense for -- GHC.RenamedSource hsTyDecls :: t -> [[GHC.LTyClDecl GHC.Name]] - +-} -- ++AZ++ see if we can get away with one only.. isDeclaredIn :: (HsValBinds t) => GHC.Name -> t -> Bool isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True - +{- instance HsValBinds (GHC.RenamedSource) where hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) @@ -2330,7 +2270,7 @@ hsTyDecls _ = [] -- --------------------------------------------------------------------- - +-} -- --------------------------------------------------------------------- @@ -2401,21 +2341,10 @@ -- --------------------------------------------------------------------- -{- + -- | Returns True is a syntax phrase, say a, is part of another syntax -- phrase, say b. -- Expects to be at least Parser output -findEntity:: (SYB.Data a, SYB.Data b)=> a -> b -> Bool -findEntity a b = fromMaybe False res - where - res = somethingStaged SYB.Parser Nothing worker b - - worker :: (SYB.Typeable b, SYB.Data b) => b -> Maybe Bool - worker b = if SYB.typeOf a == SYB.typeOf b - -- then Just (getStartEndLoc b == getStartEndLoc a) - then Just True -- ++AZ++ test for now - else Nothing --} findEntity':: (SYB.Data a, SYB.Data b) => a -> b -> Maybe (SimpPos,SimpPos) findEntity' a b = res @@ -2820,123 +2749,13 @@ | showGhc name == str = Just name workerExpr _ = Nothing - - ------------------------------------------------------------------------------------- - - -- --------------------------------------------------------------------- -- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs -- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add -- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create -- an explict export list to contain only the new identifiers, otherwise do nothing. -{- -addItemsToExport::( ) - => HsModuleP -- The module AST. - -> Maybe PName -- The condtion identifier. - -> Bool -- Create an explicit list or not - -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. - -> m HsModuleP -- The result. --} -{- -addItemsToExport::(MonadState (([PosToken],Bool), t1) m) - => HsModuleP -- The module AST. - -> Maybe PName -- The condtion identifier. - -> Bool -- Create an explicit list or not - -> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format. - -> m HsModuleP -- The result. - -addItemsToExport mod _ _ (Left []) = return mod -addItemsToExport mod _ _ (Right []) = return mod -addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids - = case exps of - Just ents ->let (e1,e2) = break (findEntity pn) ents - in if e2 /=[] - then do ((toks,_),others)<-get - let e = (ghead "addVarItemInExport" e2) - es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - let (_,endPos) = getStartEndLoc toks e - (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks - newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) - toks' = replaceToks toks endPos endPos [newToken] - put ((toks',modified),others) - return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds) - else return mod - Nothing -> return mod - -addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids - = do ((toks,_),others)<-get - let es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - (t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '(' - newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++","))) - else (t, (pos,(s++showEntities (render.ppi) es))) - pos'= simpPos pos - toks' = replaceToks toks pos' pos' [newToken] - put ((toks',modified),others) - return mod {hsModExports=Just (es++ ents)} - -addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids - =case createExp of - True ->do ((toks,_),others)<-get - let es = case ids of - (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is' - (Right es') -> es' - pos = (row,col) - newToken = mkToken Varid pos (modNameToStr modName++ "(" - ++ showEntities (render.ppi) es++")") - toks' = replaceToks toks pos pos [newToken] - put ((toks', modified), others) - return mod {hsModExports=Just es} - False ->return mod --} - -{- -addItemsToImport::( ) - =>ModuleName -- ^ The imported module name. - ->Maybe PName -- ^ The condition identifier. - ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format. - ->t -- ^ The given syntax phrase. - ->m t -- ^ The result. --} - -{- -addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m) - =>ModuleName -- ^ The imported module name. - ->Maybe PName -- ^ The condition identifier. - ->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format. - ->t -- ^ The given syntax phrase. - ->m t -- ^ The result. - -addItemsToImport serverModName pn (Left []) t = return t -addItemsToImport serverModName pn (Right []) t = return t -addItemsToImport serverModName pn ids t - =applyTP (full_buTP (idTP `adhocTP` inImport)) t - where - inImport (imp@(HsImportDecl loc m@(SN modName _) qual as h):: HsImportDeclP) - | serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True) - = case h of - Nothing -> return imp - Just (b, ents) -> do let ents'=case ids of - Left is' -> map (\x-> Var (nameToPNT x)) is' - Right es -> es - ((toks,_),others)<-get - let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents) - (t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks - newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents') - toks'=replaceToks toks endPos endPos [newToken] - put ((toks',modified),others) - return (HsImportDecl loc m qual as (Just (b, ents++ents'))) - inImport imp = return imp --} - --- --------------------------------------------------------------------- - addImportDecl :: GHC.RenamedSource -> GHC.ModuleName @@ -2971,7 +2790,7 @@ newToks <- liftIO $ basicTokenise (showGhc impDecl) logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ++ - void $ putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks + void $ addToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c) where @@ -3167,9 +2986,9 @@ if (emptyList localDecls) then - void $ putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent 4 2) newToks + void $ addToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent 4 2) newToks else - void $ putToksAfterPos (startLoc,endLoc) (PlaceAbsCol (rowIndent+1) prevCol 2) newToks + void $ addToksAfterPos (startLoc,endLoc) (PlaceAbsCol (rowIndent+1) prevCol 2) newToks return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds)))) @@ -3367,7 +3186,7 @@ Left l@(GHC.RealSrcSpan ss) -> do newToks' <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr let newToks = map markToken newToks' - _ <- putToksAfterSpan l PlaceAdjacent newToks + _ <- addToksAfterSpan l PlaceAdjacent newToks return () Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss) Right pats -> do @@ -3504,145 +3323,6 @@ -} - -{- - addActualParamsToRhs pn paramPNames - = applyTP (stop_tdTP (failTP `adhocTP` worker)) - where - worker exp@(TiDecorate.Exp (HsId (HsVar (PNT pname ty loc)))) - | pname==pn - = do let newExp=TiDecorate.Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames))) - if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint - return newExp' - else return newExp - worker x =mzero - - addParamToExp exp param=(TiDecorate.Exp (HsApp exp param)) --} - - - --- | Remove those specified items from the entity list in the import declaration. -{- - rmItemsFromImport::( ) - =>HsModuleP -- ^ The module AST - ->[PName] -- ^ The items to be removed - ->m HsModuleP -- ^ The result --} - -{- -rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m) - =>HsModuleP -- ^ The module AST - ->[PName] -- ^ The items to be removed - ->m HsModuleP -- ^ The result - - -rmItemsFromImport mod pns - = applyTP (full_buTP (idTP `adhocTP` inImport)) mod - where - inImport (imp@(HsImportDecl loc modName qual as h)::HsImportDeclP) - | any (flip findEntity imp) pns - = case h of - Just (b, ents) -> - do let matchedEnts=findEnts pns ents - if matchedEnts==[] - then return imp - else if length matchedEnts == length ents - then do ((toks,_),others)<-get - let (startPos,endPos)=getStartEndLoc toks ents - toks'=deleteToks toks startPos endPos - put ((toks',modified),others) - return (HsImportDecl loc modName qual as (Just (b,[]))) - else do ((toks,_),others)<-get - let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns - toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts - put ((toks',modified),others) - return (HsImportDecl loc modName qual as (Just (b, remainedEnts))) - _ ->return imp - inImport x = return x - - findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns - - -- this function does not check this sub entities of the ListSubs. any problems? - match::PName -> EntSpec PNT ->Bool - match pn (Var pnt) = pNTtoPN pnt == pn - match pn (Abs pnt) = pNTtoPN pnt == pn - match pn (AllSubs pnt) = pNTtoPN pnt == pn - match pn (ListSubs pnt _) = pNTtoPN pnt == pn --} - - -{- --- | Remove the sub entities of a type constructor or class from the export list. -rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m) - =>PName -- ^ The type constructor or class name - ->HsModuleP -- ^ The module AST - ->m HsModuleP -- ^ The result -rmSubEntsFromExport typeCon - = applyTP (full_buTP (idTP `adhocTP` inEntSpec)) - where - inEntSpec (ent@(AllSubs pnt)::EntSpec PNT) - | pNTtoPN pnt == typeCon - =do (ent', _)<-updateToks ent (Abs pnt) prettyprint - return ent' - inEntSpec (ent@(ListSubs pnt _)) - | pNTtoPN pnt == typeCon - = do (ent', _) <- updateToks ent (Abs pnt) prettyprint - return ent' - inEntSpec ent = return ent --} - ---------------------------------------------------------------------------------------- --- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats: --- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities. -{-rmItemsFromExport::( ) - =>HsModuleP -- ^ The module AST. - ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove. - ->m HsModuleP -- ^ The result. --} -{- -rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m) - =>HsModuleP -- ^ The module AST. - ->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove. - ->m HsModuleP -- ^ The result. - -rmItemsFromExport mod@(HsModule loc modName exps imps ds) (Left (modNames, pns)) - =if isNothing exps - then return mod - else do let ents =findEnts (modNames, pns) (fromJust exps) - rmItemsFromExport mod (Right ents) - where - findEnts (modNames, pns) ents - =let ms = concatMap (\m ->filter (\e -> case e of - ModuleE (SN m' _) -> m==m' - EntE e' -> False) ents) modNames - es =concatMap (\pn->filter (\e ->case e of - ModuleE _ -> False - EntE e' -> match pn e') ents) pns - in (ms++es) - match::PName -> EntSpec PNT ->Bool - match pn (Var pnt) = pNTtoPN pnt == pn - match pn (Abs pnt) = pNTtoPN pnt == pn - match pn (AllSubs pnt) = pNTtoPN pnt == pn - match pn (ListSubs pnt _) = pNTtoPN pnt == pn - -rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents) - = do exps'<- if ents==[] - then return exps - else if length ents == length es - then do ((toks,_),others)<-get - let (startPos,endPos) = getStartEndLoc toks ents - toks'= deleteToks toks startPos endPos - put ((toks',modified),others) - return (Just [] ) -- should not remove the empty bracket!!! - else do ((toks,_),others)<-get - let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents - put ((toks',modified),others) - return (Just (es \\ ents)) - return (HsModule loc modName exps' imps ds) -rmItemsFromExport mod _ = return mod --} - -- --------------------------------------------------------------------- -- | Duplicate a function\/pattern binding declaration under a new name @@ -4290,31 +3970,6 @@ return () else return () --- --------------------------------------------------------------------- - --- | Create a new name token. If 'useQual' then use the qualified --- name, if it exists. --- The end position is not changed, so the eventual realignment can --- know what the difference in length in the token is -newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> PosToken -newNameTok useQual l newName = - ((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr) - where - newNameStr = if useQual then (showGhc newName) - else (GHC.occNameString $ GHC.getOccName newName) - - l' = case l of - GHC.RealSrcSpan ss -> - let - ((ForestLine _ _ _ startRow,startCol),_) = ghcSrcSpanToForestSpan l - - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol) - in - GHC.mkSrcSpan locStart locEnd - _ -> l - - ---------------------------------------------------------------------------------------- -- | Check whether the specified identifier is declared in the given syntax phrase t, -- if so, rename the identifier by creating a new name automatically. If the Bool parameter @@ -4350,22 +4005,6 @@ showEntities _ [] = "" showEntities f [pn] = f pn showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns - - --- --------------------------------------------------------------------- -{- --- | Return True if the identifier can become qualified. -canBeQualified::(Term t)=>PNT->t->Bool -canBeQualified pnt t - = isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t) - where - findPntInImp pnt - = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp))) - where - inImp ((HsImportDecl loc modName qual as h)::HsImportDeclP) - |findEntity pnt h = Just True - inImp _ = Nothing --} -- ---------------------------------------------------------------------