HaRe 0.7.2.4 → 0.7.2.5

raw patch · 11 files changed

+755/−2997 lines, 11 filesdep ~basedep ~haskell-token-utilsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, haskell-token-utils

API changes (from Hackage documentation)

Files

• ChangeLog +3/−0
• HaRe.cabal +7/−7
• src/Language/Haskell/Refact/API.hs +6/−5
• src/Language/Haskell/Refact/Utils/Binds.hs +424/−0
• src/Language/Haskell/Refact/Utils/LocUtils.hs +7/−6
• src/Language/Haskell/Refact/Utils/Monad.hs +2/−1
• src/Language/Haskell/Refact/Utils/MonadFunctions.hs +30/−99
• src/Language/Haskell/Refact/Utils/TokenUtils.hs +233/−2266
• src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +0/−188
• src/Language/Haskell/Refact/Utils/TypeSyn.hs +1/−22
• src/Language/Haskell/Refact/Utils/TypeUtils.hs +42/−403

@@ -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

@@ -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:

@@ -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

@@ -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 _ = []++-- ---------------------------------------------------------------------

@@ -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,

@@ -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-+-} -- ---------------------------------------------------------------------  

@@ -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)]

@@ -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

@@ -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

@@ -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"--} -- ---------------------------------------------------------------------

@@ -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--}   -- ---------------------------------------------------------------------