HaRe 0.7.0.7 → 0.7.0.8
raw patch · 20 files changed
+3530/−211 lines, 20 filesdep +dual-treedep +hspec-discoverdep +monoid-extrasdep −cmdthelinedep ~HaRedep ~ghc-mod
Dependencies added: dual-tree, hspec-discover, monoid-extras, semigroups
Dependencies removed: cmdtheline
Dependency ranges changed: HaRe, ghc-mod
Files
- HaRe.cabal +29/−14
- src/Language/Haskell/Refact/Case.hs +8/−3
- src/Language/Haskell/Refact/DupDef.hs +2/−2
- src/Language/Haskell/Refact/MoveDef.hs +10/−9
- src/Language/Haskell/Refact/Renaming.hs +1/−1
- src/Language/Haskell/Refact/SwapArgs.hs +1/−1
- src/Language/Haskell/Refact/Utils.hs +22/−14
- src/Language/Haskell/Refact/Utils/DualTree.hs +498/−0
- src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +2/−2
- src/Language/Haskell/Refact/Utils/GhcUtils.hs +1/−0
- src/Language/Haskell/Refact/Utils/Layout.hs +1725/−0
- src/Language/Haskell/Refact/Utils/LayoutTypes.hs +36/−0
- src/Language/Haskell/Refact/Utils/LayoutUtils.hs +166/−0
- src/Language/Haskell/Refact/Utils/LocUtils.hs +12/−9
- src/Language/Haskell/Refact/Utils/Monad.hs +4/−4
- src/Language/Haskell/Refact/Utils/MonadFunctions.hs +82/−3
- src/Language/Haskell/Refact/Utils/TokenUtils.hs +815/−101
- src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +59/−2
- src/Language/Haskell/Refact/Utils/TypeSyn.hs +0/−5
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +57/−41
HaRe.cabal view
@@ -1,5 +1,5 @@ Name: HaRe-Version: 0.7.0.7+Version: 0.7.0.8 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha@@ -22,10 +22,6 @@ . Current known defects: .- * After renaming, the layout of nested let/where clauses is not adjusted.- This can cause problems if the new name is a different length from the- old one.- . * liftToTopLevel of a recursive function may introduce parameter errors. e.g. lifting 'g' in the 'zmapQ' function from 'syz-0.2.0.0' 'Data.Generics.Zipper' results in the following@@ -50,12 +46,18 @@ Build-Depends: base >= 4.0 && < 4.7 , containers , directory++ , dual-tree+ , semigroups+ , monoid-extras+ , filepath , ghc , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 3.1.2+ , ghc-mod >= 3.1.4+ -- , lens , mtl , old-time , pretty@@ -67,7 +69,7 @@ , Strafunski-StrategyLib , syz - -- GHC-Options: -Wall+ GHC-Options: -Wall Hs-Source-Dirs: src Other-Modules: Paths_HaRe@@ -78,10 +80,14 @@ , Language.Haskell.Refact.Renaming , Language.Haskell.Refact.SwapArgs , Language.Haskell.Refact.Utils+ , Language.Haskell.Refact.Utils.DualTree , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph , Language.Haskell.Refact.Utils.GhcUtils , Language.Haskell.Refact.Utils.GhcVersionSpecific+ , Language.Haskell.Refact.Utils.Layout+ , Language.Haskell.Refact.Utils.LayoutTypes+ , Language.Haskell.Refact.Utils.LayoutUtils , Language.Haskell.Refact.Utils.LocUtils , Language.Haskell.Refact.Utils.Monad , Language.Haskell.Refact.Utils.MonadFunctions@@ -97,22 +103,26 @@ Executable ghc-hare Main-Is: MainHaRe.hs -- Other-Modules: Paths_HaRe- -- GHC-Options: -Wall+ GHC-Options: -Wall -- GHC-Options: -prof -fprof-auto -rtsopts -caf-all Hs-Source-Dirs: ./src Build-Depends: base >= 4.0 && < 4.7 , array- -- TODO: remove cmdtheline- , cmdtheline >= 0.2.1 , containers , directory++ , dual-tree+ , semigroups+ , monoid-extras+ , filepath , ghc , ghc-paths , ghc-prim , ghc-syb-utils- , ghc-mod >= 3.1.2+ , ghc-mod >= 3.1.4+ -- , lens , mtl , old-time , parsec@@ -124,7 +134,7 @@ , hslogger , Strafunski-StrategyLib , syz- , HaRe >= 0.7.0.0+ , HaRe >= 0.7.0.8 Extensions: CPP @@ -150,6 +160,11 @@ , HUnit == 1.2.* , QuickCheck >= 2.5 , containers++ , dual-tree+ , semigroups+ , monoid-extras+ , deepseq , directory , filepath@@ -158,8 +173,8 @@ , ghc-prim , ghc-syb-utils , ghc-mod >= 3.1.2- -- , hspec == 1.4.* , hspec+ , hspec-discover , mtl , old-time , process@@ -172,7 +187,7 @@ , hslogger , Strafunski-StrategyLib , syz- , HaRe >= 0.7.0.0+ , HaRe >= 0.7.0.8 Extensions: CPP source-repository head
src/Language/Haskell/Refact/Case.hs view
@@ -5,6 +5,7 @@ import qualified GHC as GHC +import Control.Monad import Control.Monad.IO.Class import Language.Haskell.GhcMod import Language.Haskell.Refact.Utils@@ -50,15 +51,16 @@ reallyDoIfToCase expr rs = do everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs+ showLinesDebug "after refactoring" return () where inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _))) | sameOccurrence expr exp1 = do+ drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug newExp <- ifToCaseTransform exp1- -- updateToks exp1 newExp prettyprint True- -- updateToks exp1 newExp prettyprint2 True+ let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l caseTok <- liftIO $ tokenise rl 0 False "case" condToks <- getToksForSpan l1@@ -101,7 +103,10 @@ -- drawTokenTreeDetailed "reallyDoIfToCase" - putToksForSpan l caseToks+ void $ putToksForSpan l caseToks++ -- drawTokenTree "reallyDoIfToCase after putToks"+ -- drawTokenTreeDetailed "reallyDoIfToCase after putToks" return newExp
src/Language/Haskell/Refact/DupDef.hs view
@@ -43,7 +43,7 @@ Just pn -> do -- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName- (refactoredMod@((_fp,ismod),(_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName)+ (refactoredMod@((_fp,ismod),(_,_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName) case (ismod) of False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module " True -> return ()@@ -189,7 +189,7 @@ -- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName (refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName) return refactoredMod- else return ((fileName,unmodified),([],renamed))+ else return ((fileName,unmodified),([],[],renamed)) where needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool needToBeHided name exps parsed = do
src/Language/Haskell/Refact/MoveDef.hs view
@@ -317,7 +317,7 @@ logm $ "moveDecl1: (ns,funBinding)=" ++ (showGhc (ns,funBinding)) -- ++AZ++ let Just sspan = getSrcSpan funBinding- -- drawTokenTree "before getting toks" -- ++AZ+++ drawTokenTree "before getting toks" -- ++AZ++ funToks <- getToksForSpan sspan logm $ "moveDecl1:funToks=" ++ (showToks funToks) drawTokenTree "moveDecl1:after getting toks" -- ++AZ++ 'in' present@@ -326,12 +326,12 @@ -- (t'',sigsRemoved) <- rmTypeSigs ns t (t'',sigsRemoved) <- rmTypeSigs sigNames t -- drawTokenTree "moveDecl1:after rmTypeSigs" -- ++AZ++- drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ+++ -- drawTokenTreeDetailed "moveDecl1:after rmTypeSigs" -- ++AZ++ -- logm $ "moveDecl1:t''=" ++ (SYB.showData SYB.Renamer 0 t'') -- ++AZ++ (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' -- logm $ "moveDecl1:t'=" ++ (SYB.showData SYB.Renamer 0 t') -- ++AZ++ -- drawTokenTree "moveDecl1:after rmDecl" -- ++AZ++- drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing+ -- drawTokenTreeDetailed "moveDecl1:after rmDecl" -- ++AZ++ 'in' missing let getToksForMaybeSig (GHC.L ss _) = do@@ -912,6 +912,7 @@ putRefactRenamed renamed' -- ren <- getRefactRenamed -- error ("doDemoting:ren=" ++ (showGhc ren))+ showLinesDebug "doDemoting done" return () {- =runStateT (applyTP ((once_tdTP (failTP `adhocTP` demoteInMod@@ -1496,13 +1497,13 @@ rmParamsInParent pn es -- =applyTP (full_buTP (idTP `adhocTP` worker)) = everywhereMStaged SYB.Renamer (SYB.mkM worker)- where worker exp@(GHC.L _ (GHC.HsApp e1 e2))+ where worker expr@(GHC.L _ (GHC.HsApp e1 e2)) -- was | findPN pn e1 && (elem (GHC.unLoc e2) es) | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))- = update exp e1 exp- worker (exp@(GHC.L _ (GHC.HsPar e1)))+ = update expr e1 expr+ worker (expr@(GHC.L _ (GHC.HsPar e1))) |pn==expToName e1- = update exp e1 exp+ = update expr e1 expr worker x =return x @@ -1523,10 +1524,10 @@ -} ----- make Substitions between formal and actual parameters.----------------- mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]- mkSubst pats params+ mkSubst pats1 params = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1) then Just (fromJust $ patToPNT x,(ghead "mkSubst") y)- else Nothing) pats params)+ else Nothing) pats1 params) {- = catMaybes (zipWith (\x y ->if (patToPN x/=defaultPN) && (length (nub y)==1) then Just (patToPN x,(ghead "mkSubst") y)
src/Language/Haskell/Refact/Renaming.hs view
@@ -239,7 +239,7 @@ | True = do logm $ "renameInMod" renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True- renameInMod _ren = mzero+ -- renameInMod _ren = mzero {- original doRenaming oldPNT@(PNT oldPN Value loc) newName modName mod inscps exps env
src/Language/Haskell/Refact/SwapArgs.hs view
@@ -54,7 +54,7 @@ -- let pnt = locToPNT (GHC.mkFastString fileName) (row, col) renamed -- let pnt = gfromJust "SwapArgs.comp" $ locToRdrName (GHC.mkFastString fileName) (row, col) renamed - (refactoredMod@(_, (_t, _s)),_) <- applyRefac (doSwap pn) (RSFile fileName)+ (refactoredMod,_) <- applyRefac (doSwap pn) (RSFile fileName) return [refactoredMod] Nothing -> error "Incorrect identifier selected!" --if isFunPNT pnt mod -- Add this back in ++ CMB +++
src/Language/Haskell/Refact/Utils.hs view
@@ -43,6 +43,7 @@ import Data.List import Data.Maybe import Language.Haskell.GhcMod+import Language.Haskell.Refact.Utils.DualTree import Language.Haskell.Refact.Utils.GhcBugWorkArounds import Language.Haskell.Refact.Utils.GhcModuleGraph import Language.Haskell.Refact.Utils.GhcUtils@@ -50,6 +51,8 @@ import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions+import Language.Haskell.Refact.Utils.TokenUtils+import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn import Language.Haskell.Refact.Utils.TypeUtils import System.Directory@@ -144,7 +147,7 @@ -- NOTE: does not seem to be required target <- GHC.guessTarget (targetFile) Nothing GHC.setTargets [target]- GHC.load GHC.LoadAllTargets+ void $ GHC.load GHC.LoadAllTargets return () Nothing -> return () return ()@@ -215,7 +218,7 @@ target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The * -- is to force interpretation, for inscopes GHC.setTargets [target]- GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make+ void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make {- graph <- GHC.getModuleGraph@@ -237,7 +240,8 @@ -- | The result of a refactoring is the file, a flag as to whether it -- was modified, the updated token stream, and the updated AST-type ApplyRefacResult = ((FilePath, Bool), ([PosToken], GHC.RenamedSource))+-- type ApplyRefacResult = ((FilePath, Bool), ([Ppr],[PosToken], GHC.RenamedSource))+type ApplyRefacResult = ((FilePath, Bool), ([Line],[PosToken], GHC.RenamedSource)) -- | Manage a whole refactor session. Initialise the monad, load the@@ -247,7 +251,8 @@ -- It is intended that this forms the umbrella function, in which -- applyRefac is called ---runRefacSession :: RefactSettings+runRefacSession ::+ RefactSettings -> Cradle -- ^ Identifies the surrounding -- project -> RefactGhc [ApplyRefacResult] -- ^ The computation doing the@@ -310,14 +315,16 @@ res <- refac -- Run the refactoring, updating the state as required - mod' <- getRefactRenamed- toks' <- fetchToksFinal- m <- getRefactStreamModified+ mod' <- getRefactRenamed+ toks' <- fetchToksFinal+ -- pprVal <- fetchPprFinal+ linesVal <- fetchLinesFinal+ m <- getRefactStreamModified -- Clear the refactoring state clearParsedModule - return (((fileName,m),(toks', mod')),res)+ return (((fileName,m),(linesVal,toks', mod')),res) -- ---------------------------------------------------------------------@@ -337,7 +344,7 @@ -- --------------------------------------------------------------------- -modifiedFiles :: [((String, Bool), ([PosToken], GHC.RenamedSource))] -> [String]+modifiedFiles :: [ApplyRefacResult] -> [String] modifiedFiles refactResult = map (\((s,_),_) -> s) $ filter (\((_,b),_) -> b) refactResult @@ -476,7 +483,7 @@ -- | Write refactored program source to files. writeRefactoredFiles ::- VerboseLevel -> [((String, Bool), ([PosToken], GHC.RenamedSource))] -> IO ()+ VerboseLevel -> [ApplyRefacResult] -> IO () writeRefactoredFiles verbosity files = do let filesModified = filter (\((_f,m),_) -> m == modified) files @@ -486,13 +493,14 @@ -- mapM_ writeTestDataForFile files -- This should be removed for the release version. where- modifyFile ((fileName,_),(ts,renamed)) = do+ modifyFile ((fileName,_),(finalLines,ts,renamed)) = do -- let source = concatMap (snd.snd) ts - -- The bug fix only works if we strip any empty tokens- -- let ts' = bypassGHCBug7351 $ filter (\t -> not $ isEmpty t) ts let ts' = bypassGHCBug7351 ts- let source = GHC.showRichTokenStream ts'+ -- let source = GHC.showRichTokenStream ts'++ -- let source = renderPpr ppr+ let source = renderLines finalLines -- (Julien personnal remark) seq forces the evaluation of -- its first argument and returns its second argument. It
+ src/Language/Haskell/Refact/Utils/DualTree.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Refact.Utils.DualTree (+ layoutTreeToSourceTree+ , retrieveLinesFromLayoutTree+ , retrieveLines+ , renderLines+ , renderSourceTree+ , SourceTree+ , Line(..)+ , Source(..)+ , renderLinesFromLayoutTree+ ) where++import qualified GHC as GHC+import qualified Outputable as GHC++import Control.Monad.State+import qualified Data.Tree as T++import Language.Haskell.Refact.Utils.LayoutTypes+import Language.Haskell.Refact.Utils.LocUtils+import Language.Haskell.Refact.Utils.TokenUtils+import Language.Haskell.Refact.Utils.TokenUtilsTypes+import Language.Haskell.Refact.Utils.TypeSyn+-- import Language.Haskell.Refact.Utils.TypeUtils++-- ----------+import Data.Tree.DUAL+import Data.Semigroup+import Data.Monoid.Action+import qualified Data.List.NonEmpty as NE+import qualified Data.Tree.DUAL.Internal as I++-- ---------------------------------------------------------------------++data DeletedSpan = DeletedSpan Span RowOffset SimpPos+ deriving (Show,Eq)++-- TODO: We are not actually using any of these+data Transformation = AsIs+ | T Integer+ | TAbove ColOffset EndOffset (Row,Col) (Row,Col) EndOffset+ | TDeleted ForestSpan RowOffset SimpPos+ | TAdded+ deriving Show++-- I have no idea why this is needed, but any dual tree operations fail if it is not present+instance Num Transformation where+ fromInteger n = T n+++transform :: Transformation -> Prim -> Prim+transform AsIs p = p+transform (T _n) (PToks s) = (PToks s)+transform (TAbove _co _bo _p1 _p2 _eo) (PToks s) = (PToks s)+transform (TDeleted _sspan _ro _p) (PToks s) = (PToks s)+transform TAdded (PToks s) = (PToks s)++-- | The value that bubbles up. This is the Span occupied by the+-- subtree, together with a string representation of the subtree. The+-- origin of the string is the start of the span.++data Up = Up Span Alignment (NE.NonEmpty Line) [DeletedSpan]+ | UDeleted [DeletedSpan]+ deriving Show++data Span = Span (Row,Col) (Row,Col)+ deriving (Show,Eq)++data Line = Line Row Col RowOffset Source LineOpt [PosToken]++data Alignment = ANone | AVertical+ deriving (Show,Eq)++instance Show Line where+ show (Line r c o f s toks) = "(" ++ show r ++ " " ++ show c ++ " " ++ show o+ ++ " " ++ show f+ ++ " " ++ show s ++ "\"" ++ GHC.showRichTokenStream toks ++ "\")"++data Source = SOriginal+ | SAdded+ | SWasAdded+ deriving (Show,Eq)++data LineOpt = ONone+ -- | This line needs to be grouped with the next in terms+ -- of layout, so any column offsets need to be propagated+ | OGroup+ deriving (Show,Eq)++data Annot = Ann String+ | ADeleted ForestSpan RowOffset SimpPos+ | ASubtree ForestSpan+ deriving Show++data Prim = PToks [PosToken]+ | PDeleted ForestSpan RowOffset SimpPos+ deriving Show+++type SourceTree = DUALTree Transformation Up Annot Prim+++instance Semigroup Span where+ (Span p1 _p2) <> (Span _q1 q2) = (Span p1 q2)++instance Semigroup Up where+ u1 <> u2 = combineUps u1 u2++instance Semigroup Transformation where+ (T n1) <> (T n2) = T (n1 + n2)++instance (Action Transformation Up) where+ act AsIs s = s+ act (T _n) (Up sspan a s ds) = (Up sspan a s ds)+ act (TAbove _co _bo _p1 _p2 _eo) (Up sspan _a s ds) = (Up sspan a' s' ds)+ where+ a' = AVertical+ s' = NE.map (\(Line r c o ss _f toks) -> (Line r c o ss OGroup toks)) s+ act (TDeleted _sspan _ro _p) (Up sspan a s ds) = (Up sspan a s ds)+ act TAdded s = s++-- ---------------------------------------------------------------------++instance GHC.Outputable SourceTree where+ ppr (I.DUALTree ot)+ = case getOption ot of+ Nothing -> GHC.text "Nothing"+ Just t -> GHC.ppr t++instance GHC.Outputable (I.DUALTreeU Transformation Up Annot Prim) where+ ppr (I.DUALTreeU (u,t)) = GHC.parens $ GHC.ppr u GHC.<> GHC.comma GHC.$$ GHC.ppr t++instance GHC.Outputable (I.DUALTreeNE Transformation Up Annot Prim) where+ ppr (I.Leaf u l) = GHC.parens $ GHC.hang (GHC.text "Leaf") 1 (GHC.ppr u GHC.$$ GHC.ppr l)+ ppr (I.LeafU u) = GHC.parens $ GHC.hang (GHC.text "LeafU") 1 (GHC.ppr u)+ ppr (I.Concat dts) = GHC.parens $ GHC.hang (GHC.text "Concat") 1 (GHC.ppr dts)+ ppr (I.Act d t) = GHC.parens $ GHC.hang (GHC.text "Act") 1 (GHC.ppr d GHC.$$ GHC.ppr t)+ ppr (I.Annot a t) = GHC.parens $ GHC.hang (GHC.text "Annot") 1 (GHC.ppr a GHC.$$ GHC.ppr t)++instance GHC.Outputable Prim where+ ppr (PToks toks) = GHC.parens $ GHC.text "PToks" GHC.<+> GHC.text (show toks)+ ppr (PDeleted ss pg p) = GHC.parens $ GHC.text "PDeleted" GHC.<+> GHC.ppr ss+ GHC.<+> GHC.ppr pg GHC.<+> GHC.ppr p++instance GHC.Outputable Transformation where+ ppr (AsIs) = GHC.parens $ GHC.text "AsIs"+ ppr (T n) = GHC.parens $ GHC.text "T" GHC.<+> GHC.text (show n)+ ppr (TAbove co bo p1 p2 eo) = GHC.parens $ GHC.text "TAbove" GHC.<+> GHC.ppr co+ GHC.<+> GHC.ppr bo+ GHC.<+> GHC.ppr p1 GHC.<+> GHC.ppr p2+ GHC.<+> GHC.ppr eo+ ppr (TDeleted sspan ro p) = GHC.parens $ GHC.text "TAbove" GHC.<+> GHC.ppr sspan+ GHC.<+> GHC.ppr ro GHC.<+> GHC.ppr p+ ppr (TAdded) = GHC.parens $ GHC.text "TAdded"++instance GHC.Outputable EndOffset where+ ppr None = GHC.text "None"+ ppr (SameLine co) = GHC.parens $ GHC.text "SameLine" GHC.<+> GHC.ppr co+ ppr (FromAlignCol rc) = GHC.parens $ GHC.text "FromAlignCol" GHC.<+> GHC.ppr rc++instance GHC.Outputable Annot where+ ppr (Ann str) = GHC.parens $ GHC.text "Ann" GHC.<+> GHC.text str+ ppr (ADeleted ss pg p) = GHC.parens $ GHC.text "ADeleted" GHC.<+> GHC.ppr ss+ GHC.<+> GHC.ppr pg GHC.<+> GHC.ppr p+ ppr (ASubtree ss) = GHC.parens $ GHC.text "ASubtree" GHC.<+> GHC.ppr ss++instance GHC.Outputable Up where+ ppr (Up ss a ls ds) = GHC.parens $ GHC.hang (GHC.text "Up") 1+ ((GHC.ppr ss GHC.<+> GHC.ppr a) GHC.$$ GHC.ppr ls GHC.$$ GHC.ppr ds)+ ppr (UDeleted d) = GHC.parens $ GHC.text "UDeleted" GHC.<+> GHC.ppr d++instance GHC.Outputable Alignment where+ ppr ANone = GHC.text "ANone"+ ppr AVertical = GHC.text "AVertical"++instance GHC.Outputable DeletedSpan where+ ppr (DeletedSpan ss ro p) = GHC.parens $ (GHC.text "DeletedSpan")+ GHC.<+> GHC.ppr ss GHC.<+> GHC.ppr ro+ GHC.<+> GHC.ppr p+++instance GHC.Outputable Span where+ ppr (Span sp ep) = GHC.parens $ GHC.text "Span" GHC.<+> GHC.ppr sp GHC.<+> GHC.ppr ep++instance (GHC.Outputable a) => GHC.Outputable (NE.NonEmpty a) where+ -- ppr (x NE.:| xs) = GHC.parens $ GHC.hang (GHC.text "NonEmpty") 1 (GHC.ppr (x:xs))+ ppr (x NE.:| xs) = (GHC.ppr (x:xs))++instance GHC.Outputable Line where+ ppr (Line r c o s f str) = GHC.parens $ GHC.text "Line" GHC.<+> GHC.ppr r+ GHC.<+> GHC.ppr c GHC.<+> GHC.ppr o+ GHC.<+> GHC.ppr s GHC.<+> GHC.ppr f+ GHC.<+> GHC.text ("\"" ++ (GHC.showRichTokenStream str) ++ "\"")+ -- GHC.<+> GHC.text (show str) -- ++AZ++ debug++instance GHC.Outputable Source where+ ppr SOriginal = GHC.text "SOriginal"+ ppr SAdded = GHC.text "SAdded"+ ppr SWasAdded = GHC.text "SWasAdded"++instance GHC.Outputable LineOpt where+ ppr ONone = GHC.text "ONone"+ ppr OGroup = GHC.text "OGroup"++-- ---------------------------------------------------------------------++renderLinesFromLayoutTree :: LayoutTree -> String+renderLinesFromLayoutTree = renderLines . retrieveLinesFromLayoutTree++-- ---------------------------------------------------------------------++retrieveLinesFromLayoutTree :: LayoutTree -> [Line]+retrieveLinesFromLayoutTree = retrieveLines . layoutTreeToSourceTree++-- ---------------------------------------------------------------------++retrieveLines :: SourceTree -> [Line]+retrieveLines srcTree+ = case getU srcTree of+ Nothing -> []+ Just (Up _ss _a str _ds) -> NE.toList str++-- ---------------------------------------------------------------------++renderSourceTree :: SourceTree -> String+renderSourceTree srcTree = r+ where+ r = case getU srcTree of+ Nothing -> ""+ Just (Up _ss _a str _ds) -> renderLines $ NE.toList str++-- ---------------------------------------------------------------------++renderLines :: [Line] -> String+renderLines ls = res+ where+ (_,(_,res)) = runState (go 0 ls) ((1,1),"")++ go _ [] = do return ()+ go ci ((Line r c _o _f _s str):ls') = do+ newPos r (c+ci)+ addString (GHC.showRichTokenStream str)+ go ci ls'++ -- State operations ----------------++ getRC = do+ (rc,_) <- get+ return rc++ putRC (r,c) = do+ (_,str) <- get+ put ((r,c),str)++ newPos newRow newCol = do+ (oldRow',oldCol) <- getRC++ -- Allow for out of order additions that result from additions+ -- to the tree. Will break the invariant.+ let oldRow = if oldRow' <= newRow then oldRow' else (newRow - 1)+ putRC (oldRow,oldCol)++ if oldRow == newRow+ then addString (take (newCol - oldCol) $ repeat ' ')+ else+ addString ( (take (newRow - oldRow) $ repeat '\n') +++ (take (newCol - 1) $ repeat ' ') )++ addString [] = return ()+ addString str = do+ ((r,c),curr) <- get+ let ll = (length $ filter (=='\n') str)+ let c'' = (length $ takeWhile (/='\n') $ reverse str)+++ let (r',c') = case ll of+ 0 -> (r,c + c'')+ _ -> (r + ll, c'' + 1)+ put ((r',c'),curr++str)++ -- checkInvariant $ "addString" ++ show str++ addDebugString str = do+ ((r,c),curr) <- get+ put ((r,c),curr++str)++-- ---------------------------------------------------------------------++layoutTreeToSourceTree :: LayoutTree -> SourceTree++-- TODO: simplify by getting rid of PDeleted, and use leafU+layoutTreeToSourceTree (T.Node (Deleted sspan pg eg) _)+ = leaf (UDeleted [(DeletedSpan (fs2s sspan) pg eg)]) (PDeleted sspan pg eg)++layoutTreeToSourceTree (T.Node (Entry sspan NoChange []) ts0)+ = annot (ASubtree sspan) (mconcatl $ map layoutTreeToSourceTree ts0)+layoutTreeToSourceTree (T.Node (Entry sspan (Above bo p1 p2 eo) []) ts0)+ = annot (ASubtree sspan)+ (applyD (TAbove co bo p1 p2 eo) subs)+ where+ subs = (mconcatl $ map layoutTreeToSourceTree ts0)+ co = 0++layoutTreeToSourceTree (T.Node (Entry sspan _lay toks) _ts) = leaf (mkUp sspan toks) (PToks toks)++-- -------------------------------------++-- We use the foldl version to get a more bushy tree, else the ppr of+-- it is very hard to follow+mconcatl :: (Monoid a) => [a] -> a+mconcatl = foldl mappend mempty++-- ---------------------------------------------------------------------++fs2s :: ForestSpan -> Span+fs2s ss = Span sp ep+ where+ (sp,ep) = forestSpanToSimpPos ss++-- ---------------------------------------------------------------------++mkUp :: ForestSpan -> [PosToken] -> Up+mkUp sspan toks = Up ss a ls []+ where+ a = ANone+ s = if forestSpanVersionSet sspan then SAdded else SOriginal+ ss = mkSpan sspan+ -- toksByLine = groupTokensByLine $ reAlignMarked toks+ toksByLine = groupTokensByLine toks++ ls = NE.fromList $ concatMap (mkLinesFromToks s) toksByLine++-- ---------------------------------------------------------------------++mkLinesFromToks :: Source -> [PosToken] -> [Line]+mkLinesFromToks _ [] = []+mkLinesFromToks s toks = [Line ro co 0 s f toks']+ where+ f = ONone+ ro' = tokenRow $ head toks+ co' = tokenCol $ head toks+ (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks)+ toks' = addOffsetToToks (-ro',-co') toks++-- ---------------------------------------------------------------------++-- | Combine the 'U' annotations as they propagate from the leafs to+-- be cached at the root of the tree. This is the heart of the+-- DualTree functionality+combineUps :: Up -> Up -> Up+combineUps (UDeleted d1) (UDeleted d2) = UDeleted (d1 <> d2)++combineUps (UDeleted d1) (Up sp2 a2 l2 d2) = (Up sp2 a2 l (d1 <> d2))+ where+ l = adjustForDeleted d1 l2++combineUps (Up sp1 a1 l1 d1) (UDeleted d2) = (Up sp1 a1 l1 (d1 <> d2))++combineUps (Up sp1 _a1 l1 d1) (Up sp2 _a2 l2 d2) = (Up (sp1 <> sp2) a l (d1 <> d2))+ where+ a = ANone++ l2' = adjustForDeleted d1 l2++ (Line _ _ o2 _ _ _) = NE.head l2'+ -- 1 0+ l2'' = if o1 == o2+ then l2'+ else NE.fromList $ map (\(Line r c f aa ff s) -> (Line (r + (o1-f)) c (o1-f) aa ff s)) (NE.toList l2')++ (Line r1 c1 o1 ss1 ff1 s1) = NE.last l1+ (Line r2 c2 _o2 ss2 ff2 s2) = NE.head l2''++ l = if r1 == r2+ then NE.fromList $ (NE.init l1) ++ m ++ ll+ else NE.fromList $ (NE.toList l1) ++ rest++ s2' = addOffsetToToks (0,c2 - c1) s2++ s1' = s1 ++ s2'+ ff' = if ff1 == OGroup || ff2 == OGroup then OGroup else ONone+ m' = [Line r1 c1 o1 ss1 ff' s1']++ -- 'o' takes account of any length change due to tokens being+ -- replaced by others of different length+ odiff = sum $ map (\t@(_,s) -> (length s) - (tokenColEnd t - tokenCol t)) s1++ st1 = GHC.showRichTokenStream s1+ st2 = GHC.showRichTokenStream (s1 ++ s2')+ st3 = drop (length st1) st2+ st4 = takeWhile (==' ') st3+ oo = length (st1++st4)+ coo = c1 + oo+ o = coo - c2++ (m,ll) = if (ss1 /= ss2) && (length s1 == 1 && (tokenLen $ head s1) == 0)+ then ([NE.last l1],map (\(Line r c f aa ff s) -> (Line (r+1) (c + o) (f+1) aa ff s)) (NE.toList l2''))+ else if ff' == OGroup+ then (m',addOffsetToGroup o (NE.tail l2''))+ else (m', (NE.tail l2''))++ rest = if ff2 == OGroup+ then addOffsetToGroup odiff (NE.toList l2'')+ else NE.toList l2''++ addOffsetToGroup _off [] = []+ addOffsetToGroup _off (ls@((Line _r _c _f _aa ONone _s):_)) = ls+ addOffsetToGroup off ((Line r c f aa OGroup s):ls) = (Line r (c+off) f aa OGroup s) : addOffsetToGroup off ls++{-++((o,st1,st3)=(0,"x y= sq x + sq y where"," sq x= x^pow"))++(Line+r1 = 7+c1 = 12+o1 = 0+ss1 = SOriginal+ff1 = ONone+s1 = \"x y= square x + square y where\")++(Line+r2 = 7+c2 = 35+o2 = 0+ss2 = SOriginal+ff2 = OGroup+s2 = \"square x= x^pow\")++------------------------++(Up+ (Span (7, 12) (9, 40)) ANone+ [(Line 7 12 0 SOriginal OGroup \"x y= square x + square y where square x= x^pow\"),+ (Line 8 -5 0 SOriginal OGroup \"--There is a comment.\"),+ (Line 9 27 0 SOriginal OGroup \"pow=2\")]+ [])++-------------+Up1+(Up+ (Span (7, 12) (7, 34)) ANone+ [(Line 7 12 0 SOriginal ONone \"x y= square x + square y where\")]+ [])++Up2+(Up+ (Span (7, 35) (9, 40)) AVertical+ [(Line 7 35 0 SOriginal OGroup \"square x= x^pow\"),+ (Line 8 3 0 SOriginal OGroup \"--There is a comment.\"),+ (Line 9 35 0 SOriginal OGroup \"pow=2\")]+ [])+++-}++++-- -------------------------------------++adjustForDeleted :: [DeletedSpan] -> NE.NonEmpty Line -> NE.NonEmpty Line+adjustForDeleted d1 l2 = l+ where+ deltaL = calcDelta d1+ l = NE.map go l2++ go (Line r c o SOriginal f str) = Line (r - deltaL) c o SOriginal f str+ go (Line r c o SWasAdded f str) = Line (r - deltaL) c o SWasAdded f str+ go (Line r c o SAdded f str) = Line r c o SWasAdded f str++-- -------------------------------------++calcDelta :: [DeletedSpan] -> RowOffset+calcDelta d1 = deltaL+ where+ deltaL = case d1 of+ [] -> 0+ _ -> (-1) + (sum $ map calcDelta' d1)++ calcDelta' :: DeletedSpan -> RowOffset+ calcDelta' (DeletedSpan (Span (rs,_cs) (re,_ce)) pg (rd,_cd)) = r + 1+ where+ ol = re - rs+ eg = rd+ r = (pg + ol + eg) - (max pg eg)+++-- ---------------------------------------------------------------------++mkSpan :: ForestSpan -> Span+mkSpan ss = Span s e+ where+ (s,e) = forestSpanToSimpPos ss++-- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs view
@@ -253,8 +253,8 @@ cmp (x1,_) (x2,_) = compare x1 x2 -} mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-mergeBy cmp [] ys = ys-mergeBy cmp xs [] = xs+mergeBy _cmp [] ys = ys+mergeBy _cmp xs [] = xs mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) -- Ordering derives Eq, Ord, so the comparison below is valid. -- Explanation left as an exercise for the reader.
src/Language/Haskell/Refact/Utils/GhcUtils.hs view
@@ -17,6 +17,7 @@ -- * SYB versions everythingButStaged , somethingStaged+ , everythingStaged , somewhereMStaged , somewhereMStagedBu , everywhereMStaged
+ src/Language/Haskell/Refact/Utils/Layout.hs view
@@ -0,0 +1,1725 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+--++module Language.Haskell.Refact.Utils.Layout (+ initTokenLayout+ , nullTokenLayout+ , allocTokens+ , retrieveTokens+ , getLoc++ -- * For testing+ , addEndOffsets+ ) where++import qualified Bag as GHC+import qualified ForeignCall as GHC+import qualified GHC as GHC+-- import qualified HsTypes as GHC+-- import qualified Outputable as GHC+-- import qualified SrcLoc as GHC++import Outputable++-- import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import Data.List+-- import Data.Maybe+import Data.Tree+-- import Language.Haskell.Refact.Utils.GhcUtils+import Language.Haskell.Refact.Utils.GhcVersionSpecific+import Language.Haskell.Refact.Utils.LayoutTypes+import Language.Haskell.Refact.Utils.LocUtils+import Language.Haskell.Refact.Utils.TokenUtils+import Language.Haskell.Refact.Utils.TokenUtilsTypes+import Language.Haskell.Refact.Utils.TypeSyn++-- import qualified Data.Tree.Zipper as Z++-- ---------------------------------------------------------------------++-- | Extract the layout-sensitive parts of the GHC AST.++-- The layout keywords are `let`, `where`, `of` and `do`. The+-- expressions introduced by them need to be kept indented at the same+-- level.++{-++AST Items for layout keywords.++(gleaned from Parser.y.pp in the ghc sources)++`let`+++@+ HsLet+ HsLet (HsLocalBinds id) (LHsExpr id) :: HsExpr id+ ^^keep aligned++ LetStmt+ LetStmt (HsLocalBindsLR idL idR) :: StmtLR idL idR+ ^^keep aligned+@++`where`++@+ HsModule+ -- not relevant to layout++ ClassDecl :: TyClDecl+ ClassDecl ....++ ClsInstD :: InstDecl+ ClsInstD typ binds sigs [fam_insts]+ ^^the binds, sigs, fam_insts should all align++ GRHSs+ GRHS [LStmt id] (LHsExpr id)+ ^^keep aligned++ TyDecl :: TyClDecl+ TyDecl name vars defn fvs+ ^^keep aligned+ [The `where` is in the defn]++ FamInstDecl+ FamInstDecl tycon pats defn fvs+ ^^keep aligned+ [The `where` is in the defn]+@++`of`++@+ HsCase :: HsExpr+ HsCase (LHsExpr id) (MatchGroup id)+ ^^keep aligned+@++`do`++@+ DoExpr :: HsExpr+ HsDo (HsStmtContext Name) [LStmt id] PostTcType+ ^^keep aligned+@+-}++-- Pretty print combinators of interest+--+-- ($$) :: Doc -> Doc -> Doc+--+-- Above, except that if the last line of the first argument stops at+-- least one position before the first line of the second begins,+-- these two lines are overlapped.+--+--+-- ($+$) :: Doc -> Doc -> Doc+--+-- Above, with no overlapping.+--+--+-- nest :: Int -> Doc -> Doc+--+-- Nest (or indent) a document by a given number of positions+-- (which may also be negative)+--+--+-- hang :: Doc -> Int -> Doc -> Doc+--+-- hang d1 n d2 = sep [d1, nest n d2]+--+++-- ---------------------------------------------------------------------++deriving instance Show Label++instance Outputable (Tree Entry) where+ ppr (Node label subs) = hang (text "Node") 2 (vcat [ppr label,ppr subs])++instance Outputable Entry where+ ppr (Entry sspan lay toks) = text "Entry" <+> ppr sspan <+> ppr lay <+> text (show toks)+ ppr (Deleted sspan pg eg) = text "Deleted" <+> ppr sspan <+> ppr pg <+> ppr eg++instance Outputable Layout where+ ppr (Above so p1 p2 oe) = text "Above" <+> ppr so <+> ppr p1 <+> ppr p2 <+> ppr oe+ -- ppr (Offset r c) = text "Offset" <+> ppr r <+> ppr c+ ppr (NoChange) = text "NoChange"+ -- ppr (EndOffset r c) = text "EndOffset" <+> ppr r <+> ppr c++instance Outputable PprOrigin where+ ppr Original = text "Original"+ ppr Added = text "Added"++instance Outputable Ppr where+ ppr (PprText r c o str) = text "PprText" <+> ppr r <+> ppr c <+> ppr o+ <+> text "\"" <> text str <> text "\""+ ppr (PprAbove so rc erc pps) = hang (text "PprAbove" <+> ppr so <+> ppr rc <+> ppr erc)+ 2 (ppr pps)+ -- ppr (PprOffset ro co pps) = hang (text "PprOffset" <+> ppr ro <+> ppr co)+ -- 2 (ppr pps)+ ppr (PprDeleted ro co lb l la) = text "PprDeleted" <+> ppr ro <+> ppr co+ <+> ppr lb <+> ppr l <+> ppr la+ -- <+> ppr n++instance Outputable EndOffset where+ ppr None = text "None"+ ppr (SameLine co) = text "SameLine" <+> ppr co+ ppr (FromAlignCol off) = text "FromAlignCol" <+> ppr off++-- ---------------------------------------------------------------------++initTokenLayout :: GHC.ParsedSource -> [PosToken] -> LayoutTree+initTokenLayout parsed toks = (allocTokens parsed toks)++nullTokenLayout :: TokenLayout+-- nullTokenLayout = TL (Leaf nullSrcSpan NoChange [])+nullTokenLayout = TL (Node (Entry (sf nullSrcSpan) NoChange []) [])++-- ---------------------------------------------------------------------++-- TODO: bring in startEndLocIncComments'+allocTokens :: GHC.ParsedSource -> [PosToken] -> LayoutTree+allocTokens (GHC.L _l (GHC.HsModule maybeName maybeExports imports decls _warns _haddocks)) toks = r+ where+ (nameLayout,toks1) =+ case maybeName of+ Nothing -> ([],toks)+ Just (GHC.L ln _modName) -> ((makeLeafFromToks s1) ++ [makeLeaf ln NoChange modNameToks],toks')+ where+ (s1,modNameToks,toks') = splitToksIncComments (ghcSpanStartEnd ln) toks++ (exportLayout,toks2) =+ case maybeExports of+ Nothing -> ([],toks1)+ Just exps -> ((makeLeafFromToks s2) ++ (makeLeafFromToks expToks),toks2')+ where+ (s2,expToks,toks2') = splitToksForList exps toks1++ (importLayout,toks3) =+ case imports of+ [] -> ([],toks2)+ is -> ((makeLeafFromToks s3) ++ (makeLeafFromToks impToks),toks3')+ where+ (s3,impToks,toks3') = splitToksForList is toks2++ (declLayout,toks4) =+ case decls of+ [] -> ([],toks3)+ is -> ((makeLeafFromToks s4) ++ allocDecls is declToks ++ (makeLeafFromToks toks4'),[])+ where+ (s4,declToks,toks4') = splitToksForList is toks3++ r' = makeGroup (strip $ nameLayout ++ exportLayout ++ importLayout ++ declLayout ++ (makeLeafFromToks toks4))+ r = addEndOffsets r' toks+ -- r = error $ "allocTokens:(nameLayout,toks1)=" ++ (show (nameLayout,toks1)) -- ++AZ+++ -- r = error $ "allocTokens:(exportLayout,toks2)=" ++ (show (exportLayout,toks2)) -- ++AZ+++ -- r = error $ "allocTokens:(importLayout,toks3)=" ++ (show (importLayout,toks3)) -- ++AZ+++ -- r = error $ "allocTokens:(declLayout,toks4)=" ++ (show (declLayout,_toks4)) -- ++AZ++++-- ---------------------------------------------------------------------+++addEndOffsets :: LayoutTree -> [PosToken] -> LayoutTree+addEndOffsets tree toks = go tree+ where+ go (t@(Node (Entry _ _ _toks) [])) = t+ go ( (Node (Entry s (Above so p1 (r,c) _eo) []) subs))+ = (Node (Entry s (Above so p1 (r,c) eo') []) (map go subs))+ where+ -- (_,m,_) = splitToksIncComments ((r,c),(99999,1)) toks+ (_,m,_) = splitToks ((r,c),(99999,1)) toks+ eo' = case m of+ [] -> None+ [_] -> None+ xs -> if ro' /= 0 then FromAlignCol off+ else SameLine co'+ where+ -- off@(ro',co') = case (dropWhile isWhiteSpace $ tail xs) of+ -- off@(ro',co') = case (dropWhile isWhiteSpace xs) of+ off@(ro',co') = case (dropWhile isEmpty xs) of+ [] -> (tokenRow y - r, tokenCol y - c) where y = head $ tail xs+ (y:_) -> (tokenRow y - r, tokenCol y - c)+ -- eo' = error $ "addEndOffsets:m=" ++ (show ((r,c),m))+ -- eo' = error $ "addEndOffsets:m dropped=" ++ (show $ dropWhile isWhiteSpace m)+ -- eo' = error $ "addEndOffsets:m dropped=" ++ (show $ dropWhile isWhiteSpaceOrIgnored m)+ -- eo' = error $ "addEndOffsets:m dropped=" ++ (show $ dropWhile isWhiteSpaceOrIgnored $ tail m)+ -- eo' = (0,0)+ go ( (Node (Entry s l []) subs)) = (Node (Entry s l []) (map go subs))+ go n = error $ "addEndOffsets:strange node:" ++ (show n)++-- ---------------------------------------------------------------------++allocDecls :: [GHC.LHsDecl GHC.RdrName] -> [PosToken] -> [LayoutTree]+allocDecls decls toks = r+ where+ (declLayout,tailToks) = foldl' doOne ([],toks) decls++ r = strip $ declLayout ++ (makeLeafFromToks tailToks)+ -- r = error $ "allocDecls:tailToks=" ++ (show tailToks)+ -- r = error $ "allocDecls:declLayout=" ++ (show declLayout)++ doOne :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+ doOne acc d@(GHC.L _ (GHC.TyClD _)) = allocTyClD acc d+ doOne acc d@(GHC.L _ (GHC.InstD _)) = allocInstD acc d+ doOne acc d@(GHC.L _ (GHC.DerivD _)) = allocDerivD acc d+ doOne acc d@(GHC.L _ (GHC.ValD _)) = allocValD acc d+ doOne acc d@(GHC.L _ (GHC.SigD _)) = allocSigD acc d+ doOne acc d@(GHC.L _ (GHC.DefD _)) = allocDefD acc d+ doOne acc d@(GHC.L _ (GHC.ForD _)) = allocForD acc d+ doOne acc d@(GHC.L _ (GHC.WarningD _)) = allocWarningD acc d+ doOne acc d@(GHC.L _ (GHC.AnnD _)) = allocAnnD acc d+ doOne acc d@(GHC.L _ (GHC.RuleD _)) = allocRuleD acc d+ doOne acc d@(GHC.L _ (GHC.VectD _)) = allocVectD acc d+ doOne acc d@(GHC.L _ (GHC.SpliceD _)) = allocSpliceD acc d+ doOne acc d@(GHC.L _ (GHC.DocD _)) = allocDocD acc d+ doOne acc d@(GHC.L _ (GHC.QuasiQuoteD _)) = allocQuasiQuoteD acc d++-- ---------------------------------------------------------------------++allocTyClD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ForeignType ln _))) = (r,toks')+ where+ (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ lnToks = allocLocated ln clToks+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ lnToks)]+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyFamily _f n@(GHC.L ln _) vars _mk))) = (r,toks')+ where+ (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,varsToks) = splitToksIncComments (ghcSpanStartEnd ln) toks'+ nLayout = allocLocated n nToks+#if __GLASGOW_HASKELL__ > 704+ (varsLayout,s3) = allocTyVarBndrs vars varsToks+#else+ varsLayout = allocList vars varsToks allocTyVarBndr+ s3 = []+#endif+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks clToks)+ ++ (makeLeafFromToks s2) ++ nLayout ++ varsLayout+ ++ (makeLeafFromToks s3))]+#if __GLASGOW_HASKELL__ > 704+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyDecl (GHC.L ln _) vars def _fvs))) = (r,toks')+ where+ (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) clToks+ (varsLayout,toks3) = allocTyVarBndrs vars toks''+ (typeLayout,toks4) = allocHsTyDefn def toks3+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ (makeLeafFromToks nToks) ++ varsLayout ++ typeLayout+ ++ (makeLeafFromToks toks4))]+#else+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyData _ (GHC.L lc ctx) (GHC.L ln _) vars mpats mkind cons mderivs))) = (r,toks')+ where+ (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s15,ctxToks,toks'a) = splitToksIncComments (ghcSpanStartEnd lc) clToks+ (s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) toks'a+ (s21,vToks,toks3) = splitToksForList vars toks''+ ctxLayout = allocHsContext ctx ctxToks+ varsLayout = allocList vars vToks allocTyVarBndr+ (patsLayout,toks4) = case mpats of+ Nothing -> ([],toks3)+ Just pats -> ([makeGroup (strip $ (makeLeafFromToks s3) ++ (allocList pats patsToks allocType))],toks4')+ where (s3,patsToks,toks4') = splitToksForList pats toks3+ (kindLayout,toks5) = case mkind of+ Nothing -> ([],toks4)+ Just k@(GHC.L lk _k) -> (kLayout,toks5')+ where+ (s4,kToks,toks5') = splitToksIncComments (ghcSpanStartEnd lk) toks4+ kLayout = [makeGroup (strip $ (makeLeafFromToks s4) ++ allocHsKind k kToks)]+ (s5,consToks,toks6) = splitToksForList cons toks5+ consLayout = [makeGroup (strip $ (makeLeafFromToks s5) ++ (allocList cons consToks allocConDecl))]+ (derivsLayout,toks7) = case mderivs of+ Nothing -> ([],toks6)+ Just derivs -> (dLayout,toks7')+ where+ (s6,dToks,toks7') = splitToksForList derivs toks6+ dLayout = [makeGroup (strip $ (makeLeafFromToks s6) ++ (allocList derivs dToks allocType))]++ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+ ++ (makeLeafFromToks s15)+ ++ ctxLayout+ ++ (makeLeafFromToks s2)+ ++ (makeLeafFromToks nToks)+ ++ (makeLeafFromToks s21)+ ++ varsLayout ++ patsLayout+ ++ kindLayout+ ++ consLayout ++ derivsLayout+ ++ (makeLeafFromToks toks7))]+{-+tcdND :: NewOrData+tcdCtxt :: LHsContext name++ Context...++ Context +tcdLName :: Located name++ Name of the class++ type constructor++ Type constructor +tcdTyVars :: [LHsTyVarBndr name]++ Class type variables++ type variables++ Type variables +tcdTyPats :: Maybe [LHsType name]++ Type patterns See Note [tcdTyVars and tcdTyPats]++ Type patterns. See Note [tcdTyVars and tcdTyPats] +tcdKindSig :: Maybe (LHsKind name)++ Optional kind signature.++ (Just k) for a GADT-style data, or data instance decl with explicit kind sig +tcdCons :: [LConDecl name]++ Data constructors++ For data T a = T1 | T2 a the LConDecls all have ResTyH98. For data T a where { T1 :: T a } the LConDecls all have ResTyGADT. +tcdDerivs :: Maybe [LHsType name]++ Derivings; Nothing => not specified, Just [] => derive exactly what is asked++ These types must be of form forall ab. C ty1 ty2 Typically the foralls and ty args are empty, but they are non-empty for the newtype-deriving case +-}+#endif+#if __GLASGOW_HASKELL__ > 704+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs))) = (acc++r,toks')+#else+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs ))) = (acc++r,toks')+#endif+ where+ (s1,clToks, toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,ctxToks, toks1) = splitToksIncComments (ghcSpanStartEnd lc) clToks+ (s3,nToks, toks2) = splitToksIncComments (ghcSpanStartEnd ln) toks1+#if __GLASGOW_HASKELL__ > 704+ (varsLayout, toks3) = allocTyVarBndrs vars toks2+#else+ varsLayout = allocList vars toks2 allocTyVarBndr+ toks3 = [] -- hmm+#endif+ (s5,fdToks, toks4) = splitToksForList fds toks3++ ctxLayout = allocHsContext ctx ctxToks+ nLayout = allocLocated n nToks+ fdsLayout = allocList fds fdToks allocFunDep++ bindList = GHC.bagToList meths+ sigMix = makeMixedListEntry sigs (shim allocSig)+ methsMix = makeMixedListEntry bindList (shim allocBind)+ atsMix = makeMixedListEntry ats (shim allocLTyClDecl)+#if __GLASGOW_HASKELL__ > 704+ atsdefsMix = makeMixedListEntry atdefs (shim allocLFamInstDecl)+#else+ atsdefsMix = makeMixedListEntry atdefs (shim allocLTyClDecl)+#endif+ docsMix = makeMixedListEntry docs (shim allocLocated)++ bindsLayout = allocMixedList (sigMix++methsMix++atsMix++atsdefsMix++docsMix) toks4++ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ ctxLayout ++ (makeLeafFromToks s3)+ ++ nLayout ++ varsLayout ++ (makeLeafFromToks s5)+ ++ fdsLayout ++ bindsLayout]++allocTyClD (acc,toks) x = error $ "allocTyClD:unknown value:" ++ showGhc x++{-+ClassDecl ++tcdCtxt :: LHsContext name++ Context...++ Context +tcdLName :: Located name++ Name of the class++ type constructor++ Type constructor +tcdTyVars :: [LHsTyVarBndr name]++ Class type variables++ type variables++ Type variables +tcdFDs :: [Located (FunDep name)]++ Functional deps +tcdSigs :: [LSig name]++ Methods' signatures +tcdMeths :: LHsBinds name++ Default methods +tcdATs :: [LTyClDecl name]++ Associated types; ie only TyFamily +tcdATDefs :: [LTyClDecl name]++ Associated type defaults; ie only TySynonym +tcdDocs :: [LDocDecl]++ Haddock docs ++-}+-- ---------------------------------------------------------------------++allocInstD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocInstD (acc,toks) (GHC.L l (GHC.InstD inst)) = (r,toks')+ where+ (s1,instToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ instLayout = allocInstDecl (GHC.L l inst) instToks+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup instLayout] )]+++-- ---------------------------------------------------------------------++allocDerivD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocDerivD (acc,toks) d@(GHC.L l (GHC.DerivD _))+ = error "allocDerivD undefined"++-- ---------------------------------------------------------------------++allocValD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocValD (acc,toks) (GHC.L l (GHC.ValD bind)) = (r,toks')+ where+ (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ bindLayout = allocBind (GHC.L l bind) bindToks+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup bindLayout] )]+ -- r = error $ "allocValD:bindToks=" ++ show bindToks++-- ---------------------------------------------------------------------++allocSigD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocSigD (acc,toks) (GHC.L l (GHC.SigD sig)) = (r,toks')+ where+ (s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ sigLayout = allocSig (GHC.L l sig) sigToks+ r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+ ++ sigLayout)]++-- ---------------------------------------------------------------------++allocDefD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocDefD (acc,toks) d@(GHC.L l (GHC.DefD _))+ = error "allocDefD undefined"++-- ---------------------------------------------------------------------++allocForD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocForD (acc,toks) d@(GHC.L l (GHC.ForD _))+ = error "allocForD undefined"++-- ---------------------------------------------------------------------++allocWarningD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocWarningD (acc,toks) d@(GHC.L l (GHC.WarningD _))+ = error "allocWarningD undefined"++-- ---------------------------------------------------------------------++allocAnnD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocAnnD (acc,toks) d@(GHC.L l (GHC.AnnD _))+ = error "allocAnnD undefined"++-- ---------------------------------------------------------------------++allocRuleD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocRuleD (acc,toks) d@(GHC.L l (GHC.RuleD _))+ = error "allocRuleD undefined"++-- ---------------------------------------------------------------------++allocVectD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocVectD (acc,toks) d@(GHC.L l (GHC.VectD _))+ = error "allocVectD undefined"++-- ---------------------------------------------------------------------++allocSpliceD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocSpliceD (acc,toks) d@(GHC.L l (GHC.SpliceD _))+ = error "allocSpliceD undefined"++-- ---------------------------------------------------------------------++allocDocD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocDocD (acc,toks) d@(GHC.L l (GHC.DocD _))+ = error "allocDocD undefined"++-- ---------------------------------------------------------------------++allocQuasiQuoteD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocQuasiQuoteD (acc,toks) d@(GHC.L l (GHC.QuasiQuoteD _))+ = error "allocQuasiQuoteD undefined"++-- ---------------------------------------------------------------------++allocMatches :: [GHC.LMatch GHC.RdrName] -> [PosToken] -> [LayoutTree]+allocMatches matches toksIn = allocList matches toksIn doOne+ where+ doOne :: GHC.LMatch GHC.RdrName -> [PosToken] -> [LayoutTree]+ doOne (GHC.L lm (GHC.Match pats mtyp grhs@(GHC.GRHSs rhs _))) toks = r+ where+ (sb,matchToks,sa) = splitToksIncComments (ghcSpanStartEnd lm) toks+ (s2,patsToks,toks2) = splitToksForList pats matchToks+ (mtypLayout,toks') = case mtyp of+ Nothing -> ([],toks2)+ Just (typ@(GHC.L l _)) -> (typeLayout,toks'')+ where+ (t1,typToks,toks'') = splitToksIncComments (ghcSpanStartEnd l) toks2+ typeLayout = strip $ (makeLeafFromToks t1) ++ allocType typ typToks++ (s3,rhsToks,bindsToks) = splitToksForList rhs toks'+ patLayout = allocList pats patsToks allocPat+ grhsLayout = allocGRHSs grhs (rhsToks++bindsToks)+ matchLayout = [makeGroup $ strip $ (makeLeafFromToks s2)+ ++ patLayout ++ mtypLayout+ ++ (makeLeafFromToks s3) ++ grhsLayout+ -- ++ (makeLeafFromToks toks2)+ ]+ r = (strip $ (makeLeafFromToks sb)+ ++ matchLayout+ ++ (makeLeafFromToks sa))+ -- r = error $ "allocMatches.doOne:toks=" ++ show toks++-- ---------------------------------------------------------------------++allocGRHSs :: GHC.GRHSs GHC.RdrName -> [PosToken] -> [LayoutTree]+allocGRHSs (GHC.GRHSs rhs localBinds) toks = r+ where+ (s1,rhsToks,bindsToks) = splitToksForList rhs toks+ rhsLayout = allocList rhs rhsToks allocRhs+ localBindsLayout = allocLocalBinds localBinds bindsToks+ r = (strip $ (makeLeafFromToks s1) ++ rhsLayout ++ localBindsLayout)+ -- r = error $ "allocGRHSs:toks=" ++ (show localBindsLayout)+ -- r = error $ "allocGRHSs:toks=" ++ (show toks)++-- ---------------------------------------------------------------------++allocPat :: GHC.LPat GHC.RdrName -> [PosToken] -> [LayoutTree]+allocPat (GHC.L l _) toks = makeLeafFromToks toks++-- ---------------------------------------------------------------------++allocRhs :: GHC.LGRHS GHC.RdrName -> [PosToken] -> [LayoutTree]+allocRhs (GHC.L l (GHC.GRHS stmts expr)) toksIn = r+ where+ (sb,toksRhs,sa) = splitToksIncComments (ghcSpanStartEnd l) toksIn+ (s1,stmtsToks,toks') = splitToksForList stmts toksRhs+ stmtsLayout = allocList stmts stmtsToks allocStmt+ exprLayout = allocExpr expr toks'+ exprMainLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ stmtsLayout ++ exprLayout]+ r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)+ -- r = error $ "allocRhs.GRHS:toksIn=" ++ show toksIn+-- ---------------------------------------------------------------------++allocStmt :: GHC.LStmt GHC.RdrName -> [PosToken] -> [LayoutTree]+allocStmt (GHC.L _ (GHC.LastStmt expr _)) toks = allocExpr expr toks+allocStmt (GHC.L _ (GHC.BindStmt pat@(GHC.L lp _) expr _ _)) toks = r+ where+ (s1,patToks,toks') = splitToksIncComments (ghcSpanStartEnd lp) toks+ patLayout = allocPat pat patToks+ exprLayout = allocExpr expr toks'+ r = strip $ (makeLeafFromToks s1) ++ patLayout ++ exprLayout+allocStmt (GHC.L _ (GHC.ExprStmt expr _ _ _)) toks = allocExpr expr toks+allocStmt (GHC.L _ (GHC.LetStmt binds)) toks = allocLocalBinds binds toks+#if __GLASGOW_HASKELL__ > 704+allocStmt (GHC.L _ (GHC.ParStmt stmts _ _)) toks = error "allocStmt ParStmt undefined"+#else+allocStmt (GHC.L _ (GHC.ParStmt stmts _ _ _)) toks = error "allocStmt ParStmt undefined"+#endif+allocStmt (GHC.L _ (GHC.TransStmt _ _ _ _ _ _ _ _ )) toks = error "allocStmt TransStmt undefined"+allocStmt (GHC.L _ (GHC.RecStmt _ _ _ _ _ _ _ _ _)) toks = error "allocStmt RecStmt undefined"++-- ---------------------------------------------------------------------++allocExpr :: GHC.LHsExpr GHC.RdrName -> [PosToken] -> [LayoutTree]+allocExpr (GHC.L l (GHC.HsVar _)) toks = [makeLeaf l NoChange toks]+allocExpr (GHC.L l (GHC.HsLit _)) toks = [makeLeaf l NoChange toks]+allocExpr (GHC.L l (GHC.HsOverLit _)) toks = [makeLeaf l NoChange toks]+allocExpr (GHC.L _ (GHC.HsLam (GHC.MatchGroup matches _))) toks+ = allocMatches matches toks+#if __GLASGOW_HASKELL__ > 704+allocExpr (GHC.L _ (GHC.HsLamCase _ (GHC.MatchGroup matches _))) toks+ = allocMatches matches toks+#endif+allocExpr (GHC.L l (GHC.HsApp e1@(GHC.L l1 _) e2)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.OpApp e1@(GHC.L l1 _) e2@(GHC.L l2 _) _ e3)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,e1Toks,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr+ (s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks1+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ e3Layout = allocExpr e3 e3Toks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1)+ ++ e1Layout ++ (makeLeafFromToks s2)+ ++ e2Layout ++ e3Layout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.NegApp expr _)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocExpr expr toksExpr]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.HsPar expr)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocExpr expr toksExpr]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.SectionL e1@(GHC.L l1 _) e2)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.SectionR e1@(GHC.L l1 _) e2)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.ExplicitTuple tupArgs _)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,tupToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toksExpr+ tupLayout = allocTupArgList tupArgs tupToks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ tupLayout+ ++ (makeLeafFromToks toks')]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+-- ExplicitTuple [HsTupArg id] Boxity+allocExpr (GHC.L l (GHC.HsCase expr@(GHC.L le _) (GHC.MatchGroup matches _))) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,exprToks,toks1) = splitToksIncComments (ghcSpanStartEnd le) toksExpr+ (s2,matchToks,toks2) = splitToksForList matches toks1+ exprLayout = allocExpr expr exprToks++ firstMatchTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored matchToks+ p1 = (tokenRow firstMatchTok,tokenCol firstMatchTok)+ (ro,co) = case (filter isOf s2) of+ [] -> (0,0)+ (x:_) -> (tokenRow firstMatchTok - tokenRow x,+ tokenCol firstMatchTok - (tokenCol x + tokenLen x))++ (rt,ct) = calcLastTokenPos matchToks++ so = makeOffset ro (co - 1)+ matchesLayout = [placeAbove so p1 (rt,ct) (allocMatches matches matchToks)]++ exprMainLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout+ ++ (makeLeafFromToks s2) ++ matchesLayout ++ (makeLeafFromToks toks2)]++ r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.HsIf _ e1@(GHC.L l1 _) e2@(GHC.L l2 _) e3)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,e1Toks,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr+ (s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks1+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ e3Layout = allocExpr e3 e3Toks+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1)+ ++ e1Layout ++ (makeLeafFromToks s2)+ ++ e2Layout ++ e3Layout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+#if __GLASGOW_HASKELL__ > 704+allocExpr (GHC.L l (GHC.HsMultiIf _ rhs)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocList rhs toksExpr allocRhs]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+#endif+allocExpr (GHC.L l (GHC.HsLet localBinds expr@(GHC.L le _))) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (bindToks,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd le) toksExpr+ bindLayout = allocLocalBinds localBinds bindToks+ exprLayout = allocExpr expr exprToks+ exprMainLayout = [makeGroup $ strip $ bindLayout ++ [makeGroup exprLayout] ++ (makeLeafFromToks toks')]+ r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.HsDo _ stmts _)) toks = r+ where+ (s1,toksBinds',toks1) = splitToksIncComments (ghcSpanStartEnd l) toks++ (before,including) = break isDo toksBinds'+ doToks = before ++ [ghead "allocExpr" including]+ toksBinds = gtail ("allocExpr.HsDo" ++ show (before,including,toks)) including++ bindsLayout' = allocList stmts toksBinds allocStmt++ firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds+ p1 = (tokenRow firstBindTok,tokenCol firstBindTok)+ (ro,co) = case (filter isDo doToks) of+ [] -> (0,0)+ (x:_) -> (tokenRow firstBindTok - tokenRow x,+ tokenCol firstBindTok - (tokenCol x + tokenLen x))++ (rt,ct) = calcLastTokenPos toksBinds++ so = makeOffset ro (co -1)++ bindsLayout = case bindsLayout' of+ [] -> []+ bs -> [placeAbove so p1 (rt,ct) bs]++ r = strip $ (makeLeafFromToks (s1++doToks) ++ bindsLayout ++ makeLeafFromToks toks1)+ -- r = error $ "allocExpr.HsDo:toksBinds=" ++ (show toksBinds)+ -- r = error $ "allocExpr.HsDo:toks=" ++ (show toks)+allocExpr (GHC.L l (GHC.ExplicitList _ exprs)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocList exprs toksExpr allocExpr]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.ExplicitPArr _ exprs)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocList exprs toksExpr allocExpr]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)+allocExpr (GHC.L l (GHC.RecordCon (GHC.L ln _) _ (GHC.HsRecFields fields _))) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ (s1,nameToks,fieldsToks) = splitToksIncComments (ghcSpanStartEnd ln) toksExpr+ nameLayout = [makeLeaf ln NoChange nameToks]+ fieldsLayout = error "allocExpr allocRecField needs work"+ exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ nameLayout ++ fieldsLayout]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)++allocExpr (GHC.L l (GHC.ArithSeq _ info)) toks = r+ where+ (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+ exprLayout = [makeGroup $ allocArithSeqInfo info toksExpr]+ r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)++allocExpr e toks = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)++-- ---------------------------------------------------------------------++allocLocalBinds :: GHC.HsLocalBinds GHC.RdrName -> [PosToken] -> [LayoutTree]+allocLocalBinds GHC.EmptyLocalBinds toks = strip $ makeLeafFromToks toks+allocLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) toks = r+ where+ bindList = GHC.bagToList binds++ startBind = startPosForList bindList+ startSig = startPosForList sigs+ start = if startSig < startBind then startSig else startBind++ endBind = endPosForList bindList+ endSig = endPosForList sigs+ end = if endSig > endBind then endSig else endBind++ (s1,toksBinds,toks1) = splitToksIncComments (start,end) toks++ firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds+ p1 = (tokenRow firstBindTok,tokenCol firstBindTok)+ (ro,co) = case (filter isWhereOrLet s1) of+ [] -> (0,0)+ (x:_) -> (tokenRow firstBindTok - tokenRow x,+ tokenCol firstBindTok - (tokenCol x + tokenLen x))++ -- (rt,ct) = case (dropWhile isWhiteSpaceOrIgnored (reverse toksBinds)) of+ {-+ (rt,ct) = case (dropWhile isEmpty (reverse toksBinds)) of+ [] -> (0,0)+ (x:_) -> (tokenRow x,tokenCol x)+ -}+ (rt,ct) = calcLastTokenPos toksBinds++ bindsLayout' = allocInterleavedLists bindList sigs (toksBinds) allocBind allocSig++ so = makeOffset ro (co -1)++ bindsLayout = case bindsLayout' of+ [] -> []+ bs -> [placeAbove so p1 (rt,ct) bs]++ r = strip $ (makeLeafFromToks s1) ++ bindsLayout ++ (makeLeafFromToks toks1)+ -- r = error $ "allocLocalBinds:(s1,toksBinds,toks1)=" ++ show (s1,toksBinds,toks1)++allocLocalBinds (GHC.HsIPBinds ib) toks = error "allocLocalBinds undefined"++-- ---------------------------------------------------------------------++makeOffset :: RowOffset -> ColOffset -> EndOffset+makeOffset 0 0 = None+makeOffset 0 co = SameLine co+makeOffset ro co = FromAlignCol (ro,co)++-- ---------------------------------------------------------------------++startPosForList :: [GHC.Located a] -> SimpPos+startPosForList xs = start+ where+ (start,_) = case xs of+ [] -> ((100000,0),(0,0))+ ((GHC.L ls _):_) -> ghcSpanStartEnd ls++endPosForList :: [GHC.Located a] -> SimpPos+endPosForList xs = end+ where+ (_,end) = case xs of+ [] -> ((0,0),(0,0))+ ls -> ghcSpanStartEnd $ GHC.getLoc $ last ls++-- ---------------------------------------------------------------------++allocBind :: GHC.LHsBind GHC.RdrName -> [PosToken] -> [LayoutTree]+allocBind (GHC.L l (GHC.FunBind (GHC.L ln _) _ (GHC.MatchGroup matches _) _ _ _)) toks = r+ where+ (nameLayout,toks1) = ((makeLeafFromToks s1)++[makeLeaf ln NoChange nameToks],toks')+ where+ (s1,nameToks,toks') = splitToksIncComments (ghcSpanStartEnd ln) toks++ (matchesLayout,toks2) = ((makeLeafFromToks s2) ++ allocMatches matches matchToks,toks2')+ where+ (s2,matchToks,toks2') = splitToksForList matches toks1++ r = strip $ [mkGroup l NoChange (strip $ nameLayout ++ matchesLayout)] ++ (makeLeafFromToks toks2)+ -- r = error $ "allocBind.FunBind:toks2=" ++ show toks2+ -- r = error $ "allocBind.FunBind:matchesLayout=" ++ show matchesLayout++allocBind (GHC.L l (GHC.PatBind lhs@(GHC.L ll _) grhs@(GHC.GRHSs rhs _) _ _ _)) toks = r+ where+ (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,lhsToks,toks1) = splitToksIncComments (ghcSpanStartEnd ll) bindToks+ (s3,rhsToks,bindsToks) = splitToksForList rhs toks1++ lhsLayout = allocPat lhs lhsToks+ grhsLayout = allocGRHSs grhs (rhsToks ++ bindsToks)++ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ lhsLayout ++ (makeLeafFromToks s3) ++ grhsLayout+ ++ (makeLeafFromToks toks')) ]++allocBind d@(GHC.L l (GHC.VarBind n rhs _)) toks = error "allocValD:VarBinds"+allocBind d@(GHC.L l (GHC.AbsBinds tvs vars exps ev binds)) toks = error "allocValD:AbsBinds"++-- ---------------------------------------------------------------------++allocSig :: GHC.LSig GHC.RdrName -> [PosToken] -> [LayoutTree]+allocSig (GHC.L l (GHC.TypeSig names t@(GHC.L lt _))) toks = r+ where+ (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nameToks,toks'') = splitToksForList names bindToks+ (s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks''+ nameLayout = allocList names nameToks allocLocated+ typeLayout = allocType t typeToks+ r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ nameLayout ++ (makeLeafFromToks s3) ++ typeLayout+ ++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks'))]+allocSig (GHC.L l (GHC.GenericSig names t@(GHC.L lt _))) toks = r+ where+ (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nameToks,toks'') = splitToksForList names bindToks+ (s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks''+ nameLayout = allocList names nameToks allocLocated+ typeLayout = allocType t typeToks+ r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ nameLayout ++ (makeLeafFromToks s3) ++typeLayout+ ++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks') )]+allocSig (GHC.L l (GHC.IdSig _i)) toks = r+ where+ (s1,nameToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ [makeLeaf l NoChange nameToks])+ ++ (makeLeafFromToks toks') ]+allocSig (GHC.L l (GHC.FixSig (GHC.FixitySig n@(GHC.L ln _) _fix))) toks = r+ where+ (s1,fToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,fixToks) = splitToksIncComments (ghcSpanStartEnd ln) fToks++ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (allocLocated n nToks)+ ++ (makeLeafFromToks s2) ++ (makeLeafFromToks fixToks))+ ++ (makeLeafFromToks toks') ]+allocSig (GHC.L l (GHC.InlineSig n@(GHC.L ln _) _ip)) toks = r+ where+ (s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,ipToks) = splitToksIncComments (ghcSpanStartEnd ln) sigToks+ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (allocLocated n nToks)+ ++ (makeLeafFromToks s2) ++ (makeLeafFromToks ipToks))+ ++ (makeLeafFromToks toks') ]+allocSig (GHC.L l (GHC.SpecSig n@(GHC.L ln _) t@(GHC.L lt _) _ip)) toks = r+ where+ (s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) sigToks+ (s3,tToks,ipToks) = splitToksIncComments (ghcSpanStartEnd lt) toks''+ nameLayout = allocLocated n nToks+ typeLayout = allocType t tToks+ ipLayout = makeLeafFromToks ipToks+ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ nameLayout ++ (makeLeafFromToks s2)+ ++ typeLayout ++ (makeLeafFromToks s3) ++ ipLayout+ ++ (makeLeafFromToks toks')) ]+allocSig (GHC.L l (GHC.SpecInstSig t)) toks = r+ where+ (s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ allocType t sigToks+ ++ (makeLeafFromToks toks')) ]++-- ---------------------------------------------------------------------++allocRecField :: GHC.HsRecFields GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [PosToken] -> [LayoutTree]+allocRecField = error "Layout.allocRecField undefined"++-- ---------------------------------------------------------------------++allocArithSeqInfo :: GHC.ArithSeqInfo GHC.RdrName -> [PosToken] -> [LayoutTree]+allocArithSeqInfo (GHC.From e) toks = allocExpr e toks+allocArithSeqInfo (GHC.FromThen e1@(GHC.L l _) e2) toksIn = r+ where+ (s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l) toksIn+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout++allocArithSeqInfo (GHC.FromTo e1@(GHC.L l _) e2) toksIn = r+ where+ (s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l) toksIn+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout+allocArithSeqInfo (GHC.FromThenTo e1@(GHC.L l1 _) e2@(GHC.L l2 _) e3) toksIn = r+ where+ (s1,e1Toks,toks) = splitToksIncComments (ghcSpanStartEnd l1) toksIn+ (s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks+ e1Layout = allocExpr e1 e1Toks+ e2Layout = allocExpr e2 e2Toks+ e3Layout = allocExpr e3 e3Toks+ r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout ++ (makeLeafFromToks s2) ++ e3Layout++-- ---------------------------------------------------------------------++allocType :: GHC.LHsType GHC.RdrName -> [PosToken] -> [LayoutTree]+allocType (GHC.L l (GHC.HsForAllTy _ef vars (GHC.L lc ctx) typ) ) toks = r+ where+ (s1,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+#if __GLASGOW_HASKELL__ > 704+ (varsLayout,toks2) = allocTyVarBndrs vars exprToks+#else+ (s1',tp,toks2) = splitToksForList vars exprToks+ varsLayout = strip $ (makeLeafFromToks s1') ++ allocList vars tp allocTyVarBndr+#endif+ (s2,ctxToks,toks3) = splitToksIncComments (ghcSpanStartEnd lc) toks2++ ctxLayout = allocHsContext ctx ctxToks+ typLayout = allocType typ toks3++ r = strip $ (makeLeafFromToks s1) ++ varsLayout ++ (makeLeafFromToks s2)+ ++ (makeLeafFromToks s2) ++ ctxLayout+ ++ typLayout ++ (makeLeafFromToks toks')+allocType n@(GHC.L _l (GHC.HsTyVar _) ) toks = allocLocated n toks+allocType (GHC.L l (GHC.HsAppTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks+ t1Layout = allocType t1 t1Toks+ t2Layout = allocType t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsFunTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks+ t1Layout = allocType t1 t1Toks+ t2Layout = allocType t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsListTy t1@(GHC.L l1 _)) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks+ t1Layout = allocType t1 t1Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsPArrTy t1@(GHC.L l1 _)) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks+ t1Layout = allocType t1 t1Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsTupleTy _sort types)) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ typesLayout = allocList types typeToks allocType+ r = strip $ (makeLeafFromToks s1)+ ++ typesLayout ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsOpTy t1@(GHC.L l1 _) _op t2@(GHC.L l2 _))) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1+ (s4,t2Toks,toks4) = splitToksIncComments (ghcSpanStartEnd l2) toks2+ t1Layout = allocType t1 t1Toks+ -- opLayout = allocLocated op opToks+ t2Layout = allocType t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout -- ++ (makeLeafFromToks s3)+ {- ++ opLayout -} ++ (makeLeafFromToks s4)+ ++ t2Layout ++ (makeLeafFromToks toks4)+ ++ (makeLeafFromToks toks')+allocType n@(GHC.L _l (GHC.HsParTy _) ) toks = allocLocated n toks+allocType (GHC.L l (GHC.HsIParamTy _ typ@(GHC.L lt _)) ) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1+ typLayout = allocType typ typToks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ typLayout ++ (makeLeafFromToks toks2)+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsEqTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1+ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2+ t1Layout = allocType t1 t1Toks+ t2Layout = allocType t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks s3)+ ++ t2Layout ++ (makeLeafFromToks toks3)+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsKindSig t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1+ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2+ t1Layout = allocType t1 t1Toks+ t2Layout = allocType t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks s3)+ ++ t2Layout ++ (makeLeafFromToks toks3)+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote _n _lq _)) ) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ quoteLayout = makeLeafFromToks toks1+ r = strip $ (makeLeafFromToks s1)+ ++ quoteLayout+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsSpliceTy (GHC.HsSplice _n e@(GHC.L le _)) _fv _k) ) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,eToks,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1+ eLayout = allocExpr e eToks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ eLayout ++ (makeLeafFromToks toks2)+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsDocTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1+ (s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2+ t1Layout = allocType t1 t1Toks+ t2Layout = allocLocated t2 t2Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks s3)+ ++ t2Layout ++ (makeLeafFromToks toks3)+ ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsBangTy _ t1@(GHC.L l1 _)) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks+ t1Layout = allocType t1 t1Toks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')+allocType (GHC.L l (GHC.HsRecTy decls) ) toks = r+ where+ (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (declsLayout,toks1) = allocConDeclFieldList decls typeToks+ r = strip $ (makeLeafFromToks s1)+ ++ declsLayout+ ++ (makeLeafFromToks toks1)+ ++ (makeLeafFromToks toks')+allocType n@(GHC.L _l (GHC.HsCoreTy _) ) toks = allocLocated n toks+allocType (GHC.L _l (GHC.HsExplicitListTy _ ts) ) toks = allocList ts toks allocType+allocType (GHC.L _l (GHC.HsExplicitTupleTy _ ts) ) toks = allocList ts toks allocType+#if __GLASGOW_HASKELL__ > 704+allocType n@(GHC.L _l (GHC.HsTyLit _) ) toks = allocLocated n toks+#endif+allocType (GHC.L l (GHC.HsWrapTy _ typ) ) toks = allocType (GHC.L l typ) toks+allocType t toks = error $ "allocType: not implemented for:" ++ (showGhc t)++-- ---------------------------------------------------------------------++allocInstDecl :: GHC.LInstDecl GHC.RdrName -> [PosToken] -> [LayoutTree]+#if __GLASGOW_HASKELL__ > 704+allocInstDecl (GHC.L l (GHC.ClsInstD polyTy@(GHC.L lt _) binds sigs famInsts)) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,polytToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1++ polytLayout = allocType polyTy polytToks++ -- TODO: will require 3-way merge of binds,sigs and famInsts+ bindList = GHC.bagToList binds+ bindMix = makeMixedListEntry bindList (shim allocBind)+ sigMix = makeMixedListEntry sigs (shim allocSig)+ famMix = makeMixedListEntry famInsts (shim allocLFamInstDecl)++ bindsLayout' = allocMixedList (bindMix++sigMix++famMix) toks2+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ polytLayout ++ bindsLayout'+ ++ (makeLeafFromToks toks')+allocInstDecl (GHC.L l (GHC.FamInstD decl)) toks = r+ where+ (s1,toks1,s2) = splitToksIncComments (ghcSpanStartEnd l) toks+ declLayout = allocLFamInstDecl (GHC.L l decl) toks1+ r = strip $(makeLeafFromToks s1) ++ declLayout ++ (makeLeafFromToks s2)+#else+-- InstDecl (LHsType name) (LHsBinds name) [LSig name] [LTyClDecl name]+allocInstDecl (GHC.L l (GHC.InstDecl (GHC.L ln _) binds sigs tycldecls)) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks++ -- TODO: will require 3-way merge of binds,sigs and famInsts+ bindList = GHC.bagToList binds+ bindMix = makeMixedListEntry bindList (shim allocBind)+ sigMix = makeMixedListEntry sigs (shim allocSig)+ famMix = makeMixedListEntry tycldecls (shim allocLTyClDecl)++ bindsLayout' = allocMixedList (bindMix++sigMix++famMix) toks1+ r = strip $ (makeLeafFromToks s1)+ ++ bindsLayout'+ ++ (makeLeafFromToks toks')+#endif++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocLFamInstDecl :: GHC.LFamInstDecl GHC.RdrName -> [PosToken] -> [LayoutTree]+allocLFamInstDecl (GHC.L l (GHC.FamInstDecl n@(GHC.L ln _) (GHC.HsWB typs _ _) defn _fvs)) toks = r+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) toks1+ (s3,typsToks,defnToks) = splitToksForList typs toks2++ nLayout = allocLocated n nToks+ patsLayout = allocList typs typsToks allocType+ (defnLayout,s4) = allocHsTyDefn defn defnToks+ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ nLayout ++ (makeLeafFromToks s3)+ ++ patsLayout ++ defnLayout+ ++ (makeLeafFromToks s4)+ ++ (makeLeafFromToks toks')+#endif++-- ---------------------------------------------------------------------++allocLTyClDecl = error "allocLTyClDecl undefined"+allocFunDep = error "allocFunDep undefined"++allocHsTupArg :: GHC.HsTupArg GHC.RdrName -> [PosToken] -> [LayoutTree]+allocHsTupArg = error "allocHsTupArg undefined"++-- ---------------------------------------------------------------------++allocTupArgList :: [GHC.HsTupArg GHC.RdrName] -> [PosToken] -> [LayoutTree]+allocTupArgList tas toksIn = r+ where+ go :: ([LayoutTree],[PosToken]) -> [GHC.HsTupArg GHC.RdrName] -> ([LayoutTree],[PosToken])+ go (acc,toks) [] = (acc,toks)+ go (acc,toks) ((GHC.Missing _):ts') = go (acc,toks) ts'+ go (acc,toks) ((GHC.Present expr@(GHC.L l _)):ts') = go (acc++exprLayout,toks') ts'+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ eLayout = allocExpr expr toks1+ exprLayout = strip $ (makeLeafFromToks s1) ++ eLayout+ (lay,toksOut) = go ([],toksIn) tas+ r = strip $ lay ++ (makeLeafFromToks toksOut)++-- ---------------------------------------------------------------------++allocLocated :: GHC.Located b -> [PosToken] -> [LayoutTree]+allocLocated (GHC.L l _) toks = r+ where+ (s1,toks1,s2) = splitToksIncComments (ghcSpanStartEnd l) toks+ r = strip $ (makeLeafFromToks s1) ++ [makeLeaf l NoChange toks1] ++ (makeLeafFromToks s2)++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocTyVarBndrs :: GHC.LHsTyVarBndrs GHC.RdrName -> [PosToken] -> ([LayoutTree],[PosToken])+allocTyVarBndrs (GHC.HsQTvs _kvs tvs) toks = (r,s1)+ where+ (kvsToks,tyvarToks,s1) = splitToksForList tvs toks+ tyvarLayout = allocList tvs tyvarToks allocTyVarBndr+ r = (strip $ (makeLeafFromToks kvsToks) ++ tyvarLayout)+#else++#endif++-- ---------------------------------------------------------------------++allocTyVarBndr :: GHC.LHsTyVarBndr GHC.RdrName -> [PosToken] -> [LayoutTree]+#if __GLASGOW_HASKELL__ > 704+allocTyVarBndr n@(GHC.L l (GHC.UserTyVar _ )) toks = r+#else+allocTyVarBndr n@(GHC.L l (GHC.UserTyVar _ _)) toks = r+#endif+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ nLayout = allocLocated n toks1+ r = strip $ (makeLeafFromToks s1) ++ nLayout+ ++ (makeLeafFromToks toks')+#if __GLASGOW_HASKELL__ > 704+allocTyVarBndr (GHC.L l (GHC.KindedTyVar _n k@(GHC.L lk _) )) toks = r+#else+allocTyVarBndr (GHC.L l (GHC.KindedTyVar _n k@(GHC.L lk _) _)) toks = r+#endif+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (nToks,kToks,toks2) = splitToksIncComments (ghcSpanStartEnd lk) toks1+ nLayout = makeLeafFromToks nToks+ kindLayout = allocType k kToks+ r = strip $ (makeLeafFromToks s1) ++ nLayout+ ++ kindLayout ++ (makeLeafFromToks toks2)+ ++ (makeLeafFromToks toks')++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocHsTyDefn :: GHC.HsTyDefn GHC.RdrName -> [PosToken] -> ([LayoutTree],[PosToken])+allocHsTyDefn (GHC.TySynonym typ@(GHC.L l _)) toks = (r,toks')+ where+ (s1,typToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ typeLayout = allocType typ typToks+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ typeLayout]+allocHsTyDefn (GHC.TyData _ (GHC.L lc ctx) mc mk cons mderivs) toks = (r,toks')+ where+ (s1,ctxToks,toks2) = splitToksIncComments (ghcSpanStartEnd lc) toks+ ctxLayout = allocHsContext ctx ctxToks++ -- TODO: correctly determine the token range for this+ (mcLayout,toks3) = case mc of+ Nothing -> ([],toks2)+ Just ct -> (rc,toks2')+ where+ ctLayout = allocCType ct toks2+ toks2' = toks2+ rc = strip $ ctLayout++ (mkLayout,toks4) = case mk of+ Nothing -> ([],toks3)+ Just k@(GHC.L lk _) -> (rk,toks3')+ where+ (sk,kToks,toks3') = splitToksIncComments (ghcSpanStartEnd lk) toks3+ kindLayout = allocHsKind k kToks+ rk = strip $ (makeLeafFromToks sk) ++ kindLayout++ (s2,consToks,toks5) = splitToksForList cons toks4+ consLayout = allocList cons consToks allocConDecl++ (mderivsLayout,toks6) = case mderivs of+ Nothing -> ([],toks5)+ Just ds -> (rd,toksd)+ where+ (sd,derivToks,toksd) = splitToksForList ds toks5+ derivLayout = allocList ds derivToks allocType+ rd = strip $ (makeLeafFromToks sd) ++ derivLayout+ toks' = toks6+ r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ ctxLayout ++ mcLayout ++ mkLayout+ ++ (makeLeafFromToks s2) ++ consLayout ++ mderivsLayout]+#endif++-- ---------------------------------------------------------------------++allocConDecl :: GHC.LConDecl GHC.RdrName -> [PosToken] -> [LayoutTree]+allocConDecl (GHC.L l (GHC.ConDecl n@(GHC.L ln _) _expl qvars (GHC.L lc ctx) details res mdoc _)) toks = r+ where+ (s1,conDeclToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ (s2,nameToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) conDeclToks+ nameLayout = allocLocated n nameToks+#if __GLASGOW_HASKELL__ > 704+ (qvarsLayout,toks3) = allocTyVarBndrs qvars toks2+#else+ qvarsLayout = allocList qvars toks2 allocTyVarBndr+ toks3 = []+#endif+ (s3,ctxToks,toks4) = splitToksIncComments (ghcSpanStartEnd lc) toks3+ ctxLayout = allocHsContext ctx ctxToks++ (detailsLayout,toks5) = allocHsConDeclDetails details toks4+ (resLayout,toks6) = case res of+ GHC.ResTyH98 -> ([],toks5)+ GHC.ResTyGADT (ty@(GHC.L lt _)) -> (rt,toks6')+ where+ (st,tyToks,toks6') = splitToksIncComments (ghcSpanStartEnd lt) toks5+ tyLayout = allocType ty tyToks+ rt = strip $ (makeLeafFromToks st) ++ tyLayout++ (docLayout,toks7) = case mdoc of+ Nothing -> ([],toks6)+ Just ds@(GHC.L ld _) -> (rd,toks7')+ where+ (sd,dsToks,toks7') = splitToksIncComments (ghcSpanStartEnd ld) toks6+ dsLayout = allocLocated ds dsToks+ rd = strip (makeLeafFromToks sd) ++ dsLayout++ r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+ ++ nameLayout ++ qvarsLayout ++ (makeLeafFromToks s3)+ ++ ctxLayout ++ detailsLayout ++ resLayout+ ++ docLayout ++ (makeLeafFromToks toks7)+ ++ (makeLeafFromToks toks')++-- ---------------------------------------------------------------------++allocHsConDeclDetails :: GHC.HsConDeclDetails GHC.RdrName -> [PosToken] -> ([LayoutTree],[PosToken])+allocHsConDeclDetails (GHC.PrefixCon ds) toks = (r,toks')+ where+ (s1,dsToks,toks') = splitToksForList ds toks+ dsLayout = allocList ds dsToks allocLBangType+ r = strip $ (makeLeafFromToks s1) ++ dsLayout+allocHsConDeclDetails (GHC.RecCon conDecls) toks = allocConDeclFieldList conDecls toks+allocHsConDeclDetails (GHC.InfixCon bt1@(GHC.L lb1 _) bt2@(GHC.L lb2 _)) toks = (r,toks')+ where+ (s1,bt1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd lb1) toks+ (s2,bt2Toks,toks') = splitToksIncComments (ghcSpanStartEnd lb2) toks2+ bt1Layout = allocType bt1 bt1Toks+ bt2Layout = allocType bt2 bt2Toks++ r = strip $ (makeLeafFromToks s1) ++ bt1Layout+ ++ (makeLeafFromToks s2) ++ bt2Layout++-- ---------------------------------------------------------------------++allocConDeclFieldList :: [GHC.ConDeclField GHC.RdrName] -> [PosToken] -> ([LayoutTree],[PosToken])+allocConDeclFieldList conDecls toks = (r,toks')+ where+ (r,toks') = foldl' doOne ([],toks) conDecls++ doOne (acc,toksOne) cdf = (r1,toks2)+ where+ (lay,toks2) = allocConDeclField cdf toksOne+ r1 = acc ++ lay++allocConDeclField :: GHC.ConDeclField GHC.RdrName -> [PosToken] -> ([LayoutTree],[PosToken])+allocConDeclField (GHC.ConDeclField n@(GHC.L ln _) typ@(GHC.L lb _) mdoc) toks = (r,toks')+ where+ (s1,nToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toks+ nLayout = allocLocated n nToks+ (s2,btToks,toks2) = splitToksIncComments (ghcSpanStartEnd lb) toks1+ btLayout = allocLBangType typ btToks+ (mdocLayout,toks') = case mdoc of+ Nothing -> ([],toks2)+ Just ldoc@(GHC.L ld _) -> (rd,toks2')+ where+ (sd,docToks,toks2') = splitToksIncComments (ghcSpanStartEnd ld) toks2+ rdLayout = allocLocated ldoc docToks+ rd = strip $ (makeLeafFromToks sd) ++ rdLayout+ r = strip $ (makeLeafFromToks s1) ++ nLayout ++ (makeLeafFromToks s2)+ ++ btLayout ++ mdocLayout++-- ---------------------------------------------------------------------++allocLBangType :: GHC.LBangType GHC.RdrName -> [PosToken] -> [LayoutTree]+allocLBangType bt toks = allocType bt toks++-- ---------------------------------------------------------------------++allocHsKind :: GHC.LHsKind GHC.RdrName -> [PosToken] -> [LayoutTree]+allocHsKind = error "allocHsKind undefined"++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocCType :: GHC.CType -> [PosToken] -> [LayoutTree]+#endif+allocCType = error "allocCType undefined"++-- ---------------------------------------------------------------------++allocHsContext :: GHC.HsContext GHC.RdrName -> [PosToken] -> [LayoutTree]+allocHsContext ts toks = r+ where+ r = allocList ts toks allocType++-- ---------------------------------------------------------------------++strip :: [LayoutTree] -> [LayoutTree]+strip ls = filter (not . emptyNode) ls+ where+ emptyNode (Node (Entry _ _ []) []) = True+ emptyNode _ = False++-- ---------------------------------------------------------------------++allocList :: [GHC.Located b] -> [PosToken]+ -> (GHC.Located b -> [PosToken] -> [LayoutTree])+ -> [LayoutTree]+allocList xs toksIn allocFunc = r+ where+ (s2,listToks,toks2') = splitToksForList xs toksIn+ (layout,toks2) = ((makeLeafFromToks s2) ++ allocAll xs listToks,toks2')++ allocAll xs' toks = res+ where+ (declLayout,tailToks) = foldl' doOne ([],toks) xs'++ res = strip $ declLayout ++ (makeLeafFromToks tailToks)++ -- doOne :: ([LayoutTree],[PosToken]) -> GHC.Located a -> ([LayoutTree],[PosToken])+ doOne (acc,toksOne) x@(GHC.L l _) = r1+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toksOne+ layout' = (makeLeafFromToks s1) ++ [makeGroup (strip $ allocFunc x funcToks)]+ r1 = (acc ++ (strip layout'),toks')++ r = strip $ layout ++ (makeLeafFromToks toks2)++-- ---------------------------------------------------------------------++-- TODO: get rid of this in favour of mix stuf+allocInterleavedLists :: [GHC.Located a] -> [GHC.Located b] -> [PosToken]+ -> (GHC.Located a -> [PosToken] -> [LayoutTree])+ -> (GHC.Located b -> [PosToken] -> [LayoutTree])+ -> [LayoutTree]+allocInterleavedLists axs bxs toksIn allocFuncA allocFuncB = r+ where+ -- go :: ([LayoutTree],[PosToken]) -> [GHC.Located a] -> [GHC.Located b] -> ([LayoutTree],[PosToken])+ go (acc,ts) [] [] = (acc,ts)+ go (acc,ts) (a:as) [] = go (acc ++ aa,ts') as []+ where+ (aa,ts') = allocA a ts+ go (acc,ts) [] (b:bs) = go (acc ++ bb,ts') [] bs+ where+ (bb,ts') = allocB b ts+ go (acc,ts) (a:as) (b:bs) = if GHC.getLoc a < GHC.getLoc b+ then go (acc ++ aa,tsa') as (b:bs)+ else go (acc ++ bb,tsb') (a:as) bs+ where+ (aa,tsa') = allocA a ts+ (bb,tsb') = allocB b ts++ -- allocA :: GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken])+ allocA x@(GHC.L l _) toks = (r',toks')+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ funcLayout = allocFuncA x funcToks+ r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]++ -- allocB :: GHC.Located b -> [PosToken] -> ([LayoutTree],[PosToken])+ allocB x@(GHC.L l _) toks = (r',toks')+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ funcLayout = allocFuncB x funcToks+ r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]+ -- r' = error $ "allocB:(funcLayout)=" ++ show funcLayout++ (layout,s2) = go ([],toksIn) axs bxs+ r = strip $ layout ++ (makeLeafFromToks s2)++-- ---------------------------------------------------------------------+{-+allocInterleavedLists3 :: [GHC.Located a] -> [GHC.Located b] -> [GHC.Located c]+ -> [PosToken]+ -> (GHC.Located a -> [PosToken] -> [LayoutTree])+ -> (GHC.Located b -> [PosToken] -> [LayoutTree])+ -> (GHC.Located c -> [PosToken] -> [LayoutTree])+ -> [LayoutTree]+allocInterleavedLists3 axs bxs cxs toksIn allocFuncA allocFuncB allocFuncC = r+ where+ -- go :: ([LayoutTree],[PosToken]) -> [GHC.Located a] -> [GHC.Located b] -> ([LayoutTree],[PosToken])+ go (acc,ts) [] [] [] = (acc,ts)+ go (acc,ts) (a:as) [] [] = go (acc ++ aa,ts') as [] []+ where+ (aa,ts') = allocA a ts+ go (acc,ts) [] (b:bs) [] = go (acc ++ bb,ts') [] bs []+ where+ (bb,ts') = allocB b ts+ go (acc,ts) [] [] (c:cs) = go (acc ++ cc,ts') [] [] cs+ where+ (cc,ts') = allocC c ts++ go (acc,ts) (a:as) (b:bs) [] = if GHC.getLoc a < GHC.getLoc b+ then go (acc ++ aa,tsa') as (b:bs) []+ else go (acc ++ bb,tsb') (a:as) bs []+ where+ (aa,tsa') = allocA a ts+ (bb,tsb') = allocB b ts++ -- allocA :: GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken])+ allocA x@(GHC.L l _) toks = (r',toks')+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ funcLayout = allocFuncA x funcToks+ r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]++ -- allocB :: GHC.Located b -> [PosToken] -> ([LayoutTree],[PosToken])+ allocB x@(GHC.L l _) toks = (r',toks')+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ funcLayout = allocFuncB x funcToks+ r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]+ -- r' = error $ "allocB:(funcLayout)=" ++ show funcLayout++ -- allocC :: GHC.Located c -> [PosToken] -> ([LayoutTree],[PosToken])+ allocC x@(GHC.L l _) toks = (r',toks')+ where+ (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ funcLayout = allocFuncC x funcToks+ r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]+ -- r' = error $ "allocC:(funcLayout)=" ++ show funcLayout++ (layout,s2) = go ([],toksIn) axs bxs cxs+ r = strip $ layout ++ (makeLeafFromToks s2)+-}++-- ---------------------------------------------------------------------++shim ::+ (GHC.Located a -> [PosToken] -> [LayoutTree])+ -> (GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken]))+shim f = f'+ where+ f' x@(GHC.L l _) toks = (r,toks')+ where+ (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+ r = strip $ (makeLeafFromToks s1) ++ f x toks1++makeMixedListEntry ::+ [GHC.Located a]+ -> (GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken]))+ -> [(SimpPos,([PosToken] -> ([LayoutTree],[PosToken])))]+makeMixedListEntry xs f = map (\x@(GHC.L l _) -> (fst $ ghcSpanStartEnd l,f x)) xs++allocMixedList ::+ [(SimpPos,([PosToken] -> ([LayoutTree],[PosToken])))]+ -> [PosToken] -> [LayoutTree]+allocMixedList xs toksIn = r+ where+ xs' = sortBy (\(p1,_) (p2,_) -> compare p1 p2) xs+ (layout,toksFin) = foldl' doOne ([],toksIn) xs'++ doOne :: ([LayoutTree],[PosToken]) -> (SimpPos,([PosToken] -> ([LayoutTree],[PosToken])))+ -> ([LayoutTree],[PosToken])+ doOne (acc,toks) (_,f) = (acc++lay,toks')+ where+ (lay,toks') = f toks++ r = strip $ layout ++ (makeLeafFromToks toksFin)++-- ---------------------------------------------------------------------++-- | Split the given tokens into the ones that occur prior to the start+-- of the list and ones that occur after+splitToksForList :: [GHC.Located a] -> [PosToken] -> ([PosToken],[PosToken],[PosToken])+splitToksForList [] toks = ([],[],toks)+splitToksForList xs toks = splitToksIncComments (getGhcLoc s, getGhcLocEnd e) toks+ where+ (GHC.L s _) = head xs+ (GHC.L e _) = last xs++-- ---------------------------------------------------------------------++calcLastTokenPos :: [PosToken] -> (Int,Int)+calcLastTokenPos toks = (rt,ct)+ where+ (rt,ct) = case (dropWhile isEmpty (reverse toks)) of+ [] -> (0,0)+ (x:_) -> (tokenRow x,tokenCol x + tokenLen x)++-- ---------------------------------------------------------------------++placeAbove :: EndOffset -> (Row,Col) -> (Row,Col) -> [LayoutTree] -> LayoutTree+placeAbove _ _ _ [] = error "placeAbove []"+placeAbove so p1 p2 ls = Node (Entry loc (Above so p1 p2 None) []) ls+ where+ loc = combineSpans (getLoc $ head ls) (getLoc $ last ls)++-- ---------------------------------------------------------------------++{-+placeOffset :: RowOffset -> ColOffset -> [LayoutTree] -> LayoutTree+placeOffset _ _ [] = error "placeOffset []"+placeOffset r c ls = Node (Entry loc (Offset r c) []) ls+ where+ loc = combineSpans (getLoc $ head ls) (getLoc $ last ls)+-}+++-- ---------------------------------------------------------------------++makeGroup :: [LayoutTree] -> LayoutTree+makeGroup [x] = x+makeGroup ls = makeGroupLayout NoChange ls++makeGroupLayout :: Layout -> [LayoutTree] -> LayoutTree+makeGroupLayout lay ls = Node (Entry loc lay []) ls+ where+ loc = case ls of+ [] -> sf nullSrcSpan+ _ -> combineSpans (getLoc $ head ls) (getLoc $ last ls)++mkGroup :: GHC.SrcSpan -> Layout -> [LayoutTree] -> LayoutTree+mkGroup sspan lay subs = Node (Entry (sf sspan) lay []) subs++-- ---------------------------------------------------------------------++makeLeafFromToks :: [PosToken] -> [LayoutTree]+makeLeafFromToks [] = []+makeLeafFromToks toks = [Node (Entry loc NoChange toks) []]+ where+ -- TODO: ignore leading/trailing comments etc+ loc = combineSpans (sf $ tokenSrcSpan $ head toks) (sf $ tokenSrcSpan $ last toks)++makeLeaf :: GHC.SrcSpan -> Layout -> [PosToken] -> LayoutTree+makeLeaf sspan lay toks = Node (Entry (sf sspan) lay toks) []++-- ---------------------------------------------------------------------++getLoc :: LayoutTree -> ForestSpan+getLoc (Node (Entry l _ _) _) = l+getLoc (Node (Deleted l _ _) _) = l++-- ---------------------------------------------------------------------++retrieveTokens :: LayoutTree -> [PosToken]+retrieveTokens layout = go [] layout+ where+ -- go acc (Group _ _ xs) = acc ++ (concat $ map (go []) xs)+ -- go acc (Leaf _ _ toks) = acc ++ toks+ go acc (Node (Entry _ _ [] ) xs) = acc ++ (concat $ map (go []) xs)+ go acc (Node (Entry _ _ toks) _) = acc ++ toks+ go acc (Node (Deleted _ _ _) _) = acc++-- ---------------------------------------------------------------------++-- | Split the given tokens to include the comments belonging to the span.+splitToksIncComments ::+ (SimpPos, SimpPos)+ -> [PosToken]+ -> ([PosToken], [PosToken], [PosToken])+splitToksIncComments pos toks = splitToks pos' toks+ where+ pos' = startEndLocIncComments' toks pos++-- ---------------------------------------------------------------------+
+ src/Language/Haskell/Refact/Utils/LayoutTypes.hs view
@@ -0,0 +1,36 @@+-- |+--++module Language.Haskell.Refact.Utils.LayoutTypes (+ TokenLayout(..)+ , LayoutTree+ , Label(..)+ ) where++import GHC++import Data.Tree++import Language.Haskell.Refact.Utils.TypeSyn+import Language.Haskell.Refact.Utils.TokenUtilsTypes++-- ---------------------------------------------------------------------++data TokenLayout = TL (Tree Entry)++type LayoutTree = Tree Entry++-- ---------------------------------------------------------------------+++{-+data LayoutTree a = Group GHC.SrcSpan Layout [LayoutTree a] -- Same as current+ -- TokenUtils internal tree node+ | Leaf GHC.SrcSpan Layout [PosToken] -- Same as current+ -- TokenUtils leaf node+ deriving (Foldable,Traversable,Functor)+-}++data Label = Label GHC.SrcSpan Layout [PosToken]++
+ src/Language/Haskell/Refact/Utils/LayoutUtils.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TypeOperators #-}++module Language.Haskell.Refact.Utils.LayoutUtils+ (+ -- getLayoutFor+ -- , addDeclLayoutAfterSrcSpan+ showLTOne+ -- , openZipper+ ) where++import qualified GHC as GHC++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++import Language.Haskell.Refact.Utils.GhcVersionSpecific+import Language.Haskell.Refact.Utils.Layout+import Language.Haskell.Refact.Utils.LayoutTypes+import Language.Haskell.Refact.Utils.LocUtils+import Language.Haskell.Refact.Utils.Monad+import Language.Haskell.Refact.Utils.TokenUtils+import Language.Haskell.Refact.Utils.TokenUtilsTypes+import Language.Haskell.Refact.Utils.TypeSyn++import Data.Tree++import qualified Data.Tree.Zipper as Z++import qualified Language.Haskell.Refact.Utils.TokenUtils as U+import qualified Language.Haskell.Refact.Utils.TokenUtilsTypes as U++-- ---------------------------------------------------------------------++getLayoutFor :: GHC.SrcSpan -> TokenLayout -> LayoutTree+getLayoutFor sspan (TL layout) = getLayoutFor' sspan layout++getLayoutFor' :: GHC.SrcSpan -> LayoutTree -> LayoutTree+-- getLayoutFor' sspan tl@(Leaf ss _ _)+getLayoutFor' sspan tl@(Node (U.Entry ss _ _) [])+ | sspan == (fs ss) = tl+ | otherwise = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " not in " ++ (showGhc tl)++-- getLayoutFor' sspan tl@(Group ss _ subs)+getLayoutFor' sspan tl@(Node (U.Entry ss _ []) subs)+ | sspan == (fs ss) = tl+ | null subs = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " not in " ++ (showGhc tl)+ | length subs > 1 = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " multiple in " ++ (showGhc tl)+ | otherwise = getLayoutFor' sspan sub+ where+ sub = getChildForSpan sspan subs++-- ---------------------------------------------------------------------++{-+addDeclLayoutAfterSrcSpan :: (SYB.Data t) =>+ LayoutTree -- ^TokenTree to be modified+ -> GHC.SrcSpan -- ^Preceding location for new tokens+ -> U.Positioning+ -> LayoutTree -- ^New tokens to be added+ -> GHC.Located t -- ^Declaration the tokens belong to, to be synced+ -> (TokenLayout, GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for+ -- the new tokens in the TokenTree, and+ -- updated AST element+addDeclLayoutAfterSrcSpan tl oldSpan pos layout t = (tl'',newSpan,t')+ where+ (tl',newSpan) = addLayoutAfterSrcSpan tl oldSpan pos layout+ (t',tl'') = syncAST t newSpan tl'+-}++-- ---------------------------------------------------------------------+{-+-- |Add new tokens after the given SrcSpan, constructing a new SrcSpan+-- in the process+addLayoutAfterSrcSpan ::+ LayoutTree -- ^TokenTree to be modified+ -> GHC.SrcSpan -- ^Preceding location for new tokens+ -> U.Positioning+ -> LayoutTree -- ^New tokens to be added+ -> (LayoutTree, GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for+ -- the new tokens in the TokenTree+addLayoutAfterSrcSpan lt oldSpan pos layout = (lt',newSpan')+ where+ tree = getSrcSpanFor lt oldSpan++ toks'' = placeLayoutForSpan lt oldSpan tree pos layout++ (startPos,endPos) = U.nonCommentSpan toks''++ newSpan = U.posToSrcSpanTok mkZeroToken (startPos,endPos)++ (lt',newSpan') = addNewSrcSpanAndToksAfter lt oldSpan newSpan pos layout+-}+-- ---------------------------------------------------------------------++-- getSrcSpanFor = error "getSrcSpanFor undefined"+-- placeLayoutForSpan = undefined+-- addNewSrcSpanAndToksAfter = undefined++-- ---------------------------------------------------------------------++{-+openZipperToSpan :: GHC.SrcSpan -> LayoutTree -> Top :>> LayoutTree+openZipperToSpan sspan lay = r+ where+ -- r = toZipper lay+ r = zipper lay+-}+{-+openZipper :: GHC.SrcSpan -> Top :>> LayoutTree -> Top :>> LayoutTree+openZipper sspan z+ | getLoc (view focus z) == sspan = z+ | isLeaf (view focus z) = error $ "openZipperToSpan not found " ++ showGhc sspan ++ ":" ++ showLTOne (view focus z)+ | otherwise = openZipper sspan z'+ where+ (Group _ _ subs) = view focus z+ z' = zipper (getChildForSpan sspan subs)+-}+{-+openZipper :: GHC.SrcSpan+ -> Z.TreePos Z.Full Label+ -> Z.TreePos Z.Full Label+openZipper sspan z+ | getLoc (Z.tree z) == sspan = z+ | otherwise = openZipper sspan child+ where+ child = ghead "openZipper" $ filter (GHC.isSubspanOf sspan . getLoc . Z.tree) childrenAsZ+ childrenAsZ = getChildrenAsZ 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)+-}++-- ---------------------------------------------------------------------++-- TODO: need to make ForestLine version of isSubspanof+getChildForSpan :: GHC.SrcSpan -> [LayoutTree] -> LayoutTree+getChildForSpan sspan subs = sub+ where+ sub = ghead "getChildForSpan" $ map snd $ filter (GHC.isSubspanOf sspan . fst) + $ map (\t -> (fs $ getLoc t,t)) subs++-- ---------------------------------------------------------------------++showLTOne :: LayoutTree -> String+-- showLTOne (Leaf ss lay _toks) = "(Leaf " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ "toks)"+-- showLTOne (Group ss lay subs) = "(Group " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ showGhc (map getLoc subs) ++ ")"+showLTOne (Node (U.Entry ss lay _toks) []) = "(Leaf " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ "toks)"+showLTOne (Node (U.Entry ss lay []) subs) = "(Group " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ showGhc (map getLoc subs) ++ ")"+++-- ---------------------------------------------------------------------++isLeaf :: LayoutTree -> Bool+isLeaf (Node _ []) = True+isLeaf _ = False++-- ---------------------------------------------------------------------++-- experiments++
src/Language/Haskell/Refact/Utils/LocUtils.hs view
@@ -15,7 +15,7 @@ -- ,lengthOfToks -- , mkToken, mkZeroToken {-,defaultToken, -} {-whiteSpacesToken -}- ,whiteSpaceTokens+ , whiteSpaceTokens , realSrcLocFromTok , isWhite , notWhite@@ -60,6 +60,7 @@ , prettyprint -- , prettyprintGhc , prettyprintPatList , groupTokensByLine+ , toksOnSameLine , addLocInfo -- , getIndentOffset , getLineOffset@@ -74,6 +75,7 @@ , tokenRow , tokenPos , tokenPosEnd+ , tokenSrcSpan , tokenCon , increaseSrcSpan , getGhcLoc@@ -550,13 +552,13 @@ -- Note1: does not re-align, else other later replacements may fail. -- Note2: must keep original end col, to know what the inter-token gap -- was when re-aligning-replaceTokNoReAlign::[PosToken]->SimpPos->PosToken->[PosToken]+replaceTokNoReAlign:: [PosToken] -> SimpPos -> PosToken -> [PosToken] replaceTokNoReAlign toks pos newTok = toks1 ++ [newTok'] ++ toksRest where (toks1,toks2) = break (\t -> tokenPos t >= pos && tokenLen t > 0) toks toksRest = if (emptyList toks2) then [] else (gtail "replaceTokNoReAlign" toks2)- oldTok = if (emptyList toks2) then newTok else (ghead "replaceTokNoReAlign" toks2)+ oldTok = if (emptyList toks2) then newTok else (ghead "replaceTokNoReAlign" toks2) -- newTok' = markToken newTok newTok' = markToken $ matchTokenPos oldTok newTok @@ -1017,6 +1019,9 @@ tokenPosEnd :: (GHC.GenLocated GHC.SrcSpan t1, t) -> SimpPos tokenPosEnd (GHC.L l _,_) = getGhcLocEnd l +tokenSrcSpan :: (GHC.Located t1, t) -> GHC.SrcSpan+tokenSrcSpan (GHC.L l _,_) = l+ -- TODO: badly named function tokenCon :: PosToken -> String tokenCon (_,s) = s@@ -1105,7 +1110,6 @@ (toks1,toks21,toks22) - -- ---------------------------------------------------------------------- -- |Get around lack of instance Eq when simply testing for empty list@@ -1133,13 +1137,11 @@ notIgnored tt = not (isWhiteSpaceOrIgnored tt) - -- (leadinr,leadr) = break notWhiteSpace $ reverse begin (leadinr,leadr) = break notIgnored $ reverse begin leadr' = filter (\t -> not (isEmpty t)) leadr prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr') firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle) (_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr- -- leadComments = dropWhile (\tt -> (isThen tt || isElse tt || isEmpty tt || isIn tt || isDo tt)) leadComments' leadComments = dropWhile (\tt -> (isEmpty tt)) leadComments' (trail,trailrest) = break notWhiteSpace end@@ -1396,9 +1398,10 @@ -- --------------------------------------------------------------------- groupTokensByLine :: [PosToken] -> [[PosToken]]-groupTokensByLine xs = groupBy fn xs- where- fn t1 t2 = tokenRow t1 == tokenRow t2+groupTokensByLine xs = groupBy toksOnSameLine xs++toksOnSameLine :: PosToken -> PosToken -> Bool+toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2 {- groupTokensByLine :: [PosToken] -> [[PosToken]]
src/Language/Haskell/Refact/Utils/Monad.hs view
@@ -32,15 +32,12 @@ import Control.Monad.State import Data.List--- import Data.Maybe import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal+-- import Language.Haskell.Refact.Utils.LayoutTypes import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn--- import System.Directory--- import System.FilePath--- import System.Log.Logger import qualified Control.Monad.IO.Class as MU -- ---------------------------------------------------------------------@@ -84,6 +81,7 @@ { rsTypecheckedMod :: !GHC.TypecheckedModule , rsOrigTokenStream :: ![PosToken] -- ^Original Token stream for the current module , rsTokenCache :: !TokenCache -- ^Token stream for the current module, maybe modified, in SrcSpan tree form+ -- , rsTokenLayout :: !TokenLayout -- ^Token stream for the current module, maybe modified, in SrcSpan tree form , rsStreamModified :: !Bool -- ^current module has updated the token stream } @@ -164,8 +162,10 @@ , ghcOpts = ghcOptsDirs , operators = False , detailed = False+ , qualified = False , expandSplice = False , lineSeparator = rsetLineSeparator settings+ , packageId = Nothing -- TODO: work this through if needed } (_readLog,mcabal) <- initializeFlagsWithCradle opt cradle (options settings) True
src/Language/Haskell/Refact/Utils/MonadFunctions.hs view
@@ -12,6 +12,8 @@ -- * Conveniences for state access fetchToksFinal+ -- , fetchPprFinal+ , fetchLinesFinal , fetchOrigToks , fetchToks -- Deprecated -- , putToks -- ^Deprecated, destroys token tree@@ -41,10 +43,16 @@ , syncDeclToLatestStash , indentDeclAndToks + -- * LayoutUtils API+ -- , getLayoutForSpan+ -- , putDeclLayoutAfterSpan+ -- * For debugging , drawTokenTree , drawTokenTreeDetailed , getTokenTree+ -- , showPprDebug+ , showLinesDebug -- * State flags for managing generic traversals , getRefactDone@@ -70,9 +78,13 @@ import qualified Data.Data as SYB +import Language.Haskell.Refact.Utils.DualTree import Language.Haskell.Refact.Utils.GhcVersionSpecific-import Language.Haskell.Refact.Utils.Monad+import Language.Haskell.Refact.Utils.Layout+import Language.Haskell.Refact.Utils.LayoutTypes+import Language.Haskell.Refact.Utils.LayoutUtils import Language.Haskell.Refact.Utils.LocUtils+import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.TokenUtils import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn@@ -102,6 +114,26 @@ logm $ "fetchToksFinal (not showing toks)" return toks +-- TODO: get rid of this, superseded by dualtree+{-+-- |fetch the final tokens in Ppr format+fetchPprFinal :: RefactGhc [Ppr]+fetchPprFinal = do+ Just tm <- gets rsModule+ let pprVal = retrieveTokensPpr $ (tkCache $ rsTokenCache tm) Map.! mainTid+ -- logm $ "fetchToks" ++ (showToks toks)+ logm $ "fetchPprFinal (not showing ppr)"+ return pprVal+-}++-- |fetch the final tokens in Ppr format+fetchLinesFinal :: RefactGhc [Line]+fetchLinesFinal = do+ Just tm <- gets rsModule+ let linesVal = retrieveLinesFromLayoutTree $ (tkCache $ rsTokenCache tm) Map.! mainTid+ logm $ "fetchLinesFinal (not showing lines)"+ return linesVal+ -- |fetch the pristine token stream fetchOrigToks :: RefactGhc [PosToken] fetchOrigToks = do@@ -313,6 +345,23 @@ -- --------------------------------------------------------------------- +{-+-- |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)+ return ()++-- ---------------------------------------------------------------------+ syncDeclToLatestStash :: (SYB.Data t) => (GHC.Located t) -> RefactGhc (GHC.Located t) syncDeclToLatestStash t = do st <- get@@ -338,8 +387,35 @@ drawTokenTree "indentDeclToks result" return t' +-- =====================================================================+-- Layout Tree stuff -- ---------------------------------------------------------------------+{-+getLayoutForSpan :: GHC.SrcSpan -> RefactGhc LayoutTree+getLayoutForSpan sspan = do+ st <- get+ let Just tm = rsModule st+ let lay = getLayoutFor sspan (rsTokenLayout tm)+ logm $ "getLayoutForSpan " ++ (showGhc sspan) ++ ":" ++ (showGhc lay)+ return lay+-}+{-+putDeclLayoutAfterSpan :: (SYB.Data t)+ => GHC.SrcSpan -> GHC.Located t -> Positioning -> LayoutTree+ -> RefactGhc (GHC.Located t)+putDeclLayoutAfterSpan oldSpan t pos lay = do+ logm $ "putDeclLayoutAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (show (showSrcSpanF oldSpan,pos,lay))+ st <- get+ let Just tm = rsModule st+ let (TL layoutTree) = rsTokenLayout tm+ let (tl',_newSpan, t') = addDeclLayoutAfterSrcSpan layoutTree oldSpan pos lay t+ let rsModule' = Just (tm {rsTokenLayout = tl', rsStreamModified = True})+ put $ st { rsModule = rsModule' }+ return t'+-} +-- =====================================================================+ getTypecheckedModule :: RefactGhc GHC.TypecheckedModule getTypecheckedModule = do mtm <- gets rsModule@@ -459,7 +535,10 @@ initRefactModule tm toks = Just (RefMod { rsTypecheckedMod = tm , rsOrigTokenStream = toks- , rsTokenCache = initTokenCache toks+ -- , rsTokenCache = initTokenCache toks+ , rsTokenCache = initTokenCacheLayout (initTokenLayout+ (GHC.pm_parsed_source $ GHC.tm_parsed_module tm) + toks) , rsStreamModified = False }) @@ -478,7 +557,7 @@ let newToks' = if addTrailingNl then newToks ++ [newLnToken (last newToks)] else newToks- putToksForSpan sspan newToks'+ void $ putToksForSpan sspan newToks' return () -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/TokenUtils.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,6 +15,7 @@ module Language.Haskell.Refact.Utils.TokenUtils( -- * Creating initTokenCache+ , initTokenCacheLayout , mkTreeFromTokens , mkTreeFromSpanTokens @@ -33,6 +36,7 @@ , insertSrcSpan , removeSrcSpan , getSrcSpanFor+ , getSrcSpanForDeep , addNewSrcSpanAndToksAfter , addToksAfterSrcSpan , addDeclToksAfterSrcSpan@@ -42,6 +46,9 @@ -- * Retrieving tokens , retrieveTokensFinal+ -- , retrieveTokensPpr+ -- , renderPpr+ , adjustLinesForDeleted , retrieveTokensInterim , retrieveTokens' -- temporary for debug @@ -57,6 +64,10 @@ , fileNameFromTok , treeStartEnd , spanStartEnd+ , sf+ , fs+ , forestSpanFromEntry+ , combineSpans -- * A token stream with last tokens first, and functions to manipulate it , ReversedToks(..)@@ -85,8 +96,13 @@ , ghcSpanStartEnd , insertNodeAfter , retrievePrevLineToks+ , getTreeSpansAsList , openZipperToNode+ , openZipperToNodeDeep , openZipperToSpan+ , openZipperToSpanDeep+ , openZipperToSpanAdded+ , openZipperToSpanOrig , forestSpanToSimpPos , forestSpanToGhcPos @@ -108,7 +124,7 @@ , srcPosToSimpPos , showForestSpan , deleteGapsToks- , deleteGapsToks'+ -- , deleteGapsToks' , calcEndGap , stripForestLines @@ -118,7 +134,7 @@ , drawTokenCacheDetailed , drawForestEntry , drawEntry-+ , drawTreeCompact ) where @@ -132,16 +148,19 @@ import qualified Data.Foldable as F import Language.Haskell.Refact.Utils.GhcUtils+import Language.Haskell.Refact.Utils.LayoutTypes import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn +import Control.Monad.Trans.State.Lazy 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 @@ -214,9 +233,21 @@ -} -deriving instance Show Entry => Show (Entry)+deriving instance Show Entry +instance Ord LayoutTree where+ compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b) +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@@ -526,12 +557,12 @@ -- -------------------------------------------------------------------- forestSpanFromEntry :: Entry -> ForestSpan-forestSpanFromEntry (Entry ss _ ) = ss-forestSpanFromEntry (Deleted ss _) = ss+forestSpanFromEntry (Entry ss _ _) = ss+forestSpanFromEntry (Deleted ss _ _) = ss putForestSpanInEntry :: Entry -> ForestSpan -> Entry-putForestSpanInEntry (Entry _ss toks) ssnew = (Entry ssnew toks)-putForestSpanInEntry (Deleted _ss toks) ssnew = (Deleted ssnew toks)+putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks)+putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg) -- -------------------------------------------------------------------- @@ -561,13 +592,20 @@ initTokenCache :: [PosToken] -> TokenCache initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0) +initTokenCacheLayout :: Tree Entry -> TokenCache+initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0)+ -- --------------------------------------------------------------------- treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry-treeIdIntoTree tid (Node (Entry fs toks) subTree) = tree'+treeIdIntoTree tid (Node (Entry fspan lay toks) subTree) = tree' where- fs' = treeIdIntoForestSpan tid fs- tree' = Node (Entry fs' toks) subTree+ 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 -- --------------------------------------------------------------------- @@ -627,13 +665,13 @@ tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) } putTidInTree :: TreeId -> Tree Entry -> Tree Entry-putTidInTree tid (Node (Deleted fs eg) []) = (Node (Deleted fs' eg) [])- where fs' = treeIdIntoForestSpan tid fs-putTidInTree tid (Node (Entry fs toks) subs) = tree'+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 fs- tree' = Node (Entry fs' toks) subs'+ fs' = treeIdIntoForestSpan tid fspan+ tree' = Node (Entry fs' lay toks) subs' -- --------------------------------------------------------------------- @@ -646,8 +684,8 @@ -- = error $ "syncAstToLatestCache:sspan=" ++ (show sspan) where mainForest = (tkCache tk) Map.! mainTid- forest@(Node (Entry fs _) _) = (tkCache tk) Map.! (tkLastTreeId tk)- pos = forestSpanToGhcPos fs+ forest@(Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk)+ pos = forestSpanToGhcPos fspan sspan = posToSrcSpan mainForest pos (t',_) = syncAST t sspan forest @@ -686,7 +724,7 @@ getTokensBefore :: Tree Entry -> GHC.SrcSpan -> (Tree Entry,ReversedToks) getTokensBefore forest sspan = (forest', prevToks') where- (forest',tree@(Node (Entry _s _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)+ (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest' @@ -704,24 +742,31 @@ -- 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 -> GHC.SrcSpan -> PosToken -> Tree Entry replaceTokenForSrcSpan forest sspan tok = forest' where (GHC.L tl _,_) = tok -- First open to the sspan, making use of any Forestline annotations- z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest+ z = openZipperToSpanDeep (srcSpanToForestSpan sspan) $ Z.fromTree forest -- Then drill down to the specific subtree containing the token- z' = openZipperToSpan (srcSpanToForestSpan tl) z+ -- z' = openZipperToSpan (srcSpanToForestSpan tl) z+ z' = z -- No, pass in original token span as sspan. - (tspan,toks) = case Z.tree z' of- (Node (Entry ss tks) []) -> (ss,tks)- (Node (Entry _ []) _sub) -> error $ "replaceTokenForSrcSpan: expecting tokens, found: " ++ (show $ Z.tree z')+ -- 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 $ srcSpanToForestSpan tl toks' = replaceTokNoReAlign toks (row,col) tok - zf = Z.setTree (Node (Entry tspan toks') []) z'+ zf = Z.setTree (Node (Entry tspan lay toks') []) z' forest' = Z.toTree zf -- forest' = forest@@ -736,7 +781,7 @@ updateTokensForSrcSpan :: Tree Entry -> GHC.SrcSpan -> [PosToken] -> (Tree Entry,GHC.SrcSpan,Tree Entry) updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree) where- (forest',tree@(Node (Entry _s _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan)+ (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) prevToks = retrieveTokensInterim tree -- endComments = reverse $ takeWhile isWhiteSpace $ reverse toks@@ -783,7 +828,7 @@ zf = openZipperToNode tree $ Z.fromTree forest' - zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) toks'') []) zf+ zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) NoChange toks'') []) zf forest'' = Z.toTree zf' -- forest'' = error $ "updateTokensForSrcSpan: toks''=" ++ (show toks'') -- ++AZ++ -- forest'' = error $ "updateTokensForSrcSpan: (posToSrcSpan forest (startPos,endPos))=" ++ (showGhc $ posToSrcSpan forest (startPos,endPos)) -- ++AZ++@@ -804,6 +849,20 @@ 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 -> ForestSpan -> (Tree Entry, Tree Entry)+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@@ -813,11 +872,13 @@ 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+ (Entry _ _ toks) = Z.label z (tokStartPos,tokEndPos) = forestSpanToSimpPos sspan @@ -840,9 +901,9 @@ subTree = tree1 ++ tree2 ++ tree3 subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree- (Entry sspan2 _) = Z.label z+ (Entry sspan2 _ _) = Z.label z - z' = Z.setTree (Node (Entry sspan2 []) subTree') z+ z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z forest'' = Z.toTree z' in forest'' else@@ -850,11 +911,11 @@ (before,middle,end) = doSplitTree (Z.tree z) sspan newTree = case middle of [x] -> x- _xs -> (Node (Entry sspan []) middle)+ _xs -> (Node (Entry sspan NoChange []) middle) subTree' = before ++ [newTree] ++ end- (Entry sspan2 _) = Z.label z+ (Entry sspan2 _ _) = Z.label z - z' = Z.setTree (Node (Entry sspan2 []) subTree') z+ z' = Z.setTree (Node (Entry sspan2 NoChange []) subTree') z forest'' = Z.toTree z' in forest''@@ -864,14 +925,15 @@ -- forest'' = error $ "insertSrcSpan:(startLoc,endLoc)=" ++ (show (startLoc,endLoc)) -- ++AZ++ -- forest'' = error $ "insertSrcSpan:(tokStartPos,tokEndPos,toks)=" ++ (show (tokStartPos,tokEndPos,toks)) -- ++AZ++ + -- --------------------------------------------------------------------- doSplitTree :: Tree Entry -> ForestSpan -> ([Tree Entry], [Tree Entry], [Tree Entry])-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'')+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@@ -910,7 +972,7 @@ mkTreeListFromTokens [] _sspan _ = [] mkTreeListFromTokens toks sspan useOriginalSpan = res where- (Node (Entry tspan treeToks) sub) = mkTreeFromTokens toks+ (Node (Entry tspan NoChange treeToks) sub) = mkTreeFromTokens toks ((ForestLine chs ts vs _, _),(ForestLine che te ve _, _)) = sspan ((ForestLine _ _ _ ls,cs),(ForestLine _ _ _ le,ce)) = tspan@@ -920,8 +982,8 @@ res = if nonCommentSpan toks == ((0,0),(0,0)) then [] else if useOriginalSpan- then [(Node (Entry sspan treeToks) sub)]- else [(Node (Entry span' treeToks) sub)]+ then [(Node (Entry sspan NoChange treeToks) sub)]+ else [(Node (Entry span' NoChange treeToks) sub)] -- --------------------------------------------------------------------- @@ -929,22 +991,23 @@ Tree Entry -> (ForestPos, ForestPos) -> ([Tree Entry], [Tree Entry], [Tree Entry])-splitSubToks n@(Node (Deleted (treeStart,treeEnd) _eg) []) (sspanStart,sspanEnd) = (b',m',e')+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) egs) []]+ then [Node (Deleted (treeStart,treeStart) pg egs) []] else [] m' = [n] e' = if treeEnd > sspanEnd- then [Node (Deleted (sspanEnd,treeEnd) ege) []]+ 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) toks) []) = tree+ (Node (Entry ss@(treeStart,treeEnd) _lay toks) []) = tree (sspanStart,sspanEnd) = sspan -- TODO: ignoring comment boundaries to start @@ -969,8 +1032,8 @@ else mkTreeListFromTokens toksm (sspanStart,treeEnd) False _tl' = if emptyList tl then []- else [Node (Entry (st,(ForestLine ch ts v le,ce)) tk) []]- where [Node (Entry (st,(ForestLine ch ts v _l,_c)) tk) []] = tl+ 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@@ -993,8 +1056,8 @@ tl = mkTreeListFromTokens toksm (treeStart,sspanEnd) False tl' = if emptyList tl then []- else [Node (Entry (st,sspanEnd) tk) []]- where [Node (Entry (st,_en) tk) []] = mkTreeListFromTokens toksm (treeStart,sspanEnd) False+ 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@@ -1058,11 +1121,15 @@ z = openZipperToSpan sspan $ Z.fromTree forest' zp = gfromJust "removeSrcSpan" $ Z.parent z +{-+ pg = error $ "removeSrcSpan: need calcPriorGap" eg = calcEndGap forest' sspan+-}+ ((pg,_),eg) = calcPriorAndEndGap forest' sspan pt = Z.tree zp -- subTree = filter (\t -> not (treeStartEnd t == sspan)) $ subForest pt- subTree = map (\t -> if (treeStartEnd t == sspan) then (Node (Deleted sspan eg) []) else t) $ subForest pt+ 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'@@ -1076,6 +1143,56 @@ -- |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 -> 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)+ -- pg = error $ "calcPriorAndEndGap : (tokRowPg,tokColPg):" ++ (show $ ((tokRowPg,tokColPg),(spanStartRow,spanStartCol)))+ -- pg = error $ "calcPriorAndEndGap : (head before):" ++ (show $ last before)+++-- ---------------------------------------------------------------------++-- 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 -> ForestSpan -> SimpPos calcEndGap tree sspan = gap where@@ -1098,9 +1215,9 @@ else (r,c) where (r,c) = case ghead ("calcEndGap:after="++(show after)) after of- (Entry _ toks) -> (tokenRow t,tokenCol t)+ (Entry _ _ toks) -> (tokenRow t,tokenCol t) where t = ghead "calcEndGap" toks- (Deleted ss _) -> fst $ forestSpanToSimpPos ss+ (Deleted ss _ _) -> fst $ forestSpanToSimpPos ss gap = (tokRow - spanRow, tokCol - spanCol) -- gap = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after)))@@ -1115,6 +1232,439 @@ -- --------------------------------------------------------------------- +-- |Retrieve the tokens in a ppr format, so they can be rendered+retrieveTokensPpr :: Tree Entry -> [Ppr]+retrieveTokensPpr forest = pps'''+ where+ -- forest' = adjustLinesForDeleted forest+ (pps,_,lastLine) = retrieveTokensPpr' ([],Original,[]) forest+ pps' = pps ++ (mkPprFromLineToks lastLine)+ pps'' = mergeDeletesPpr pps'+ pps''' = adjustPprForDeleted pps''++retrieveTokensPpr' :: ([Ppr],PprOrigin,[PosToken]) -> Tree Entry -> ([Ppr],PprOrigin,[PosToken])++retrieveTokensPpr' acc (Node (Deleted _sspan _pg ( 0,_cd) ) _) = acc+retrieveTokensPpr' acc (Node (Deleted sspan pg (rd,_cd) ) _) = acc'+ where+ (ac,o,curLineToks) = acc+ ll = mkPprFromLineToksSrc o curLineToks+ ((rs,cs),(re,_ce)) = forestSpanToSimpPos sspan+ ol = re - rs+ acc' = (ac ++ ll ++ [PprDeleted rs cs pg ol rd],o,[])++retrieveTokensPpr' acc (Node (Entry _sspan NoChange []) subs)+ = foldl' retrieveTokensPpr' acc subs++retrieveTokensPpr' acc (Node (Entry _sspan (Above so _ (r,c) eo) []) subs) = acc'+ where+ (ac,_o,curLineToks) = acc+ (sss,o2,cl2) = foldl' retrieveTokensPpr' ([],Original,[]) subs+ cl2Acc = mkPprFromLineToksSrc o2 cl2+ ll = mkPprFromLineToks curLineToks+ acc' = (ac ++ ll ++ [PprAbove so (r,c) eo (normaliseColumns (sss++cl2Acc))],o2,[])++retrieveTokensPpr' (acc,oi,curLineToks) (Node (Entry sspan _ toks) []) = (acc++accNew,o,curLineToks')+ where+ o = if (forestSpanVersionSet sspan) then Added else Original+ oi' = if o == Added || oi == Added then Added else Original+ toksByLine = groupTokensByLine toks+ (accNew,curLineToks') = case curLineToks of+ [] -> case toksByLine of+ [] -> ([],[])+ [x] -> ([],x)+ xs -> (concatMap (mkPprFromLineToksSrc o) (init xs),last xs)++ _ -> case toksByLine of+ [] -> ([],[])+ [x] -> if (toksOnSameLine (last curLineToks) (head x))+ then ([],curLineToks ++ x)+ else (mkPprFromLineToksSrc oi curLineToks,x)+ (x:xs) -> if (toksOnSameLine (last curLineToks) (head x))+ then ((mkPprFromLineToksSrc oi' (curLineToks++x)) ++ concatMap (mkPprFromLineToksSrc o) ( init xs),last xs)+ else ((mkPprFromLineToksSrc oi curLineToks ) ++ concatMap (mkPprFromLineToksSrc o) (x:init xs),last xs)++-- Keep -Wall happy+retrieveTokensPpr' _acc n@(Node (Entry _sspan (Above _so _ (_r,_c) _eo) _toks) _subs)+ = error $ "retrieveTokensPpr': Above entry with toks:" ++ (show n)+-- retrieveTokensPpr' _acc n@(Node (Entry _sspan (Offset _r _c) _toks) _subs)+-- = error $ "retrieveTokensPpr': Offset entry with toks:" ++ (show n)+retrieveTokensPpr' _acc n@(Node (Entry _sspan (NoChange) _toks) _subs)+ = error $ "retrieveTokensPpr': NoChange entry with toks:" ++ (show n)+++mkPprFromLineToks :: [PosToken] -> [Ppr]+mkPprFromLineToks toks = mkPprFromLineToksSrc Original toks++mkPprFromLineToksSrc :: PprOrigin -> [PosToken] -> [Ppr]+mkPprFromLineToksSrc _ [] = []+mkPprFromLineToksSrc o toks = [PprText ro co o str]+ where+ ro' = tokenRow $ head toks+ co' = tokenCol $ head toks+ (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks)+ toks' = addOffsetToToks (-ro',-co') toks+ str = GHC.showRichTokenStream toks'+++-- | The PprAbove construct needs all the starting columns to be reset to zero+normaliseColumns :: [Ppr] -> [Ppr]+normaliseColumns [] = []+normaliseColumns ps = ps'+ where+ offset = case (head ps) of+ PprText _r c _ _ -> c - 1+ PprDeleted _r c _ _ _ -> c - 1+ _ -> 0+ ps' = map removeOffset ps++ removeOffset (PprText r c o toks) = (PprText r (c - offset) o toks)+ removeOffset (PprDeleted r c p l e) = (PprDeleted r (c - offset) p l e)+ removeOffset x = x++-- ---------------------------------------------------------------------++adjustPprForDeleted :: [Ppr] -> [Ppr]+adjustPprForDeleted [] = []+adjustPprForDeleted pps = pps'+ where+ (_,pps') = foldl' go ((0,0),[]) pps++ go :: ((Int,Int),[Ppr]) -> Ppr -> ((Int,Int),[Ppr])+ go ((ro,co),acc) (PprText r c Original str) = ((ro, co),acc++[PprText (r-ro) (c-co) Original str])+ go ((ro,co),acc) (PprText r c Added str) = ((ro-1,co),acc++[PprText (r ) (c ) Added str])+ -- go ((ro,co),acc) (PprDeleted r c rd) = ((ro - rd,co),acc)+ go ((ro,co),acc) (PprDeleted r c pg l eg)+ = ((ro + (pg + l + eg) - (max pg eg),co),acc++[PprDeleted r c pg l eg])+ -- NOTE: see below for derivation of the above calc+ go ((ro,co),acc) (PprAbove so p1 eo subs) = ((ro',co'),acc++[PprAbove so' p1' eo' subs'])+ where+ so' = so+ p1' = p1+ eo' = eo+ ((ro',co'),subs') = foldl' go ((ro,co),[]) subs++{-++Case 1++Code is+----+3:data D = A | B String | C+4:+5:ff :: Int -> Int <<<line to be deleted+6:ff y = y + zz+7: where+8: zz = 1+-----+PprDeleted 5 1 2 0 1+So pg is 2 (5 - 3)+ l is 0 (5 - 5)+ eg is 1 (6 - 5)++New location needs to be 5, so+ro needs to be 1++-------------++Case 2++Code is+----+ 5:ff :: Int -> Int+ 6:ff y = y + zz <<<line to be deleted+ 7: where <<<line to be deleted+ 8: zz = 1 <<<line to be deleted+ 9:+10:x = 3+-----+PprDeleted 6 1 1 2 2+So pg is 1 ( 6 - 5)+ l is 2 ( 8 - 6)+ eg is 2 (10 - 8)++New location needs to be 7, so+ro needs to be 3++so (pg - 1) + (l + 1) or pg + l+++-------------++Case 3++Code is+----+ 4:ff :: Int -> Int+ 5:+ 6:ff y = y + zz <<<line to be deleted+ 7: where <<<line to be deleted+ 8: zz = 1 <<<line to be deleted+ 9:+10:x = 3+-----+PprDeleted 6 1 2 2 2+So pg is 2 ( 6 - 4)+ l is 2 ( 8 - 6)+ eg is 2 (10 - 8)++New location needs to be 6, so+ro needs to be 4++so (pg - 1) + (l + 1) or pg + l++=================================++First principles.++We have+ sr : last non-blank line before deletion area+ dr : first non-blank line after deletion area++ fd : first line of deletion area+ ld : last line of deletion area++We need to calculate the offset to bring dr to have the same end+gap as for the original.++ Case 1 Case 2 Case 3+ sr 3 5 4+ fd 5 6 6+ ld 5 8 8+ dr 6 10 10++ pg 2 1 2+ eg 1 2 2++ np 5 7 6+ ro 1 3 4++i.e. we need to apply the largest of (pg,eg) to the original sr.++so+ np = sr + max(pg,eg)++ ro = dr - np++Hence++ ro = dr - sr - max(pg,eg)++In PprDeleted, dr - sr is same as (pg + l + eg)++ ro = (pg + l + eg) - max(pg,eg)++-}++-- ---------------------------------------------------------------------++mergeDeletesPpr :: [Ppr] -> [Ppr]+mergeDeletesPpr [] = []+mergeDeletesPpr ((PprDeleted r1 c1 pg1 l1 eg1):(PprDeleted _r _c pg2 l2 eg2):ps)+ = (PprDeleted r1 c1 pg1 (l1 + eg1 + pg2 + l2 - 1) eg2) : mergeDeletesPpr ps+{-+The total gap taken up by each delete is pg+l+eg.++We have+ pg1 + l1 + eg1 + pg2 + l2 + eg2++The combined span has+ pg1 + (l1 + eg1 + pg2 + l2) + eg2++Why do we need the (-1)? TBD++pg1 : fb - sr+eg1 : dr - lb+ l1 : lb - fb+sum: (fb - sr) + (dr - lb) + (lb - fb)+ = -sr + dr -- fb and lb cancels out+ = dr - sr+so we have (dr1 - sr1) + (dr2 - sr2)+bu, dr1 == sr2+so (dr1 - sr1 + dr2 - dr1)+or dr2 - sr1+-}+mergeDeletesPpr (p:ps) = p : mergeDeletesPpr ps++-- ---------------------------------------------------------------------++getPprStartRow :: Ppr -> Row+getPprStartRow (PprText r _ _ _) = r+getPprStartRow (PprDeleted r _ _ _ _) = r+getPprStartRow (PprAbove _ _ _ []) = error "getPprStartRow: PprAbove with no subs"+getPprStartRow (PprAbove _ _ _ subs) = getPprStartRow $ head subs++getPprEndRow :: Ppr -> Row+getPprEndRow (PprText r _ _ _) = r+getPprEndRow (PprDeleted r _ _ _ _) = r+getPprEndRow (PprAbove _ _ _ []) = error "getPprEndRow: PprAbove with no subs"+getPprEndRow (PprAbove _ _ _ subs) = getPprEndRow $ last subs++-- ---------------------------------------------------------------------++-- TODO: deprecated, doing this at the Ppr level now+adjustLinesForDeleted :: Tree Entry -> Tree Entry+adjustLinesForDeleted forest = forest'+ where+ (_,forest') = go (0,0) forest++ go :: (Int,Int) -> Tree Entry -> ((Int,Int),Tree Entry)+ 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 -> Tree Entry+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++-- ---------------------------------------------------------------------++renderPpr :: [Ppr] -> String+renderPpr ps = res+ where+ (_,(_,res)) = runState (go 0 ps) ((1,1),"")++ go _ [] = return ()++ go ci (ppt@(PprText _rt _ct _ _toks):ppa@(PprAbove so (_,_cc) eo _subs):ps') = do+ renderPprText ci ppt+ addOffset so+ (_,c) <- getRC+ renderPprAbove c ppa+ (cr,_cc) <- getRC+ -- addOffset eo+ if ps' /= []+ then+ case eo of+ FromAlignCol (ero,eco) -> newPos (cr+ero) (ci+eco)+ SameLine _ -> addOffset eo+ None -> return ()+ else return ()+ -- (r',c') <- getRC+ -- addDebugString $ "(eo:" ++ show (ci,(r',c')) ++ ")" -- ++AZ++ debug+ go ci ps'++ go ci (p@(PprText _rt _ct _ _toks):ps') = do+ renderPprText ci p+ go ci ps'++ go ci ((PprDeleted _ _ _ _ _):ps') = go ci ps'++ go _ pps = error $ "renderPpr: unmatched in go:" ++ (show pps)++ ------------------------------------++ renderPprAbove _ci (PprAbove _ _ _ []) = return ()+ renderPprAbove ci (PprAbove _ _ _ subs) = go ci subs++ renderPprAbove _ ppr = error $ "renderPprAbove:unexpected ppr:" ++ (show ppr)++ ------------------------------------++ -- renderPprText :: Col -> Ppr -> String+ renderPprText ci (PprText rt ct _ str) = do+ -- (r',c') <- getRC+ -- addDebugString $ "(op" ++ (show (ci,(r',c'),(rt,ct))) ++ ")" -- ++AZ++ for debugging+ newPos rt (ci + ct)+ -- (r,c) <- getRC+ -- addDebugString $ "(np:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging+ addString str+ -- addDebugString $ "(fp:" ++ (show (r,c)) ++ ")" -- ++AZ++ for debugging++ renderPprText _ ppr = error $ "renderPprText:unexpected ppr:" ++ (show ppr)++ ------------------------------------++ addOffset None = return ()+ addOffset (SameLine co) = do+ (r,c) <- getRC+ newPos r (c+co)+ addOffset (FromAlignCol (ro,co)) = do+ (r,c) <- getRC+ newPos (r+ro) (c+co)++ newPos newRow newCol = do+ (oldRow',oldCol) <- getRC++ -- Allow for out of order additions that result from additions+ -- to the tree. Will break the invariant.+ let oldRow = if oldRow' <= newRow then oldRow' else (newRow - 1)+ putRC (oldRow,oldCol)++ if oldRow == newRow+ then addString (take (newCol - oldCol) $ repeat ' ')+ else+ addString ( (take (newRow - oldRow) $ repeat '\n') +++ (take (newCol - 1) $ repeat ' ') )+ checkInvariant $ "newPos:" ++ (show (newRow,newCol))+++ -- Check invariant+ -- 1. r == number of '\n' + 1+ -- 2. c == number of chars in last line.+ -- We assume the c val refers to positions between characters+ -- of output.+ checkInvariant str = do+{-+ ((r,c),cur) <- get+ let ll = 1 + (length $ filter (=='\n') cur)+ let lc = 1 + (length $ takeWhile (/='\n') $ reverse cur)+ if r /= ll+ then error $ "renderPpr.newPos: r /= ll :" ++ (show (r,ll,cur,str))+ else return ()+ if c /= lc+ then error $ "renderPpr.newPos: c /= lc :" ++ (show (c,lc,cur,str))+ else return ()+-}+ return ()++ -- State operations ----------------++ getRC = do+ (rc,_) <- get+ return rc++ putRC (r,c) = do+ (_,str) <- get+ put ((r,c),str)++ addString [] = return ()+ addString str = do+ ((r,c),curr) <- get+ let ll = (length $ filter (=='\n') str)+ let c'' = (length $ takeWhile (/='\n') $ reverse str)+++ let (r',c') = case ll of+ 0 -> (r,c + c'')+ _ -> (r + ll, c'' + 1)+ put ((r',c'),curr++str)++ checkInvariant $ "addString" ++ show str++ addDebugString str = do+ ((r,c),curr) <- get+ put ((r,c),curr++str)++-- ---------------------------------------------------------------------+ -- |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]@@ -1122,24 +1672,24 @@ $ concat $ map (\t -> F.foldl accum [] t) [forest] where accum :: [PosToken] -> Entry -> [PosToken]- accum acc (Entry _ []) = acc- accum acc (Entry _ toks) = acc ++ toks- accum acc (Deleted _ _) = acc+ accum acc (Entry _ _ []) = acc+ accum acc (Entry _ _ toks) = acc ++ toks+ accum acc (Deleted _ _ _) = acc retrieveTokens' :: Tree Entry -> [Entry] retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest] where accum :: [Entry] -> Entry -> [Entry]- accum acc (Entry _ []) = acc- accum acc e@(Entry _ _toks) = acc ++ [e]- accum acc e@(Deleted _ _) = acc ++ [e]+ accum acc (Entry _ _ []) = acc+ accum acc e@(Entry _ _ _toks) = acc ++ [e]+ accum acc e@(Deleted _ _ _) = acc ++ [e] -- |Merge adjacent Deleted entries mergeDeletes :: [Entry] -> [Entry] mergeDeletes [] = [] mergeDeletes [x] = [x]-mergeDeletes ((Deleted ss1 (r1,_)):(Deleted ss2 (r2,c2)):xs) = (Deleted ss o):xs+mergeDeletes ((Deleted ss1 pg1 (r1,_)):(Deleted ss2 _ (r2,c2)):xs) = (Deleted ss pg1 o):xs where (start,_) = ss1 (_, end) = ss2@@ -1155,12 +1705,12 @@ goDeleteGapsToks :: SimpPos -> [Entry] -> [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 t1:Deleted _ eg:t2:ts)+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@@ -1169,13 +1719,11 @@ (deltaR,_deltaC) = eg (_,(sr,_sc)) = forestSpanToSimpPos ss ((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2- offset' = if deltaR > 0- then (fr + (sr - dr) + deltaR, fc)- else (fr + (sr - dr) + deltaR, fc)- -- offset' = (fr + sr - dr + 1, fc)+ offset' = (fr + (sr - dr) + deltaR, fc) t1' = map (increaseSrcSpan (fr,fc)) t1 +{- -- -- | Process the leaf nodes of a tree to remove all deleted spans deleteGapsToks' :: [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])]@@ -1183,12 +1731,12 @@ goDeleteGapsToks' :: SimpPos -> [Entry] -> [(SimpPos,String,ForestSpan,[PosToken])] goDeleteGapsToks' _ [] = [((0,0), "N",nullSpan, [])]-goDeleteGapsToks' offset [Entry ss t] = [(offset,"E1",ss,map (increaseSrcSpan offset) t)]+goDeleteGapsToks' offset [Entry ss _ t] = [(offset,"E1",ss,map (increaseSrcSpan offset) t)] goDeleteGapsToks' _ [Deleted _ _] = [((0,0), "D1",nullSpan, [])] goDeleteGapsToks' offset (Deleted _ _:ts) = (offset, "D0",nullSpan, []):goDeleteGapsToks' offset ts-goDeleteGapsToks' offset [Entry ss t,Deleted _ _] = [(offset,"[ED]",ss,map (increaseSrcSpan offset) t)]-goDeleteGapsToks' offset (Entry ss t1:e@(Entry _ _):ts) =(offset,"EE", ss, (map (increaseSrcSpan offset) t1)):goDeleteGapsToks' offset (e:ts)-goDeleteGapsToks' (fr,fc) (Entry ss t1:Deleted _ _:t2:ts)+goDeleteGapsToks' offset [Entry ss _ t,Deleted _ _] = [(offset,"[ED]",ss,map (increaseSrcSpan offset) t)]+goDeleteGapsToks' offset (Entry ss _ t1:e@(Entry _ _ _):ts) =(offset,"EE", ss, (map (increaseSrcSpan offset) t1)):goDeleteGapsToks' offset (e:ts)+goDeleteGapsToks' (fr,fc) (Entry ss _ t1:Deleted _ _:t2:ts) = ((fr,fc),"ED",ss,t1') : goDeleteGapsToks' offset' (t2:ts) where -- TODO: use actual first and last toks, may be comments@@ -1201,6 +1749,7 @@ t1' = map (increaseSrcSpan (fr,fc)) t1 --+-} -- --------------------------------------------------------------------- @@ -1216,13 +1765,18 @@ -- prevToks = retrieveTokens $ Z.tree z prevToks = retrieveTokensInterim $ Z.tree z - res' = reverse $ (concat (go z)) ++ prevToks+ -- Next one is the usual one+ -- res' = reverse $ (concat (go z)) ++ prevToks+ res' = reverse $ concat $ reverse (prevToks : (go z))++ -- res' = (reverse prevToks) ++ (concat (go z)) -- res' = error $ "retrievePrevLineToks:res'=" ++ (show (dropWhile (\tok -> isWhiteSpace tok || tokenRow tok < endLine) res)) -- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show prevToks) -- res' = error $ "retrievePrevLineToks:prevToks=" ++ (show res) -- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show (prevToks : (go z)))+ -- res' = error $ "retrievePrevLineToks:(prevToks : (go z))=" ++ (show $ concat $ reverse (prevToks : (go z))) -- TODO: ++AZ++ what is this actually doing? go :: Z.TreePos Z.Full Entry -> [[PosToken]]@@ -1319,7 +1873,7 @@ -- identify this span in its position addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan') where- (forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan oldSpan)+ (forest',tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) (ghcl,_c) = getGhcLoc newSpan (ForestLine ch tr v l) = ghcLineToForestLine ghcl@@ -1327,7 +1881,7 @@ toks' = placeToksForSpan forest' oldSpan tree pos toks - newNode = Node (Entry (srcSpanToForestSpan newSpan') toks') []+ newNode = Node (Entry (srcSpanToForestSpan newSpan') NoChange toks') [] forest'' = insertNodeAfter tree newNode forest' @@ -1342,7 +1896,7 @@ -> [PosToken] placeToksForSpan forest oldSpan tree pos toks = toks' where- z = openZipperToSpan (srcSpanToForestSpan oldSpan) $ Z.fromTree forest+ z = openZipperToSpanDeep (srcSpanToForestSpan oldSpan) $ Z.fromTree forest prevToks = case (retrievePrevLineToks z) of RT [] -> reverseToks $ retrieveTokensInterim tree xs -> xs@@ -1365,7 +1919,7 @@ -- the new tokens in the TokenTree addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan') where- (fwithspan,tree) = getSrcSpanFor forest (srcSpanToForestSpan oldSpan)+ (fwithspan,tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) toks'' = placeToksForSpan fwithspan oldSpan tree pos toks @@ -1410,6 +1964,7 @@ -- --------------------------------------------------------------------- + reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken] reIndentToks _ _ [] = [] reIndentToks pos prevToks toks = toks''@@ -1458,10 +2013,14 @@ $ dropWhile isWhiteSpaceOrIgnored prevToks -- colStart = prevOffset -- colStart = error $ "reIndentToks:prevToks=" ++ (show prevToks)+ lineStart = (tokenRow (lastTok)) -- + 1+ -- lineStart = error $ "reIndentToks:PlaceOffset:lastTok=" ++ show lastTok+ -- lineStart = error $ "reIndentToks:PlaceOffset:firstTok=" ++ show firstTok 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@@ -1475,7 +2034,8 @@ toks' = addOffsetToToks (lineOffset,colOffset) toks toks'' = if endNewlines > 0- then toks' ++ [(newLinesToken endNewlines $ glast "reIndentToks.3" toks')]+ -- then toks' ++ [(newLinesToken endNewlines $ glast "reIndentToks.3" toks')]+ then toks' ++ [(newLinesToken (endNewlines - 1) $ glast "reIndentToks.3" toks')] else toks' -- ---------------------------------------------------------------------@@ -1486,14 +2046,11 @@ nonCommentSpan [] = ((0,0),(0,0)) nonCommentSpan toks = (startPos,endPos) where- -- stripped = dropWhile isWhiteSpace $ toks stripped = dropWhile isIgnoredNonComment $ toks (startPos,endPos) = case stripped of [] -> ((0,0),(0,0)) _ -> (tokenPos startTok,tokenPosEnd endTok) where- -- startTok = ghead "nonCommentSpan.1" $ dropWhile isWhiteSpace $ toks- -- endTok = ghead "nonCommentSpan.2" $ dropWhile isWhiteSpace $ reverse toks startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks @@ -1539,8 +2096,8 @@ :: Tree Entry -> Tree Entry -> Tree Entry -> Tree Entry insertNodeAfter oldNode newNode forest = forest' where- zf = openZipperToNode oldNode $ Z.fromTree forest- -- zp = gfromJust "insertNodeAfter" $ Z.parent zf+ zf = openZipperToNodeDeep oldNode $ Z.fromTree forest+ zp = gfromJust ("insertNodeAfter:" ++ (show (oldNode,newNode,forest))) $ Z.parent zf tp = Z.tree zp @@ -1561,10 +2118,23 @@ :: Tree Entry -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry-openZipperToNode (Node (Entry sspan _) _) z+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+ -> Z.TreePos Z.Full Entry+ -> Z.TreePos Z.Full Entry+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@@ -1595,6 +2165,23 @@ -> Z.TreePos Z.Full Entry -> Z.TreePos Z.Full Entry 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+ -> Z.TreePos Z.Full Entry+openZipperToSpanOrig sspan z = if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z) then z else z'@@ -1640,6 +2227,67 @@ -- --------------------------------------------------------------------- +-- |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+ -> Z.TreePos Z.Full Entry+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+ -> Z.TreePos Z.Full Entry+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 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 -> [(Int,ForestSpan)]+getTreeSpansAsList = getTreeSpansAsList' 0++getTreeSpansAsList' :: Int -> Tree Entry -> [(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@@ -1738,10 +2386,10 @@ r = checkNode [] tree checkNode :: [String] -> Tree Entry -> [String]- checkNode _acc (Node (Deleted _sspan _) []) = []- checkNode _acc node@(Node (Deleted _sspan _) _sub)+ 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 toks) sub) = acc ++ r ++ rinc ++ rsubs ++ rnull+ 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)@@ -1760,7 +2408,8 @@ -- span, they do not need to completely fill it, because some may -- have been removed during manipulation checkInclusion (Node _ []) = []- checkInclusion node@(Node (Entry _sspan _toks) sub) = rs ++ rseq+ checkInclusion (Node (Deleted _ _ _) _) = []+ checkInclusion node@(Node (Entry _sspan _lay _toks) sub) = rs ++ rseq where (start,end) = treeStartEnd node subs = map treeStartEnd sub@@ -1773,9 +2422,12 @@ 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 @@ -1817,8 +2469,8 @@ -- treeStartEnd :: Tree Entry -> (SimpPos,SimpPos) -- treeStartEnd (Node (Entry sspan _) _) = (getGhcLoc sspan,getGhcLocEnd sspan) treeStartEnd :: Tree Entry -> ForestSpan-treeStartEnd (Node (Entry sspan _ ) _) = sspan-treeStartEnd (Node (Deleted sspan _) _) = sspan+treeStartEnd (Node (Entry sspan _ _) _) = sspan+treeStartEnd (Node (Deleted sspan _ _) _) = sspan -- |Get the start and end position of a SrcSpan -- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos)@@ -1875,8 +2527,8 @@ drawForestEntry = unlines . map drawTreeEntry drawEntry :: Tree Entry -> [String]-drawEntry (Node (Deleted sspan eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"]-drawEntry (Node (Entry sspan _toks) ts0) = (showForestSpan sspan) : drawSubTrees ts0+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] =@@ -1886,19 +2538,35 @@ 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 -> String+drawTreeCompact = unlines . drawTreeCompact' 0++drawTreeCompact' :: Int -> Tree Entry -> [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 -> String showTree = prettyshow -- |Represent a tree in a more concise/pretty way prettyshow :: Tree Entry -> String-prettyshow (Node (Deleted sspan eg) [])+prettyshow (Node (Deleted sspan pg eg) _nullSubs) = "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")"-prettyshow (Node (Entry sspan toks) sub)+prettyshow (Node (Entry sspan _lay toks) sub) = "Node (Entry " ++ (showForestSpan sspan) ++ " " ++ (prettyToks toks) ++ ") "- ++ show (map prettyshow sub)+ -- ++ show (map prettyshow sub)+ ++ "[" ++ intercalate "," (map prettyshow sub) ++ "]" prettyToks :: [PosToken] -> String prettyToks [] = "[]"@@ -1910,8 +2578,8 @@ -- |Make a tree representing a particular set of tokens mkTreeFromTokens :: [PosToken] -> Tree Entry-mkTreeFromTokens [] = Node (Entry nullSpan []) []-mkTreeFromTokens toks = Node (Entry sspan toks) []+mkTreeFromTokens [] = Node (Entry nullSpan NoChange []) []+mkTreeFromTokens toks = Node (Entry sspan NoChange toks) [] where (startLoc',endLoc') = nonCommentSpan toks sspan = if (startLoc',endLoc') == ((0,0),(0,0))@@ -1922,7 +2590,7 @@ -- |Make a tree representing a particular set of tokens mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree Entry-mkTreeFromSpanTokens sspan toks = Node (Entry sspan toks) []+mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) [] -- --------------------------------------------------------------------- @@ -2018,9 +2686,10 @@ off = (0,offset) -- Pretty sure this could be a fold of some kind- go (Node (Deleted ss eg) []) = (Node (Deleted (addOffsetToForestSpan off ss) eg) [])- go (Node (Entry ss []) sub) = (Node (Entry (addOffsetToForestSpan off ss) []) (map go sub))- go (Node (Entry ss toks) []) = (Node (Entry (addOffsetToForestSpan off ss) (addOffsetToToks off toks)) [])+ 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) -- --------------------------------------------------------------------- @@ -2061,5 +2730,50 @@ -- ---------------------------------------------------------------------++sf :: GHC.SrcSpan -> ForestSpan+sf = srcSpanToForestSpan++fs :: ForestSpan -> GHC.SrcSpan+fs = forestSpanToSrcSpan+++-- | 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))++{-+-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Assumes the "file" part is the same in both inputs+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful+combineSrcSpans l (UnhelpfulSpan _) = l+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)+ = RealSrcSpan (combineRealSrcSpans span1 span2)++-- | Combines two 'SrcSpan' into one that spans at least all the characters+-- within both spans. Assumes the "file" part is the same in both inputs+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan+combineRealSrcSpans span1 span2+ = if line_start == line_end+ then if col_start == col_end+ then SrcSpanPoint file line_start col_start+ else SrcSpanOneLine file line_start col_start col_end+ else SrcSpanMultiLine file line_start col_start line_end col_end+ where+ (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)+ (srcSpanStartLine span2, srcSpanStartCol span2)+ (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)+ (srcSpanEndLine span2, srcSpanEndCol span2)+ file = srcSpanFile span1+++-} -- EOF
src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs view
@@ -12,15 +12,26 @@ , mainTid -- * Structure of each tree , Entry(..)+ , Layout(..)+ , EndOffset(..)+ , RowOffset+ , ColOffset+ , Row+ , Col , ForestLine(..) , ForestPos , ForestSpan+ , PprOrigin(..)+ , Ppr(..)+ -- , HDoc(..) ) where import Language.Haskell.Refact.Utils.TypeSyn import Data.Tree import qualified Data.Map as Map +import Outputable+ -- --------------------------------------------------------------------- {-@@ -60,16 +71,38 @@ -- 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+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@@ -94,6 +127,8 @@ ++ " " ++ (show $ flLine s) ++ ")" +instance Outputable ForestLine where+ ppr fl = text (show fl) -- --------------------------------------------------------------------- @@ -116,6 +151,28 @@ { 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) -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/TypeSyn.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This is a legacy module from the pre-GHC HaRe, and will disappear
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -124,6 +124,7 @@ -- * Debug stuff , getDeclAndToks, getSigAndToks+ , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging -- , allPNT -- , allPNTLens , newNameTok@@ -1661,6 +1662,7 @@ -- 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)@@ -1675,6 +1677,7 @@ 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) @@ -2628,8 +2631,14 @@ -- --------------------------------------------------------------------- addImportDecl ::- GHC.RenamedSource -> GHC.ModuleName -> Maybe GHC.FastString -> Bool -> Bool -> Bool ->- Maybe String -> Bool -> [GHC.Name] -> RefactGhc GHC.RenamedSource+ GHC.RenamedSource+ -> GHC.ModuleName+ -> Maybe GHC.FastString -- ^qualifier+ -> Bool -> Bool -> Bool+ -> Maybe String -- ^alias+ -> Bool+ -> [GHC.Name]+ -> RefactGhc GHC.RenamedSource addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames = do toks <- fetchToks@@ -2645,13 +2654,17 @@ in toks1' else toks + drawTokenTreeDetailed "before starting"+ logm $ "addImportDecl:toks =" ++ show toks+ logm $ "addImportDecl:toks1=" ++ show toks1+ let lastTok = ghead "addImportDecl" $ dropWhile isWhiteSpace $ reverse toks1 let startPos = tokenPos lastTok let endPos = tokenPosEnd lastTok newToks <- liftIO $ basicTokenise (showGhc impDecl)- -- logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ++- putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks+ logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ+++ void $ putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c) where @@ -2789,8 +2802,7 @@ -- --------------------------------------------------------------------- -- | Adding a declaration to the declaration list of the given syntax--- phrase(so far only adding function\/pattern binding has been--- tested). If the second argument is Nothing, then the declaration+-- phrase. If the second argument is Nothing, then the declaration -- will be added to the beginning of the declaration list, but after -- the data type declarations is there is any. addDecl:: (SYB.Data t,HsValBinds t)@@ -2828,7 +2840,7 @@ (decls1,decls2) = break (\x->isFunOrPatBindR x {- was || isTypeSig x -}) decls newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks)- -- logm $ "addTopLevelDecl:newToks=" ++ (show newToks)+ logm $ "addTopLevelDecl:newToks=" ++ (show newToks) let Just sspan = if (emptyList decls2) then getSrcSpan (glast "addTopLevelDecl" decls1)@@ -2836,11 +2848,6 @@ decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks -{-- case maybeSig of- Nothing -> return (replaceBinds parent (decls1++[decl']++decls2))- Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds))))--} return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds)))) appendDecl :: (SYB.Data t, HsValBinds t)@@ -2891,10 +2898,11 @@ if (emptyList localDecls) then- putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent colIndent 2) newToks+ void $ putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent colIndent 2) newToks -- putToksAfterPos (startLoc,endLoc) (PlaceAbsolute (r+1) c) newToks else- putToksAfterPos (startLoc,endLoc) (PlaceIndent rowIndent colIndent 2) newToks+ void $ putToksAfterPos (startLoc,endLoc) (PlaceIndent rowIndent colIndent 2) newToks+ -- void $ putToksAfterPos (startLoc,endLoc) (PlaceIndent rowIndent colIndent 3) newToks {- case maybeSig of@@ -3023,7 +3031,7 @@ -- toks'=replaceToks toks start end [newToken] -- toks'=replaceTok toks start newToken - putToksForPos (start,end) [newToken]+ void $ putToksForPos (start,end) [newToken] return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents))) @@ -3096,6 +3104,7 @@ newToks <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr _ <- putToksAfterSpan l PlaceAdjacent newToks return ()+ Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss) Right (GHC.L l _) -> do toks <- getToksForSpan l newToks <- liftIO $ tokenise (realSrcLocFromTok $ ghead "addFormalParams" toks) 0 False newStr@@ -3368,12 +3377,14 @@ = do let Just sspan = getSrcSpan funBinding toks <- getToksForSpan sspan+ -- lay <- getLayoutForSpan sspan newSpan <- case typeSig of [] -> return sspan _ -> do let Just sspanSig = getSrcSpan typeSig- toksSig <- getToksForSpan sspanSig+ toksSig <- getToksForSpan sspanSig+ -- laySig <- getLayoutForSpan sspanSig let colStart = tokenCol $ ghead "duplicateDecl.sig" $ dropWhile isWhiteSpace toksSig@@ -3424,7 +3435,7 @@ -- drawTokenTreeDetailed "rmDecl.entry tree" -- ++AZ++ 'in' present setStateStorage StorageNone t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing+ -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t@@ -3487,7 +3498,7 @@ 1 -> do -- Removing the last declaration logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- putToksForSpan ss toks- putToksForSpan ss $ dropWhile (\tok -> isEmpty tok || isIn tok) toks+ void $ putToksForSpan ss $ dropWhile (\tok -> isEmpty tok || isIn tok) toks return expr _ -> do logm $ "rmDecl.inLet:length decls /= 1"@@ -3628,7 +3639,7 @@ then extendForwards toks (startPos1',endPos1') isComma else extendBackwards toks (startPos1',endPos1') isComma toks' = deleteToks toks startPos1 endPos1- putToksForSpan sspan toks'+ void $ putToksForSpan sspan toks' -- Construct the old signature, by keeping the -- signature part but discarding the other names@@ -3637,7 +3648,7 @@ let typeLoc = extendBackwards toks (getStartEndLoc typ) isDoubleColon let (_,typTok,_) = splitToks typeLoc toks let (_,pntTok,_) = splitToks (getStartEndLoc pnt) toks- putToksForSpan sspan' (pntTok ++ typTok)+ void $ putToksForSpan sspan' (pntTok ++ typTok) setStateStorage (StorageSig sig') @@ -3712,7 +3723,7 @@ qualifyToplevelName n = do renamed <- getRefactRenamed logm $ "qualifyToplevelName:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed)- renamePN n n True True renamed+ _ <- renamePN n n True True renamed return () -- ---------------------------------------------------------------------@@ -3735,6 +3746,7 @@ renamePN oldPN newName updateTokens useQual t = do -- = error $ "renamePN: sspan=" ++ (showGhc sspan) -- ++AZ++ -- logm $ "renamePN': (oldPN,newName)=" ++ (showGhc (oldPN,newName))+ logm $ "renamePN': t=" ++ (SYB.showData SYB.Renamer 0 t) -- Note: bottom-up traversal let isRenamed = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t@@ -3748,8 +3760,8 @@ ) t else renamePNworker oldPN newName updateTokens useQual t- t'' <- adjustLayoutAfterRename oldPN newName t'- return t''+ -- t'' <- adjustLayoutAfterRename oldPN newName t'+ return t' where isRenamedSource :: GHC.RenamedSource -> Maybe Bool isRenamedSource (_g,_i,_e,_d) = Just True@@ -3808,7 +3820,8 @@ | (GHC.nameUnique n == GHC.nameUnique oldPN) = do logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l)- worker useQual l n+ drawTokenTree "before worker" -- ++AZ++ debug+ worker useQual l return (GHC.L l newName) rename x = return x @@ -3816,8 +3829,8 @@ renameVar (GHC.L l (GHC.HsVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do- -- logm $ "renamePNworker:renameVar at :" ++ (show (row,col))- worker useQual l n+ logm $ "renamePNworker:renameVar at :" ++ (showGhc l)+ worker useQual l return (GHC.L l (GHC.HsVar newName)) renameVar x = return x @@ -3826,8 +3839,8 @@ renameTyVar (GHC.L l (GHC.HsTyVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do- -- logm $ "renamePNworker:renameTyVar at :" ++ (show (row,col))- worker useQual l n+ logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l)+ worker useQual l return (GHC.L l (GHC.HsTyVar newName)) renameTyVar x = return x @@ -3840,8 +3853,8 @@ #endif | (GHC.nameUnique n == GHC.nameUnique oldPN) = do- -- logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (show (row,col))- worker useQual l n+ logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l)+ worker useQual l #if __GLASGOW_HASKELL__ > 704 return (GHC.L l (GHC.UserTyVar newName)) #else@@ -3853,8 +3866,8 @@ renameLIE (GHC.L l (GHC.IEVar n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do- -- logm $ "renamePNworker:renameLIE at :" ++ (show (row,col))- worker useQual l n+ logm $ "renamePNworker:renameLIE at :" ++ (showGhc l)+ worker useQual l return (GHC.L l (GHC.IEVar newName)) renameLIE x = return x @@ -3862,8 +3875,8 @@ renameLPat (GHC.L l (GHC.VarPat n)) | (GHC.nameUnique n == GHC.nameUnique oldPN) = do- -- logm $ "renamePNworker:renameLPat at :" ++ (show (row,col))- worker False l n+ logm $ "renamePNworker:renameLPat at :" ++ (showGhc l)+ worker False l return (GHC.L l (GHC.VarPat newName)) renameLPat x = return x @@ -3876,12 +3889,14 @@ -- (b) rename each of 'tail matches' -- (head is renamed in (a) ) -- logm $ "renamePNWorker.renameFunBind"- worker False l n+ worker False ln -- Now do (b)- -- logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"- let w (GHC.L lm _match) = worker False lm n- mapM w $ tail matches- -- logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done"+ logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"+ let w (GHC.L lm _match) = worker False lm'+ where+ ((GHC.L lm' _),_) = newNameTok False lm oldPN+ mapM_ w $ tail matches+ logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done" return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick)) renameFunBind x = return x @@ -3897,7 +3912,8 @@ return (GHC.L l (GHC.TypeSig ns' typ')) -- The param l is only useful for the start of the token pos- worker useQual' l _n+ worker :: Bool -> GHC.SrcSpan -> RefactGhc ()+ worker useQual' l = do if updateTokens then do replaceToken l (markToken $ newNameTok useQual' l newName)@@ -4020,7 +4036,7 @@ logm $ "adjustLMatch: (l,off)=" ++ showGhc (l,off) return x - adjustLMatch x = return x+ -- adjustLMatch x = return x -- -------------------------------------