diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2014-07-03 v0.7.2.4 + Re-architect to split out haskell-token-utils as a separate + package, usable with haskell-src-exts too 2014-05-02 v0.7.2.3 * Update for ghc-mod 4.1.0 2014-04-03 v0.7.2.2 diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.2.3 +Version: 0.7.2.4 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -66,6 +66,8 @@ , Strafunski-StrategyLib , syz + , haskell-token-utils + GHC-Options: -Wall Hs-Source-Dirs: src @@ -78,13 +80,10 @@ , Language.Haskell.Refact.Refactoring.MoveDef , Language.Haskell.Refact.Refactoring.Renaming , Language.Haskell.Refact.Refactoring.SwapArgs - , 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.LocUtils , Language.Haskell.Refact.Utils.Monad , Language.Haskell.Refact.Utils.MonadFunctions @@ -131,7 +130,8 @@ , hslogger , Strafunski-StrategyLib , syz - , HaRe >= 0.7.1.6 + , haskell-token-utils + , HaRe >= 0.7.2.3 Extensions: CPP @@ -154,7 +154,8 @@ build-depends: base >= 4.0 && < 4.7 , Diff >= 0.3.0 - , HUnit == 1.2.* + -- , HUnit == 1.2.* + , HUnit , QuickCheck >= 2.5 , containers @@ -166,7 +167,8 @@ , directory , filepath , ghc >= 7.0.1 && < 7.8 - , ghc-paths == 0.1.* + -- , ghc-paths == 0.1.* + , ghc-paths , ghc-prim , ghc-syb-utils , ghc-mod >= 4.1.0 @@ -183,8 +185,22 @@ , hslogger , Strafunski-StrategyLib , syz - , HaRe >= 0.7.1.6 + , haskell-token-utils + , HaRe >= 0.7.2.3 Extensions: CPP + + +-- test-suite doctests +-- type: exitcode-stdio-1.0 +-- ghc-options: -threaded +-- main-is: doctests.hs +-- build-depends: base >= 4.0 && < 4.7 +-- , doctest >= 0.8 +-- , ghc-mod +-- Hs-Source-Dirs: +-- -- src +-- test + source-repository head type: git diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ -Copyright (c) 2003, OGI School of Science & Engineering, Oregon -Health & Science University, All rights reserved. +Copyright (c) 2014, University of Kent and contributors listed in +README.markdown, in this directory. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following @@ -13,9 +13,9 @@ disclaimer in the documentation and/or other materials provided with the distribution. -- Neither the name of OGI or OHSU nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +- Neither the name of the copyright holder nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -53,7 +53,7 @@ -- ** Conveniences for state access - , fetchToksFinal + -- , fetchToksFinal , fetchLinesFinal , fetchOrigToks , fetchToks -- Deprecated @@ -110,7 +110,7 @@ , SimpPos,unmodified,modified , simpPos0 , nullSrcSpan - , showToks + -- , showToks , whiteSpaceTokens , realSrcLocFromTok , isWhite @@ -175,7 +175,7 @@ , fileNameFromTok , splitToks , emptyList, nonEmptyList - , divideComments + -- , divideComments , notWhiteSpace , isDoubleColon , isEmpty @@ -190,8 +190,8 @@ , splitOnNewLn , tokenLen , newLnToken - , newLinesToken - , monotonicLineToks + -- , newLinesToken + -- , monotonicLineToks , reSequenceToks , mkToken , mkZeroToken @@ -203,7 +203,7 @@ -- * from `Language.Haskell.Refact.Utils.TypeSyn` , InScopes - , PosToken(..) + , PosToken , ghead , glast , gtail @@ -372,7 +372,7 @@ -- * from `Language.Haskell.Refact.Utils.TokenUtils` , Positioning(..) , reIndentToks - , srcSpanToForestSpan + , ghcSrcSpanToForestSpan ) where import Language.Haskell.Refact.Utils.GhcUtils @@ -385,3 +385,7 @@ import Language.Haskell.Refact.Utils.TypeUtils import Language.Haskell.Refact.Utils.Utils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Utils +-- import Language.Haskell.TokenUtils.GHC.Layout diff --git a/src/Language/Haskell/Refact/HaRe.hs b/src/Language/Haskell/Refact/HaRe.hs --- a/src/Language/Haskell/Refact/HaRe.hs +++ b/src/Language/Haskell/Refact/HaRe.hs @@ -25,4 +25,5 @@ import Language.Haskell.Refact.Refactoring.Renaming import Language.Haskell.Refact.Refactoring.SwapArgs import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.TokenUtils.Types + diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -335,7 +335,7 @@ return sigToks maybeToksSigMulti <- mapM getToksForMaybeSig - $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (srcSpanToForestSpan s1) (srcSpanToForestSpan s2)) + $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (ghcSrcSpanToForestSpan s1) (ghcSrcSpanToForestSpan s2)) sigsRemoved let maybeToksSig = concat maybeToksSigMulti @@ -820,7 +820,7 @@ logm $ "addParamsToSigs:replaceSpan=" ++ showGhc replaceSpan logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]" newToks <- liftIO $ basicTokenise newStr - putToksForSpan replaceSpan newToks + void $ putToksForSpan replaceSpan newToks let typ' = foldl addOneType ltyp ts sigOk <- isNewSignatureOk ts logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr) @@ -878,9 +878,9 @@ typeToHsType (GHC.FunTy t1 t2) = GHC.HsFunTy (GHC.noLoc $ typeToHsType t1) (GHC.noLoc $ typeToHsType t2) #if __GLASGOW_HASKELL__ > 704 -typeToHsType (GHC.ForAllTy v t) = GHC.HsForAllTy GHC.Explicit (GHC.HsQTvs [] []) (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) +typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit (GHC.HsQTvs [] []) (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) #else -typeToHsType (GHC.ForAllTy v t) = GHC.HsForAllTy GHC.Explicit [] (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) +typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit [] (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) #endif #if __GLASGOW_HASKELL__ > 704 @@ -932,7 +932,7 @@ -} tyConAppToHsType :: GHC.Type -> GHC.HsType GHC.Name -tyConAppToHsType t@(GHC.TyConApp tc _ts) +tyConAppToHsType (GHC.TyConApp tc _ts) | GHC.isFunTyCon tc = r "isFunTyCon" | GHC.isAlgTyCon tc = r "isAlgTyCon" | GHC.isTupleTyCon tc = r "isTupleTyCon" @@ -947,7 +947,7 @@ #if __GLASGOW_HASKELL__ > 704 r str = GHC.HsTyLit (GHC.HsStrTy $ GHC.mkFastString str) #else - r str = error $ "tyConAppToHsType: " ++ str ++ " unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t) + r str = error $ "tyConAppToHsType: " ++ str ++ " unexpected:" ++ (SYB.showData SYB.TypeChecker 0 r) #endif tyConAppToHsType t@(GHC.TyConApp _tc _ts) diff --git a/src/Language/Haskell/Refact/Utils/DualTree.hs b/src/Language/Haskell/Refact/Utils/DualTree.hs deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/DualTree.hs +++ /dev/null @@ -1,575 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -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 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 = TAbove ColOffset EndOffset (Row,Col) (Row,Col) EndOffset - deriving Show - -{- -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 - --- | The main data structure for this module -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 - (TAbove co1 bo1 p11 _p21 _eo1) <> (TAbove _co2 _bo2 _p12 p22 eo2) - = (TAbove co1 bo1 p11 p22 eo2) - - -instance (Action Transformation Up) where - 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 (TAbove _co _bo _p1 _p2 _eo) (UDeleted ds) = UDeleted ds - --- --------------------------------------------------------------------- - -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 (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 - -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 - Just (UDeleted _) -> [] - --- --------------------------------------------------------------------- - -renderSourceTree :: SourceTree -> String -renderSourceTree srcTree = r - where - r = case getU srcTree of - Nothing -> "" - Just (Up _ss _a str _ds) -> renderLines $ NE.toList str - Just (UDeleted _) -> "" - --- --------------------------------------------------------------------- - -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) - --- TODO: only apply TAbove if the subs go on to the next line -layoutTreeToSourceTree (T.Node (Entry sspan (Above bo p1 p2 eo) []) ts0) - = case (numLines ts0) of - 0 -> annot (ASubtree sspan) (mconcatl $ map layoutTreeToSourceTree ts0) - _ -> annot (ASubtree sspan) - (applyD (TAbove co bo p1 p2 eo) subs) - where - subs = (mconcatl $ map layoutTreeToSourceTree ts0) - co = 0 - numLines :: [T.Tree Entry] -> Int - numLines [] = 0 - numLines sts = l - f - where - ((f,_),_ ) = forestSpanToSimpPos $ treeStartEnd $ head sts - (_ ,(l,_)) = forestSpanToSimpPos $ treeStartEnd $ last sts - -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 - --- --------------------------------------------------------------------- - --- TODO: What if the toks comprise multiple lines, e.g. in a block comment? -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)) $ filter (not.isComment) 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 - rest = if ff2 == OGroup && ff1 == 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 - -{- - - -((((36,23),(41,25)),ITblockComment \" ++AZ++ : hsBinds does not re - -(Up - (Span (31, 23) (34, - 72)) ANone - [(Line 31 23 0 SOriginal ONone \"-- renamed <- getRefactRenamed\"), - (Line 32 23 0 SOriginal OGroup \"let renamed = undefined\"), - (Line 33 23 0 SOriginal OGroup \"let declsr = hsBinds renamed\"), - (Line 34 23 0 SOriginal OGroup \"let (before,parent,after) = divideDecls declsr pn\"), - (Line 35 23 0 SOriginal OGroup \"-- error (\"liftToMod:(before,parent,after)=\" ++ (showGhc (before,parent,after))) -- ++AZ++\"), - (Line 36 23 0 SOriginal OGroup \"{- ++AZ++ : hsBinds does not return class or instance definitions - when (isClassDecl $ ghead \"liftToMod\" parent) - $ error \"Sorry, the refactorer cannot lift a definition from a class declaration!\" - when (isInstDecl $ ghead \"liftToMod\" parent) - $ error \"Sorry, the refactorer cannot lift a definition from an instance declaration!\" - -}\")] - []) - ------------------------- - -(Up - (Span (42, 23) (43, - 79)) ANone - [(Line 42 23 0 SOriginal OGroup \"let liftedDecls = definingDeclsNames [n] parent True True\"), - (Line 43 27 0 SOriginal OGroup \"declaredPns = nub $ concatMap definedPNs liftedDecls\")] - []) --} -{- - -(Line -r1 = 10 -c1 = 3 -o1 = 0 -ss1 = SOriginal -ff1 = ONone -s1 = \"g2 <- getCurrentModuleGraph\") - -(Line -r2 = 11 -c2 = 3 -o2 = 0 -ss2 = SOriginal -ff2 = OGroup -s2 = \"let scc = topSortModuleGraph False g2 Nothing\") - ---- -(Up - (Span (9, 3) (11, 47)) ANone - [(Line 9 3 0 SOriginal ONone \"-- g <- GHC.getModuleGraph\"), - (Line 10 3 0 SOriginal ONone \"g2 <- getCurrentModuleGraph\"), - (Line 11 4 0 SOriginal OGroup \"let scc = topSortModuleGraph False g2 Nothing\")] - []) - -------------------------- - -Up1 -(Up - (Span (9, 3) (10, 29)) ANone - [(Line 9 3 0 SOriginal ONone \"-- g <- GHC.getModuleGraph\"), - (Line 10 3 0 SOriginal ONone \"g2 <- getCurrentModuleGraph\")] - []) - -Up2 -(Up - (Span (11, 3) (11, 47)) ANone - [(Line 11 3 0 SOriginal OGroup \"let scc = topSortModuleGraph False g2 Nothing\")] - []) - --} - -{- - -((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/Layout.hs b/src/Language/Haskell/Refact/Utils/Layout.hs deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/Layout.hs +++ /dev/null @@ -1,2053 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- - -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 Outputable - -import qualified GHC.SYB.Utils as SYB - -import Data.List -import Data.Tree -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 - --- --------------------------------------------------------------------- - - -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) - 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) - - 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 d)) = (r,toks') - where - (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - declLayout = allocLTyClDecl (GHC.L l d) clToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ declLayout)] -allocTyClD _ x = error $ "allocTyClD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -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] )] -allocInstD _ x = error $ "allocInstD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocDerivD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocDerivD (acc,toks) (GHC.L l (GHC.DerivD (GHC.DerivDecl typ))) = (r,toks') - where - (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - typLayout = allocType typ bindToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup typLayout] )] -allocDerivD _ x = error $ "allocDerivD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -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] )] -allocValD _ x = error $ "allocValD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -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)] -allocSigD _ x = error $ "allocSigD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocDefD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocDefD (acc,toks) (GHC.L l (GHC.DefD (GHC.DefaultDecl typs))) = (r,toks') - where - (s1,typsToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - typsLayout = allocList typs typsToks allocType - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) - ++ typsLayout)] -allocDefD _ x = error $ "allocDefD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocForD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignImport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks') - where - (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks - (s3,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1 - nameLayout = [makeLeaf ln NoChange nameToks] - typLayout = allocType typ typToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) - ++ (makeLeafFromToks s2) ++ nameLayout - ++ (makeLeafFromToks s3) ++ typLayout - ++ (makeLeafFromToks toks2))] -allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignExport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks') - where - (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks - (s3,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1 - nameLayout = [makeLeaf ln NoChange nameToks] - typLayout = allocType typ typToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) - ++ (makeLeafFromToks s2) ++ nameLayout - ++ (makeLeafFromToks s3) ++ typLayout - ++ (makeLeafFromToks toks2))] -allocForD _ x = error $ "allocForD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocWarningD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocWarningD (acc,toks) (GHC.L _l (GHC.WarningD _)) = (acc,toks) -allocWarningD _ x = error $ "allocWarningD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocAnnD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocAnnD (acc,toks) (GHC.L _l (GHC.AnnD _)) = (acc,toks) -allocAnnD _ x = error $ "allocAnnD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocRuleD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocRuleD (acc,toks) (GHC.L _l (GHC.RuleD _)) = (acc,toks) -allocRuleD _ x = error $ "allocRuleD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocVectD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocVectD (acc,toks) (GHC.L _l (GHC.VectD _)) = (acc,toks) -allocVectD _ x = error $ "allocVectD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocSpliceD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocSpliceD (acc,toks) (GHC.L l (GHC.SpliceD (GHC.SpliceDecl ex _))) = (r,toks') - where - (s1,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - exprLayout = allocExpr ex exprToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) - ++ exprLayout)] -allocSpliceD _ x = error $ "allocSpliceD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocDocD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) --- allocDocD (acc,toks) d@(GHC.L l (GHC.DocD _)) --- = error "allocDocD undefined" -allocDocD _ x = error $ "allocDocD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocQuasiQuoteD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken]) -allocQuasiQuoteD (acc,toks) (GHC.L l (GHC.QuasiQuoteD (GHC.HsQuasiQuote _n _ss _))) = (r,toks') - where - (s1,qqToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - qqLayout = makeLeafFromToks qqToks - r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) - ++ qqLayout)] -allocQuasiQuoteD _ x = error $ "allocQuasiQuoteD:unexpected value:" ++ showGhc x - --- --------------------------------------------------------------------- - -allocLTyClDecl :: GHC.LTyClDecl GHC.RdrName -> [PosToken] -> [LayoutTree] -allocLTyClDecl (GHC.L l (GHC.ForeignType ln _)) toks = r - where - (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - lnToks = allocLocated ln clToks - r = [makeGroup (strip $ (makeLeafFromToks s1) ++ lnToks ++ (makeLeafFromToks toks'))] -allocLTyClDecl (GHC.L l (GHC.TyFamily _f n@(GHC.L ln _) vars _mk)) toks = r - 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 = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks clToks) - ++ (makeLeafFromToks s2) ++ nLayout ++ varsLayout - ++ (makeLeafFromToks s3) - ++ (makeLeafFromToks toks')) - ] -#if __GLASGOW_HASKELL__ > 704 -allocLTyClDecl (GHC.L l (GHC.TyDecl (GHC.L ln _) vars def _fvs)) toks = r - 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 = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ (makeLeafFromToks nToks) ++ varsLayout ++ typeLayout - ++ (makeLeafFromToks toks4) - ++ (makeLeafFromToks toks'))] -#else -allocLTyClDecl (GHC.L l (GHC.TyData _ (GHC.L lc ctx) (GHC.L ln _) vars mpats mkind cons mderivs)) toks = r - 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 = [makeGroup (strip $ (makeLeafFromToks s1) - ++ (makeLeafFromToks s15) - ++ ctxLayout - ++ (makeLeafFromToks s2) - ++ (makeLeafFromToks nToks) - ++ (makeLeafFromToks s21) - ++ varsLayout ++ patsLayout - ++ kindLayout - ++ consLayout ++ derivsLayout - ++ (makeLeafFromToks toks7) - ++ (makeLeafFromToks toks') - )] -{- -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 -allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs)) toks = r -#else -allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs )) toks = r -#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 - fdsLayout = makeLeafFromToks fdToks - - 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 - ++ (makeLeafFromToks toks') - ] - -#if __GLASGOW_HASKELL__ > 704 -#else -allocLTyClDecl (GHC.L l (GHC.TySynonym n@(GHC.L ln _) vars mpats synrhs@(GHC.L lr _))) toks = r - where - (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,nToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) clToks - (s25,vToks,toks3) = splitToksForList vars toks2 - (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 - (s4,rToks,toks5) = splitToksIncComments (ghcSpanStartEnd lr) toks4 - varsLayout = allocList vars vToks allocTyVarBndr - synrhsLayout = allocType synrhs rToks - - r = [makeGroup (strip $ (makeLeafFromToks s1) - ++ (makeLeafFromToks s2) - ++ (makeLeafFromToks nToks) - ++ (makeLeafFromToks s25) - ++ varsLayout ++ patsLayout - ++ (makeLeafFromToks s4) - ++ synrhsLayout - ++ (makeLeafFromToks toks5) - ++ (makeLeafFromToks toks') - )] -#endif - --- allocLTyClDecl x _ = error $ "allocLTyClDecl:unknown value:" ++ showGhc x - --- --------------------------------------------------------------------- - -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 - - -- Insert a SrcSpan over the parameters, if there are any - patLayout = case (strip $ allocList pats patsToks allocPat) of - [] -> [] - ps -> [makeGroup ps] - - grhsLayout = allocGRHSs grhs (rhsToks++bindsToks) - matchLayout = [makeGroup $ strip $ (makeLeafFromToks s2) - ++ patLayout - ++ mtypLayout - ++ (makeLeafFromToks s3) - ++ grhsLayout - ] - r = (strip $ (makeLeafFromToks sb) - ++ matchLayout - ++ (makeLeafFromToks sa)) - - --- --------------------------------------------------------------------- - -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) - --- --------------------------------------------------------------------- - --- TODO: should this use the span from the LPat? -allocPat :: GHC.LPat GHC.RdrName -> [PosToken] -> [LayoutTree] -allocPat (GHC.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) - --- --------------------------------------------------------------------- - -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 l (GHC.ParStmt blocks _ _)) toks = r - where - (s1,blocksToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (blocksLayout,toks2) = foldl' allocParStmtBlock ([],blocksToks) blocks - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ blocksLayout - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks toks')] -#else -allocStmt (GHC.L l (GHC.ParStmt blocks _ _ _)) toks = r - where - (s1,blocksToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (blocksLayout,toks2) = foldl' allocParStmtBlock ([],blocksToks) blocks - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ blocksLayout - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks toks')] - - allocParStmtBlock :: ([LayoutTree],[PosToken]) - -> ([GHC.LStmt GHC.RdrName],[GHC.RdrName]) -> ([LayoutTree],[PosToken]) - allocParStmtBlock (acc,toks) (stmts,ns) = (r1,toks') - where - (s1,stmtToks,toks') = splitToksForList stmts toks - stmtLayout = allocList stmts stmtToks allocStmt - r1 = [makeGroup $ strip $ (makeLeafFromToks s1) - ++ stmtLayout] --- ParStmt [([LStmt idL], [idR])] (SyntaxExpr idR) (SyntaxExpr idR) (SyntaxExpr idR) -#endif -allocStmt (GHC.L l (GHC.TransStmt _ stmts _ using@(GHC.L lu _) mby _ _ _ )) toks = r - where - (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,stmtsToks,toks1) = splitToksForList stmts toksExpr - (s2,usingToks,toks2) = splitToksIncComments (ghcSpanStartEnd lu) toks1 - (byLayout,toks3) = case mby of - Nothing -> ([],toks2) - Just e -> (byL,toks3') - where - byL = allocExpr e toks2 - toks3' = [] - - stmtsLayout = allocList stmts stmtsToks allocStmt - usingLayout = allocExpr using usingToks - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) ++ stmtsLayout - ++ (makeLeafFromToks s2) ++ usingLayout - ++ byLayout - ++ (makeLeafFromToks toks3) - ++ (makeLeafFromToks sa) - ] - -allocStmt (GHC.L l (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) toks = r - where - -- Note: everything after the first field is filled in from the - -- renamer onwards, can be ignored here - (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,stmtsToks,toks1) = splitToksForList stmts toksExpr - stmtsLayout = allocList stmts stmtsToks allocStmt - - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) ++ stmtsLayout - ++ (makeLeafFromToks toks1) - ++ (makeLeafFromToks sa) - ] -{- -RecStmt - recS_stmts :: [LStmtLR idL idR] - recS_later_ids :: [idR] - recS_rec_ids :: [idR] - recS_bind_fn :: SyntaxExpr idR - recS_ret_fn :: SyntaxExpr idR - recS_mfix_fn :: SyntaxExpr idR - recS_later_rets :: [PostTcExpr] - recS_rec_rets :: [PostTcExpr] - recS_ret_ty :: PostTcType --} --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 704 -allocParStmtBlock :: ([LayoutTree],[PosToken]) -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> ([LayoutTree],[PosToken]) -allocParStmtBlock (acc,toks) (GHC.ParStmtBlock stmts _ns _) = (acc ++ r,toks') - where - (s1,stmtToks,toks') = splitToksForList stmts toks - stmtLayout = allocList stmts stmtToks allocStmt - r = [makeGroup $ strip $ (makeLeafFromToks s1) - ++ stmtLayout] -#endif - --- --------------------------------------------------------------------- - -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) - - --- various kinds of list comprehension -allocExpr e@(GHC.L _ (GHC.HsDo GHC.ListComp _ _)) toks = allocExprListComp e toks -allocExpr e@(GHC.L _ (GHC.HsDo GHC.MonadComp _ _)) toks = allocExprListComp e toks -allocExpr e@(GHC.L _ (GHC.HsDo GHC.PArrComp _ _)) toks = allocExprListComp e toks - - --- various kinds of do -allocExpr e@(GHC.L _ (GHC.HsDo GHC.DoExpr _ _)) toks = allocDoExpr e toks -allocExpr e@(GHC.L _ (GHC.HsDo GHC.GhciStmt _ _)) toks = allocDoExpr e toks -allocExpr e@(GHC.L _ (GHC.HsDo GHC.MDoExpr _ _)) toks = allocDoExpr e toks - - -allocExpr e@(GHC.L _ (GHC.HsDo GHC.ArrowExpr _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) -allocExpr e@(GHC.L _ (GHC.HsDo (GHC.PatGuard _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) -allocExpr e@(GHC.L _ (GHC.HsDo (GHC.ParStmtCtxt _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) -allocExpr e@(GHC.L _ (GHC.HsDo (GHC.TransStmtCtxt _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) - -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 _) _ binds)) toks = r - where - (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,nameToks,fieldsToks) = splitToksIncComments (ghcSpanStartEnd ln) toksExpr - nameLayout = [makeLeaf ln NoChange nameToks] - (bindsLayout,toks3) = allocHsRecordBinds binds fieldsToks - exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) - ++ nameLayout ++ bindsLayout - ++ (makeLeafFromToks toks3)] - - r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa) - -allocExpr (GHC.L l (GHC.RecordUpd expr@(GHC.L le _) binds _cons _ptctypes1 _ptctypes2)) toks = r - where - (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toksExpr - (bindsLayout,toks3) = allocHsRecordBinds binds toks2 - exprLayout = allocExpr expr toksE - recLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout - ++ bindsLayout ++ (makeLeafFromToks toks3)] - r = strip $ (makeLeafFromToks sb) ++ recLayout ++ (makeLeafFromToks sa) -{- -RecordUpd (LHsExpr id) (HsRecordBinds id) [DataCon] [PostTcType] [PostTcType] --} -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 (GHC.L l (GHC.ExprWithTySig (GHC.L le expr) (GHC.L lt typ))) toks = r - where - (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toksExpr - (s2,toksType,toks3) = splitToksIncComments (ghcSpanStartEnd lt) toks2 - - exprLayout = allocExpr (GHC.L le expr) toksE - typeLayout = allocType (GHC.L lt typ) toksType - layout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout - ++ (makeLeafFromToks s2) ++ typeLayout - ++ (makeLeafFromToks toks3)] - r = strip $ (makeLeafFromToks sb) ++ layout ++ (makeLeafFromToks sa) - -allocExpr (GHC.L _ (GHC.HsIPVar _)) toks = makeLeafFromToks toks -allocExpr e@(GHC.L _ (GHC.PArrSeq _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) -allocExpr (GHC.L _ (GHC.HsSCC _ ex)) toks = allocExpr ex toks -allocExpr (GHC.L _ (GHC.HsCoreAnn _ ex)) toks = allocExpr ex toks -allocExpr (GHC.L l (GHC.HsBracket bracket)) toks = r - where - (sb,toksBrack,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - layoutBrack = case bracket of - GHC.ExpBr ex -> allocExpr ex toksBrack - GHC.PatBr p -> allocPat p toksBrack - GHC.DecBrL decs -> allocDecls decs toksBrack - GHC.DecBrG g -> error $ "allocExpr.DecBrG undefined for " ++ (SYB.showData SYB.Parser 0 g) - GHC.TypBr typ -> allocType typ toksBrack - GHC.VarBr _ _ -> makeLeafFromToks toksBrack - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ layoutBrack - ++ (makeLeafFromToks sa)] - --- Note: these are only present after the typechecker -allocExpr e@(GHC.L _ (GHC.ExprWithTySigOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) -allocExpr e@(GHC.L _ (GHC.HsBracketOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) - - -allocExpr (GHC.L _l (GHC.HsSpliceE (GHC.HsSplice _ expr))) toks = allocExpr expr toks - -allocExpr e@(GHC.L _ (GHC.HsQuasiQuoteE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e) - -allocExpr (GHC.L l (GHC.HsProc p@(GHC.L lp _) cmd@(GHC.L lc _))) toks = r - where - (sb,toksBrack,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksPat,toks1) = splitToksIncComments (ghcSpanStartEnd lp) toksBrack - (s2,toksCmd,toks2) = splitToksIncComments (ghcSpanStartEnd lc) toks1 - layoutPat = allocPat p toksPat - layoutCmd = allocCmdTop cmd toksCmd - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ layoutPat - ++ (makeLeafFromToks s2) - ++ layoutCmd - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L l (GHC.HsArrApp e1@(GHC.L l1 _) e2@(GHC.L l2 _) _ _ _)) toks = r - where - (sb,toksApp,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksE1,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksApp - (s2,toksE2,toks2) = splitToksIncComments (ghcSpanStartEnd l2) toks1 - layoutE1 = allocExpr e1 toksE1 - layoutE2 = allocExpr e2 toksE2 - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ layoutE1 - ++ (makeLeafFromToks s2) - ++ layoutE2 - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L l (GHC.HsArrForm e@(GHC.L le _) _ cmds)) toks = r - where - (sb,toksApp,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksExpr,toks1) = splitToksIncComments (ghcSpanStartEnd le) toksApp - (s2,toksCmd,toks2) = splitToksForList cmds toks1 - layoutExpr = allocExpr e toksExpr - layoutCmds = allocList cmds toksCmd allocCmdTop - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ layoutExpr - ++ (makeLeafFromToks s2) - ++ layoutCmds - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L _ (GHC.HsTick _ e)) toks = allocExpr e toks -allocExpr (GHC.L _ (GHC.HsBinTick _ _ e)) toks = allocExpr e toks -allocExpr (GHC.L _ (GHC.HsTickPragma _ e)) toks = allocExpr e toks - -allocExpr (GHC.L l (GHC.EWildPat)) toks = r - where - (sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks toksPat) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L l (GHC.EAsPat (GHC.L ln _) e@(GHC.L le _))) toks = r - where - (sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksN,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toksPat - (s2,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1 - layoutN = makeLeafFromToks toksN - layoutExpr = allocExpr e toksE - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ layoutN - ++ (makeLeafFromToks s2) - ++ layoutExpr - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L l (GHC.EViewPat e1@(GHC.L l1 _) e2@(GHC.L l2 _))) toks = r - where - (sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,toksE1,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksPat - (s2,toksE2,toks2) = splitToksIncComments (ghcSpanStartEnd l2) toks1 - layoutE1 = allocExpr e1 toksE1 - layoutE2 = allocExpr e2 toksE2 - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ layoutE1 - ++ (makeLeafFromToks s2) - ++ layoutE2 - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa)] - -allocExpr (GHC.L _ (GHC.ELazyPat e)) toks = allocExpr e toks -allocExpr (GHC.L _ (GHC.HsType typ)) toks = allocType typ toks -allocExpr e@(GHC.L _ (GHC.HsWrap _ _)) toks = allocExpr e toks - --- ------------------------------------- - -allocDoExpr :: GHC.LHsExpr GHC.RdrName -> [PosToken] -> [LayoutTree] -allocDoExpr _e@(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:" ++ (show toksBinds') ++ (SYB.showData SYB.Renamer 0 _e)) including] - toksBinds = gtail ("allocExpr.HsDo" ++ show (l,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) -allocDoExpr e _ - = error $ "Layout.allocDoExpr should not have been called with " ++ showGhc e - --- ------------------------------------- - -allocExprListComp :: GHC.LHsExpr GHC.RdrName -> [PosToken] -> [LayoutTree] -allocExprListComp _e@(GHC.L l (GHC.HsDo _ stmts _)) toks = r - where - (s1,toksBinds,toks1) = splitToksIncComments (ghcSpanStartEnd l) toks - bindsLayout = allocList stmts toksBinds allocStmt - r = strip $ ((makeLeafFromToks s1) ++ bindsLayout ++ makeLeafFromToks toks1) -allocExprListComp e _ - = error $ "Layout.allocExprListComp should not have been called with " ++ showGhc e - --- --------------------------------------------------------------------- - -allocCmdTop :: GHC.LHsCmdTop GHC.RdrName -> [PosToken] -> [LayoutTree] -allocCmdTop (GHC.L l (GHC.HsCmdTop cmd _ _ _)) toks = r - where - (sb,toksCmd,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - layoutExpr = allocExpr cmd toksCmd - r = [makeGroup $ strip $ (makeLeafFromToks sb) - ++ layoutExpr - ++ (makeLeafFromToks sa)] - --- --------------------------------------------------------------------- - -allocHsRecordBinds :: GHC.HsRecordBinds GHC.RdrName -> [PosToken] -> ([LayoutTree],[PosToken]) -allocHsRecordBinds (GHC.HsRecFields flds _dot) toks = (r,toks') - where - (r,toks') = foldl doOne ([],toks) flds - - doOne (r1,toks1) fld = (r1',toks1') - where - (r2,toks1') = allocHsRecField fld toks1 - r1' = r1 ++ r2 -{- -type HsRecordBinds id = HsRecFields id (LHsExpr id) - -data HsRecFields id arg - -Constructors - HsRecFields - rec_flds :: [HsRecField id arg] - rec_dotdot :: Maybe Int - -data HsRecField id arg - -Constructors - HsRecField - hsRecFieldId :: Located id - hsRecFieldArg :: arg - hsRecPun :: Bool - --} - -allocHsRecField :: - GHC.HsRecField GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [PosToken] - -> ([LayoutTree],[PosToken]) -allocHsRecField (GHC.HsRecField (GHC.L ln _) expr@(GHC.L le _) _) toks = (r,toks') - where - (s1,toksN,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toks - (s2,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1 - nLayout = makeLeafFromToks toksN - exprLayout = allocExpr expr toksE - toks' = toks2 - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ nLayout - ++ (makeLeafFromToks s2) ++ exprLayout] - --- --------------------------------------------------------------------- - -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 - - -- s1 will contain the 'where' token, split into prior comments, - -- the token, and post comments so that if the 'where' token must - -- be removed the comments will stay - (s1p,s1r) = break isWhereOrLet s1 - (w,s1a) = break (not.isWhereOrLet) s1r - whereLayout = makeLeafFromToks s1p ++ makeLeafFromToks w ++ makeLeafFromToks s1a - - 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) = 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 = strip $ whereLayout ++ bindsLayout ++ (makeLeafFromToks toks1) -allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut _ _)) _ - = error "allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut..)) should not be required" - -allocLocalBinds (GHC.HsIPBinds (GHC.IPBinds bs _)) toks = r - where - -- Note: only the Left x part is populated until after renaming, so no - -- need to process deeper than this - bindsLayout = allocList bs toks allocLocated - r = strip $ bindsLayout - --- --------------------------------------------------------------------- - -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) - -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 (GHC.L l (GHC.VarBind _n rhs@(GHC.L lr _) _)) toks = r - where - (sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,exprToks,toks2) = splitToksIncComments (ghcSpanStartEnd lr) toksBind - exprLayout = allocExpr rhs exprToks - r = [makeGroup $ (strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ exprLayout - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa) - ) - ] - -allocBind (GHC.L l (GHC.AbsBinds _tvs _vars _exps _ev binds)) toks = r - where - bindsList = GHC.bagToList binds - (sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks - (s1,bindsToks,toks2) = splitToksForList bindsList toksBind - bindsLayout = allocList bindsList bindsToks allocBind - r = [makeGroup $ (strip $ (makeLeafFromToks sb) - ++ (makeLeafFromToks s1) - ++ bindsLayout - ++ (makeLeafFromToks toks2) - ++ (makeLeafFromToks sa) - ) - ] - --- --------------------------------------------------------------------- - -allocSig :: GHC.LSig GHC.RdrName -> [PosToken] -> [LayoutTree] -allocSig (GHC.L l (GHC.TypeSig names t@(GHC.L lt _))) toks = r - where - -- TODO: make sure a grouped span completely covers the gap - -- between the names and the type, so it can be replaced later - (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,nameToks,toks'') = splitToksForList names bindToks - (s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks'' - nameLayout = allocList names nameToks allocLocated - typeLayout = allocType t typeToks - -- The nameLayout cannot have leading and/or trailing comment Nodes, based on the way the tokens are split. - nsub = ghead "allocSig.1" nameLayout - tsub = ghead "allocSig.2" typeLayout - (_,ne) = treeStartEnd nsub - (tb,_) = treeStartEnd tsub - gap = (ne,tb) - gapLayout = [Node (Entry gap NoChange []) (makeLeafFromToks s3)] - r = [makeGroup (strip $ (makeLeafFromToks s1) - ++ (makeLeafFromToks s2) - ++ nameLayout ++ gapLayout ++ typeLayout - ++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks'))] -allocSig (GHC.L l (GHC.GenericSig names t@(GHC.L lt _))) toks = r - where - (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')) ] - --- --------------------------------------------------------------------- - -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 = [makeGroup $ strip $ (makeLeafFromToks s1) ++ varsLayout - ++ (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 = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsFunTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r - where - (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks - t1Layout = allocType t1 t1Toks - t2Layout = allocType t2 t2Toks - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsListTy t1@(GHC.L l1 _)) ) toks = r - where - (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks - t1Layout = allocType t1 t1Toks - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsPArrTy t1@(GHC.L l1 _)) ) toks = r - where - (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks - t1Layout = allocType t1 t1Toks - r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsTupleTy _sort types)) toks = r - where - (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - typesLayout = allocList types typeToks allocType - r = [makeGroup $ strip $ (makeLeafFromToks s1) - ++ typesLayout ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsOpTy t1@(GHC.L l1 _) _op t2@(GHC.L l2 _))) toks = r - where - (s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ 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 = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2) - ++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')] -allocType (GHC.L l (GHC.HsRecTy decls) ) toks = r - where - (s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks - (declsLayout,toks1) = allocConDeclFieldList decls typeToks - r = [makeGroup $ 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 - --- --------------------------------------------------------------------- - -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 - --- --------------------------------------------------------------------- - -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) = (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 $ (makeLeafFromToks s2) ++ layout ++ (makeLeafFromToks toks2) - r = strip $ (makeLeafFromToks s2) ++ [makeGroup $ 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)] - - (layout,s2) = go ([],toksIn) axs bxs - 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) - --- --------------------------------------------------------------------- - -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 - loc = sspan - - (startLoc',endLoc') = nonCommentSpanLayout toks - sspan = if (startLoc',endLoc') == ((0,0),(0,0)) - then error $ "mkLeafFromToks:null span for:" ++ (show toks) - else simpPosToForestSpan (startLoc',endLoc') - --- --------------------------------------------------------------------- - --- |Extract the start and end position of a span, without any leading --- or trailing comments -nonCommentSpanLayout :: [PosToken] -> (SimpPos,SimpPos) -nonCommentSpanLayout [] = ((0,0),(0,0)) -nonCommentSpanLayout toks = (startPos,endPos) - where - stripped = dropWhile isComment $ toks - (startPos,endPos) = case stripped of - -- [] -> ((0,0),(0,0)) - [] -> (tokenPos $ head toks,tokenPosEnd $ last toks) - _ -> (tokenPos startTok,tokenPosEnd endTok) - where - startTok = ghead "nonCommentSpan.1" $ dropWhile isComment $ toks - endTok = ghead "nonCommentSpan.2" $ dropWhile isComment $ reverse 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 deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/LayoutTypes.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | --- - -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 Label = Label GHC.SrcSpan Layout [PosToken] - - 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 @@ -6,11 +6,11 @@ module HsTokens, PosToken,simpPos, -} - SimpPos,unmodified,modified + unmodified,modified , simpPos0 , nullSrcSpan -- , emptyList, nonEmptyList - , showToks + -- , showToks -- , tokenLen -- ,lengthOfToks -- , mkToken, mkZeroToken {-,defaultToken, -} @@ -22,9 +22,7 @@ , isWhiteSpace , isWhiteSpaceOrIgnored , isIgnored - , isIgnoredNonComment {- - ,isNewLn,isCommentStart -},isComment {-, isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -} ,isOpenSquareBracket,isCloseSquareBracket {- ,isOpenBrace,isConid, isLit,isWhereOrLet,isWhere,isLet-},isIn {- ,isCase,isDo,isIf,isForall, @@ -65,11 +63,6 @@ , insertComments, extractComments, insertTerms -} - , tokenCol - , tokenColEnd - , tokenRow - , tokenPos - , tokenPosEnd , tokenSrcSpan , tokenCon , increaseSrcSpan @@ -83,7 +76,7 @@ , fileNameFromTok , splitToks , emptyList, nonEmptyList - , divideComments + -- , divideComments , notWhiteSpace , isDoubleColon , isEmpty @@ -98,14 +91,13 @@ , splitOnNewLn , tokenLen , newLnToken - , newLinesToken - , monotonicLineToks + -- , newLinesToken + -- , monotonicLineToks , reSequenceToks , mkToken , mkZeroToken , markToken , isMarked - , addOffsetToToks , matchTokenPos , rmOffsetFromToks ) where @@ -124,19 +116,25 @@ import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.TokenUtils.GHC.Layout +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.Utils + import Data.Maybe import Data.List -- --------------------------------------------------------------------- - +{- showToks :: [PosToken] -> String showToks toks = show $ map (\(t@(GHC.L _ tok),s) -> ((getLocatedStart t, getLocatedEnd t),tok,s)) toks - +-} +{- moved to haskell-token-utils instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where show t@(GHC.L _l tok) = show ((getLocatedStart t, getLocatedEnd t),tok) - +-} --A flag used to indicate whether the token stream has been modified or not. unmodified, modified :: Bool @@ -147,8 +145,8 @@ simpPos0 :: (Int,Int) simpPos0 = (0,0) -nullSrcSpan :: GHC.SrcSpan -nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" +-- nullSrcSpan :: GHC.SrcSpan +-- nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" ------------------------------------------------ @@ -204,12 +202,12 @@ isClass (t, (_,s)) = t == Reservedid && s=="class" isInstance (t, (_,s)) = t == Reservedid && s=="instance" isNewtype (t, (_,s)) = t == Reservedid && s=="newtype" --} + isIn :: PosToken -> Bool isIn ((GHC.L _ t),_s) = case t of GHC.ITin -> True _ -> False -{- + isCase (t,(_,s)) = t==Reservedid && s=="case" isDo (t,(_,s)) = t==Reservedid && s=="do" isIf (t,(_,s)) = t==Reservedid && s=="if" @@ -396,8 +394,8 @@ (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) - -- newTok' = markToken newTok - newTok' = markToken $ matchTokenPos oldTok newTok + -- newTok' = markToken $ matchTokenPos oldTok newTok + newTok' = matchTokenPos oldTok newTok -- --------------------------------------------------------------------- @@ -608,25 +606,8 @@ -- --------------------------------------------------------------------- --- Returned from TokenUtils - --Some functions for fetching a specific field of a token -tokenCol :: PosToken -> Int -tokenCol (GHC.L l _,_) = c where (_,c) = getGhcLoc l - -tokenColEnd :: PosToken -> Int -tokenColEnd (GHC.L l _,_) = c where (_,c) = getGhcLocEnd l - -tokenRow :: PosToken -> Int -tokenRow (GHC.L l _,_) = r where (r,_) = getGhcLoc l - -tokenPos :: (GHC.GenLocated GHC.SrcSpan t1, t) -> SimpPos -tokenPos (GHC.L l _,_) = getGhcLoc l - -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 @@ -635,7 +616,7 @@ tokenCon (_,s) = s -- --------------------------------------------------------------------- - +{- increaseSrcSpan :: SimpPos -> PosToken -> PosToken increaseSrcSpan (lineAmount,colAmount) posToken@(lt@(GHC.L _l t), s) = (GHC.L newL t, s) @@ -649,7 +630,7 @@ add1 :: (Int, Int) -> (Int, Int) add1 (r,c) = (r+lineAmount,c+colAmount) - +-} -- --------------------------------------------------------------------- -- | gets the (row,col) of the start of the @GHC.SrcSpan@, or (-1,-1) @@ -707,7 +688,7 @@ fileNameFromTok (GHC.L _ _,_) = GHC.mkFastString "f" -- --------------------------------------------------------------------- - +{- -- | Split the token stream into three parts: the tokens before the -- startPos, the tokens between startPos and endPos, and the tokens -- after endPos. @@ -721,10 +702,11 @@ in (toks1,toks21,toks22) - +-} -- ---------------------------------------------------------------------- -- |Get around lack of instance Eq when simply testing for empty list +-- TODO: get rid of this in favour of `null` built in fn emptyList :: [t] -> Bool emptyList [] = True emptyList _ = False @@ -741,7 +723,7 @@ startEndLocIncComments::(SYB.Data t) => [PosToken] -> t -> (SimpPos,SimpPos) startEndLocIncComments toks t = startEndLocIncComments' toks (getStartEndLoc t) - +{- startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos) startEndLocIncComments' toks (startLoc,endLoc) = let @@ -812,62 +794,44 @@ go acc [_x] = acc go acc (((_s1,e1),_t1):b@((s2,_e2),t2):xs) = go (acc ++ [((s2 - e1),t2)] ) (b:xs) - +-} -- --------------------------------------------------------------------- isWhiteSpace :: PosToken -> Bool isWhiteSpace tok = isComment tok || isEmpty tok - +{- notWhiteSpace :: PosToken -> Bool notWhiteSpace tok = not (isWhiteSpace tok) -isWhiteSpaceOrIgnored :: PosToken -> Bool -isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok - -- Tokens that are ignored when allocating tokens to a SrcSpan isIgnored :: PosToken -> Bool isIgnored tok = isThen tok || isElse tok || isIn tok || isDo tok - --- | Tokens that are ignored when determining the first non-comment --- token in a span -isIgnoredNonComment :: PosToken -> Bool -isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok - - +-} -- --------------------------------------------------------------------- isDoubleColon :: PosToken -> Bool isDoubleColon ((GHC.L _ (GHC.ITdcolon)), "::") = True isDoubleColon _ = False -isComment :: PosToken -> Bool -isComment ((GHC.L _ (GHC.ITdocCommentNext _)),_s) = True -isComment ((GHC.L _ (GHC.ITdocCommentPrev _)),_s) = True -isComment ((GHC.L _ (GHC.ITdocCommentNamed _)),_s) = True -isComment ((GHC.L _ (GHC.ITdocSection _ _)),_s) = True -isComment ((GHC.L _ (GHC.ITdocOptions _)),_s) = True -isComment ((GHC.L _ (GHC.ITdocOptionsOld _)),_s) = True -isComment ((GHC.L _ (GHC.ITlineComment _)),_s) = True -isComment ((GHC.L _ (GHC.ITblockComment _)),_s) = True -isComment ((GHC.L _ _),_s) = False - +{- isEmpty :: PosToken -> Bool isEmpty ((GHC.L _ (GHC.ITsemi)), "") = True isEmpty ((GHC.L _ (GHC.ITvocurly)), "") = True isEmpty ((GHC.L _ _), "") = True isEmpty _ = False - -isWhereOrLet :: PosToken -> Bool -isWhereOrLet t = isWhere t || isLet t +-} +-- isWhereOrLet :: PosToken -> Bool +-- isWhereOrLet t = isWhere t || isLet t -- --------------------------------------------------------------------- -- This section is horrible because there is no Eq instance for -- GHC.Token +{- _ -> False isWhere :: PosToken -> Bool isWhere ((GHC.L _ t),_s) = case t of GHC.ITwhere -> True - _ -> False + isLet :: PosToken -> Bool isLet ((GHC.L _ t),_s) = case t of GHC.ITlet -> True @@ -892,7 +856,7 @@ isDo ((GHC.L _ t),_s) = case t of GHC.ITdo -> True _ -> False - +-} -- --------------------------------------------------------------------- @@ -933,7 +897,7 @@ importDecl (GHC.L l _) = Just l -- --------------------------------------------------------------------- - +{- -- | Get the indent of the line before, taking into account in-line -- 'where', 'let', 'in' and 'do' tokens getIndentOffset :: [PosToken] -> SimpPos -> Int @@ -976,14 +940,14 @@ | onSameLn (glast "splitOnNewLn" ss) (head xs) = go (ss ++ [head xs]) (tail xs) | otherwise = (ss,xs) - +-} -- --------------------------------------------------------------------- - +{- tokenLen :: PosToken -> Int tokenLen (_,s) = length s --check this again! need to handle the tab key. - +-} -- --------------------------------------------------------------------- - +{- newLnToken :: PosToken -> PosToken newLnToken tok = newLinesToken 1 tok @@ -999,17 +963,17 @@ in GHC.mkSrcSpan loc loc _ -> l - +-} -- --------------------------------------------------------------------- -groupTokensByLine :: [PosToken] -> [[PosToken]] -groupTokensByLine xs = groupBy toksOnSameLine xs +-- groupTokensByLine :: [PosToken] -> [[PosToken]] +-- groupTokensByLine xs = groupBy toksOnSameLine xs toksOnSameLine :: PosToken -> PosToken -> Bool toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2 -- --------------------------------------------------------------------- - +{- -- | sort out line numbering so that they are always monotonically -- increasing. monotonicLineToks :: [PosToken] -> [PosToken] @@ -1027,7 +991,7 @@ -- t1' = increaseSrcSpan (orow,ocol) t1 t2' = increaseSrcSpan offset' t2 - +-} -- --------------------------------------------------------------------- -- |Adjust token stream to cater for changes in token length due to @@ -1036,34 +1000,28 @@ reSequenceToks toks = toks -- --------------------------------------------------------------------- - +{- -- |Compose a new token using the given arguments. mkToken::GHC.Token -> SimpPos -> String -> PosToken mkToken t (row,col) c = ((GHC.L l t),c) where filename = (GHC.mkFastString "f") l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) )) - - +-} +{- mkZeroToken :: PosToken mkZeroToken = mkToken GHC.ITsemi (0,0) "" - --- --------------------------------------------------------------------- - --- |Add a constant line and column offset to a span of tokens -addOffsetToToks :: SimpPos -> [PosToken] -> [PosToken] -addOffsetToToks (r,c) toks = map (\t -> increaseSrcSpan (r,c) t) toks - +-} -- --------------------------------------------------------------------- - +{- onSameLn :: PosToken -> PosToken -> Bool onSameLn (GHC.L l1 _,_) (GHC.L l2 _,_) = r1 == r2 where (r1,_) = getGhcLoc l1 (r2,_) = getGhcLoc l2 - +-} -- --------------------------------------------------------------------- - +{- -- |Used as a marker in the filename part of the SrcSpan on modified -- tokens, to trigger re-alignment when retrieving the tokens. tokenFileMark :: GHC.FastString @@ -1092,7 +1050,7 @@ case l of GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark _ -> False - +-} -- --------------------------------------------------------------------- rmOffsetFromToks :: [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 @@ -43,8 +43,9 @@ import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal -import Language.Haskell.Refact.Utils.TokenUtilsTypes +import Language.Haskell.TokenUtils.Types import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.TokenUtils.Utils import System.Directory import System.FilePath.Posix import System.Log.Logger @@ -91,7 +92,7 @@ data RefactModule = RefMod { 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 + , rsTokenCache :: !(TokenCache PosToken) -- ^Token stream for the current module, maybe modified, in SrcSpan tree form , rsStreamModified :: !Bool -- ^current module has updated the token stream } @@ -244,14 +245,14 @@ (libs,exes,tests,benches) <- liftIO $ cabalAllTargets pkgDesc setCurrentDirectory currentDir - let -- libs' = addCurrentDir libs + let libs' = filter (\l -> not (isPrefixOf "Paths_" l)) libs exes' = addCabalDir exes tests' = addCabalDir tests benches' = addCabalDir benches addCabalDir ts = map (\t -> combine cabalDir t) ts - return (libs,exes',tests',benches') + return (libs',exes',tests',benches') -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -11,9 +11,9 @@ ( -- * Conveniences for state access - fetchToksFinal + -- fetchToksFinal -- , fetchPprFinal - , fetchLinesFinal + fetchLinesFinal , fetchOrigToks , fetchToks -- Deprecated -- , putToks -- ^Deprecated, destroys token tree @@ -79,20 +79,21 @@ import qualified Data.Data as SYB -import Language.Haskell.Refact.Utils.DualTree import Language.Haskell.Refact.Utils.GhcVersionSpecific -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 +import Language.Haskell.TokenUtils.DualTree +import Language.Haskell.TokenUtils.GHC.Layout +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.Utils -import Data.Time.Clock + +-- import Data.Time.Clock import Data.Tree -import System.Log.Logger +-- import System.Log.Logger import qualified Data.Map as Map -- --------------------------------------------------------------------- @@ -106,6 +107,7 @@ logm $ "fetchToks (not showing toks" return toks +{- -- |fetch the final tokens fetchToksFinal :: RefactGhc [PosToken] fetchToksFinal = do @@ -114,9 +116,10 @@ -- logm $ "fetchToks" ++ (showToks toks) logm $ "fetchToksFinal (not showing toks)" return toks +-} -- |fetch the final tokens in Ppr format -fetchLinesFinal :: RefactGhc [Line] +fetchLinesFinal :: RefactGhc [Line PosToken] fetchLinesFinal = do Just tm <- gets rsModule let linesVal = retrieveLinesFromLayoutTree $ (tkCache $ rsTokenCache tm) Map.! mainTid @@ -138,7 +141,7 @@ let Just tm = rsModule st let forest = getTreeFromCache sspan (rsTokenCache tm) -- let (forest',toks) = getTokensFor checkInv forest sspan - let (forest',toks) = getTokensForNoIntros checkInv forest sspan + let (forest',toks) = getTokensForNoIntros checkInv forest (ss2s sspan) let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } @@ -154,7 +157,7 @@ let checkInv = False let Just tm = rsModule st let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensFor checkInv forest sspan + let (forest',toks) = getTokensFor checkInv forest (ss2s sspan) -- let (forest',toks) = getTokensForNoIntros checkInv forest sspan let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk'}) @@ -171,7 +174,7 @@ let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st let Just tm = rsModule st let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensFor checkInv forest sspan + let (forest',toks) = getTokensFor checkInv forest (ss2s sspan) let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } @@ -179,12 +182,12 @@ return toks -- |Get the current tokens preceding a given GHC.SrcSpan. -getToksBeforeSpan :: GHC.SrcSpan -> RefactGhc ReversedToks +getToksBeforeSpan :: GHC.SrcSpan -> RefactGhc (ReversedToks PosToken) getToksBeforeSpan sspan = do st <- get let Just tm = rsModule st let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',toks) = getTokensBefore forest sspan + let (forest',toks) = getTokensBefore forest (ss2s sspan) let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk'}) put $ st { rsModule = rsModule' } @@ -199,7 +202,7 @@ st <- get let Just tm = rsModule st - let tk' = replaceTokenInCache (rsTokenCache tm) sspan tok + let tk' = replaceTokenInCache (rsTokenCache tm) (ss2s sspan) tok let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } return () @@ -212,10 +215,10 @@ st <- get let Just tm = rsModule st - let (tk',newSpan) = putToksInCache (rsTokenCache tm) sspan toks + let (tk',newSpan) = putToksInCache (rsTokenCache tm) (ss2s sspan) toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } - return newSpan + return (s2ss newSpan) -- |Replace the tokens for a given GHC.SrcSpan, return new GHC.SrcSpan -- delimiting new tokens, and update the AST fragment to reflect it @@ -239,11 +242,11 @@ let Just tm = rsModule st let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid let sspan = posToSrcSpan mainForest pos - let (tk',newSpan) = putToksInCache (rsTokenCache tm) sspan toks + let (tk',newSpan) = putToksInCache (rsTokenCache tm) (ss2s sspan) toks let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) put $ st { rsModule = rsModule' } -- drawTokenTree "" - return newSpan + return (s2ss newSpan) -- |Add tokens after a designated GHC.SrcSpan putToksAfterSpan :: GHC.SrcSpan -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan @@ -252,11 +255,11 @@ st <- get let Just tm = rsModule st let forest = getTreeFromCache oldSpan (rsTokenCache tm) - let (forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks + let (forest',newSpan) = addToksAfterSrcSpan forest (ss2s oldSpan) pos toks let tk' = replaceTreeInCache oldSpan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } - return newSpan + return (s2ss newSpan) -- |Add tokens after a designated position putToksAfterPos :: (SimpPos,SimpPos) -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan @@ -267,12 +270,12 @@ let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid let sspan = posToSrcSpan mainForest pos let forest = getTreeFromCache sspan (rsTokenCache tm) - let (forest',newSpan) = addToksAfterSrcSpan forest sspan position toks + let (forest',newSpan) = addToksAfterSrcSpan forest (ss2s sspan) position toks let tk' = replaceTreeInCache sspan forest' $ rsTokenCache tm let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } -- logm $ "putToksAfterPos result:" ++ (show forest') ++ "\ntree:\n" ++ (drawTreeEntry forest') - return newSpan + return (s2ss newSpan) -- |Add tokens after a designated GHC.SrcSpan, and update the AST -- fragment to reflect it @@ -294,7 +297,7 @@ logm $ "removeToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) st <- get let Just tm = rsModule st - let tk' = removeToksFromCache (rsTokenCache tm) sspan + let tk' = removeToksFromCache (rsTokenCache tm) (ss2s sspan) let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } return () @@ -307,7 +310,7 @@ let Just tm = rsModule st let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid let sspan = posToSrcSpan mainForest pos - let tk' = removeToksFromCache (rsTokenCache tm) sspan + let tk' = removeToksFromCache (rsTokenCache tm) (ss2s sspan) let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } -- drawTokenTree "removeToksForPos result" @@ -338,7 +341,7 @@ -- --------------------------------------------------------------------- -- |Get the Token Tree for debug purposes -getTokenTree :: RefactGhc (Tree Entry) +getTokenTree :: RefactGhc (Tree (Entry PosToken)) getTokenTree = do st <- get let Just tm = rsModule st @@ -382,7 +385,7 @@ let Just tm = rsModule st let tk = rsTokenCache tm let forest = (tkCache tk) Map.! mainTid - let (t',forest') = indentDeclToks t forest offset + let (t',forest') = indentDeclToks syncAST t forest offset let tk' = tk {tkCache = Map.insert mainTid forest' (tkCache tk) } let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) put $ st { rsModule = rsModule' } 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 @@ -12,33 +12,34 @@ -- This API is used internally by MonadFunctions and the other utility -- modules, it should probably never be used directly in a refactoring. -module Language.Haskell.Refact.Utils.TokenUtils( +module Language.Haskell.Refact.Utils.TokenUtils ( +{- -- * Creating initTokenCache , initTokenCacheLayout , mkTreeFromTokens , mkTreeFromSpanTokens - +-} -- * Operations at 'TokenCache' level - , putToksInCache + putToksInCache , putDeclToksInCache , replaceTokenInCache - , removeToksFromCache + -- , removeToksFromCache , getTreeFromCache , replaceTreeInCache , syncAstToLatestCache -- * Operations at 'Tree' 'Entry' level - , getTokensFor - , getTokensForNoIntros - , getTokensBefore - , replaceTokenForSrcSpan - , updateTokensForSrcSpan - , insertSrcSpan - , removeSrcSpan - , getSrcSpanFor - , getSrcSpanForDeep - , addNewSrcSpanAndToksAfter + -- , getTokensFor + -- , getTokensForNoIntros + -- , getTokensBefore + -- , replaceTokenForSrcSpan + -- , updateTokensForSrcSpan + -- , insertSrcSpan + -- , removeSrcSpan + -- , getSrcSpanFor + -- , getSrcSpanForDeep + -- , addNewSrcSpanAndToksAfter , addToksAfterSrcSpan , addDeclToksAfterSrcSpan , syncAST @@ -46,119 +47,123 @@ , Positioning(..) -- * Retrieving tokens - , retrieveTokensFinal + -- , retrieveTokensFinal -- , retrieveTokensPpr -- , renderPpr - , adjustLinesForDeleted + -- , adjustLinesForDeleted , retrieveTokensInterim - , retrieveTokens' -- temporary for debug + -- , retrieveTokens' -- temporary for debug -- * Token Tree Selection , treeIdFromForestSpan -- * Token marking and re-alignment - , reAlignMarked + -- , reAlignMarked -- * Utility , posToSrcSpan , posToSrcSpanTok , fileNameFromTok , treeStartEnd - , spanStartEnd + -- , spanStartEnd , sf , fs + , ss2f,f2ss + , ss2s,s2ss , forestSpanFromEntry - , combineSpans + -- , combineSpans -- * A token stream with last tokens first, and functions to manipulate it - , ReversedToks(..) - , reverseToks - , unReverseToks - , reversedToks + -- , ReversedToks(..) + -- , reverseToks + -- , unReverseToks + -- , reversedToks -- * Internal, for testing - , placeToksForSpan - , limitPrevToks - , reIndentToks - , reAlignOneLine - , reAlignToks - , splitForestOnSpan - , spanContains - , containsStart, containsMiddle, containsEnd - , doSplitTree, splitSubtree, splitSubToks + -- , placeToksForSpan + -- , limitPrevToks + -- , reIndentToks + -- , reAlignOneLine + -- , reAlignToks + -- , splitForestOnSpan + -- , spanContains + -- , containsStart, containsMiddle, containsEnd + -- , doSplitTree, splitSubtree, splitSubToks , nonCommentSpan - , invariantOk - , invariant - , showForest + -- , invariantOk + -- , invariant + -- , showForest , showTree , showSrcSpan , showSrcSpanF , ghcSpanStartEnd - , insertNodeAfter - , retrievePrevLineToks - , getTreeSpansAsList - , openZipperToNode - , openZipperToNodeDeep - , openZipperToSpan - , openZipperToSpanDeep - , openZipperToSpanAdded - , openZipperToSpanOrig + -- , insertNodeAfter + -- , retrievePrevLineToks + -- , getTreeSpansAsList + -- , openZipperToNode + -- , openZipperToNodeDeep + -- , openZipperToSpan + -- , openZipperToSpanDeep + -- , openZipperToSpanAdded + -- , openZipperToSpanOrig , forestSpanToSimpPos , forestSpanToGhcPos , ghcLineToForestLine , stripForestLineFromGhc , forestLineToGhcLine - , forestSpanToSrcSpan - , forestPosVersionSet - , forestPosVersionNotSet - , forestSpanLenChanged + , forestSpanToGhcSrcSpan + -- , forestPosVersionSet + -- , forestPosVersionNotSet + -- , forestSpanLenChanged , forestSpanVersions , forestSpanVersionSet - , forestSpanVersionNotSet + -- , forestSpanVersionNotSet , insertForestLineInSrcSpan - , insertLenChangedInSrcSpan - , insertVersionsInSrcSpan - , srcSpanToForestSpan - , nullSpan, nullPos - , simpPosToForestSpan + -- , insertLenChangedInSrcSpan + -- , insertVersionsInSrcSpan + , ghcSrcSpanToForestSpan + , nullForestSpan, nullForestPos + -- , simpPosToForestSpan , srcPosToSimpPos , showForestSpan , deleteGapsToks -- , deleteGapsToks' - , calcEndGap - , stripForestLines + -- , calcEndGap + -- , stripForestLines -- * Based on Data.Tree , drawTreeEntry - , drawTokenCache - , drawTokenCacheDetailed + -- , drawTokenCache + -- , drawTokenCacheDetailed , drawForestEntry - , drawEntry + -- , drawEntry , drawTreeCompact ) where import qualified FastString as GHC import qualified GHC as GHC -import qualified SrcLoc as GHC +-- import qualified SrcLoc as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB -import qualified Data.Foldable as F +-- import 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 Data.Bits -import Data.List +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.Utils + +-- import Data.Bits +-- import Data.List import Data.Tree import qualified Data.Map as Map -import qualified Data.Tree.Zipper as Z +-- import qualified Data.Tree.Zipper as Z -- import Debug.Trace @@ -233,11 +238,14 @@ -} -deriving instance Show Entry +-- deriving instance Show Entry +{- moved to haskell-token-utils instance Ord LayoutTree where compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b) +-} +{- moved to haskell-token-utils instance Eq Entry where (Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2) = fs1 == fs2 && lay1 == lay2 @@ -247,9 +255,10 @@ = fs1 == fs2 && pg1 == pg2 && lay1 == lay2 (==) _ _ = False +-} -- --------------------------------------------------------------------- - +{- -- |Keep track of when tokens are reversed, to avoid confusion data ReversedToks = RT [PosToken] deriving (Show) @@ -283,7 +292,7 @@ -- start, num lines to add at the end -- relative to the indent level of the prior line deriving (Show) - +-} -- --------------------------------------------------------------------- {- @@ -331,17 +340,20 @@ -- 5 bits for version : 32 values -- 20 bits for line number: 1048576 values -forestLineMask,forestVersionMask,forestTreeMask,forestLenChangedMask :: Int -forestLineMask = 0xfffff -- bottom 20 bits -forestVersionMask = 0x1f00000 -- next 5 bits -forestTreeMask = 0x3e000000 -- next 5 bits -forestLenChangedMask = 0x40000000 -- top (non-sign) bit +-- forestLineMask :: Int +-- forestVersionMask :: Int +-- forestTreeMask :: Int +-- forestLenChangedMask :: Int +-- forestLineMask = 0xfffff -- bottom 20 bits +-- forestVersionMask = 0x1f00000 -- next 5 bits +-- forestTreeMask = 0x3e000000 -- next 5 bits +-- forestLenChangedMask = 0x40000000 -- top (non-sign) bit -forestVersionShift :: Int -forestVersionShift = 20 +-- forestVersionShift :: Int +-- forestVersionShift = 20 -forestTreeShift :: Int -forestTreeShift = 25 +-- forestTreeShift :: Int +-- forestTreeShift = 25 {- This has been moved to TokenUtilsTypes @@ -357,6 +369,7 @@ } deriving (Eq) -} +{- moved to haskell-token-utils -- | Extract an encoded ForestLine from a GHC line ghcLineToForestLine :: Int -> ForestLine ghcLineToForestLine l = ForestLine ch tr v l' @@ -365,16 +378,19 @@ v = shiftR (l .&. forestVersionMask) forestVersionShift tr = shiftR (l .&. forestTreeMask) forestTreeShift ch = (l .&. forestLenChangedMask) /= 0 +-} +{- moved to haskell-token-utils -- TODO: check that the components are in range forestLineToGhcLine :: ForestLine -> Int forestLineToGhcLine fl = (if (flSpanLengthChanged fl) then forestLenChangedMask else 0) + (shiftL (flTreeSelector fl) forestTreeShift) + (shiftL (flInsertVersion fl) forestVersionShift) + (flLine fl) +-} -forestSpanToSrcSpan :: ForestSpan -> GHC.SrcSpan -forestSpanToSrcSpan ((fls,sc),(fle,ec)) = sspan +forestSpanToGhcSrcSpan :: ForestSpan -> GHC.SrcSpan +forestSpanToGhcSrcSpan ((fls,sc),(fle,ec)) = sspan where lineStart = forestLineToGhcLine fls lineEnd = forestLineToGhcLine fle @@ -383,6 +399,7 @@ sspan = GHC.mkSrcSpan locStart locEnd +{- moved to haskell-token-utils instance Ord ForestLine where -- Use line as the primary comparison, but break any ties with the -- version @@ -393,11 +410,13 @@ if (l1 == l2) then compare v1 v2 else compare l1 l2 - +-} +{- -- |Gets the version numbers forestSpanVersions :: ForestSpan -> (Int,Int) forestSpanVersions ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = (sv,ev) - +-} +{- -- |Gets the AST tree numbers forestSpanAstVersions :: ForestSpan -> (Int,Int) forestSpanAstVersions ((ForestLine _ trs _ _,_),(ForestLine _ tre _ _,_)) = (trs,tre) @@ -405,11 +424,13 @@ -- |Gets the SpanLengthChanged flags forestSpanLenChangedFlags :: ForestSpan -> (Bool,Bool) forestSpanLenChangedFlags ((ForestLine chs _ _ _,_),(ForestLine che _ _ _,_)) = (chs,che) - +-} +{- moved to haskell-token-utils -- |Checks if the version is non-zero in either position forestSpanVersionSet :: ForestSpan -> Bool forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0 - +-} +{- -- |Checks if the version is zero in both positions forestSpanVersionNotSet :: ForestSpan -> Bool forestSpanVersionNotSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv == 0 && ev == 0 @@ -428,47 +449,53 @@ forestSpanLenChanged :: ForestSpan -> Bool forestSpanLenChanged (s,e) = (forestPosLenChanged s) || (forestPosLenChanged e) - -forestPosLenChanged :: ForestPos -> Bool -forestPosLenChanged (ForestLine ch _ _ _,_) = ch - +-} +-- forestPosLenChanged :: ForestPos -> Bool +-- forestPosLenChanged (ForestLine ch _ _ _,_) = ch +{- -- |Puts a TreeId into a forestSpan treeIdIntoForestSpan :: TreeId -> ForestSpan -> ForestSpan treeIdIntoForestSpan (TId sel) ((ForestLine chs _ sv sl,sc),(ForestLine che _ ev el,ec)) = ((ForestLine chs sel sv sl,sc),(ForestLine che sel ev el,ec)) - +-} +{- moved to haskell-token-utils -- |Strip out the version markers forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos) forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec)) - +-} +{- -- |Strip out the version markers forestSpanToGhcPos :: ForestSpan -> (SimpPos,SimpPos) forestSpanToGhcPos ((fls,sc),(fle,ec)) = ((forestLineToGhcLine fls,sc),(forestLineToGhcLine fle,ec)) - - +-} +{- simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan simpPosToForestSpan ((sr,sc),(er,ec)) = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec)) - +-} +{- moved to haskell-token-utils srcPosToSimpPos :: (Int,Int) -> (Int,Int) srcPosToSimpPos (sr,c) = (l,c) where (ForestLine _ _ _ l) = ghcLineToForestLine sr - +-} +{- forestSpanStart :: ForestSpan -> ForestPos forestSpanStart (start,_) = start forestSpanEnd :: ForestSpan -> ForestPos forestSpanEnd (_,end) = end - -nullSpan :: ForestSpan -nullSpan = (nullPos,nullPos) - -nullPos :: ForestPos -nullPos = (ForestLine False 0 0 0,0) +-} +{- +nullForestSpan :: ForestSpan +nullForestSpan = (nullForestPos,nullForestPos) +nullForestPos :: ForestPos +nullForestPos = (ForestLine False 0 0 0,0) +-} +{- showForestSpan :: ForestSpan -> String showForestSpan ((sr,sc),(er,ec)) = show ((flToNum sr,sc),(flToNum er,ec)) @@ -477,7 +504,7 @@ + ((fromIntegral tr) * 100000000::Integer) + ((fromIntegral v) * 1000000::Integer) + (fromIntegral l) - +-} -- --------------------------------------------------------------------- -- | Replace any ForestLine flags already in a SrcSpan with the given ones @@ -485,7 +512,7 @@ insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss' where lineStart = forestLineToGhcLine fl - (_,(ForestLine _ _ _ le,_)) = srcSpanToForestSpan (GHC.RealSrcSpan ss) + (_,(ForestLine _ _ _ le,_)) = ghcSrcSpanToForestSpan (GHC.RealSrcSpan ss) lineEnd = forestLineToGhcLine (ForestLine ch tr v le) locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss) @@ -494,12 +521,12 @@ insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) -- --------------------------------------------------------------------- - +{- insertVersionsInSrcSpan :: Int -> Int -> GHC.SrcSpan -> GHC.SrcSpan insertVersionsInSrcSpan vs ve rss@(GHC.RealSrcSpan ss) = ss' where - (chs,che) = forestSpanLenChangedFlags $ srcSpanToForestSpan rss - (trs,tre) = forestSpanAstVersions $ srcSpanToForestSpan rss + (chs,che) = forestSpanLenChangedFlags $ ghcSrcSpanToForestSpan rss + (trs,tre) = forestSpanAstVersions $ ghcSrcSpanToForestSpan rss lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss)) lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss)) locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) @@ -507,9 +534,9 @@ ss' = GHC.mkSrcSpan locStart locEnd insertVersionsInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) - +-} -- --------------------------------------------------------------------- - +{- insertLenChangedInSrcSpan :: Bool -> Bool -> GHC.SrcSpan -> GHC.SrcSpan insertLenChangedInSrcSpan chs che rss@(GHC.RealSrcSpan ss) = ss' where @@ -524,8 +551,8 @@ locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) sl' (GHC.srcSpanStartCol ss) locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) el' (GHC.srcSpanEndCol ss) - -- (vs,ve) = forestSpanVersions $ srcSpanToForestSpan rss - -- (trs,tre) = forestSpanAstVersions $ srcSpanToForestSpan rss + -- (vs,ve) = forestSpanVersions $ ghcSrcSpanToForestSpan rss + -- (trs,tre) = forestSpanAstVersions $ ghcSrcSpanToForestSpan rss -- lineStart = forestLineToGhcLine (ForestLine chs trs vs (GHC.srcSpanStartLine ss)) -- lineEnd = forestLineToGhcLine (ForestLine che tre ve (GHC.srcSpanEndLine ss)) -- locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss) @@ -533,9 +560,9 @@ ss' = GHC.mkSrcSpan locStart locEnd insertLenChangedInSrcSpan _ _ _ss = error $ "insertVersionsInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss) - +-} -- --------------------------------------------------------------------- - +{- insertVersionsInForestSpan :: Int -> Int -> ForestSpan -> ForestSpan insertVersionsInForestSpan vsNew veNew ((ForestLine chs trs _vs ls,cs),(ForestLine che tre _ve le,ce)) = ((ForestLine chs trs vsNew ls,cs),(ForestLine che tre veNew le,ce)) @@ -545,41 +572,31 @@ insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce)) = ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce)) - +-} -- --------------------------------------------------------------------- -srcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan -srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) +ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan +ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) where (startRow,startCol) = getGhcLoc sspan (endRow,endCol) = getGhcLocEnd sspan -- -------------------------------------------------------------------- - -forestSpanFromEntry :: Entry -> ForestSpan -forestSpanFromEntry (Entry ss _ _) = ss -forestSpanFromEntry (Deleted ss _ _) = ss - -putForestSpanInEntry :: Entry -> ForestSpan -> Entry -putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks) -putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg) - --- -------------------------------------------------------------------- - +{- treeIdFromForestSpan :: ForestSpan -> TreeId treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr - +-} -- --------------------------------------------------------------------- - -initTokenCache :: [PosToken] -> TokenCache +{- +initTokenCache :: [PosToken] -> TokenCache PosToken initTokenCache toks = TK (Map.fromList [((TId 0),(mkTreeFromTokens toks))]) (TId 0) -initTokenCacheLayout :: Tree Entry -> TokenCache +initTokenCacheLayout :: Tree (Entry PosToken) -> TokenCache PosToken initTokenCacheLayout tree = TK (Map.fromList [((TId 0),tree)]) (TId 0) - +-} -- --------------------------------------------------------------------- - -treeIdIntoTree :: TreeId -> Tree Entry -> Tree Entry +{- +treeIdIntoTree :: TreeId -> Tree (Entry PosToken) -> Tree (Entry PosToken) treeIdIntoTree tid (Node (Entry fspan lay toks) subTree) = tree' where fs' = treeIdIntoForestSpan tid fspan @@ -588,10 +605,10 @@ where fs' = treeIdIntoForestSpan tid fspan tree' = Node (Deleted fs' pg eg) subTree - +-} -- --------------------------------------------------------------------- - -stash :: TokenCache -> Tree Entry -> TokenCache +{- +stash :: TokenCache PosToken -> Tree (Entry PosToken) -> TokenCache PosToken stash tk oldTree = tk' where (TId lastTreeId) = tkLastTreeId tk @@ -599,68 +616,64 @@ oldTree' = treeIdIntoTree lastTreeId' oldTree cache' = Map.insert lastTreeId' oldTree' (tkCache tk) tk' = tk {tkLastTreeId = lastTreeId', tkCache = cache' } - +-} -- --------------------------------------------------------------------- - -replaceTokenInCache :: TokenCache -> GHC.SrcSpan -> PosToken -> TokenCache +{- +replaceTokenInCache :: TokenCache PosToken -> GHC.SrcSpan -> PosToken -> TokenCache PosToken replaceTokenInCache tk sspan tok = tk' where forest = getTreeFromCache sspan tk forest' = replaceTokenForSrcSpan forest sspan tok tk' = replaceTreeInCache sspan forest' tk - +-} -- --------------------------------------------------------------------- - -putToksInCache :: TokenCache -> GHC.SrcSpan -> [PosToken] -> (TokenCache,GHC.SrcSpan) +{- +putToksInCache :: TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> (TokenCache PosToken,GHC.SrcSpan) putToksInCache tk sspan toks = (tk'',newSpan) where forest = getTreeFromCache sspan tk (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks tk' = replaceTreeInCache sspan forest' tk tk'' = stash tk' oldTree - +-} -- --------------------------------------------------------------------- putDeclToksInCache :: (SYB.Data t) => - TokenCache -> GHC.SrcSpan -> [PosToken] -> GHC.Located t - -> (TokenCache,GHC.SrcSpan,GHC.Located t) -putDeclToksInCache tk sspan toks t = (tk'',newSpan,t') + TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> GHC.Located t + -> (TokenCache PosToken,GHC.SrcSpan,GHC.Located t) +putDeclToksInCache tk sspan toks t = (tk'',s2ss newSpan,t') where - forest = getTreeFromCache sspan tk - (forest',newSpan,oldTree) = updateTokensForSrcSpan forest sspan toks - (t',forest'') = syncAST t newSpan forest' - - tk' = replaceTreeInCache sspan forest'' tk - tk'' = stash tk' oldTree + (tk'',newSpan) = putToksInCache tk (ss2s sspan) toks + t' = syncAST t (sf newSpan) -- --------------------------------------------------------------------- - -removeToksFromCache :: TokenCache -> GHC.SrcSpan -> TokenCache +{- +removeToksFromCache :: TokenCache PosToken -> GHC.SrcSpan -> TokenCache PosToken removeToksFromCache tk sspan = tk'' where forest = getTreeFromCache sspan tk - (forest',oldTree) = removeSrcSpan forest (srcSpanToForestSpan sspan) + (forest',oldTree) = removeSrcSpan forest (ghcSrcSpanToForestSpan sspan) tk' = replaceTreeInCache sspan forest' tk tk'' = stash tk' oldTree - +-} -- --------------------------------------------------------------------- -getTreeFromCache :: GHC.SrcSpan -> TokenCache -> Tree Entry +getTreeFromCache :: GHC.SrcSpan -> TokenCache PosToken -> Tree (Entry PosToken) getTreeFromCache sspan tk = (tkCache tk) Map.! tid where - tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan + tid = treeIdFromForestSpan $ ghcSrcSpanToForestSpan sspan -- --------------------------------------------------------------------- -replaceTreeInCache :: GHC.SrcSpan -> Tree Entry -> TokenCache -> TokenCache +replaceTreeInCache :: GHC.SrcSpan -> Tree (Entry PosToken) -> TokenCache PosToken -> TokenCache PosToken replaceTreeInCache sspan tree tk = tk' where - tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan + tid = treeIdFromForestSpan $ ghcSrcSpanToForestSpan sspan -- tree' = treeIdIntoTree tid tree tree' = putTidInTree tid tree tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) } -putTidInTree :: TreeId -> Tree Entry -> Tree Entry +putTidInTree :: TreeId -> Tree (Entry PosToken) -> Tree (Entry PosToken) putTidInTree tid (Node (Deleted fspan pg eg) subs) = (Node (Deleted fs' pg eg) subs) where fs' = treeIdIntoForestSpan tid fspan putTidInTree tid (Node (Entry fspan lay toks) subs) = tree' @@ -673,28 +686,28 @@ -- |Assuming most recent operation has stashed the old tokens, sync -- the given AST to the most recent stash entry -syncAstToLatestCache :: (SYB.Data t) => TokenCache -> GHC.Located t -> GHC.Located t +syncAstToLatestCache :: (SYB.Data t) => TokenCache PosToken -> GHC.Located t -> GHC.Located t syncAstToLatestCache tk t = t' where mainForest = (tkCache tk) Map.! mainTid - forest@(Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) + (Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) pos = forestSpanToGhcPos fspan sspan = posToSrcSpan mainForest pos - (t',_) = syncAST t sspan forest + t' = syncAST t (ss2f sspan) -- --------------------------------------------------------------------- - +{- -- |Get the (possible cached) tokens for a given source span, and -- cache their being fetched. -- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC. -getTokensFor :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken]) +getTokensFor :: Bool -> Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),[PosToken]) getTokensFor checkInvariant forest sspan = (forest'', tokens) where forest' = if (not checkInvariant) || invariantOk forest -- short circuit eval then forest else error $ "getTokensFor:invariant failed:" ++ (show $ invariant forest) - (forest'',tree) = getSrcSpanFor forest' (srcSpanToForestSpan sspan) + (forest'',tree) = getSrcSpanFor forest' (ghcSrcSpanToForestSpan sspan) tokens = retrieveTokensInterim tree @@ -703,23 +716,23 @@ -- |Get the (possible cached) tokens for a given source span, and -- cache their being fetched. -- NOTE: The SrcSpan may be one introduced by HaRe, rather than GHC. -getTokensForNoIntros :: Bool -> Tree Entry -> GHC.SrcSpan -> (Tree Entry,[PosToken]) +getTokensForNoIntros :: Bool -> Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),[PosToken]) getTokensForNoIntros checkInvariant forest sspan = (forest', tokens') where (forest',tokens) = getTokensFor checkInvariant forest sspan -- (lead,rest) = break (not . isWhiteSpaceOrIgnored) tokens (lead,rest) = break (not . isIgnoredNonComment) tokens tokens' = (filter (not . isIgnored) lead) ++ rest - +-} -- --------------------------------------------------------------------- - +{- -- |Get the tokens preceding a given 'SrcSpan' -getTokensBefore :: Tree Entry -> GHC.SrcSpan -> (Tree Entry,ReversedToks) +getTokensBefore :: Tree (Entry PosToken) -> GHC.SrcSpan -> (Tree (Entry PosToken),ReversedToks PosToken) getTokensBefore forest sspan = (forest', prevToks') where - (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) + (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) - z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest' + z = openZipperToSpan (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest' prevToks = case (retrievePrevLineToks z) of RT [] -> reverseToks $ retrieveTokensInterim tree @@ -727,9 +740,9 @@ (_,rtoks) = break (\t->tokenPos t < (getGhcLoc sspan)) $ reversedToks prevToks prevToks' = RT rtoks - +-} -- --------------------------------------------------------------------- - +{- -- |Replace a single token in a token tree, without changing the -- structure of the tree -- NOTE: the GHC.SrcSpan may have been used to select the appropriate @@ -738,15 +751,15 @@ -- 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 :: Tree (Entry PosToken) -> GHC.SrcSpan -> PosToken -> Tree (Entry PosToken) replaceTokenForSrcSpan forest sspan tok = forest' where (GHC.L tl _,_) = tok -- First open to the sspan, making use of any Forestline annotations - z = openZipperToSpanDeep (srcSpanToForestSpan sspan) $ Z.fromTree forest + z = openZipperToSpanDeep (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest -- Then drill down to the specific subtree containing the token - -- z' = openZipperToSpan (srcSpanToForestSpan tl) z + -- z' = openZipperToSpan (ghcSrcSpanToForestSpan tl) z z' = z -- No, pass in original token span as sspan. -- Note: with LayoutTree, the full tree matching the AST has been @@ -756,25 +769,25 @@ (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 + ((row,col),_) = forestSpanToSimpPos $ ghcSrcSpanToForestSpan tl toks' = replaceTokNoReAlign toks (row,col) tok zf = Z.setTree (Node (Entry tspan lay toks') []) z' forest' = Z.toTree zf -- forest' = forest - +-} -- --------------------------------------------------------------------- - +{- -- |Replace the tokens for a given SrcSpan with new ones. The SrcSpan -- will be inserted into the tree if it is not already there. -- If the SrcSpan changes size, replace the SrcSpan with a new one -- (marked), and return it, as well as the old one -- TODO: What about trailing comments? Preserve or replace? -updateTokensForSrcSpan :: Tree Entry -> GHC.SrcSpan -> [PosToken] -> (Tree Entry,GHC.SrcSpan,Tree Entry) +updateTokensForSrcSpan :: Tree (Entry PosToken) -> GHC.SrcSpan -> [PosToken] -> (Tree (Entry PosToken),GHC.SrcSpan,Tree (Entry PosToken)) updateTokensForSrcSpan forest sspan toks = (forest'',newSpan,oldTree) where - (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (srcSpanToForestSpan sspan) + (forest',tree@(Node (Entry _s _ _) _)) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) prevToks = retrieveTokensInterim tree endComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse toks @@ -793,7 +806,7 @@ origEndComments = reverse $ takeWhile isWhiteSpaceOrIgnored $ reverse prevToks origStartComments = takeWhile isWhiteSpaceOrIgnored $ prevToks - ((startRow,startCol),_) = forestSpanToGhcPos $ srcSpanToForestSpan sspan + ((startRow,startCol),_) = forestSpanToGhcPos $ ghcSrcSpanToForestSpan sspan core = reIndentToks (PlaceAbsolute startRow startCol) prevToks toks trail = if (emptyList origEndComments) then [] @@ -808,7 +821,7 @@ (startPos,endPos) = nonCommentSpan toks'' -- if the original sspan had a ForestLine version, preserve it - (((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = srcSpanToForestSpan sspan + (((ForestLine _chs _trs vs _),_),(ForestLine _che _tre ve _,_)) = ghcSrcSpanToForestSpan sspan -- Note: adding one to end version, so invariant won't fail -- newSpan = insertVersionsInSrcSpan vs ve $ posToSrcSpan forest (startPos,endPos) newSpan = insertLenChangedInSrcSpan True True @@ -816,28 +829,30 @@ zf = openZipperToNode tree $ Z.fromTree forest' - zf' = Z.setTree (Node (Entry (srcSpanToForestSpan newSpan) NoChange toks'') []) zf + zf' = Z.setTree (Node (Entry (ghcSrcSpanToForestSpan newSpan) NoChange toks'') []) zf forest'' = Z.toTree zf' oldTree = tree - +-} +{- -- --------------------------------------------------------------------- -- |Retrieve a path to the tree containing a ForestSpan from the forest, -- inserting it if not already present -getSrcSpanFor :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry) +getSrcSpanFor :: Tree (Entry PosToken) -> ForestSpan -> (Tree (Entry PosToken), Tree (Entry PosToken)) getSrcSpanFor forest sspan = (forest',tree) where forest' = insertSrcSpan forest sspan -- Will NO-OP if already -- there z = openZipperToSpan sspan $ Z.fromTree forest' tree = Z.tree z - +-} +{- -- --------------------------------------------------------------------- -- |Retrieve a path to the tree containing a ForestSpan from the forest, -- inserting it if not already present. -- In the case where there is a nested series of spans as in an -- 'Above' layout, return the deepest one -getSrcSpanForDeep :: Tree Entry -> ForestSpan -> (Tree Entry, Tree Entry) +getSrcSpanForDeep :: Tree (Entry PosToken) -> ForestSpan -> (Tree (Entry PosToken), Tree (Entry PosToken)) getSrcSpanForDeep forest sspan = (forest',tree) where forest' = insertSrcSpan forest sspan -- Will NO-OP if already @@ -850,7 +865,7 @@ -- |Insert a ForestSpan into the forest, if it is not there already. -- Assumes the forest was populated with the tokens containing the -- ForestSpan already -insertSrcSpan :: Tree Entry -> ForestSpan -> Tree Entry +insertSrcSpan :: Tree (Entry PosToken) -> ForestSpan -> Tree (Entry PosToken) insertSrcSpan forest sspan = forest' where z = openZipperToSpan sspan $ Z.fromTree forest @@ -884,7 +899,7 @@ else [mkTreeFromTokens endToks] subTree = tree1 ++ tree2 ++ tree3 - subTree' = filter (\t -> treeStartEnd t /= nullSpan) subTree + subTree' = filter (\t -> treeStartEnd t /= nullForestSpan) subTree -- (Entry sspan2 _ _) = Z.label z sspan2 = case Z.label z of (Entry ss _ _) -> ss @@ -919,8 +934,8 @@ -- --------------------------------------------------------------------- doSplitTree :: - Tree Entry -> ForestSpan - -> ([Tree Entry], [Tree Entry], [Tree Entry]) + Tree (Entry PosToken) -> ForestSpan + -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) doSplitTree tree@(Node (Deleted _ss _ _) []) sspan = splitSubToks tree sspan -- ++AZ+ What is correct? doSplitTree tree@(Node (Entry _ss _ _toks) []) sspan = splitSubToks tree sspan doSplitTree tree sspan = (b'',m'',e'') @@ -957,7 +972,7 @@ -- --------------------------------------------------------------------- -- TODO: The Bool is horrible -mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree Entry] +mkTreeListFromTokens :: [PosToken] -> ForestSpan -> Bool -> [Tree (Entry PosToken)] mkTreeListFromTokens [] _sspan _ = [] mkTreeListFromTokens toks sspan useOriginalSpan = res where @@ -977,9 +992,9 @@ -- --------------------------------------------------------------------- splitSubToks :: - Tree Entry + Tree (Entry PosToken) -> (ForestPos, ForestPos) - -> ([Tree Entry], [Tree Entry], [Tree Entry]) + -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) splitSubToks n@(Node (Deleted (treeStart,treeEnd) _pg _eg) []) (sspanStart,sspanEnd) = (b',m',e') where egs = (0,0) -- TODO: calculate this @@ -1008,7 +1023,7 @@ (True, False) -> (b'',m'',e'') -- Start only -- error $ "splitSubToks:StartOnly:(sspan,tree,(b'',m''))=" ++ (show (sspan,tree,(b'',m''))) where - (_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullPos,sspanStart)) toks + (_,toksb,toksm) = splitToks (forestSpanToSimpPos (nullForestPos,sspanStart)) toks -- b'' = if (emptyList toksb) then [] else [Node (Entry (treeStart, sspanEnd) toksb) []] b'' = if (emptyList toksb || nonCommentSpan toksb == ((0,0),(0,0))) then [] @@ -1037,7 +1052,7 @@ (False,True) -> (b'',m'',e'') -- End only where - (_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullPos,sspanEnd)) toks + (_,toksm,tokse) = splitToks (forestSpanToSimpPos (nullForestPos,sspanEnd)) toks b'' = [] m'' = let -- If the last span is changed, make sure it stays -- as it was @@ -1078,8 +1093,8 @@ -- srcspan, the part that is wholly included in the srcspan and the -- part the lies outside of it at the end. splitSubtree :: - Tree Entry -> ForestSpan - -> ([Tree Entry], [Tree Entry], [Tree Entry]) + Tree (Entry PosToken) -> ForestSpan + -> ([Tree (Entry PosToken)], [Tree (Entry PosToken)], [Tree (Entry PosToken)]) splitSubtree tree sspan = (before,middle,end) -- error $ "splitSubtree:(sspan,tree,middle',end')=" ++ (show (sspan,tree,middle',end')) where @@ -1096,12 +1111,12 @@ (middle,end) = (reverse middler,reverse endr) - +-} -- --------------------------------------------------------------------- - +{- -- | Removes a ForestSpan and its tokens from the forest. -removeSrcSpan :: Tree Entry -> ForestSpan - -> (Tree Entry,Tree Entry) -- ^Updated forest, removed span +removeSrcSpan :: Tree (Entry PosToken) -> ForestSpan + -> (Tree (Entry PosToken),Tree (Entry PosToken)) -- ^Updated forest, removed span removeSrcSpan forest sspan = (forest'', delTree) where forest' = insertSrcSpan forest sspan -- Make sure span is actually @@ -1120,13 +1135,13 @@ delTree = Z.tree z -- forest'' = error $ "removeSrcSpan: forest'=" ++ drawTreeCompact forest' - +-} -- --------------------------------------------------------------------- - +{- -- |For a span about to be deleted, calculate the gap between the end -- of the span being deleted and the start of the next one, at a token -- level. -calcPriorAndEndGap :: Tree Entry -> ForestSpan -> (SimpPos,SimpPos) +calcPriorAndEndGap :: Tree (Entry PosToken) -> ForestSpan -> (SimpPos,SimpPos) calcPriorAndEndGap tree sspan = (pg,eg) where ((spanStartRow,spanStartCol),(spanRow,spanCol)) = forestSpanToSimpPos sspan @@ -1174,7 +1189,7 @@ -- |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 (Entry PosToken) -> ForestSpan -> SimpPos calcEndGap tree sspan = gap where (_sspanStart,(spanRow,spanCol)) = forestSpanToSimpPos sspan @@ -1202,24 +1217,24 @@ gap = (tokRow - spanRow, tokCol - spanCol) -- gap = error $ "calcEndGap: (sspan,(before,middle,after))=" ++ (show (sspan,(_before,middle,after))) - +-} -- --------------------------------------------------------------------- - +{- -- |Retrieve all the tokens at the leaves of the tree, in order. -- Marked tokens are re-aligned, and gaps are closed. -retrieveTokensFinal :: Tree Entry -> [PosToken] +retrieveTokensFinal :: Tree (Entry PosToken) -> [PosToken] retrieveTokensFinal forest = monotonicLineToks $ stripForestLines $ reAlignMarked $ deleteGapsToks $ retrieveTokens' forest -- --------------------------------------------------------------------- -- TODO: deprecated, doing this at the Ppr level now -adjustLinesForDeleted :: Tree Entry -> Tree Entry +adjustLinesForDeleted :: Tree (Entry PosToken) -> Tree (Entry PosToken) adjustLinesForDeleted forest = forest' where (_,forest') = go (0,0) forest - go :: (Int,Int) -> Tree Entry -> ((Int,Int),Tree Entry) + go :: (Int,Int) -> Tree (Entry PosToken) -> ((Int,Int),Tree (Entry PosToken)) go (ro,co) (n@(Node (Entry _ss _lay _toks) [])) = ((ro,co),applyOffsetToTreeShallow (ro,co) n) go (ro,co) (n@(Node (Deleted _ _ (gr,_gc)) _nullSubs)) = ((ro-gr,co),n) go (ro,co) (n@(Node (Entry _ss _lay []) _subs)) = ((ro',co'),Node (Entry ss lay []) subs') @@ -1236,7 +1251,7 @@ -- --------------------------------------------------------------------- -applyOffsetToTreeShallow :: (Int,Int) -> Tree Entry -> Tree Entry +applyOffsetToTreeShallow :: (Int,Int) -> Tree (Entry PosToken) -> Tree (Entry PosToken) applyOffsetToTreeShallow (ro,co) (Node (Entry sspan lay toks) subs) = (Node (Entry sspan' lay toks') subs') where @@ -1244,31 +1259,31 @@ toks' = addOffsetToToks (ro,co) toks subs' = subs applyOffsetToTreeShallow _ n@(Node (Deleted _ _ _) _) = n - +-} -- --------------------------------------------------------------------- - +{- -- |Retrieve all the tokens at the leaves of the tree, in order. No -- adjustments are made to address gaps or re-alignment of the tokens -retrieveTokensInterim :: Tree Entry -> [PosToken] +retrieveTokensInterim :: Tree (Entry PosToken) -> [PosToken] retrieveTokensInterim forest = monotonicLineToks $ stripForestLines {- reAlignMarked -} $ concat $ map (\t -> F.foldl accum [] t) [forest] where - accum :: [PosToken] -> Entry -> [PosToken] + accum :: [PosToken] -> (Entry PosToken) -> [PosToken] accum acc (Entry _ _ []) = acc accum acc (Entry _ _ toks) = acc ++ toks accum acc (Deleted _ _ _) = acc -retrieveTokens' :: Tree Entry -> [Entry] +retrieveTokens' :: Tree (Entry PosToken) -> [Entry PosToken] retrieveTokens' forest = mergeDeletes $ concat $ map (\t -> F.foldl accum [] t) [forest] where - accum :: [Entry] -> Entry -> [Entry] + accum :: [Entry PosToken] -> Entry PosToken -> [Entry PosToken] accum acc (Entry _ _ []) = acc accum acc e@(Entry _ _ _toks) = acc ++ [e] accum acc e@(Deleted _ _ _) = acc ++ [e] -- |Merge adjacent Deleted entries -mergeDeletes :: [Entry] -> [Entry] +mergeDeletes :: [Entry PosToken] -> [Entry PosToken] mergeDeletes [] = [] mergeDeletes [x] = [x] mergeDeletes ((Deleted ss1 pg1 (r1,_)):(Deleted ss2 _ (r2,c2)):xs) = (Deleted ss pg1 o):xs @@ -1278,14 +1293,14 @@ ss = (start,end) o = (r1+r2,c2) mergeDeletes (x:xs) = x:mergeDeletes xs - +-} -- --------------------------------------------------------------------- -- | Process the leaf nodes of a tree to remove all deleted spans -deleteGapsToks :: [Entry] -> [PosToken] +deleteGapsToks :: [Entry PosToken] -> [PosToken] deleteGapsToks toks = goDeleteGapsToks (0,0) toks -goDeleteGapsToks :: SimpPos -> [Entry] -> [PosToken] +goDeleteGapsToks :: SimpPos -> [Entry PosToken] -> [PosToken] goDeleteGapsToks _ [] = [] goDeleteGapsToks offset [Entry _ _ t] = map (increaseSrcSpan offset) t goDeleteGapsToks _ [Deleted _ _ _] = [] @@ -1306,11 +1321,11 @@ t1' = map (increaseSrcSpan (fr,fc)) t1 -- --------------------------------------------------------------------- - +{- -- |Starting from a point in the zipper, retrieve all tokens backwards -- until the line changes for a non-comment/non-empty token or -- beginning of file. -retrievePrevLineToks :: Z.TreePos Z.Full Entry -> ReversedToks +retrievePrevLineToks :: Z.TreePos Z.Full (Entry PosToken) -> ReversedToks retrievePrevLineToks z = RT res' -- error $ "retrievePrevLineToks:done notWhite=" ++ (show (done notWhite)) -- ++AZ++ where -- Assuming the zipper has been opened to the span we care about, @@ -1324,7 +1339,7 @@ res' = reverse $ concat $ reverse (prevToks : (go z)) -- TODO: ++AZ++ what is this actually doing? - go :: Z.TreePos Z.Full Entry -> [[PosToken]] + go :: Z.TreePos Z.Full (Entry PosToken) -> [[PosToken]] go zz | not (Z.isRoot zz) = toks : (go $ gfromJust "retrievePrevLineToks" (Z.parent zz)) | otherwise = [toks] @@ -1332,27 +1347,27 @@ toks = concat $ reverse $ map retrieveTokensInterim $ Z.before zz -- toks = concat $ map retrieveTokensInterim $ Z.before zz - +-} -- --------------------------------------------------------------------- - +{- stripForestLines :: [PosToken] -> [PosToken] stripForestLines toks = map doOne toks where doOne (GHC.L l t,s) = (GHC.L l' t,s) where - ((ForestLine _ _ _ ls,_),(_,_)) = srcSpanToForestSpan l + ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l - +-} -- --------------------------------------------------------------------- stripForestLineFromGhc :: GHC.SrcSpan -> GHC.SrcSpan stripForestLineFromGhc l = l' where - ((ForestLine _ _ _ ls,_),(_,_)) = srcSpanToForestSpan l + ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l -- --------------------------------------------------------------------- - +{- reAlignMarked :: [PosToken] -> [PosToken] reAlignMarked toks = concatMap alignOne $ groupTokensByLine toks where @@ -1409,24 +1424,24 @@ l2' = GHC.mkRealSrcSpan (GHC.mkRealSrcLoc fname sr sc) (GHC.mkRealSrcLoc fname er ec) tok2' = ((GHC.L (GHC.RealSrcSpan l2') t2),s2) - +-} -- --------------------------------------------------------------------- - +{- -- |Add a new SrcSpan and Tokens after a given one in the token stream -- and forest. This will be given a unique SrcSpan in return, which -- specifically indexes into the forest. addNewSrcSpanAndToksAfter :: - Tree Entry -- ^The forest to update + Tree (Entry PosToken) -- ^The forest to update -> GHC.SrcSpan -- ^The new span comes after this one -> GHC.SrcSpan -- ^Existing span for the tokens -> Positioning -> [PosToken] -- ^The new tokens belonging to the new SrcSpan - -> (Tree Entry -- Updated forest with the new span + -> (Tree (Entry PosToken) -- Updated forest with the new span , GHC.SrcSpan) -- ^Unique SrcSpan allocated in the forest to -- identify this span in its position addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks = (forest'',newSpan') where - (forest',tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) + (forest',tree) = getSrcSpanForDeep forest (ghcSrcSpanToForestSpan oldSpan) (ghcl,_c) = getGhcLoc newSpan (ForestLine ch tr v l) = ghcLineToForestLine ghcl @@ -1434,22 +1449,22 @@ toks' = placeToksForSpan forest' oldSpan tree pos toks - newNode = Node (Entry (srcSpanToForestSpan newSpan') NoChange toks') [] + newNode = Node (Entry (ghcSrcSpanToForestSpan newSpan') NoChange toks') [] forest'' = insertNodeAfter tree newNode forest' -- --------------------------------------------------------------------- placeToksForSpan :: - Tree Entry + Tree (Entry PosToken) -> GHC.SrcSpan - -> Tree Entry + -> Tree (Entry PosToken) -> Positioning -> [PosToken] -> [PosToken] placeToksForSpan forest oldSpan tree pos toks = toks' where - z = openZipperToSpanDeep (srcSpanToForestSpan oldSpan) $ Z.fromTree forest + z = openZipperToSpanDeep (ghcSrcSpanToForestSpan oldSpan) $ Z.fromTree forest prevToks = case (retrievePrevLineToks z) of RT [] -> reverseToks $ retrieveTokensInterim tree xs -> xs @@ -1464,15 +1479,15 @@ -- |Add new tokens after the given SrcSpan, constructing a new SrcSpan -- in the process addToksAfterSrcSpan :: - Tree Entry -- ^TokenTree to be modified + Tree (Entry PosToken) -- ^TokenTree to be modified -> GHC.SrcSpan -- ^Preceding location for new tokens -> Positioning -> [PosToken] -- ^New tokens to be added - -> (Tree Entry, GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for + -> (Tree (Entry PosToken), GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for -- the new tokens in the TokenTree addToksAfterSrcSpan forest oldSpan pos toks = (forest',newSpan') where - (fwithspan,tree) = getSrcSpanForDeep forest (srcSpanToForestSpan oldSpan) + (fwithspan,tree) = getSrcSpanForDeep forest (ghcSrcSpanToForestSpan oldSpan) toks'' = placeToksForSpan fwithspan oldSpan tree pos toks @@ -1481,13 +1496,13 @@ newSpan = posToSrcSpan forest (startPos,endPos) (forest',newSpan') = addNewSrcSpanAndToksAfter forest oldSpan newSpan pos toks - +-} -- --------------------------------------------------------------------- - +{- limitPrevToks :: ReversedToks -> GHC.SrcSpan -> ReversedToks limitPrevToks prevToks sspan = reverseToks prevToks'' where - ((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = srcSpanToForestSpan sspan + ((ForestLine _ _ _ startRow,_startCol),(ForestLine _ _ _ endRow,_)) = ghcSrcSpanToForestSpan sspan -- Make sure the toks do not extend past where we are prevToks' = dropWhile (\t -> tokenRow t > endRow) $ unReverseToks prevToks @@ -1495,28 +1510,28 @@ -- Only use the toks for the given oldspan -- prevToks'' = dropWhile (\t -> tokenPos t < (startRow,startCol)) prevToks' prevToks'' = dropWhile (\t -> tokenRow t < startRow) prevToks' - +-} -- --------------------------------------------------------------------- -- |Add new tokens belonging to an AST fragment after a given SrcSpan, -- and re-sync the AST fragment to match the new location addDeclToksAfterSrcSpan :: (SYB.Data t) => - Tree Entry -- ^TokenTree to be modified + Tree (Entry PosToken) -- ^TokenTree to be modified -> GHC.SrcSpan -- ^Preceding location for new tokens -> Positioning -> [PosToken] -- ^New tokens to be added -> GHC.Located t -- ^Declaration the tokens belong to, to be synced - -> (Tree Entry, GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for - -- -> (Tree Entry, GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for + -> (Tree (Entry PosToken), GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for + -- -> (Tree (Entry PosToken), GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for -- the new tokens in the TokenTree, and -- updated AST element -addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest'',newSpan,t') +addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest',(s2ss newSpan),t') where - (forest',newSpan) = addToksAfterSrcSpan forest oldSpan pos toks - (t',forest'') = syncAST t newSpan forest' + (forest',newSpan) = addToksAfterSrcSpan forest (ss2s oldSpan) pos toks + t' = syncAST t (sf newSpan) -- --------------------------------------------------------------------- - +{- reIndentToks :: Positioning -> [PosToken] -> [PosToken] -> [PosToken] reIndentToks _ _ [] = [] @@ -1583,9 +1598,9 @@ toks'' = if endNewlines > 0 then toks' ++ [(newLinesToken (endNewlines - 1) $ glast "reIndentToks.3" toks')] else toks' - +-} -- --------------------------------------------------------------------- - +{- -- |Extract the start and end position of a span, without any leading -- or trailing comments nonCommentSpan :: [PosToken] -> (SimpPos,SimpPos) @@ -1599,12 +1614,12 @@ where startTok = ghead "nonCommentSpan.1" $ dropWhile isIgnoredNonComment $ toks endTok = ghead "nonCommentSpan.2" $ dropWhile isIgnoredNonComment $ reverse toks - +-} -- --------------------------------------------------------------------- -- |Convert a simple (start,end) position to a SrcSpan belonging to -- the file in the tree -posToSrcSpan :: Tree Entry -> (SimpPos,SimpPos) -> GHC.SrcSpan +posToSrcSpan :: Tree (Entry PosToken) -> (SimpPos,SimpPos) -> GHC.SrcSpan posToSrcSpan forest ((rs,cs),(re,ce)) = sspan where (GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest -- ++AZ++ Ouch, performance?? @@ -1636,10 +1651,10 @@ -- --------------------------------------------------------------------- - +{- -- |Insert a new node after the designated one in the tree insertNodeAfter - :: Tree Entry -> Tree Entry -> Tree Entry -> Tree Entry + :: Tree (Entry PosToken) -> Tree (Entry PosToken) -> Tree (Entry PosToken) -> Tree (Entry PosToken) insertNodeAfter oldNode newNode forest = forest' where zf = openZipperToNodeDeep oldNode $ Z.fromTree forest @@ -1655,15 +1670,15 @@ tp' = tp { subForest = subForest' } forest' = Z.toTree $ Z.setTree tp' zp - +-} -- --------------------------------------------------------------------- - +{- -- |Open a zipper so that its focus is the given node -- NOTE: the node must already be in the tree openZipperToNode - :: Tree Entry - -> Z.TreePos Z.Full Entry - -> Z.TreePos Z.Full Entry + :: Tree (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToNode (Node (Entry sspan _ _) _) z = openZipperToSpan sspan z openZipperToNode (Node (Deleted sspan _ _) _) z @@ -1672,9 +1687,9 @@ -- |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 + :: Tree (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToNodeDeep (Node (Entry sspan _ _) _) z = openZipperToSpanDeep sspan z openZipperToNodeDeep (Node (Deleted sspan _ _) _) z @@ -1686,9 +1701,9 @@ where go acc Nothing = acc go acc (Just zz) = go (acc ++ [zz]) (Z.next zz) - +-} -- --------------------------------------------------------------------- - +{- -- |Does the first span contain the second? Takes cognisance of the -- various flags a ForestSpan can have. -- NOTE: This function relies on the Eq instance for ForestLine @@ -1700,16 +1715,16 @@ (nvs,_nve) = forestSpanVersions $ span2 (startPos,endPos) = insertVersionsInForestSpan tvs tvs span1 (nodeStart,nodeEnd) = insertVersionsInForestSpan nvs nvs span2 - +-} -- --------------------------------------------------------------------- - +{- -- |Open a zipper so that its focus has the given SrcSpan in its -- subtree, or the location where the SrcSpan should go, if it is not -- in the tree openZipperToSpan :: ForestSpan - -> Z.TreePos Z.Full Entry - -> Z.TreePos Z.Full Entry + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToSpan sspan z | hasVersions = openZipperToSpanAdded sspan z | otherwise = openZipperToSpanOrig sspan z @@ -1725,8 +1740,8 @@ -- in the tree openZipperToSpanOrig :: ForestSpan - -> Z.TreePos Z.Full Entry - -> Z.TreePos Z.Full Entry + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToSpanOrig sspan z = if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z) then z @@ -1780,8 +1795,8 @@ -- return that instead openZipperToSpanDeep :: ForestSpan - -> Z.TreePos Z.Full Entry - -> Z.TreePos Z.Full Entry + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToSpanDeep sspan z = zf where z' = openZipperToSpan sspan z @@ -1801,8 +1816,8 @@ -- thus does not necessarily fall in the logical hierarchy of the tree openZipperToSpanAdded :: ForestSpan - -> Z.TreePos Z.Full Entry - -> Z.TreePos Z.Full Entry + -> Z.TreePos Z.Full (Entry PosToken) + -> Z.TreePos Z.Full (Entry PosToken) openZipperToSpanAdded sspan z = zf where treeAsList = getTreeSpansAsList $ Z.tree z @@ -1824,10 +1839,10 @@ -- --------------------------------------------------------------------- -getTreeSpansAsList :: Tree Entry -> [(Int,ForestSpan)] +getTreeSpansAsList :: Tree (Entry PosToken) -> [(Int,ForestSpan)] getTreeSpansAsList = getTreeSpansAsList' 0 -getTreeSpansAsList' :: Int -> Tree Entry -> [(Int,ForestSpan)] +getTreeSpansAsList' :: Int -> Tree (Entry PosToken) -> [(Int,ForestSpan)] getTreeSpansAsList' level (Node (Deleted sspan _pg _eg ) _ ) = [(level,sspan)] getTreeSpansAsList' level (Node (Entry sspan _lay _toks) ts0) = (level,sspan) : (concatMap (getTreeSpansAsList' (level + 1)) ts0) @@ -1838,8 +1853,8 @@ -- |Split a forest of trees into a (begin,middle,end) according to a -- ForestSpan, such that no tokens are included in begin or end belonging -- to the ForestSpan, and all of middle has some part of the ForestSpan -splitForestOnSpan :: Forest Entry -> ForestSpan - -> ([Tree Entry],[Tree Entry],[Tree Entry]) +splitForestOnSpan :: Forest (Entry PosToken) -> ForestSpan + -> ([Tree (Entry PosToken)],[Tree (Entry PosToken)],[Tree (Entry PosToken)]) splitForestOnSpan forest sspan = (beginTrees,middleTrees,endTrees) where (spanStart,spanEnd) = sspan @@ -1858,11 +1873,11 @@ - +-} -- --------------------------------------------------------------------- - +{- -- |Utility function to either return True or throw an error to report the problem -invariantOk :: Tree Entry -> Bool +invariantOk :: Tree (Entry PosToken) -> Bool invariantOk forest = ok where inv = invariant forest @@ -1879,20 +1894,20 @@ -- 2b. The subForest is in SrcSpan order -- 3. A given SrcSpan can only appear (or be included) in a single tree of the forest. -- 4. The parent link for all sub-trees does exist, and actually points to the parent. --- 5. There are no nullSpan entries in the tree +-- 5. There are no nullForestSpan entries in the tree -- NOTE: the tokens may extend before or after the SrcSpan, due to comments only -- NOTE2: this will have to be revisited when edits to the tokens are made -invariant :: Tree Entry -> [String] +invariant :: Tree (Entry PosToken) -> [String] invariant forest = rsub where rsub = F.foldl checkOneTree [] [forest] - checkOneTree :: [String] -> Tree Entry -> [String] + checkOneTree :: [String] -> Tree (Entry PosToken) -> [String] checkOneTree acc tree = acc ++ r where r = checkNode [] tree - checkNode :: [String] -> Tree Entry -> [String] + checkNode :: [String] -> Tree (Entry PosToken) -> [String] checkNode _acc (Node (Deleted _sspan _ _) []) = [] checkNode _acc node@(Node (Deleted _sspan _ _) _sub) = ["FAIL: deleted node with subtree: " ++ (prettyshow node)] @@ -1906,7 +1921,7 @@ rinc = checkInclusion node - rnull = if (sspan == nullSpan) + rnull = if (sspan == nullForestSpan) then ["FAIL: null SrcSpan in tree: " ++ (prettyshow node)] else [] @@ -1938,7 +1953,7 @@ rseq = checkSequence node subs - checkSequence :: Tree Entry -> [ForestSpan] -> [String] + checkSequence :: Tree (Entry PosToken) -> [ForestSpan] -> [String] checkSequence _ [] = [] checkSequence _ [_x] = [] checkSequence node' ((_s1,e1):s@(s2,_e2):ss) @@ -1969,15 +1984,17 @@ False _ -> before -} - +-} -- --------------------------------------------------------------------- +{- moved to haskell-token-utils -- |Get the start and end position of a Tree --- treeStartEnd :: Tree Entry -> (SimpPos,SimpPos) +-- treeStartEnd :: Tree (Entry PosToken) -> (SimpPos,SimpPos) -- treeStartEnd (Node (Entry sspan _) _) = (getGhcLoc sspan,getGhcLocEnd sspan) -treeStartEnd :: Tree Entry -> ForestSpan +treeStartEnd :: Tree (Entry PosToken) -> ForestSpan treeStartEnd (Node (Entry sspan _ _) _) = sspan treeStartEnd (Node (Deleted sspan _ _) _) = sspan +-} -- |Get the start and end position of a SrcSpan -- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos) @@ -1992,7 +2009,7 @@ -- showForest :: Forest Entry -> String showForest forest = map (showSubTree 0) forest where - -- showSubTree :: Int -> Tree Entry -> String + -- showSubTree :: Int -> Tree (Entry PosToken) -> String showSubTree indent tree@(Node (Entry sspan toks mp) sub) = (take indent (repeat ' ')) ++ (show (getGhcLoc sspan, getGhcLocEnd sspan)) ++ " " @@ -2000,40 +2017,40 @@ [] -> showSubTree (indent+2) sub _ -> "toks") -} - -showForest :: [Tree Entry] -> [String] +{- +showForest :: [Tree (Entry PosToken)] -> [String] showForest forest = map showTree forest -- --------------------------------------------------------------------- -- |Call drawTreeEntry on the entire token cache -drawTokenCache :: TokenCache -> String +drawTokenCache :: TokenCache PosToken -> String drawTokenCache tk = Map.foldlWithKey' doOne "" (tkCache tk) where - doOne :: String -> TreeId -> Tree Entry -> String + doOne :: String -> TreeId -> Tree (Entry PosToken) -> String doOne s key val = s ++ "tree " ++ (show key) ++ ":\n" ++ (drawTreeEntry val) -- --------------------------------------------------------------------- -- |Call drawTreeEntry on the entire token cache -drawTokenCacheDetailed :: TokenCache -> String +drawTokenCacheDetailed :: TokenCache PosToken -> String drawTokenCacheDetailed tk = Map.foldlWithKey' doOne "" (tkCache tk) where - doOne :: String -> TreeId -> Tree Entry -> String + doOne :: String -> TreeId -> Tree (Entry PosToken) -> String doOne s key val = s ++ "tree " ++ (show key) ++ ":\n" ++ (show val) -- --------------------------------------------------------------------- -- | Neat 2-dimensional drawing of a tree. -drawTreeEntry :: Tree Entry -> String +drawTreeEntry :: Tree (Entry PosToken) -> String drawTreeEntry = unlines . drawEntry -- | Neat 2-dimensional drawing of a forest. -drawForestEntry :: Forest Entry -> String +drawForestEntry :: Forest (Entry PosToken) -> String drawForestEntry = unlines . map drawTreeEntry -drawEntry :: Tree Entry -> [String] +drawEntry :: Tree (Entry PosToken) -> [String] drawEntry (Node (Deleted sspan _pg eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"] drawEntry (Node (Entry sspan lay _toks) ts0) = ((showForestSpan sspan) ++ (showLayout lay)): drawSubTrees ts0 where @@ -2052,21 +2069,21 @@ -- --------------------------------------------------------------------- -drawTreeCompact :: Tree Entry -> String +drawTreeCompact :: Tree (Entry PosToken) -> String drawTreeCompact = unlines . drawTreeCompact' 0 -drawTreeCompact' :: Int -> Tree Entry -> [String] +drawTreeCompact' :: Int -> Tree (Entry PosToken) -> [String] drawTreeCompact' level (Node (Deleted sspan _pg eg ) _ ) = [(show level) ++ ":" ++ (showForestSpan sspan) ++ (show eg) ++ "D"] drawTreeCompact' level (Node (Entry sspan lay _toks) ts0) = ((show level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay)) : (concatMap (drawTreeCompact' (level + 1)) ts0) - +-} -- --------------------------------------------------------------------- - -showTree :: Tree Entry -> String +{- +showTree :: Tree (Entry PosToken) -> String showTree = prettyshow -- |Represent a tree in a more concise/pretty way -prettyshow :: Tree Entry -> String +prettyshow :: Tree (Entry PosToken) -> String prettyshow (Node (Deleted sspan _pg eg) _nullSubs) = "Node (Deleted " ++ (showForestSpan sspan) ++ " " ++ (show eg) ++ ")" prettyshow (Node (Entry sspan _lay toks) sub) @@ -2080,12 +2097,12 @@ prettyToks toks@[_x] = showToks toks prettyToks toks@[_t1,_t2] = showToks toks prettyToks toks = showToks [ghead "prettyToks" toks] ++ ".." ++ showToks [last toks] - +-} -- --------------------------------------------------------------------- - +{- -- |Make a tree representing a particular set of tokens -mkTreeFromTokens :: [PosToken] -> Tree Entry -mkTreeFromTokens [] = Node (Entry nullSpan NoChange []) [] +mkTreeFromTokens :: [PosToken] -> Tree (Entry PosToken) +mkTreeFromTokens [] = Node (Entry nullForestSpan NoChange []) [] mkTreeFromTokens toks = Node (Entry sspan NoChange toks) [] where (startLoc',endLoc') = nonCommentSpan toks @@ -2096,9 +2113,9 @@ -- --------------------------------------------------------------------- -- |Make a tree representing a particular set of tokens -mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree Entry +mkTreeFromSpanTokens :: ForestSpan -> [PosToken] -> Tree (Entry PosToken) mkTreeFromSpanTokens sspan toks = Node (Entry sspan NoChange toks) [] - +-} -- --------------------------------------------------------------------- ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) @@ -2111,13 +2128,11 @@ -- TODO: Should this indent the tokens as well? syncAST :: (SYB.Data t) => GHC.Located t -- ^The AST (or fragment) - -> GHC.SrcSpan -- ^The SrcSpan created in the Tree Entry - -> Tree Entry -- ^Existing token tree - -> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens -syncAST ast@(GHC.L l _t) sspan forest = (GHC.L sspan xx,forest') + -> ForestSpan -- ^The SrcSpan created in the Tree (Entry PosToken) + -> (GHC.Located t) -- ^Updated AST and tokens +syncAST ast@(GHC.L l _t) fspan = GHC.L sspan xx where - forest' = forest - + sspan = f2ss fspan (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan @@ -2126,7 +2141,7 @@ -- TODO: take cognizance of the ForestLines encoded in srcspans -- when calculating the offsets etc - syncSpan s = addOffsetToSpan (rowOffset,colOffset) s + syncSpan s = addOffsetToSrcSpan (rowOffset,colOffset) s (GHC.L _s xx) = everywhereStaged SYB.Renamer ( SYB.mkT hsbindlr @@ -2149,20 +2164,20 @@ lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name -- --------------------------------------------------------------------- - +{- -- | indent the tree and tokens by the given offset, and sync the AST -- to the tree too. indentDeclToks :: (SYB.Data t) => GHC.Located t -- ^The AST (or fragment) - -> Tree Entry -- ^Existing token tree + -> Tree (Entry PosToken) -- ^Existing token tree -> Int -- ^ (signed) number of columns to indent/dedent - -> (GHC.Located t, Tree Entry) -- ^Updated AST and tokens + -> (GHC.Located t, Tree (Entry PosToken)) -- ^Updated AST and tokens indentDeclToks decl@(GHC.L sspan _) forest offset = (decl',forest'') where -- make sure the span is in the forest - (forest',tree) = getSrcSpanFor forest (srcSpanToForestSpan sspan) + (forest',tree) = getSrcSpanFor forest (ghcSrcSpanToForestSpan sspan) - z = openZipperToSpan (srcSpanToForestSpan sspan) $ Z.fromTree forest' + z = openZipperToSpan (ghcSrcSpanToForestSpan sspan) $ Z.fromTree forest' tree' = go tree -- The invariant will fail if we do not propagate this change @@ -2188,7 +2203,7 @@ Just z'' -> Z.toTree (Z.setTree (markLenChanged $ Z.tree z'') z'') - (decl',_) = syncAST decl (addOffsetToSpan off sspan) tree + decl' = syncAST decl (addOffsetToSpan off sspan) tree off = (0,offset) @@ -2197,20 +2212,20 @@ go (Node (Entry ss lay []) sub) = (Node (Entry (addOffsetToForestSpan off ss) lay []) (map go sub)) go (Node (Entry ss lay toks) []) = (Node (Entry (addOffsetToForestSpan off ss) lay (addOffsetToToks off toks)) []) go n = error $ "indentDeclToks:strange node:" ++ (show n) - +-} -- --------------------------------------------------------------------- - +{- addOffsetToForestSpan :: (Int,Int) -> ForestSpan -> ForestSpan addOffsetToForestSpan (lineOffset,colOffset) fspan = fspan' where ((ForestLine sch str sv sl,sc),(ForestLine ech etr ev el,ec)) = fspan fspan' = ((ForestLine sch str sv (sl+lineOffset),sc+colOffset), (ForestLine ech etr ev (el+lineOffset),ec+colOffset)) - +-} -- --------------------------------------------------------------------- -addOffsetToSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan -addOffsetToSpan (lineOffset,colOffset) sspan = sspan' +addOffsetToSrcSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan +addOffsetToSrcSpan (lineOffset,colOffset) sspan = sspan' where sspan' = case sspan of GHC.RealSrcSpan ss -> @@ -2231,20 +2246,29 @@ showSrcSpanF :: GHC.SrcSpan -> String showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce)) where - ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = srcSpanToForestSpan sspan + ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = ghcSrcSpanToForestSpan sspan -- chsn = if chs then 1 else 0 -- chen = if che then 1 else 0 -- --------------------------------------------------------------------- -sf :: GHC.SrcSpan -> ForestSpan -sf = srcSpanToForestSpan +ss2f :: GHC.SrcSpan -> ForestSpan +ss2f = ghcSrcSpanToForestSpan -fs :: ForestSpan -> GHC.SrcSpan -fs = forestSpanToSrcSpan +f2ss :: ForestSpan -> GHC.SrcSpan +f2ss = forestSpanToGhcSrcSpan +ss2s :: GHC.SrcSpan -> Span +ss2s ss = Span (getGhcLoc ss) (getGhcLocEnd ss) +s2ss :: Span -> GHC.SrcSpan +s2ss (Span (sr,sc) (er,ec)) = GHC.mkSrcSpan locStart locEnd + where + fname = GHC.mkFastString "foo" + locStart = GHC.mkSrcLoc fname sr sc + locEnd = GHC.mkSrcLoc fname er ec +{- -- | ForestSpan version of GHC combineSrcSpans combineSpans :: ForestSpan -> ForestSpan -> ForestSpan combineSpans fs1 fs2 = fs' @@ -2254,6 +2278,6 @@ ((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)) - +-} -- 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 @@ -6,6 +6,7 @@ -- module Language.Haskell.Refact.Utils.TokenUtilsTypes( +{- -- * The cache of trees comprising the manipulated tokens TokenCache(..) , TreeId(..) @@ -21,16 +22,15 @@ , ForestLine(..) , ForestPos , ForestSpan - , PprOrigin(..) +-} + PprOrigin(..) , Ppr(..) -- , HDoc(..) ) where -import Language.Haskell.Refact.Utils.TypeSyn -import Data.Tree -import qualified Data.Map as Map +import Language.Haskell.TokenUtils.Types -import Outputable +-- import Outputable -- --------------------------------------------------------------------- @@ -69,6 +69,7 @@ -} +{- -- 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 @@ -82,12 +83,14 @@ -- 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 @@ -97,14 +100,16 @@ -- start of the next item. | NoChange deriving (Show,Eq) - +-} +{- data EndOffset = None | SameLine ColOffset | FromAlignCol (RowOffset, ColOffset) deriving (Show,Eq) +-} -- --------------------------------------------------------------------- - +{- data ForestLine = ForestLine { flSpanLengthChanged :: !Bool -- ^The length of the -- span may have @@ -114,7 +119,8 @@ , flInsertVersion :: !Int , flLine :: !Int } -- deriving (Eq) - +-} +{- instance Eq ForestLine where -- TODO: make this undefined, and patch all broken code to use the -- specific fun here directly instead. @@ -129,29 +135,32 @@ instance Outputable ForestLine where ppr fl = text (show fl) +-} -- --------------------------------------------------------------------- - +{- type ForestPos = (ForestLine,Int) -- |Match a SrcSpan, using a ForestLine as the marker type ForestSpan = (ForestPos,ForestPos) - +-} -- --------------------------------------------------------------------- +{- data TreeId = TId !Int deriving (Eq,Ord,Show) -- |Identifies the tree carrying the main tokens, not any work in -- progress or deleted ones mainTid :: TreeId mainTid = TId 0 - +-} +{- data TokenCache = TK { tkCache :: !(Map.Map TreeId (Tree Entry)) , tkLastTreeId :: !TreeId } - +-} -- --------------------------------------------------------------------- data PprOrigin = Original -- ^ Original tokens diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -21,7 +21,7 @@ -- type InScopes=((Relations.Rel Names.QName (Ents.Ent PosName.Id))) type InScopes = [GHC.Name] -type SimpPos = (Int,Int) -- Line, column +-- type SimpPos = (Int,Int) -- Line, column -- Additions for GHC type PosToken = (GHC.Located GHC.Token, String) @@ -58,36 +58,42 @@ instance GHC.Outputable (GHC.MatchGroup GHC.Name) where ppr (GHC.MatchGroup ms _ptctyp) = GHC.text "MatchGroup" GHC.<+> GHC.ppr ms + instance GHC.Outputable (GHC.Match GHC.Name) where ppr (GHC.Match pats mtyp grhs) = GHC.text "Match" GHC.<+> GHC.ppr pats GHC.<+> GHC.ppr mtyp GHC.<+> GHC.ppr grhs + instance GHC.Outputable (GHC.GRHSs GHC.Name) where ppr (GHC.GRHSs grhss binds) = GHC.text "GRHSs" GHC.<+> GHC.ppr grhss GHC.<+> GHC.ppr binds + instance GHC.Outputable (GHC.GRHS GHC.Name) where ppr (GHC.GRHS guards rhs) = GHC.text "GRHS" GHC.<+> GHC.ppr guards GHC.<+> GHC.ppr rhs + instance GHC.Outputable (GHC.HsTupArg GHC.Name) where ppr (GHC.Present e) = GHC.text "Present" GHC.<+> GHC.ppr e ppr (GHC.Missing _typ) = GHC.text "Missing" + instance GHC.Outputable (GHC.ConDeclField GHC.Name) where ppr (GHC.ConDeclField name typ doc) = GHC.text "ConDeclField" GHC.<+> GHC.ppr name GHC.<+> GHC.ppr typ GHC.<+> GHC.ppr doc + -- --------------------------------------------------------------------- type HsModuleP = GHC.Located (GHC.HsModule GHC.RdrName) -- --------------------------------------------------------------------- -- Putting these here for the time being, to avoid import loops - +{- ghead :: String -> [a] -> a ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h @@ -103,5 +109,5 @@ gfromJust :: [Char] -> Maybe a -> a gfromJust _info (Just h) = h gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" - +-} -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -142,20 +142,23 @@ -- , lookupNameGhc ) where -import Exception +import Control.Monad.IO.Class () import Control.Monad.State import Data.Char import Data.List import Data.Maybe import Data.Monoid +import Exception import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific 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.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Types +import Language.Haskell.TokenUtils.Utils -- Modules from GHC import qualified Bag as GHC @@ -176,7 +179,7 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB -import Data.Generics.Strafunski.StrategyLib.StrategyLib +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) -- --------------------------------------------------------------------- @@ -4303,7 +4306,7 @@ l' = case l of GHC.RealSrcSpan ss -> let - ((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l + ((ForestLine _ _ _ startRow,startCol),_) = ghcSrcSpanToForestSpan l locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol) diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -32,9 +32,7 @@ import Control.Monad.State import Data.List import Data.Maybe --- import Data.Monoid 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 @@ -44,6 +42,9 @@ import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.TypeSyn import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.TokenUtils.DualTree +import Language.Haskell.TokenUtils.TokenUtils +import Language.Haskell.TokenUtils.Utils import System.Directory import System.FilePath.Posix @@ -241,7 +242,7 @@ -- | 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), ([Ppr],[PosToken], GHC.RenamedSource)) -type ApplyRefacResult = ((FilePath, Bool), ([Line],[PosToken], GHC.RenamedSource)) +type ApplyRefacResult = ((FilePath, Bool), ([Line PosToken],[PosToken], GHC.RenamedSource)) -- | Manage a whole refactor session. Initialise the monad, load the @@ -314,7 +315,8 @@ res <- refac -- Run the refactoring, updating the state as required mod' <- getRefactRenamed - toks' <- fetchToksFinal + -- toks' <- fetchToksFinal + let toks' = [] -- pprVal <- fetchPprFinal linesVal <- fetchLinesFinal m <- getRefactStreamModified