diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -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 diff --git a/src/Language/Haskell/Refact/Case.hs b/src/Language/Haskell/Refact/Case.hs --- a/src/Language/Haskell/Refact/Case.hs +++ b/src/Language/Haskell/Refact/Case.hs @@ -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 diff --git a/src/Language/Haskell/Refact/DupDef.hs b/src/Language/Haskell/Refact/DupDef.hs --- a/src/Language/Haskell/Refact/DupDef.hs +++ b/src/Language/Haskell/Refact/DupDef.hs @@ -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 diff --git a/src/Language/Haskell/Refact/MoveDef.hs b/src/Language/Haskell/Refact/MoveDef.hs --- a/src/Language/Haskell/Refact/MoveDef.hs +++ b/src/Language/Haskell/Refact/MoveDef.hs @@ -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) diff --git a/src/Language/Haskell/Refact/Renaming.hs b/src/Language/Haskell/Refact/Renaming.hs --- a/src/Language/Haskell/Refact/Renaming.hs +++ b/src/Language/Haskell/Refact/Renaming.hs @@ -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 diff --git a/src/Language/Haskell/Refact/SwapArgs.hs b/src/Language/Haskell/Refact/SwapArgs.hs --- a/src/Language/Haskell/Refact/SwapArgs.hs +++ b/src/Language/Haskell/Refact/SwapArgs.hs @@ -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 +++ diff --git a/src/Language/Haskell/Refact/Utils.hs b/src/Language/Haskell/Refact/Utils.hs --- a/src/Language/Haskell/Refact/Utils.hs +++ b/src/Language/Haskell/Refact/Utils.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/DualTree.hs b/src/Language/Haskell/Refact/Utils/DualTree.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/DualTree.hs @@ -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 + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs --- a/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +++ b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs @@ -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. diff --git a/src/Language/Haskell/Refact/Utils/GhcUtils.hs b/src/Language/Haskell/Refact/Utils/GhcUtils.hs --- a/src/Language/Haskell/Refact/Utils/GhcUtils.hs +++ b/src/Language/Haskell/Refact/Utils/GhcUtils.hs @@ -17,6 +17,7 @@ -- * SYB versions everythingButStaged , somethingStaged + , everythingStaged , somewhereMStaged , somewhereMStagedBu , everywhereMStaged diff --git a/src/Language/Haskell/Refact/Utils/Layout.hs b/src/Language/Haskell/Refact/Utils/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Layout.hs @@ -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 + +-- --------------------------------------------------------------------- + diff --git a/src/Language/Haskell/Refact/Utils/LayoutTypes.hs b/src/Language/Haskell/Refact/Utils/LayoutTypes.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/LayoutTypes.hs @@ -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] + + diff --git a/src/Language/Haskell/Refact/Utils/LayoutUtils.hs b/src/Language/Haskell/Refact/Utils/LayoutUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/LayoutUtils.hs @@ -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 + + diff --git a/src/Language/Haskell/Refact/Utils/LocUtils.hs b/src/Language/Haskell/Refact/Utils/LocUtils.hs --- a/src/Language/Haskell/Refact/Utils/LocUtils.hs +++ b/src/Language/Haskell/Refact/Utils/LocUtils.hs @@ -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]] diff --git a/src/Language/Haskell/Refact/Utils/Monad.hs b/src/Language/Haskell/Refact/Utils/Monad.hs --- a/src/Language/Haskell/Refact/Utils/Monad.hs +++ b/src/Language/Haskell/Refact/Utils/Monad.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -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 () -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/TokenUtils.hs b/src/Language/Haskell/Refact/Utils/TokenUtils.hs --- a/src/Language/Haskell/Refact/Utils/TokenUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TokenUtils.hs @@ -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 << Int + 6:ff y = y + zz << Int + 5: + 6:ff y = y + zz << [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 diff --git a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs b/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs --- a/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs +++ b/src/Language/Haskell/Refact/Utils/TokenUtilsTypes.hs @@ -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) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -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 diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -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 -- -------------------------------------