haskell-token-utils (empty) → 0.0.0.1
raw patch · 14 files changed
+4993/−0 lines, 14 filesdep +Diffdep +HUnitdep +QuickChecksetup-changed
Dependencies added: Diff, HUnit, QuickCheck, base, containers, directory, dual-tree, ghc, ghc-mod, ghc-paths, ghc-prim, ghc-syb-utils, haskell-src-exts, hspec, kure, monoid-extras, mtl, pretty, rosezipper, semigroups, syb
Files
- LICENSE +24/−0
- README.md +7/−0
- Setup.hs +2/−0
- haskell-token-utils.cabal +108/−0
- src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs +2201/−0
- src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs +678/−0
- src/Language/Haskell/TokenUtils/API.hs +17/−0
- src/Language/Haskell/TokenUtils/DualTree.hs +541/−0
- src/Language/Haskell/TokenUtils/Layout.hs +30/−0
- src/Language/Haskell/TokenUtils/Pretty.hs +129/−0
- src/Language/Haskell/TokenUtils/TokenUtils.hs +268/−0
- src/Language/Haskell/TokenUtils/Types.hs +441/−0
- src/Language/Haskell/TokenUtils/Utils.hs +540/−0
- test/Spec.hs +7/−0
+ LICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org>
+ README.md view
@@ -0,0 +1,7 @@+haskell-token-utils+===================++Utilities to tie up tokens to an AST++[](https://travis-ci.org/alanz/haskell-token-utils)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-token-utils.cabal view
@@ -0,0 +1,108 @@+name: haskell-token-utils+version: 0.0.0.1+synopsis: Utilities to tie up tokens to an AST+description: This library is currently experimental.+ .+ The GHC part is solid, since it has been migrated from HaRe.+ .+ The haskell-src-exts one is still in progress+ .+ This package provides a set of data structures to+ manage the tie-up between a Haskell AST and the+ underlying tokens, such that it explicitly+ captures the Haskell layout rules and original+ formatting. As a result changes can be made to+ the AST and the tokens will be updated so that+ the source file can be recreated with only the+ updated parts changed. This makes it easier to+ write Haskell source code modification+ programmes.+homepage: https://github.com/alanz/haskell-token-utils+bug-reports: https://github.com/alanz/haskell-token-utils/issues+license: PublicDomain+license-file: LICENSE+author: Alan Zimmerman+maintainer: alan.zimm@gmail.com+-- copyright: +category: Development+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Language.Haskell.TokenUtils.API+ , Language.Haskell.TokenUtils.DualTree+ , Language.Haskell.TokenUtils.Layout+ , Language.Haskell.TokenUtils.Pretty+ , Language.Haskell.TokenUtils.TokenUtils+ , Language.Haskell.TokenUtils.Types+ , Language.Haskell.TokenUtils.Utils+ -- to be moved into its own library when published+ , Language.Haskell.TokenUtils.GHC.Layout+ , Language.Haskell.TokenUtils.HSE.Layout+ -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <4.7+ , containers+ , dual-tree+ , semigroups+ , monoid-extras+ , mtl+ , pretty+ , rosezipper++ -- for GHC, until split out+ , ghc+ , ghc-syb-utils+ , syb++ -- for HSE, until split out+ , haskell-src-exts+ hs-source-dirs: src+ , src-ghc+ , src-hse+ default-language: Haskell2010+++test-suite spec+ type:+ exitcode-stdio-1.0+ ghc-options:+ main-is:+ Spec.hs+ Hs-Source-Dirs:+ src, test, src-ghc, src-hse+ default-language: Haskell2010+ build-depends:+ base >= 4.0 && < 4.7+ , Diff >= 0.3.0+ , HUnit+ , QuickCheck >= 2.5+ , containers+ , directory+ , hspec+ , rosezipper++ , dual-tree+ , semigroups+ , monoid-extras+ , mtl+ , pretty+ -- experimentation+ , kure+ , syb++ -- For testing the GHC version+ , ghc+ , ghc-paths+ , ghc-prim+ , ghc-syb-utils+ , ghc-mod >= 4.1.0++ -- For testing the haskell-src-exts one+ , haskell-src-exts >= 1.15++source-repository head+ type: git+ location: https://github.com/alanz/haskell-token-utils.git+
+ src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs view
@@ -0,0 +1,2201 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# Language MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+--++module Language.Haskell.TokenUtils.GHC.Layout (+ initTokenLayout+ -- , nullTokenLayout+ , ghcAllocTokens+ , retrieveTokens+ , getLoc+ , nullSrcSpan++ -- * For testing+ , addEndOffsets+ ) where++import qualified Bag as GHC+import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified ForeignCall as GHC+import qualified GHC as GHC+import qualified Lexer as GHC+import qualified Outputable as GHC+import qualified SrcLoc as GHC++import Outputable++import qualified GHC.SYB.Utils as SYB++import Control.Exception+import Data.List+import Data.Tree++import Language.Haskell.TokenUtils.DualTree+import Language.Haskell.TokenUtils.Layout+import Language.Haskell.TokenUtils.TokenUtils+import Language.Haskell.TokenUtils.Types+import Language.Haskell.TokenUtils.Utils++-- 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++-- ---------------------------------------------------------------------++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++-}++-- ---------------------------------------------------------------------++instance GHC.Outputable (Line GhcPosToken) 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"++instance GHC.Outputable (LayoutTree GhcPosToken) where+ ppr (Node e sub) = GHC.hang (GHC.text "Node") 2+ (GHC.vcat [GHC.ppr e,GHC.ppr sub])+++instance GHC.Outputable (Entry GhcPosToken) where+ ppr (Entry ffs l toks) = GHC.text "Entry" GHC.<+> GHC.ppr ffs+ GHC.<+> GHC.ppr l+ GHC.<+> GHC.text (show toks)+ ppr (Deleted ffs ro pos) = GHC.text "Deleted" GHC.<+> GHC.ppr ffs+ GHC.<+> GHC.ppr ro+ GHC.<+> GHC.ppr pos++instance GHC.Outputable ForestLine where+ ppr (ForestLine lc sel v l) = GHC.parens $ GHC.text "ForestLine"+ GHC.<+> GHC.ppr lc GHC.<+> GHC.int sel+ GHC.<+> GHC.int v GHC.<+> GHC.int l++instance GHC.Outputable Layout where+ ppr (Above bo pos1 pos2 eo) = GHC.text "Above"+ GHC.<+> GHC.ppr bo+ GHC.<+> GHC.ppr pos1+ GHC.<+> GHC.ppr pos2+ GHC.<+> GHC.ppr eo+ ppr NoChange = GHC.text "NoChange"++instance GHC.Outputable GHC.Token where+ ppr t = GHC.text (show t)++instance GHC.Outputable EndOffset where+ ppr None = GHC.text "None"+ ppr (SameLine co) = GHC.text "SameLine"+ GHC.<+> GHC.ppr co+ ppr (FromAlignCol pos) = GHC.text "FromAlignCol"+ GHC.<+> GHC.ppr pos++-- ---------------------------------------------------------------------+initTokenLayout :: GHC.ParsedSource -> [GhcPosToken] -> LayoutTree GhcPosToken+initTokenLayout parsed toks = (allocTokens parsed toks)++{-+nullTokenLayout :: TokenLayout+-- nullTokenLayout = TL (Leaf nullSrcSpan NoChange [])+nullTokenLayout = TL (Node (Entry (sf nullSrcSpan) NoChange []) [])+-}+-- ---------------------------------------------------------------------++-- TODO: bring in startEndLocIncComments'+ghcAllocTokens :: GHC.ParsedSource-> [GhcPosToken] -> LayoutTree GhcPosToken+ghcAllocTokens (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 (g2s 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++-- ---------------------------------------------------------------------++type GhcPosToken = (GHC.Located GHC.Token, String)++-- ---------------------------------------------------------------------++allocDecls :: [GHC.LHsDecl GHC.RdrName] -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocDecls decls toks = r+ where+ (declLayout,tailToks) = foldl' doOne ([],toks) decls++ r = strip $ declLayout ++ (makeLeafFromToks tailToks)++ doOne :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 (g2s 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 (g2s 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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+allocWarningD (acc,toks) (GHC.L _l (GHC.WarningD _)) = (acc,toks)+allocWarningD _ x = error $ "allocWarningD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocAnnD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+allocAnnD (acc,toks) (GHC.L _l (GHC.AnnD _)) = (acc,toks)+allocAnnD _ x = error $ "allocAnnD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocRuleD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+allocRuleD (acc,toks) (GHC.L _l (GHC.RuleD _)) = (acc,toks)+allocRuleD _ x = error $ "allocRuleD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocVectD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+allocVectD (acc,toks) (GHC.L _l (GHC.VectD _)) = (acc,toks)+allocVectD _ x = error $ "allocVectD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocSpliceD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+-- allocDocD (acc,toks) d@(GHC.L l (GHC.DocD _))+-- = error "allocDocD undefined"+allocDocD _ x = error $ "allocDocD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocQuasiQuoteD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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] -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocMatches matches toksIn = allocList matches toksIn doOne+ where+ doOne :: GHC.LMatch GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]+ 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocPat (GHC.L _ _) toks = makeLeafFromToks toks++-- ---------------------------------------------------------------------++allocRhs :: GHC.LGRHS GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 GhcPosToken],[GhcPosToken])+ -> ([GHC.LStmt GHC.RdrName],[GHC.RdrName]) -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 GhcPosToken],[GhcPosToken]) -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocExpr (GHC.L l (GHC.HsVar _)) toks = [makeLeaf (g2s l) NoChange toks]+allocExpr (GHC.L l (GHC.HsLit _)) toks = [makeLeaf (g2s l) NoChange toks]+allocExpr (GHC.L l (GHC.HsOverLit _)) toks = [makeLeaf (g2s 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 = (ghcTokenRow firstMatchTok,ghcTokenCol firstMatchTok)+ (ro,co) = case (filter isOf s2) of+ [] -> (0,0)+ (x:_) -> (ghcTokenRow firstMatchTok - ghcTokenRow x,+ ghcTokenCol firstMatchTok - (ghcTokenCol 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 (g2s 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 = (ghcTokenRow firstBindTok,ghcTokenCol firstBindTok)+ (ro,co) = case (filter isDo doToks) of+ [] -> (0,0)+ (x:_) -> (ghcTokenRow firstBindTok - ghcTokenRow x,+ ghcTokenCol firstBindTok - (ghcTokenCol 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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) -> [GhcPosToken]+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 = (ghcTokenRow firstBindTok,ghcTokenCol firstBindTok)+ (ro,co) = case (filter isWhereOrLet s1) of+ [] -> (0,0)+ (x:_) -> (ghcTokenRow firstBindTok - ghcTokenRow x,+ ghcTokenCol firstBindTok - (ghcTokenCol 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++-- ---------------------------------------------------------------------++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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocBind (GHC.L l (GHC.FunBind (GHC.L ln _) _ (GHC.MatchGroup matches _) _ _ _)) toks = r+ where+ (nameLayout,toks1) = ((makeLeafFromToks s1)++[makeLeaf (g2s 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 (g2s 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 (g2s 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+#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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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] -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocTupArgList tas toksIn = r+ where+ go :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> [GHC.HsTupArg GHC.RdrName] -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocLocated (GHC.L l _) toks = r+ where+ (s1,toks1,s2) = splitToksIncComments (ghcSpanStartEnd l) toks+ r = strip $ (makeLeafFromToks s1) ++ [makeLeaf (g2s l) NoChange toks1] ++ (makeLeafFromToks s2)++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocTyVarBndrs :: GHC.LHsTyVarBndrs GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+#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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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] -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+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 -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocLBangType bt toks = allocType bt toks++-- ---------------------------------------------------------------------++allocHsKind :: GHC.LHsKind GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocHsKind = error "allocHsKind undefined"++-- ---------------------------------------------------------------------++#if __GLASGOW_HASKELL__ > 704+allocCType :: GHC.CType -> [GhcPosToken] -> [LayoutTree GhcPosToken]+#endif+allocCType = error "allocCType undefined"++-- ---------------------------------------------------------------------++allocHsContext :: GHC.HsContext GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocHsContext ts toks = r+ where+ r = allocList ts toks allocType++-- ---------------------------------------------------------------------++-- TODO: get rid of this in favour of mix stuf+allocInterleavedLists :: [GHC.Located a] -> [GHC.Located b] -> [GhcPosToken]+ -> (GHC.Located a -> [GhcPosToken] -> [LayoutTree GhcPosToken])+ -> (GHC.Located b -> [GhcPosToken] -> [LayoutTree GhcPosToken])+ -> [LayoutTree GhcPosToken]+allocInterleavedLists axs bxs toksIn allocFuncA allocFuncB = r+ where+ -- go :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> [GHC.Located a] -> [GHC.Located b] -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])+ 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 -> [GhcPosToken] -> [LayoutTree GhcPosToken])+ -> (GHC.Located a -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken]))+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 -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken]))+ -> [(SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))]+makeMixedListEntry xs f = map (\x@(GHC.L l _) -> (fst $ ghcSpanStartEnd l,f x)) xs++allocMixedList ::+ [(SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))]+ -> [GhcPosToken] -> [LayoutTree GhcPosToken]+allocMixedList xs toksIn = r+ where+ xs' = sortBy (\(p1,_) (p2,_) -> compare p1 p2) xs+ (layout,toksFin) = foldl' doOne ([],toksIn) xs'++ doOne :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> (SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))+ -> ([LayoutTree GhcPosToken],[GhcPosToken])+ doOne (acc,toks) (_,f) = (acc++lay,toks')+ where+ (lay,toks') = f toks++ r = strip $ layout ++ (makeLeafFromToks toksFin)++-- ---------------------------------------------------------------------+{-+retrieveTokens :: LayoutTree -> [a]+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+-}+-- ---------------------------------------------------------------------++-- | gets the (row,col) of the start of the @GHC.SrcSpan@, or (-1,-1)+-- if there is an @GHC.UnhelpfulSpan@+getGhcLoc :: GHC.SrcSpan -> (Int, Int)+getGhcLoc (GHC.RealSrcSpan ss) = (GHC.srcSpanStartLine ss, GHC.srcSpanStartCol ss)+getGhcLoc (GHC.UnhelpfulSpan _) = (-1,-1)++-- | gets the (row,col) of the end of the @GHC.SrcSpan@, or (-1,-1)+-- if there is an @GHC.UnhelpfulSpan@+getGhcLocEnd :: GHC.SrcSpan -> (Int, Int)+getGhcLocEnd (GHC.RealSrcSpan ss) = (GHC.srcSpanEndLine ss, GHC.srcSpanEndCol ss)+getGhcLocEnd (GHC.UnhelpfulSpan _) = (-1,-1)++getLocatedStart :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)+getLocatedStart (GHC.L l _) = getGhcLoc l++getLocatedEnd :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)+getLocatedEnd (GHC.L l _) = getGhcLocEnd l++-- ---------------------------------------------------------------------++ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int))+ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan)++-- ---------------------------------------------------------------------++--Some functions for fetching a specific field of a token+ghcTokenCol :: GhcPosToken -> Int+ghcTokenCol (GHC.L l _,_) = c where (_,c) = getGhcLoc l++ghcTokenColEnd :: GhcPosToken -> Int+ghcTokenColEnd (GHC.L l _,_) = c where (_,c) = getGhcLocEnd l++ghcTokenRow :: GhcPosToken -> Int+ghcTokenRow (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+++-- ---------------------------------------------------------------------++-- |Show a GHC API structure+showGhc :: (GHC.Outputable a) => a -> String+#if __GLASGOW_HASKELL__ > 704+showGhc x = GHC.showSDoc GHC.tracingDynFlags $ GHC.ppr x+#else+showGhc x = GHC.showSDoc $ GHC.ppr x+#endif++ghcIsEmpty :: GhcPosToken -> Bool+ghcIsEmpty ((GHC.L _ (GHC.ITsemi)), "") = True+ghcIsEmpty ((GHC.L _ (GHC.ITvocurly)), "") = True+ghcIsEmpty ((GHC.L _ _), "") = True+ghcIsEmpty _ = False++-- ---------------------------------------------------------------------++nullSrcSpan :: GHC.SrcSpan+nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan"++g2s :: GHC.SrcSpan -> Span+g2s ss = Span (GHC.srcSpanStartLine ss',GHC.srcSpanStartCol ss')+ (GHC.srcSpanEndLine ss', GHC.srcSpanEndCol ss')+ where ss' = case ss of+ GHC.RealSrcSpan sp -> sp+ GHC.UnhelpfulSpan str -> error $ "g2 got UnhelpfulSpan" ++ (GHC.unpackFS str)+++s2g :: Span -> GHC.SrcSpan+s2g (Span (sr,sc) (er,ec)) = sp+ where+ filename = (GHC.mkFastString "f")+ sp = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec)+++-- ---------------------------------------------------------------------++instance Allocatable GHC.ParsedSource GhcPosToken where+ allocTokens = ghcAllocTokens++instance (IsToken (GHC.Located GHC.Token, String)) where+ getSpan = ghcGetSpan+ putSpan (lt,s) ns = (ghcPutSpan lt ns,s)++ tokenLen = ghcTokenLen++ isComment = ghcIsComment+ isEmpty = ghcIsEmpty+ isDo = ghcIsDo+ isElse = ghcIsElse+ isIn = ghcIsIn+ isLet = ghcIsLet+ isOf = ghcIsOf+ isThen = ghcIsThen+ isWhere = ghcIsWhere++ tokenToString (_,s) = s+ showTokenStream = GHC.showRichTokenStream++instance (HasLoc (GHC.Located a)) where+ getLoc (GHC.L l _) = start where Span start end = g2s l+ getLocEnd (GHC.L l _) = end where Span start end = g2s l+++-- showToks :: [PosToken] -> String+showToks toks = show $ map (\(t@(GHC.L _ tok),s) ->+ ((getLocatedStart t, getLocatedEnd t),tok,s)) toks++instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where+ show t@(GHC.L _l tok) = show ((getLocatedStart t, getLocatedEnd t),tok)++-- ---------------------------------------------------------------------++ghcGetSpan :: GhcPosToken -> Span+ghcGetSpan (GHC.L l _,_) = g2s l++ghcPutSpan :: (GHC.Located a) -> Span -> (GHC.Located a)+ghcPutSpan (GHC.L _l x) s = (GHC.L l' x)+ where+ l' = s2g s++-- ---------------------------------------------------------------------+-- This section is horrible because there is no Eq instance for+-- GHC.Token++ghcIsWhere :: GhcPosToken -> Bool+ghcIsWhere ((GHC.L _ t),_s) = case t of+ GHC.ITwhere -> True+ _ -> False+ghcIsLet :: GhcPosToken -> Bool+ghcIsLet ((GHC.L _ t),_s) = case t of+ GHC.ITlet -> True+ _ -> False++ghcIsElse :: GhcPosToken -> Bool+ghcIsElse ((GHC.L _ t),_s) = case t of+ GHC.ITelse -> True+ _ -> False++ghcIsThen :: GhcPosToken -> Bool+ghcIsThen ((GHC.L _ t),_s) = case t of+ GHC.ITthen -> True+ _ -> False++ghcIsOf :: GhcPosToken -> Bool+ghcIsOf ((GHC.L _ t),_s) = case t of+ GHC.ITof -> True+ _ -> False++ghcIsDo :: GhcPosToken -> Bool+ghcIsDo ((GHC.L _ t),_s) = case t of+ GHC.ITdo -> True+ _ -> False++ghcIsIn :: GhcPosToken -> Bool+ghcIsIn ((GHC.L _ t),_s) = case t of+ GHC.ITin -> True+ _ -> False++ghcIsComment :: GhcPosToken -> Bool+ghcIsComment ((GHC.L _ (GHC.ITdocCommentNext _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocCommentPrev _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocCommentNamed _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocSection _ _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocOptions _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocOptionsOld _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITlineComment _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITblockComment _)),_s) = True+ghcIsComment ((GHC.L _ _),_s) = False+++-- ---------------------------------------------------------------------+{-+isWhiteSpace :: GhcPosToken -> Bool+isWhiteSpace tok = isComment tok || isEmpty tok++notWhiteSpace :: GhcPosToken -> Bool+notWhiteSpace tok = not (isWhiteSpace tok)++isWhiteSpaceOrIgnored :: GhcPosToken -> Bool+isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok++-- Tokens that are ignored when allocating tokens to a SrcSpan+isIgnored :: GhcPosToken -> 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 :: GhcPosToken -> Bool+isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok+-}+++ghcTokenLen (_,s) = length s++
+ src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs view
@@ -0,0 +1,678 @@+{-# Language MultiParamTypeClasses #-}+{-# Language FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+module Language.Haskell.TokenUtils.HSE.Layout+ (+ loadFile+ , loadFileWithMode+ , templateHaskellMode+ , TuToken(..)+ ) where++-- import Control.Exception+import Data.Generics hiding (GT)+import Data.List+import Data.Monoid+import Data.Tree++import Language.Haskell.Exts.Annotated++import Language.Haskell.TokenUtils.Types+import Language.Haskell.TokenUtils.Utils++-- import SrcExtsKure++import Debug.Trace++-- ---------------------------------------------------------------------++-- parseFileContentsWithComments :: ParseMode -> String -> ParseResult (Module, [Comment])++-- Parse a source file from a string using a custom parse mode and retaining comments. ++data TuToken = T Token | C Comment+ deriving (Show,Eq)++loadFile :: FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))+loadFile file = loadFileWithMode defaultParseMode file++templateHaskellMode :: ParseMode+templateHaskellMode+ = defaultParseMode { extensions = (EnableExtension TemplateHaskell):(extensions defaultParseMode)}++loadFileWithMode :: ParseMode -> FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))+loadFileWithMode parseMode file = do+ src <- readFile file+ let mtoks = lexTokenStream src+ let res = case parseFileContentsWithComments parseMode src of+ ParseOk (modu,comments) -> case mtoks of+ ParseOk toks -> ParseOk (modu,comments,toks)+ ParseFailed l s -> ParseFailed l s+ ParseFailed l s -> ParseFailed l s+ case res of+ ParseOk (m, comments,toks) -> return $ ParseOk (m, (mergeToksAndComments toks comments))+ ParseFailed l s -> return (ParseFailed l s)+++-- ---------------------------------------------------------------------++mergeToksAndComments :: [Loc Token] -> [Comment] -> [Loc TuToken]+mergeToksAndComments toks comments = go toks comments+ where+ tokToTu (Loc l t) = Loc l (T t)+ commentToTu c@(Comment _ l _) = Loc l (C c)++ go :: [Loc Token] -> [Comment] -> [Loc TuToken]+ go ts [] = map tokToTu ts+ go [] cs = map commentToTu cs+ go (ht:ts) (hc@(Comment _ l _):cs)+ = if loc ht < l+ then tokToTu ht : go ts (hc:cs)+ else commentToTu hc : go (ht:ts) cs++-- tf :: IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))+-- tf = loadFile "../test/testdata/Layout/LetExpr.hs"++-- ---------------------------------------------------------------------++instance IsToken (Loc TuToken) where+ getSpan a = ss2s $ loc a+ putSpan (Loc _ss v) s = Loc (s2ss s) v++ tokenLen (Loc l (T t)) = hseTokenLen (Loc l t)+ tokenLen (Loc _l (C (Comment _ _ s))) = length s -- beware of newlines++ isComment (Loc _ (C _)) = True+ isComment _ = False++ -- No empty tokens in HSE+ isEmpty _ = False++ isDo (Loc _ (T KW_Do)) = True+ isDo (Loc _ (T KW_MDo)) = True+ isDo _ = False++ isElse (Loc _ (T KW_Else)) = True+ isElse _ = False++ isIn (Loc _ (T KW_In)) = True+ isIn _ = False++ isLet (Loc _ (T KW_Let)) = True+ isLet _ = False++ isOf (Loc _ (T KW_Of)) = True+ isOf _ = False++ isThen (Loc _ (T KW_Then)) = True+ isThen _ = False++ isWhere (Loc _ (T KW_Where)) = True+ isWhere _ = False++ tokenToString = hseTokenToString+ showTokenStream = hseShowTokenStream++ss2s :: SrcSpan -> Span+ss2s (SrcSpan _fn sr sc er ec) = Span (sr,sc) (er,ec)++s2ss :: Span -> SrcSpan+s2ss (Span (sr,sc) (er,ec)) = (SrcSpan "<unknown>" sr sc er ec)+++-- |Return the length of the token, using the string representation+-- where possible as it may have changed during a refactoing.+hseTokenLen :: Loc Token -> Int+hseTokenLen (Loc _ t) = length (showToken' t)++hseTokenToString :: Loc TuToken -> String+hseTokenToString (Loc _ (C (Comment True _ s))) = "{-" ++ s ++ "-}"+hseTokenToString (Loc _ (C (Comment False _ s))) = "--" ++ s+hseTokenToString (Loc _ (T tok)) = showToken' tok+++{-+data Comment++ A Haskell comment. The Bool is True if the comment is multi-line, i.e. {- -}.++ Constructors+ Comment Bool SrcSpan String+-}++hseShowTokenStream :: [Loc TuToken] -> String+hseShowTokenStream ts2 = (go startLoc ts2 "") ++ "\n"+ where startLoc = (1,1)+ go _ [] = id+ go (locLine,locCol) (tok@(Loc ss _):ts1)+ = case ss of+ SrcSpan _ tokLine tokCol er ec+ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)+ . (str ++)+ . go tokEnd ts1+ | otherwise -> ((replicate (tokLine - locLine) '\n') ++)+ . ((replicate (tokCol - 1) ' ') ++)+ . (str ++)+ . go tokEnd ts1+ where tokEnd = (er,ec)+ str = tokenToString tok+++-- ---------------------------------------------------------------------++-- This function is copied here from haskell-src-exts+-- module Language.Haskell.Exts.InternalLexer until issue+-- https://github.com/haskell-suite/haskell-src-exts/issues/119 is+-- resolved++------------------------------------------------------------------+-- "Pretty" printing for tokens++showToken' :: Token -> String+showToken' t = case t of+ VarId s -> s+ QVarId (q,s) -> q ++ '.':s+ IDupVarId s -> '?':s+ ILinVarId s -> '%':s+ ConId s -> s+ QConId (q,s) -> q ++ '.':s+ DVarId ss -> concat $ intersperse "-" ss+ VarSym s -> s+ ConSym s -> s+ QVarSym (q,s) -> q ++ '.':s+ QConSym (q,s) -> q ++ '.':s+ IntTok (_, s) -> s+ FloatTok (_, s) -> s+ Character (_, s) -> '\'':s ++ "'"+ StringTok (_, s) -> '"':s ++ "\""+ IntTokHash (_, s) -> s ++ "#"+ WordTokHash (_, s) -> s ++ "##"+ FloatTokHash (_, s) -> s ++ "#"+ DoubleTokHash (_, s) -> s ++ "##"+ CharacterHash (_, s) -> '\'':s ++ "'#"+ StringHash (_, s) -> '"':s ++ "\"#"+ LeftParen -> "("+ RightParen -> ")"+ LeftHashParen -> "(#"+ RightHashParen -> "#)"+ SemiColon -> ";"+ LeftCurly -> "{"+ RightCurly -> "}"+ VRightCurly -> "virtual }"+ LeftSquare -> "["+ RightSquare -> "]"+ Comma -> ","+ Underscore -> "_"+ BackQuote -> "`"+ Dot -> "."+ DotDot -> ".."+ Colon -> ":"+ DoubleColon -> "::"+ Equals -> "="+ Backslash -> "\\"+ Bar -> "|"+ LeftArrow -> "<-"+ RightArrow -> "->"+ At -> "@"+ Tilde -> "~"+ DoubleArrow -> "=>"+ Minus -> "-"+ Exclamation -> "!"+ Star -> "*"+ LeftArrowTail -> ">-"+ RightArrowTail -> "-<"+ LeftDblArrowTail -> ">>-"+ RightDblArrowTail -> "-<<"+ THExpQuote -> "[|"+ THPatQuote -> "[p|"+ THDecQuote -> "[d|"+ THTypQuote -> "[t|"+ THCloseQuote -> "|]"+ THIdEscape s -> '$':s+ THParenEscape -> "$("+ THVarQuote -> "'"+ THTyQuote -> "''"+ THQuasiQuote (n,q) -> "[$" ++ n ++ "|" ++ q ++ "]"+ RPGuardOpen -> "(|"+ RPGuardClose -> "|)"+ RPCAt -> "@:"+ XCodeTagOpen -> "<%"+ XCodeTagClose -> "%>"+ XStdTagOpen -> "<"+ XStdTagClose -> ">"+ XCloseTagOpen -> "</"+ XEmptyTagClose -> "/>"+ XPCDATA s -> "PCDATA " ++ s+ XRPatOpen -> "<["+ XRPatClose -> "]>"+ PragmaEnd -> "#-}"+ RULES -> "{-# RULES"+ INLINE b -> "{-# " ++ if b then "INLINE" else "NOINLINE"+ INLINE_CONLIKE -> "{-# " ++ "INLINE_CONLIKE"+ SPECIALISE -> "{-# SPECIALISE"+ SPECIALISE_INLINE b -> "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE"+ SOURCE -> "{-# SOURCE"+ DEPRECATED -> "{-# DEPRECATED"+ WARNING -> "{-# WARNING"+ SCC -> "{-# SCC"+ GENERATED -> "{-# GENERATED"+ CORE -> "{-# CORE"+ UNPACK -> "{-# UNPACK"+ OPTIONS (mt,_s) -> "{-# OPTIONS" ++ maybe "" (':':) mt ++ " ..."+-- CFILES s -> "{-# CFILES ..."+-- INCLUDE s -> "{-# INCLUDE ..."+ LANGUAGE -> "{-# LANGUAGE"+ ANN -> "{-# ANN"+ KW_As -> "as"+ KW_By -> "by"+ KW_Case -> "case"+ KW_Class -> "class"+ KW_Data -> "data"+ KW_Default -> "default"+ KW_Deriving -> "deriving"+ KW_Do -> "do"+ KW_MDo -> "mdo"+ KW_Else -> "else"+ KW_Family -> "family"+ KW_Forall -> "forall"+ KW_Group -> "group"+ KW_Hiding -> "hiding"+ KW_If -> "if"+ KW_Import -> "import"+ KW_In -> "in"+ KW_Infix -> "infix"+ KW_InfixL -> "infixl"+ KW_InfixR -> "infixr"+ KW_Instance -> "instance"+ KW_Let -> "let"+ KW_Module -> "module"+ KW_NewType -> "newtype"+ KW_Of -> "of"+ KW_Proc -> "proc"+ KW_Rec -> "rec"+ KW_Then -> "then"+ KW_Type -> "type"+ KW_Using -> "using"+ KW_Where -> "where"+ KW_Qualified -> "qualified"+ KW_Foreign -> "foreign"+ KW_Export -> "export"+ KW_Safe -> "safe"+ KW_Unsafe -> "unsafe"+ KW_Threadsafe -> "threadsafe"+ KW_Interruptible -> "interruptible"+ KW_StdCall -> "stdcall"+ KW_CCall -> "ccall"+ XChildTagOpen -> "<%>"+ KW_CPlusPlus -> "cplusplus"+ KW_DotNet -> "dotnet"+ KW_Jvm -> "jvm"+ KW_Js -> "js"+ KW_CApi -> "capi"++ EOF -> "EOF"+++-- ---------------------------------------------------------------------++-- |This instance is the purpose of this module+instance Allocatable (Module SrcSpanInfo) (Loc TuToken) where+ allocTokens = hseAllocTokens+++hseAllocTokens :: Module SrcSpanInfo -> [Loc TuToken] -> LayoutTree (Loc TuToken)+hseAllocTokens modu toks = r+ where+ ss = allocTokens' modu+ ss1 = (ghead "hseAllocTokens" ss)+ ss2 = addEndOffsets ss1 toks+ ss3 = decorate ss2 toks+ -- r = error $ "foo=" ++ show ss2+ -- r = error $ "foo=" ++ drawTreeCompact (Node nullSpan ss)+ -- r = error $ "foo=" ++ drawForestEntry ss+ -- r = error $ "foo toks=" ++ show toks+ -- r = error $ "foo modu=" ++ show modu+ r = ss3+++-- ---------------------------------------------------------------------++-- Allocate all the tokens to the given tree+decorate :: LayoutTree (Loc TuToken) -> [Loc TuToken] -> LayoutTree (Loc TuToken)+decorate tree toks = go toks tree+ where+ go :: [Loc TuToken] -> LayoutTree (Loc TuToken) -> LayoutTree (Loc TuToken)+ go ts (Node e subs) = (Node e subs'')+ where+ -- b = map (\t -> let f = treeStartEnd t in (getLoc f, getLocEnd f)) subs++ doOne :: ([Loc TuToken],[LayoutTree (Loc TuToken)]) -> LayoutTree (Loc TuToken) -> ([Loc TuToken],[LayoutTree (Loc TuToken)])+ doOne (ts1,acc) tree1 = (ts1',acc')+ where+ ss = treeStartEnd tree1+ (before,middle,after) = splitToksIncComments (getLoc ss,getLocEnd ss) ts1+ ts1' = after+ tree' = case tree1 of+ Node (Entry ss1 lo []) [] -> [Node (Entry ss1 lo middle) []]+ _ -> [go middle tree1]+ acc' = acc ++ makeLeafFromToks before ++ tree'++ (end,subs') = foldl' doOne (ts,[]) subs+ -- (end,subs') = doOne (ts,[]) (head subs)+ subs'' = subs' ++ makeLeafFromToks end++ -- go ts tr = error $ "decorate:not processing :" ++ show (ts,tr)+++-- ---------------------------------------------------------------------+{-+Notes re HSE let binds++data Exp l+ ....+ | Let l (Binds l) (Exp l) -- ^ local declarations with @let@ ... @in@ ...++instance ExactP Exp where+ exactP exp = case exp of+ .....+ Let l bs e ->+ case srcInfoPoints l of+ [a,b] -> do+ printString "let"+ exactPC bs+ printStringAt (pos b) "in"+ exactPC e+ _ -> errorEP "ExactP: Exp: Let is given wrong number of srcInfoPoints"+ ....+ Case l e alts ->+ case srcInfoPoints l of+ a:b:pts -> do+ printString "case"+ exactPC e+ printStringAt (pos b) "of"+ layoutList pts alts+ _ -> errorEP "ExactP: Exp: Case is given too few srcInfoPoints"+ Do l stmts ->+ case srcInfoPoints l of+ a:pts -> do+ printString "do"+ layoutList pts stmts+ _ -> errorEP "ExactP: Exp: Do is given too few srcInfoPoints"+ MDo l stmts ->+ case srcInfoPoints l of+ a:pts -> do+ printString "mdo"+ layoutList pts stmts+ _ -> errorEP "ExactP: Exp: Mdo is given wrong number of srcInfoPoints"++Need let/in+ where+ do+ case+-}++-- ---------------------------------------------------------------------++-- allocTokens' :: Module SrcSpanInfo -> [LayoutTree (Loc TuToken)]+allocTokens' :: Data a => a -> [LayoutTree (Loc TuToken)]+allocTokens' modu = r+ where+ start :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ start old = old++ -- r = synthesize [] redf (start `mkQ` bb+ -- NOTE: the token re-alignement needs a left-biased tree, not a right-biased one, hence synthesizel+ r = synthesizel [] redf (start `mkQ` bb+ `extQ` letExp+ `extQ` expr+ `extQ` match+ `extQ` bind+ `extQ` decl+ `extQ` stmt+ ) modu+++ -- ends up as GenericQ (SrcSpanInfo -> LayoutTree TuToken)+ bb :: SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ bb (SrcSpanInfo ss _sss) vv = [Node (Entry (sf $ ss2s ss) NoChange []) vv]++ letExp :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ letExp (Let l@(SrcSpanInfo ss _) _bs _e) vv =+ case srcInfoPoints l of+ [letPos,inPos] ->+ let+ (Span letStart _letEnd) = ss2s letPos+ (Span _inStart inEnd) = ss2s inPos+ io = FromAlignCol letStart+ (Span lstart lend) = ss2s ss+ eo = FromAlignCol inEnd+ in+ -- trace ("let:" ++ show (ss,map treeStartEnd (subTreeOnly vv)))+ [Node (Entry (sf $ ss2s ss) (Above io lstart lend eo) []) [(makeGroup vv)]]+ _ -> vv+ letExp _ vv = vv++ -- ---------------------------------++ expr :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ expr (Do l@(SrcSpanInfo _ss _) stmts) vv =+ case srcInfoPoints l of+ (doPos:_) ->+ let+ (Span doStart _doEnd) = ss2s doPos+ -- (Span _ ssEnd) = ss2s ss+ io = FromAlignCol doStart+ (Span lstart lend) = forestSpanToSrcSpan $ makeSpanFromTrees subs++ eo = None -- will be calculated later+ subs = concatMap allocTokens' stmts+ in+ -- trace ("do:" ++ show (ss,map treeStartEnd (subTreeOnly vv),srcInfoPoints l))+ [makeGroup [Node (Entry (sf $ ss2s doPos) NoChange []) [],+ Node (Entry (sf $ (Span lstart lend)) (Above io lstart lend eo) []) subs]]+ _ -> vv++ expr _ vv = vv++ -- ---------------------------------++ match :: Match SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ match (InfixMatch l@(SrcSpanInfo ss _) pat name pats rhs mWhere) vv = vv+ match (Match l@(SrcSpanInfo _ss _) fname pats rhs mWhere) _vv =+ let+ treeName = allocTokens' fname+ treePats = allocTokens' pats+ treeRhs = subTreeOnly (allocTokens' rhs)+ treeWhereClause = case mWhere of+ (Just bd@(BDecls (SrcSpanInfo _bs _) _)) -> [makeGroup (treeWhere ++ treeDecls)]+ where+ wherePos = ghead "redf.match" (srcInfoPoints l)+ treeWhere = [Node (Entry (sf $ ss2s wherePos) NoChange []) [] ]+ treeSubDecls = subTreeOnly (allocTokens' bd)+ treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]+ (Span lstart lend) = fs $ makeSpanFromTrees treeSubDecls+ (Span whereStart _whereEnd) = ss2s wherePos+ io = FromAlignCol whereStart+ Just (IPBinds l binds) -> []+ Nothing -> []+ -- (Span start end) = ss2s ss+ -- (Span start end) = ss2s bs+ eo = None -- will be calculated later FromAlignCol (0,0)+ subs = treeName ++ treePats ++ treeRhs ++ treeWhereClause++ in+ -- trace ("match:" ++ show (ss,map treeStartEnd subs))+ [makeGroup subs]+++ -- -----------------------++ bind :: Binds SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ bind (BDecls (SrcSpanInfo _ss _) bs) _vv =+ let+ -- TODO: properly calculate `so` and `eo`+ -- ro = 0+ -- co = 0+ -- so = makeOffset ro co+ -- (Span start end) = ss2s ss+ -- eo = FromAlignCol (1,-39)+ -- eo = None -- will be added later+ -- vv' = case vv of+ -- [Node (Entry fss _ _) sub] ->+ -- if fss == (sf $ ss2s ss) then sub else vv+ -- _ -> vv+ subs = concatMap allocTokens' bs++ in+ -- trace ("binds:BDecls" ++ show (ss, map treeStartEnd subs))+ [makeGroup subs]+ bind (IPBinds l@(SrcSpanInfo ss _) bs) vv = vv++ -- --------------++ decl :: Decl SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ decl (FunBind (SrcSpanInfo _ss _) matches) _vv =+ let+ subs = concatMap allocTokens' matches+ in+ -- trace ("decl:FunBind" ++ show (ss, map treeStartEnd subs))+ [makeGroup subs]++ decl (PatBind (SrcSpanInfo _ _) _ _ _ Nothing) vv = vv+ decl (PatBind l@(SrcSpanInfo _ss _) pat mtyp rhs (Just bd@(BDecls (SrcSpanInfo _bs _) _))) vv =+ case srcInfoPoints l of+ (wherePos:_) ->+ let+ treePat = allocTokens' pat+ treeType = allocTokens' mtyp+ treeRhs = allocTokens' rhs+ treeWhereClause = [makeGroup (treeWhere ++ treeDecls)]+ where+ treeWhere = [Node (Entry (sf $ ss2s wherePos) NoChange []) [] ]+ treeSubDecls = subTreeOnly (allocTokens' bd)+ treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]+ (Span lstart lend) = fs $ makeSpanFromTrees treeSubDecls+ (Span whereStart _whereEnd) = ss2s wherePos+ io = FromAlignCol whereStart+ eo = None -- will be calculated later FromAlignCol (0,0)+ subs = treePat ++ treeType ++ treeRhs ++ treeWhereClause+ in+ -- trace ("decl:patBind:" ++ show (ss))+ [makeGroup subs]++ _ -> vv++ decl _ vv = vv++ -- --------------++ stmt :: Stmt SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ stmt (LetStmt l@(SrcSpanInfo _ss _) _binds) vv =+ case srcInfoPoints l of+ (letPos:_) ->+ let+ (Span letStart _letEnd) = ss2s letPos+ io = FromAlignCol letStart+ (Span lstart lend) = fs $ makeSpanFromTrees (subTreeOnly vv)++ eo = None -- will be calculated later+ in+ -- trace ("stmt:LetStmt:" ++ show (ss,map treeStartEnd (subTreeOnly vv),srcInfoPoints l))+ [makeGroup [Node (Entry (sf $ ss2s letPos) NoChange []) [],+ makeGroupLayout (Above io lstart lend eo) (subTreeOnly vv)]]+ _ -> error $ "allocTokens'.stmt:LetStmt:missing statements:" ++ show (l,_binds)+ -- _ -> vv++ stmt _ vv = vv++ -- --------------++ mergeSubs as bs = as ++ bs++ redf :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]+ redf [] b = b+ redf a [] = a++ redf [a@(Node e1@(Entry s1 l1 []) sub1)] [b@(Node _e2@(Entry s2 l2 []) sub2)]+ =+ let+ (as,ae) = spanStartEnd $ fs $ treeStartEnd a+ (bs,be) = spanStartEnd $ fs $ treeStartEnd b+ ss = combineSpans s1 s2+ ret =+ case (compare as bs,compare ae be) of+ (EQ,EQ) -> [Node (Entry s1 (l1 <> l2) []) (sub1 ++ sub2)]++ (LT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub1 [b])] -- b is sub of a+ (GT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub2 [a])] -- a is sub of b++ (EQ,GT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [b] sub1)] -- b is sub of a+ (EQ,LT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [a] sub2)] -- a is sub of b++ (_,_) -> if ae <= bs+ then [Node e [a,b]]+ else if be <= as+ then [Node e [b,a]]+ else -- fully nested case+ [Node e1 (sub1++[b])] -- should merge subs+ where+ e = Entry ss NoChange []+ (Node (Entry _ _lr []) _) = head ret++ in+ {-+ trace (show ((compare as bs,compare ae be),(fs $ treeStartEnd a,l1,length sub1)+ ,(fs $ treeStartEnd b,l2,length sub2)+ ,(fs $ treeStartEnd (head ret),lr)))+ -}+ ret++ redf new old = error $ "bar2.redf:" ++ show (new,old)+++-- synthesize :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t+-- synthesize z o f++-- Bottom-up synthesis of a data structure;+-- 1st argument z is the initial element for the synthesis;+-- 2nd argument o is for reduction of results from subterms;+-- 3rd argument f updates the synthesised data according to the given term++-- synthesize :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t+-- synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))++-- foldr :: (b -> a -> a) -> a -> [b] -> a+-- foldl :: (a -> b -> a) -> a -> [b] -> a+++-- | Bottom-up synthesis of a data structure;+-- 1st argument z is the initial element for the synthesis;+-- 2nd argument o is for reduction of results from subterms;+-- 3rd argument f updates the synthesised data according to the given term+--+synthesizel :: s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t+synthesizel z o f x = f x (foldl o z (gmapQ (synthesizel z o f) x))++-- ---------------------------------------------------------------------++instance Monoid Layout where+ mempty = NoChange++ mappend NoChange NoChange = NoChange+ mappend NoChange x = x+ mappend x NoChange = x+ mappend (Above bo1 ps1 pe1 eo1) (Above bo2 ps2 pe2 eo2)+ = (Above bo ps pe eo)+ where+ (bo,ps) = if ps1 <= ps2 then (bo1,ps1)+ else (bo2,ps2)++ (eo,pe) = if pe1 >= pe2 then (eo1,pe1)+ else (eo2,pe2)++++-- nullSpan :: SrcSpan+-- nullSpan = (SrcSpan "" 0 0 0 0)++-- ---------------------------------------------------------------------
+ src/Language/Haskell/TokenUtils/API.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TypeFamilies #-}++module Language.Haskell.TokenUtils.API+ (+ IsToken(..)+ , HasLoc(..)+ ) where++import Language.Haskell.TokenUtils.Types++++++++
+ src/Language/Haskell/TokenUtils/DualTree.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.Haskell.TokenUtils.DualTree (+ layoutTreeToSourceTree+ , retrieveLinesFromLayoutTree+ , retrieveLines+ , renderLines+ , renderSourceTree+ , SourceTree+ , Line(..)+ , Source(..)+ , renderLinesFromLayoutTree++ -- * to enable pretty printing+ , Alignment(..)+ , Annot(..)+ , DeletedSpan(..)+ , LineOpt(..)+ , Prim(..)+ , Transformation(..)+ , Up(..)+ ) where++-- import qualified GHC as GHC+-- import qualified Outputable as GHC++import Control.Monad.State+import qualified Data.Tree as T++import Language.Haskell.TokenUtils.Types+++-- ----------+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++import Debug.Trace++-- ---------------------------------------------------------------------++data DeletedSpan = DeletedSpan Span RowOffset SimpPos+ deriving (Show,Eq)++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 a = Up Span Alignment (NE.NonEmpty (Line a)) [DeletedSpan]+ | UDeleted [DeletedSpan]+ deriving Show+++data Line a = Line Row Col RowOffset Source LineOpt [a]++data Alignment = ANone | AVertical+ deriving (Show,Eq)++instance (IsToken a) => Show (Line a) where+ show (Line r c o f s toks) = "(" ++ show r+ ++ " " ++ show c+ ++ " " ++ show o+ ++ " " ++ show f+ ++ " " ++ show s+ -- ++ " " ++ "\"" ++ showTokenStream toks ++ "\")"+ ++ " " ++ "\"" ++ showFriendlyToks 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 a = PToks [a]+ | PDeleted ForestSpan RowOffset SimpPos+ deriving Show++-- | The main data structure for this module+type SourceTree a = DUALTree Transformation (Up a) Annot (Prim a)+++instance Semigroup Span where+ (Span p1 _p2) <> (Span _q1 q2) = (Span p1 q2)++instance (IsToken a) => Semigroup (Up a) 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 a)) 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++-- ---------------------------------------------------------------------++renderLinesFromLayoutTree :: (IsToken a) => LayoutTree a -> String+renderLinesFromLayoutTree = renderLines . retrieveLinesFromLayoutTree++-- ---------------------------------------------------------------------++retrieveLinesFromLayoutTree :: (IsToken a) => LayoutTree a -> [Line a]+retrieveLinesFromLayoutTree = retrieveLines . layoutTreeToSourceTree++-- ---------------------------------------------------------------------++retrieveLines :: (IsToken a) => SourceTree a -> [Line a]+retrieveLines srcTree+ = case getU srcTree of+ Nothing -> []+ Just (Up _ss _a str _ds) -> NE.toList str+ Just (UDeleted _) -> []++-- ---------------------------------------------------------------------++renderSourceTree :: (IsToken a) => SourceTree a -> String+renderSourceTree srcTree = r+ where+ r = case getU srcTree of+ Nothing -> ""+ Just (Up _ss _a str _ds) -> renderLines $ NE.toList str+ Just (UDeleted _) -> ""++-- ---------------------------------------------------------------------++renderLines :: (IsToken a) => [Line a] -> 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 (showTokenStream 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 :: (IsToken a) => LayoutTree a -> SourceTree a++-- 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 a)] -> 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 :: (IsToken a) => ForestSpan -> [a] -> Up a+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 :: (IsToken a) => Source -> [a] -> [Line a]+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 :: (IsToken a) => Up a -> Up a -> Up a+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 u1@(Up sp1 _a1 l1 d1) u2@(Up sp2 _a2 l2 d2)+ = -- trace ("combineUps:" ++ show (u1,u2))+ (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++ -- PROBLEM: assumes c1 is final addition to the left of the line.+ -- i.e. tree must be created top down, not bottom up+ 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 -> (tokenLen t) - (tokenColEnd t - tokenCol t)) $ filter (not . isComment) s1++ st1 = showTokenStream s1+ st2 = showTokenStream (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++{-++Should end up with+ [(Line 1 1 0 SOriginal ONone \"module LayoutIn1 where\"),+ (Line 3 1 0 SOriginal ONone \"--Layout rule applies after 'where','let','do' and 'of'\"),+ (Line 5 1 0 SOriginal ONone \"--In this Example: rename 'sq' to 'square'.\"),+ (Line 7 1 0 SOriginal OGroup \"sumSquares x y= square x + square y where square x= x^pow\"),+ (Line 8 11 0 SOriginal OGroup \"--There is a comment.\"),+ (Line 9 43 0 SOriginal OGroup \"pow=2\"),+ (Line 10 1 0 SOriginal ONone \"\")]++But we are getting++ Up (Span (7,12) (9,40)) ANone (+ (7 12 0 SOriginal OGroup "x y= square x + square y where square x= x^pow") :| [+ (8 13 0 SOriginal OGroup "--There is a comment."),+ (9 45 0 SOriginal OGroup "pow=2")]) [])++From++ (Up (Span (7,12) (7,15)) ANone (+ (7 12 0 SOriginal ONone "x y") :| []) [],+ Up (Span (7,15) (9,40)) ANone (+ (7 15 0 SOriginal OGroup "= square x + square y where square x= x^pow") :| [+ (8 11 0 SOriginal OGroup "--There is a comment."),+ (9 43 0 SOriginal OGroup "pow=2")]) [])+++++-----------------------------------------------------++((((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 :: (IsToken a) => [DeletedSpan] -> NE.NonEmpty (Line a) -> NE.NonEmpty (Line a)+adjustForDeleted d1 l2 = l+ where+ deltaL = calcDelta d1+ l = NE.map go l2++ go (Line r c o SOriginal f str) = Line (r - deltaL) c o SOriginal f str+ go (Line r c o SWasAdded f str) = Line (r - deltaL) c o SWasAdded f str+ go (Line r c o SAdded f str) = Line r c o SWasAdded f str++-- -------------------------------------++calcDelta :: [DeletedSpan] -> RowOffset+calcDelta d1 = deltaL+ where+ deltaL = case d1 of+ [] -> 0+ _ -> (-1) + (sum $ map calcDelta' d1)++ calcDelta' :: DeletedSpan -> RowOffset+ calcDelta' (DeletedSpan (Span (rs,_cs) (re,_ce)) pg (rd,_cd)) = r + 1+ where+ ol = re - rs+ eg = rd+ r = (pg + ol + eg) - (max pg eg)+++-- ---------------------------------------------------------------------++mkSpan :: ForestSpan -> Span+mkSpan ss = Span s e+ where+ (s,e) = forestSpanToSimpPos ss++-- ---------------------------------------------------------------------
+ src/Language/Haskell/TokenUtils/Layout.hs view
@@ -0,0 +1,30 @@+module Language.Haskell.TokenUtils.Layout+ (+ -- allocTokens+ retrieveTokens+ ) where+++import Control.Exception+import Data.Tree++import Language.Haskell.TokenUtils.Types+-- import Language.Haskell.TokenUtils.Utils++-- ---------------------------------------------------------------------++-- allocTokens = assert False undefined++-- ---------------------------------------------------------------------++retrieveTokens :: (IsToken a) => LayoutTree a -> [a]+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++-- ---------------------------------------------------------------------+
+ src/Language/Haskell/TokenUtils/Pretty.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.Haskell.TokenUtils.Pretty+ (+ Outputable(..)+ , showPpr+ ) where++import Data.Semigroup hiding ( (<>) )++import Language.Haskell.TokenUtils.DualTree+import Language.Haskell.TokenUtils.Types++import Text.PrettyPrint++import qualified Data.List.NonEmpty as NE+import qualified Data.Tree.DUAL.Internal as I+++-- ---------------------------------------------------------------------++showPpr :: Outputable a => a -> String+showPpr a = render $ ppr a++-- ---------------------------------------------------------------------++class Outputable a where+ ppr :: a -> Doc++-- ---------------------------------------------------------------------++instance (IsToken a) => Outputable (SourceTree a) where+ ppr (I.DUALTree ot)+ = case getOption ot of+ Nothing -> text "Nothing"+ Just t -> ppr t++instance (IsToken a) =>+ Outputable (I.DUALTreeU Transformation (Up a) Annot (Prim a)) where+ ppr (I.DUALTreeU (u,t)) = parens $ ppr u <> comma $$ ppr t++instance (IsToken a) =>+ Outputable (I.DUALTreeNE Transformation (Up a) Annot (Prim a)) where+ ppr (I.Leaf u l) = parens $ hang (text "Leaf") 1 (ppr u $$ ppr l)+ ppr (I.LeafU u) = parens $ hang (text "LeafU") 1 (ppr u)+ ppr (I.Concat dts) = parens $ hang (text "Concat") 1 (ppr dts)+ ppr (I.Act d t) = parens $ hang (text "Act") 1 (ppr d $$ ppr t)+ ppr (I.Annot a t) = parens $ hang (text "Annot") 1 (ppr a $$ ppr t)++instance (IsToken a) => Outputable (Prim a) where+ ppr (PToks toks) = parens $ text "PToks" <+> text (show toks)+ ppr (PDeleted ss pg p) = parens $ text "PDeleted" <+> ppr ss+ <+> ppr pg <+> ppr p++instance Outputable Transformation where+ ppr (TAbove co bo p1 p2 eo) = parens $ text "TAbove" <+> ppr co+ <+> ppr bo+ <+> ppr p1 <+> ppr p2+ <+> ppr eo++instance Outputable EndOffset where+ ppr None = text "None"+ ppr (SameLine co) = parens $ text "SameLine" <+> ppr co+ ppr (FromAlignCol rc) = parens $ text "FromAlignCol" <+> ppr rc++instance Outputable Annot where+ ppr (Ann str) = parens $ text "Ann" <+> text str+ ppr (ADeleted ss pg p) = parens $ text "ADeleted" <+> ppr ss+ <+> ppr pg <+> ppr p+ ppr (ASubtree ss) = parens $ text "ASubtree" <+> ppr ss++instance (IsToken a) => Outputable (Up a) where+ ppr (Up ss a ls ds) = parens $ hang (text "Up") 1+ ((ppr ss <+> ppr a) $$ ppr ls $$ ppr ds)+ ppr (UDeleted d) = parens $ text "UDeleted" <+> ppr d++instance Outputable Alignment where+ ppr ANone = text "ANone"+ ppr AVertical = text "AVertical"++instance Outputable DeletedSpan where+ ppr (DeletedSpan ss ro p) = parens $ (text "DeletedSpan")+ <+> ppr ss <+> ppr ro+ <+> ppr p+++instance Outputable Span where+ ppr (Span sp ep) = parens $ text "Span" <+> ppr sp <+> ppr ep++instance (Outputable a) => Outputable (NE.NonEmpty a) where+ -- ppr (x NE.:| xs) = parens $ hang (text "NonEmpty") 1 (ppr (x:xs))+ ppr (x NE.:| xs) = (ppr (x:xs))++instance (IsToken a) => Outputable (Line a) where+ ppr (Line r c o s f str) = parens $ text "Line" <+> ppr r+ <+> ppr c <+> ppr o+ <+> ppr s <+> ppr f+ <+> text ("\"" ++ (init $ showTokenStream str) ++ "\"")+ -- <+> text ("\"" ++ (init $ showFriendlyToks str) ++ "\"")+ -- <+> text (show str) -- ++AZ++ debug++instance Outputable Source where+ ppr SOriginal = text "SOriginal"+ ppr SAdded = text "SAdded"+ ppr SWasAdded = text "SWasAdded"++instance Outputable LineOpt where+ ppr ONone = text "ONone"+ ppr OGroup = text "OGroup"++instance Outputable ForestLine where+ ppr (ForestLine lc sel v l) = parens $ text "ForestLine"+ <+> ppr lc <+> int sel+ <+> int v <+> int l++instance Outputable Bool where+ ppr True = text "True"+ ppr False = text "False"++instance Outputable Row where+ ppr r = int r++instance Outputable a => Outputable [a] where+ ppr xs = brackets (fsep (punctuate comma (map ppr xs)))++instance (Outputable a,Outputable b) => Outputable (a,b) where+ ppr (x,y) = parens (ppr x <> comma <> ppr y)++
+ src/Language/Haskell/TokenUtils/TokenUtils.hs view
@@ -0,0 +1,268 @@+module Language.Haskell.TokenUtils.TokenUtils+ (+ replaceTokenInCache+ , replaceTokenForSrcSpan+ , invariant+ ) where++import Control.Exception+import Data.List+import Data.Tree++import Language.Haskell.TokenUtils.Types+import Language.Haskell.TokenUtils.Utils++import qualified Data.Map as Map+import qualified Data.Tree.Zipper as Z++-- ---------------------------------------------------------------------++invariant :: a+invariant = assert False undefined++-- ---------------------------------------------------------------------++replaceTokenInCache :: (IsToken a) => TokenCache a -> Span -> a -> TokenCache a+replaceTokenInCache tk sspan tok = tk'+ where+ forest = getTreeFromCache sspan tk+ forest' = replaceTokenForSrcSpan forest sspan tok+ tk' = replaceTreeInCache sspan forest' tk++-- ---------------------------------------------------------------------++getTreeFromCache :: (IsToken a) => Span -> TokenCache a -> Tree (Entry a)+getTreeFromCache sspan tk = (tkCache tk) Map.! tid+ where+ tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan++-- ---------------------------------------------------------------------++replaceTreeInCache :: (IsToken a) => Span -> Tree (Entry a) -> TokenCache a -> TokenCache a+replaceTreeInCache sspan tree tk = tk'+ where+ tid = treeIdFromForestSpan $ srcSpanToForestSpan sspan+ -- tree' = treeIdIntoTree tid tree+ tree' = putTidInTree tid tree+ tk' = tk {tkCache = Map.insert tid tree' (tkCache tk) }++putTidInTree :: (IsToken a) => TreeId -> Tree (Entry a) -> Tree (Entry a)+putTidInTree tid (Node (Deleted fspan pg eg) subs) = (Node (Deleted fs' pg eg) subs)+ where fs' = treeIdIntoForestSpan tid fspan+putTidInTree tid (Node (Entry fspan lay toks) subs) = tree'+ where+ subs' = map (putTidInTree tid) subs+ fs' = treeIdIntoForestSpan tid fspan+ tree' = Node (Entry fs' lay toks) subs'++-- ---------------------------------------------------------------------++-- |Replace a single token in a token tree, without changing the+-- structure of the tree+-- NOTE: the GHC.SrcSpan may have been used to select the appropriate+-- forest in the first place, and is required to select the correct+-- span in the tree, due to the ForestLine annotations that may be present++-- TODO: work at the token level, not the sspan level+-- TODO: Use start of token span only, with length 1.+replaceTokenForSrcSpan :: (IsToken a) => Tree (Entry a) -> Span -> a -> Tree (Entry a)+replaceTokenForSrcSpan forest sspan tok = forest'+ where+ -- (GHC.L tl _,_) = tok+ tl = getSpan tok+ -- First open to the sspan, making use of any Forestline annotations+ z = openZipperToSpanDeep (srcSpanToForestSpan sspan) $ Z.fromTree forest++ -- Then drill down to the specific subtree containing the token+ -- z' = openZipperToSpan (srcSpanToForestSpan tl) z+ z' = z -- No, pass in original token span as sspan.++ -- Note: with LayoutTree, the full tree matching the AST has been+ -- built, still need to drill down to the nearest enclosing span+ (tspan,lay,toks) = case Z.tree z' of+ (Node (Entry ss ly tks) []) -> (ss,ly,tks)+ (Node (Entry _ _ _nullToks) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting tokens, found: " ++ (show $ Z.tree z')+ (Node (Deleted _ _ _) _sub) -> error $ "replaceTokenForSrcSpan:tok pos" ++ (showForestSpan $ sf sspan) ++ " expecting Entry, found: " ++ (show $ Z.tree z')++ ((row,col),_) = forestSpanToSimpPos $ srcSpanToForestSpan tl+ toks' = replaceTokNoReAlign toks (row,col) tok++ zf = Z.setTree (Node (Entry tspan lay toks') []) z'+ forest' = Z.toTree zf+++-- ---------------------------------------------------------------------++-- |Open a zipper so that its focus has the given SrcSpan in its+-- subtree, or the location where the SrcSpan should go, if it is not+-- in the tree.+-- In the case of an 'Above' layout with the same SrcSpan below,+-- return that instead+openZipperToSpanDeep+ :: (IsToken a)+ => ForestSpan+ -> Z.TreePos Z.Full (Entry a)+ -> Z.TreePos Z.Full (Entry a)+openZipperToSpanDeep sspan z = zf+ where+ z' = openZipperToSpan sspan z++ zf = case Z.tree z' of+ (Node (Entry _ (Above _ _ _ _) _) _) ->+ case getChildrenAsZ z' of+ [] -> z'+ [x] -> if (treeStartEnd (Z.tree x) == sspan) then x else z'+ _ -> z'+ _ -> z'+++-- ---------------------------------------------------------------------++-- |Open a zipper 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 ::+ (IsToken a)+ => ForestSpan+ -> Z.TreePos Z.Full (Entry a)+ -> Z.TreePos Z.Full (Entry a)+openZipperToSpan sspan z+ | hasVersions = openZipperToSpanAdded sspan z+ | otherwise = openZipperToSpanOrig sspan z+ where+ (vs,_ve) = forestSpanVersions sspan+ hasVersions = vs /= 0+++-- ---------------------------------------------------------------------++-- |Open a zipper so that its focus has the given SrcSpan in its+-- subtree, or the location where the SrcSpan should go, if it is not+-- in the tree+openZipperToSpanOrig ::+ (IsToken a)+ => ForestSpan+ -> Z.TreePos Z.Full (Entry a)+ -> Z.TreePos Z.Full (Entry a)+openZipperToSpanOrig sspan z+ = if (treeStartEnd (Z.tree z) == sspan) || (Z.isLeaf z)+ then z+ else z'+ where+ -- go through all of the children to find the one that+ -- either is what we are looking for, or contains it++ -- childrenAsZ = go [] (Z.firstChild z)+ childrenAsZ = getChildrenAsZ z+ z' = case (filter contains childrenAsZ) of+ [] -> z -- Not directly in a subtree, this is as good as+ -- it gets+ [x] -> -- exactly one, drill down+ openZipperToSpan sspan x++ xx -> case (filter (\zt -> (treeStartEnd $ Z.tree zt) == sspan) xx) of + [] -> -- more than one matches, see if we can get+ -- rid of the ones that have been lengthened+ case (filter (not .forestSpanLenChanged . treeStartEnd . Z.tree) xx) of+ [] -> z -- we tried...+ [w] -> openZipperToSpan sspan w+ -- ww -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,ww))+ ww -> -- more than one candidate, break+ -- the tie on version match+ case (filter (\zt -> matchVersions sspan zt) ww) of+ [v] -> openZipperToSpan sspan v+ _ -> error $ "openZipperToSpan:can't resolve:(sspan,ww)="++(show (sspan,map (\zt -> treeStartEnd $ Z.tree zt) ww))+ [y] -> openZipperToSpan sspan y+ yy -> -- Multiple, check if we can separate out by+ -- version+ case (filter (\zt -> (fst $ forestSpanVersions $ treeStartEnd $ Z.tree zt) == (fst $ forestSpanVersions sspan)) xx) of+ -- [] -> z+ [] -> error $ "openZipperToSpan:no version match:(sspan,yy)=" ++ (show (sspan,yy)) -- ++AZ+++ [w] -> openZipperToSpan sspan w+ _ww -> error $ "openZipperToSpan:multiple version match:" ++ (show (sspan,yy)) -- ++AZ++++ contains zn = spanContains (treeStartEnd $ Z.tree zn) sspan++ matchVersions span1 z2 = isMatch+ where+ span2 = treeStartEnd $ Z.tree z2+ isMatch = forestSpanVersions span1 == forestSpanVersions span2++-- ---------------------------------------------------------------------++-- |Open a zipper to a SrcSpan that has been added in the tree, and+-- thus does not necessarily fall in the logical hierarchy of the tree+openZipperToSpanAdded ::+ (IsToken a)+ => ForestSpan+ -> Z.TreePos Z.Full (Entry a)+ -> Z.TreePos Z.Full (Entry a)+openZipperToSpanAdded sspan z = zf+ where+ treeAsList = getTreeSpansAsList $ Z.tree z++ -- True if first span contains the second+ myMatch (((ForestLine _ _ vs1 rs1),cs1),((ForestLine _ _ ve1 re1),ce1))+ (((ForestLine _ _ vs2 rs2),cs2),((ForestLine _ _ ve2 re2),ce2))+ = vs1 == vs2 && ve1 == ve2 && ((rs1,cs1) <= (rs2,cs2)) && ((re1,ce1) >= (re2,ce2))+ tl2 = dropWhile (\(_,s) -> not (myMatch s sspan)) $ reverse treeAsList++ fff [] _ = []+ fff acc@((cd,_cs):_) (v,sspan') = if v < cd then (v,sspan'):acc+ else acc++ tl3 = foldl' fff [(head tl2)] tl2+ -- tl3 now contains the chain of ForestSpans to open in order in the zipper++ zf = foldl' (flip openZipperToSpanOrig) z $ map snd tl3++-- ---------------------------------------------------------------------++getTreeSpansAsList :: (IsToken a) => Tree (Entry a) -> [(Int,ForestSpan)]+getTreeSpansAsList = getTreeSpansAsList' 0++getTreeSpansAsList' :: (IsToken a) => Int -> Tree (Entry a) -> [(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)+++-- ---------------------------------------------------------------------++getChildrenAsZ :: Z.TreePos Z.Full a -> [Z.TreePos Z.Full a]+getChildrenAsZ z = go [] (Z.firstChild z)+ where+ go acc Nothing = acc+ go acc (Just zz) = go (acc ++ [zz]) (Z.next zz)++-- ---------------------------------------------------------------------++-- |Replace a single token in the token stream by a new token, without+-- adjusting the layout.+-- Note1: does not re-align, else other later replacements may fail.+-- Note2: must keep original end col, to know what the inter-token gap+-- was when re-aligning+replaceTokNoReAlign:: (IsToken a) => [a] -> SimpPos -> a -> [a]+replaceTokNoReAlign toks pos newTok =+ toks1 ++ [newTok'] ++ toksRest+ where+ (toks1,toks2) = break (\t -> tokenPos t >= pos && tokenLen t > 0) toks+ toksRest = if (null toks2) then [] else (gtail "replaceTokNoReAlign" toks2)+ oldTok = if (null toks2) then newTok else (ghead "replaceTokNoReAlign" toks2)+ -- newTok' = markToken $ matchTokenPos oldTok newTok+ newTok' = matchTokenPos oldTok newTok++-- ---------------------------------------------------------------------++-- |Transfer the location information from the first param to the second+matchTokenPos :: (IsToken a) => a -> a -> a+matchTokenPos t1 t2 = putSpan t2 (getSpan t1)++{-+-- |Transfer the location information from the first param to the second+matchTokenPos :: PosToken -> PosToken -> PosToken+matchTokenPos (GHC.L l _,_) (GHC.L _ t,s) = (GHC.L l t,s)+-}++-- ---------------------------------------------------------------------+
+ src/Language/Haskell/TokenUtils/Types.hs view
@@ -0,0 +1,441 @@+{-# Language FlexibleInstances #-}+{-# Language MultiParamTypeClasses #-}+{-# Language TypeSynonymInstances #-}+module Language.Haskell.TokenUtils.Types+ (+ Entry(..)+ , TokenCache(..)+ , TreeId(..)+ , mainTid+ , ForestSpan+ , ForestPos+ , ForestLine(..)+ , RowOffset+ , ColOffset+ , Row+ , Col+ , SimpPos+ , Layout(..)+ , EndOffset(..)+ , Located(..)+ , Span(..)+ , nullSpan+ , TokenLayout+ , LayoutTree+ , forestSpanFromEntry+ , putForestSpanInEntry+ , forestSpanToSimpPos+ , forestSpanVersionSet+ , treeStartEnd+ , groupTokensByLine+ , tokenRow+ , tokenCol+ , tokenColEnd+ , tokenPos+ , tokenPosEnd+ , increaseSrcSpan+ , srcPosToSimpPos+ , addOffsetToToks+ , ghcLineToForestLine+ , forestLineToGhcLine++ , IsToken(..)+ , notWhiteSpace+ , isWhiteSpaceOrIgnored+ , isIgnored+ , isIgnoredNonComment+ , isWhereOrLet+ , showFriendlyToks+ , HasLoc(..)+ , Allocatable(..)+ ) where++import Control.Exception+import Data.Bits+import Data.List+import Data.Tree++import qualified Data.Map as Map++-- ---------------------------------------------------------------------++-- | An entry in the data structure for a particular srcspan.+data Entry a =+ -- |Entry has+ -- * the source span contained in this Node+ -- * how the sub-elements nest+ -- * the tokens for the SrcSpan if subtree is empty+ Entry !ForestSpan+ !Layout+ ![a]+ -- |Deleted has+ -- * the source span has been deleted+ -- * prior gap in lines+ -- * the gap between this span end and the+ -- start of the next in the fringe of the+ -- tree.+ | Deleted !ForestSpan+ !RowOffset+ !SimpPos+ deriving (Show)++instance (IsToken a) => Eq (Entry a) where+ (Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2)+ = fs1 == fs2 && lay1 == lay2+ && (show toks1) == (show toks2)++ (Deleted fs1 pg1 lay1) == (Deleted fs2 pg2 lay2)+ = fs1 == fs2 && pg1 == pg2 && lay1 == lay2++ (==) _ _ = False++instance HasLoc (Entry a) where+ getLoc (Entry fs _ _) = getLoc fs+ getLoc (Deleted fs _ _) = getLoc fs++ getLocEnd (Entry fs _ _) = getLocEnd fs+ getLocEnd (Deleted fs _ _) = getLocEnd fs+++type RowOffset = Int+type ColOffset = Int+type Row = Int+type Col = Int++type SimpPos = (Int,Int) -- Line, column++data Layout = Above EndOffset (Row,Col) (Row,Col) EndOffset+ -- ^ Initial offset from token before the+ -- stacked list of items, the (r,c) of the first+ -- non-comment token, the (r,c) of the end of the last non-comment+ -- token in the stacked list to be able to calculate the+ -- (RowOffset,ColOffset) between the last token and the+ -- start of the next item.+ | NoChange+ deriving (Show,Eq)++data EndOffset = None+ | SameLine ColOffset+ | FromAlignCol (RowOffset, ColOffset)+ deriving (Show,Eq)++-- ---------------------------------------------------------------------++data ForestLine = ForestLine+ { flSpanLengthChanged :: !Bool -- ^The length of the+ -- span may have+ -- changed due to+ -- updated tokens.+ , flTreeSelector :: !Int+ , flInsertVersion :: !Int+ , flLine :: !Int+ } -- deriving (Eq)++instance Eq ForestLine where+ -- TODO: make this undefined, and patch all broken code to use the+ -- specific fun here directly instead.+ (ForestLine _ s1 v1 l1) == (ForestLine _ s2 v2 l2) = s1 == s2 && v1 == v2 && l1 == l2++instance Show ForestLine where+ show s = "(ForestLine " ++ (show $ flSpanLengthChanged s)+ ++ " " ++ (show $ flTreeSelector s)+ ++ " " ++ (show $ flInsertVersion s)+ ++ " " ++ (show $ flLine s)+ ++ ")"++-- instance Outputable ForestLine where+-- ppr fl = text (show fl)+instance Ord ForestLine where+ -- Use line as the primary comparison, but break any ties with the+ -- version+ -- Tree is ignored, as it is only a marker on the topmost element+ -- Ignore sizeChanged flag, it will only be relevant in the+ -- invariant check+ compare (ForestLine _sc1 _ v1 l1) (ForestLine _sc2 _ v2 l2) =+ if (l1 == l2)+ then compare v1 v2+ else compare l1 l2+++-- ---------------------------------------------------------------------++type ForestPos = (ForestLine,Int)+++-- |Match a SrcSpan, using a ForestLine as the marker+type ForestSpan = (ForestPos,ForestPos)++instance HasLoc ForestSpan where+ getLoc fs = fst (forestSpanToSimpPos fs)+ getLocEnd fs = snd (forestSpanToSimpPos fs)++-- ---------------------------------------------------------------------++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 a = TK+ { tkCache :: !(Map.Map TreeId (Tree (Entry a)))+ , tkLastTreeId :: !TreeId+ }++-- ---------------------------------------------------------------------++class Allocatable b a where+ allocTokens :: b -> [a] -> LayoutTree a+++-- |The IsToken class captures the different token type in use. For+-- GHC it represents the type returned by `GHC.getRichTokenStream`,+-- namely [(GHC.Located GHC.Token, String)]+-- For haskell-src-exts this is the reult of `lexTokenStream`, namely `[HSE.Loc HSE.Token]`+class (Show a) => IsToken a where+ -- TODO: get rid of these and put a HasLoc requirement+ getSpan :: a -> Span+ putSpan :: a -> Span -> a++ -- |tokenLen returns the length of the string representation of the+ -- token, not just the difference in the location, as the string may+ -- have changed without the position being updated, e.g. in a+ -- renaming+ tokenLen :: a -> Int++ isComment :: a -> Bool++ -- |Zero-length tokens, as appear in GHC as markers+ isEmpty :: a -> Bool++ isDo :: a -> Bool+ isElse :: a -> Bool+ isIn :: a -> Bool+ isLet :: a -> Bool+ isOf :: a -> Bool+ isThen :: a -> Bool+ isWhere :: a -> Bool++ tokenToString :: a -> String+ -- TODO: may be able to get rid of next due to former+ showTokenStream :: [a] -> String++-- derived functions+isWhiteSpace :: (IsToken a) => a -> Bool+isWhiteSpace tok = isComment tok || isEmpty tok++notWhiteSpace :: (IsToken a) => a -> Bool+notWhiteSpace tok = not (isWhiteSpace tok)++isWhiteSpaceOrIgnored :: (IsToken a) => a -> Bool+isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok++-- Tokens that are ignored when allocating tokens to a SrcSpan+isIgnored :: (IsToken a) => a -> 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 :: (IsToken a) => a -> Bool+isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok++isWhereOrLet :: (IsToken a) => a -> Bool+isWhereOrLet t = isWhere t || isLet t++showFriendlyToks :: IsToken a => [a] -> String+showFriendlyToks toks = reverse $ dropWhile (=='\n')+ $ reverse $ dropWhile (=='\n') $ showTokenStream toks+++class HasLoc a where+ getLoc :: a -> SimpPos+ getLocEnd :: a -> SimpPos++data Located e = L Span e+ deriving Show++data Span = Span (Row,Col) (Row,Col)+ deriving (Show,Eq,Ord)++nullSpan :: Span+nullSpan = Span (0,0) (0,0)++data TokenLayout a = TL (Tree (Entry a))++type LayoutTree a = Tree (Entry a)++instance (IsToken t) => Ord (LayoutTree t) where+ compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b)++-- --------------------------------------------------------------------++forestSpanFromEntry :: Entry a -> ForestSpan+forestSpanFromEntry (Entry ss _ _) = ss+forestSpanFromEntry (Deleted ss _ _) = ss++putForestSpanInEntry :: Entry a -> ForestSpan -> Entry a+putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks)+putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg)++-- ---------------------------------------------------------------------++-- |Strip out the version markers+forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos)+forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec))++-- |Checks if the version is non-zero in either position+forestSpanVersionSet :: ForestSpan -> Bool+forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0++-- ---------------------------------------------------------------------++-- |Get the start and end position of a Tree+-- treeStartEnd :: Tree Entry -> (SimpPos,SimpPos)+-- treeStartEnd (Node (Entry sspan _) _) = (getGhcLoc sspan,getGhcLocEnd sspan)+treeStartEnd :: Tree (Entry a) -> ForestSpan+treeStartEnd (Node (Entry sspan _ _) _) = sspan+treeStartEnd (Node (Deleted sspan _ _) _) = sspan++-- ---------------------------------------------------------------------++groupTokensByLine :: (IsToken a) => [a] -> [[a]]+groupTokensByLine xs = groupBy toksOnSameLine xs++toksOnSameLine :: (IsToken a) => a -> a -> Bool+toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2+++-- ---------------------------------------------------------------------++tokenRow :: (IsToken a) => a -> Int+tokenRow tok = r+ where (Span (r,_) _) = getSpan tok++tokenCol :: (IsToken a) => a -> Int+tokenCol tok = c+ where (Span (_,c) _) = getSpan tok++tokenColEnd :: (IsToken a) => a -> Int+tokenColEnd tok = c+ where (Span _ (_,c)) = getSpan tok++tokenPos :: IsToken a => a -> SimpPos+tokenPos tok = startPos+ where (Span startPos _) = getSpan tok++tokenPosEnd :: IsToken a => a -> SimpPos+tokenPosEnd tok = endPos+ where (Span _ endPos) = getSpan tok++-- ---------------------------------------------------------------------++-- tokenLen :: PosToken -> Int+-- tokenLen (_,s) = length s --check this again! need to handle the tab key.++-- ---------------------------------------------------------------------++srcPosToSimpPos :: (Int,Int) -> (Int,Int)+srcPosToSimpPos (sr,c) = (l,c)+ where+ (ForestLine _ _ _ l) = ghcLineToForestLine sr++-- ---------------------------------------------------------------------++-- A data type for the line entries in a SrcSpan. This has the+-- following properties+--+-- 1. It can be converted to and from the underlying Int in the+-- original SrcSpan+-- 2. It allows the insertion of an arbitrary line as the start of a+-- new SrcSpan+-- 3. It has an ordering relation, which honours the inserts which+-- were made.+-- 4. It can keep track of tokens that have been removed from the main+-- AST, which can be edited outside of it and then inserted again+--+-- This is achieved by adding two fields to the SrcSpan, one to+-- indicate which AST fragment it is in, and the other to indicate its+-- insert relationship, encoded as 0 for the original, 1 for the+-- first, 2 for the second and so on.+--+-- This field is converted to and from the original line by being+-- multiplied by a very large number and added to the original.+--+-- The guaranteed max value in Haskell for an Int is 2^29 - 1.+-- This evaluates to 536,870,911,or 536.8 million.+--+-- However, as pointed out on #haskell, the GHC compiler (which this+-- implemtation explicitly targets) provides the full 32 bits (at+-- least, can be 64), so we have+-- maxBound :: Int = 2,147,483,647+--+-- Schema:max pos value is 0x7fffffff (31 bits)+-- 1 bit for LenChanged+-- 5 bits for tree : 32 values+-- 5 bits for version : 32 values+-- 20 bits for line number: 1048576 values++forestLineMask,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++forestVersionShift :: Int+forestVersionShift = 20++forestTreeShift :: Int+forestTreeShift = 25+++-- | Extract an encoded ForestLine from a GHC line+ghcLineToForestLine :: Int -> ForestLine+ghcLineToForestLine l = ForestLine ch tr v l'+ where+ l' = l .&. forestLineMask+ v = shiftR (l .&. forestVersionMask) forestVersionShift+ tr = shiftR (l .&. forestTreeMask) forestTreeShift+ ch = (l .&. forestLenChangedMask) /= 0++-- 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)+++-- ---------------------------------------------------------------------++-- |Add a constant line and column offset to a span of tokens+addOffsetToToks :: (IsToken a) => SimpPos -> [a] -> [a]+addOffsetToToks (r,c) toks = map (\t -> increaseSrcSpan (r,c) t) toks++-- ---------------------------------------------------------------------++-- |Shift the whole token by the given offset+increaseSrcSpan :: (IsToken a) => SimpPos -> a -> a+increaseSrcSpan (lineAmount,colAmount) posToken+ = putSpan posToken newL+ where+ newL = Span (startLine + lineAmount, startCol + colAmount)+ (endLine + lineAmount, endCol + colAmount)++ (Span (startLine, startCol) (endLine,endCol)) = getSpan posToken++++-- ---------------------------------------------------------------------++{-+getLocatedStart :: Located t -> (Int, Int)+getLocatedStart (L l _) = getGhcLoc l++getLocatedEnd :: Located t -> (Int, Int)+getLocatedEnd (L l _) = getGhcLocEnd l++getGhcLoc (Span fm _to) = fm+getGhcLocEnd (Span _fm to) = to+-}+
+ src/Language/Haskell/TokenUtils/Utils.hs view
@@ -0,0 +1,540 @@+module Language.Haskell.TokenUtils.Utils+ (+ splitToks++ , ghead+ , glast+ , gtail+ , gfromJust++ , addEndOffsets+ , calcLastTokenPos+ , makeOffset+ , makeLeaf+ , makeLeafFromToks+ , splitToksIncComments+ , makeGroup+ , makeGroupLayout+ , makeSpanFromTrees+ , mkGroup+ , subTreeOnly+ , splitToksForList+ , placeAbove+ , allocList+ , strip++ -- * SrcSpan to ForestSpan conversions+ , sf+ , srcSpanToForestSpan+ , fs+ , forestSpanToSrcSpan++ -- * ForestSpans+ , treeIdFromForestSpan+ , forestSpanVersions+ , forestSpanAstVersions+ , forestSpanLenChangedFlags+ , forestSpanVersionNotSet+ , forestPosVersionSet+ , forestPosAstVersionSet+ , forestPosVersionNotSet+ , forestSpanLenChanged+ , forestPosLenChanged+ , treeIdIntoForestSpan+ , spanContains+ , insertVersionsInForestSpan+ , insertLenChangedInForestSpan++ -- * Spans+ , spanStartEnd+ , combineSpans++ -- * drawing the various trees+ , drawTreeEntry+ , drawForestEntry+ , showLayout+ , drawTreeCompact+ , drawTreeWithToks+ , showForestSpan+ ) where++import Control.Exception+import Data.List+import Data.Tree++-- import Language.Haskell.TokenUtils.DualTree+-- import Language.Haskell.TokenUtils.Layout+-- import Language.Haskell.TokenUtils.TokenUtils+import Language.Haskell.TokenUtils.Types++-- ---------------------------------------------------------------------++-- | Split the token stream into three parts: the tokens before the+-- startPos, the tokens between startPos and endPos, and the tokens+-- after endPos.+-- Note: The startPos and endPos refer to the startPos of a token only.+-- So a single token will have the same startPos and endPos+-- NO^^^^+++-- splitToks::(SimpPos,SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken])+splitToks::(IsToken a) => (SimpPos,SimpPos)->[a]->([a],[a],[a])+splitToks (startPos, endPos) toks =+ let (toks1,toks2) = break (\t -> tokenPos t >= startPos) toks+ (toks21,toks22) = break (\t -> tokenPos t >= endPos) toks2+ in+ (toks1,toks21,toks22)+++-- ---------------------------------------------------------------------+-- Putting these here for the time being, to avoid import loops++ghead :: String -> [a] -> a+ghead info [] = error $ "ghead "++info++" []"+ghead _info (h:_) = h++glast :: String -> [a] -> a+glast info [] = error $ "glast " ++ info ++ " []"+glast _info h = last h++gtail :: String -> [a] -> [a]+gtail info [] = error $ "gtail " ++ info ++ " []"+gtail _info h = tail h++gfromJust :: [Char] -> Maybe a -> a+gfromJust _info (Just h) = h+gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"++-- ---------------------------------------------------------------------++addEndOffsets :: (IsToken a) => LayoutTree a -> [a] -> LayoutTree a+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,_) = 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 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)++-- ---------------------------------------------------------------------++calcLastTokenPos :: (IsToken a) => [a] -> (Int,Int)+calcLastTokenPos toks = (rt,ct)+ where+ (rt,ct) = case (dropWhile isEmpty (reverse toks)) of+ [] -> (0,0)+ (x:_) -> (tokenRow x,tokenCol x + tokenLen x)++-- ---------------------------------------------------------------------++makeOffset :: RowOffset -> ColOffset -> EndOffset+makeOffset 0 0 = None+makeOffset 0 co = SameLine co+makeOffset ro co = FromAlignCol (ro,co)++-- ---------------------------------------------------------------------++-- | Split the given tokens into the ones that occur prior to the start+-- of the list and ones that occur after+splitToksForList :: (IsToken a,HasLoc b) => [b] -> [a] -> ([a],[a],[a])+splitToksForList [] toks = ([],[],toks)+splitToksForList xs toks = splitToksIncComments (getLoc s, getLocEnd e) toks+ where+ s = head xs+ e = last xs++-- ---------------------------------------------------------------------++-- | Split the given tokens to include the comments belonging to the span.+splitToksIncComments :: (IsToken a)+ => (SimpPos, SimpPos)+ -> [a]+ -> ([a], [a], [a]) -- before,included,after+splitToksIncComments pos toks = splitToks pos' toks+ where+ pos' = startEndLocIncComments' toks pos++-- ---------------------------------------------------------------------++startEndLocIncComments' :: (IsToken a) => [a] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos)+startEndLocIncComments' toks (startLoc,endLoc) =+ let+ (begin,middle,end) = splitToks (startLoc,endLoc) toks++ notIgnored tt = not (isWhiteSpaceOrIgnored tt)++ (leadinr,leadr) = break notIgnored $ reverse begin+ leadr' = filter (\t -> not (isEmpty t)) leadr+ prevLine = if (null leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr')+ firstLine = if (null middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle)+ (_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr+ leadComments = dropWhile (\tt -> (isEmpty tt)) leadComments'++ (trail,trailrest) = break notWhiteSpace end+ trail' = filter (\t -> not (isEmpty t)) trail+ lastLine = if (null middle)+ then 0+ else (tokenRow $ glast "startEndLocIncComments'2" middle)+ nextLine = if (null trailrest)+ then 100000+ else (tokenRow $ ghead "startEndLocIncComments'2" trailrest)+ (trailComments,_) = divideComments lastLine nextLine trail'++ middle' = leadComments ++ middle ++ trailComments+ in+ if (null middle')+ then ((0,0),(0,0))+ else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle'))++-- ---------------------------------------------------------------------++-- |Split a set of comment tokens into the ones that belong with the startLine+-- and those that belong with the endLine+divideComments :: (IsToken a) => Int -> Int -> [a] -> ([a],[a])+divideComments startLine endLine toks = (first,second)+ where+ groups = groupBy groupByAdjacent toks+ groupLines = map (\ts -> ((tokenRow $ ghead "divideComments" ts,tokenRow $ glast "divideComments" ts),ts)) groups+ groupLines' = [((startLine,startLine),[])] ++ groupLines ++ [((endLine,endLine),[])]+ groupGaps = go [] groupLines'+ -- groupGaps is now a list of gaps followed by the tokens. The+ -- last gap has an empty token list, since there is one more gap+ -- than token groups++ -- e.g [(0,[comments1]),(3,[comments2]),(1,[]) captures+ -- ---------------------+ -- b + bar -- ^trailing comment+ --+ --+ -- -- leading comment+ -- foo x y =+ -- ----------------------++ biggest = maximum $ map fst groupGaps++ (firsts,seconds) = break (\(g,_) -> g >= biggest) groupGaps++ first = concatMap snd firsts+ second = concatMap snd seconds++ -- Helpers+ groupByAdjacent :: (IsToken a) => a -> a -> Bool+ groupByAdjacent a b = 1 + tokenRow a == tokenRow b++ go :: (IsToken a) => [(Int,[a])] -> [((Int,Int),[a])] -> [(Int,[a])]+ go acc [] = acc+ go acc [_x] = acc+ go acc (((_s1,e1),_t1):b@((s2,_e2),t2):xs) = go (acc ++ [((s2 - e1),t2)] ) (b:xs)++-- ---------------------------------------------------------------------++placeAbove :: (IsToken a) => EndOffset -> (Row,Col) -> (Row,Col) -> [LayoutTree a] -> LayoutTree a+placeAbove _ _ _ [] = error "placeAbove []"+placeAbove so p1 p2 ls = Node (Entry loc (Above so p1 p2 None) []) ls+ where+ loc = makeSpanFromTrees ls++-- ---------------------------------------------------------------------++makeGroup :: (IsToken a) => [LayoutTree a] -> LayoutTree a+makeGroup [x] = x+makeGroup ls = makeGroupLayout NoChange ls++makeGroupLayout :: (IsToken a) => Layout -> [LayoutTree a] -> LayoutTree a+makeGroupLayout lay ls = Node (Entry loc lay []) ls+ where+ loc = makeSpanFromTrees ls++-- ---------------------------------------------------------------------++makeSpanFromTrees :: [LayoutTree a] -> ForestSpan+makeSpanFromTrees ls+ = case ls of+ [] -> sf nullSpan+ _ -> combineSpans (getTreeLoc $ head ls) (getTreeLoc $ last ls)++-- ---------------------------------------------------------------------++subTreeOnly :: (IsToken a) => [LayoutTree a] -> [LayoutTree a]+subTreeOnly [(Node _ sub)] = sub+subTreeOnly xs = xs++-- ---------------------------------------------------------------------++getTreeLoc :: LayoutTree a -> ForestSpan+getTreeLoc (Node (Entry l _ _) _) = l+getTreeLoc (Node (Deleted l _ _) _) = l++-- ---------------------------------------------------------------------++mkGroup :: (IsToken a) => Span -> Layout -> [LayoutTree a] -> LayoutTree a+mkGroup sspan lay subs = Node (Entry (sf sspan) lay []) subs+++-- TODO: Move this into the main Utils+makeLeaf :: (IsToken a) => Span -> Layout -> [a] -> LayoutTree a+makeLeaf sspan lay toks = Node (Entry (sf sspan) lay toks) []++-- ---------------------------------------------------------------------++sf :: Span -> ForestSpan+sf = srcSpanToForestSpan++fs :: ForestSpan -> Span+fs = forestSpanToSrcSpan++srcSpanToForestSpan :: Span -> ForestSpan+srcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol))+ where+ (Span (startRow,startCol) (endRow,endCol)) = sspan++forestSpanToSrcSpan :: ForestSpan -> Span+forestSpanToSrcSpan ((fls,sc),(fle,ec)) = sspan+ where+ lineStart = forestLineToGhcLine fls+ lineEnd = forestLineToGhcLine fle+ locStart = (lineStart, sc)+ locEnd = (lineEnd, ec)+ sspan = Span locStart locEnd+++-- ---------------------------------------------------------------------++-- |Gets the version numbers+forestSpanVersions :: ForestSpan -> (Int,Int)+forestSpanVersions ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = (sv,ev)++-- |Gets the AST tree numbers+forestSpanAstVersions :: ForestSpan -> (Int,Int)+forestSpanAstVersions ((ForestLine _ trs _ _,_),(ForestLine _ tre _ _,_)) = (trs,tre)++-- |Gets the SpanLengthChanged flags+forestSpanLenChangedFlags :: ForestSpan -> (Bool,Bool)+forestSpanLenChangedFlags ((ForestLine chs _ _ _,_),(ForestLine che _ _ _,_)) = (chs,che)++{- moved to haskell-token-utils+-- |Checks if the version is non-zero in either position+forestSpanVersionSet :: ForestSpan -> Bool+forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0+-}++-- |Checks if the version is zero in both positions+forestSpanVersionNotSet :: ForestSpan -> Bool+forestSpanVersionNotSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv == 0 && ev == 0++-- |Checks if the version is non-zero+forestPosVersionSet :: ForestPos -> Bool+forestPosVersionSet (ForestLine _ _ v _,_) = v /= 0++-- |Checks if the AST version is non-zero+forestPosAstVersionSet :: ForestPos -> Bool+forestPosAstVersionSet (ForestLine _ tr _ _,_) = tr /= 0++-- |Checks if the version is zero+forestPosVersionNotSet :: ForestPos -> Bool+forestPosVersionNotSet (ForestLine _ _ v _,_) = v == 0++forestSpanLenChanged :: ForestSpan -> Bool+forestSpanLenChanged (s,e) = (forestPosLenChanged s) || (forestPosLenChanged e)++forestPosLenChanged :: ForestPos -> Bool+forestPosLenChanged (ForestLine ch _ _ _,_) = ch++-- |Puts a TreeId into a forestSpan+treeIdIntoForestSpan :: TreeId -> ForestSpan -> ForestSpan+treeIdIntoForestSpan (TId sel) ((ForestLine chs _ sv sl,sc),(ForestLine che _ ev el,ec))+ = ((ForestLine chs sel sv sl,sc),(ForestLine che sel ev el,ec))++-- ---------------------------------------------------------------------++-- |Does the first span contain the second? Takes cognisance of the+-- various flags a ForestSpan can have.+-- NOTE: This function relies on the Eq instance for ForestLine+spanContains :: ForestSpan -> ForestSpan -> Bool+spanContains span1 span2 = (startPos <= nodeStart && endPos >= nodeEnd)+ where+ -- TODO: This looks like a no-op?+ (tvs,_tve) = forestSpanVersions $ span1+ (nvs,_nve) = forestSpanVersions $ span2+ (startPos,endPos) = insertVersionsInForestSpan tvs tvs span1+ (nodeStart,nodeEnd) = insertVersionsInForestSpan nvs nvs span2++-- ---------------------------------------------------------------------++insertVersionsInForestSpan :: Int -> Int -> ForestSpan -> ForestSpan+insertVersionsInForestSpan vsNew veNew ((ForestLine chs trs _vs ls,cs),(ForestLine che tre _ve le,ce))+ = ((ForestLine chs trs vsNew ls,cs),(ForestLine che tre veNew le,ce))++-- ---------------------------------------------------------------------++insertLenChangedInForestSpan :: Bool -> ForestSpan -> ForestSpan+insertLenChangedInForestSpan chNew ((ForestLine _chs trs vs ls,cs),(ForestLine _che tre ve le,ce))+ = ((ForestLine chNew trs vs ls,cs),(ForestLine chNew tre ve le,ce))++-- ---------------------------------------------------------------------++makeLeafFromToks :: (IsToken a) => [a] -> [LayoutTree a]+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 :: (IsToken a) => [a] -> (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++-- ---------------------------------------------------------------------++-- | ForestSpan version of GHC combineSrcSpans+combineSpans :: ForestSpan -> ForestSpan -> ForestSpan+combineSpans fs1 fs2 = fs'+ where+ [lowFs,highFs] = sort [fs1,fs2]+ ((ForestLine chls trls vls lls ,cls),(ForestLine _chle _trle _vle _lle,_cle)) = lowFs+ ((ForestLine _chhs _trhs _vhs _lhs,_chs),(ForestLine chhe trhe vhe lhe, che)) = highFs++ fs' = ((ForestLine chls trls vls lls,cls),(ForestLine chhe trhe vhe lhe,che))+++simpPosToForestSpan :: (SimpPos,SimpPos) -> ForestSpan+simpPosToForestSpan ((sr,sc),(er,ec))+ = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec))++-- ---------------------------------------------------------------------++strip :: (IsToken a) => [LayoutTree a] -> [LayoutTree a]+strip ls = filter (not . emptyNode) ls+ where+ emptyNode (Node (Entry _ _ []) []) = True+ emptyNode _ = False++-- ---------------------------------------------------------------------++allocList :: (IsToken a,HasLoc b)+ => [b]+ -> [a]+ -> (b -> [a] -> [LayoutTree a])+ -> [LayoutTree a]+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],[GhcPosToken]) -> GHC.Located a -> ([LayoutTree],[GhcPosToken])+ doOne (acc,toksOne) x = r1+ where+ l = (getLoc x,getLocEnd x)+ (s1,funcToks,toks') = splitToksIncComments 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)++-- ---------------------------------------------------------------------++spanStartEnd :: Span -> (SimpPos,SimpPos)+spanStartEnd (Span start end) = (start,end)++-- ---------------------------------------------------------------------++treeIdFromForestSpan :: ForestSpan -> TreeId+treeIdFromForestSpan ((ForestLine _ tr _ _,_),(ForestLine _ _ _ _,_)) = TId tr++-- ---------------------------------------------------------------------+-- | Neat 2-dimensional drawing of a tree.+drawTreeEntry :: Tree (Entry a) -> String+drawTreeEntry = unlines . drawEntry++-- | Neat 2-dimensional drawing of a forest.+drawForestEntry :: Forest (Entry a) -> String+drawForestEntry = unlines . map drawTreeEntry++drawEntry :: Tree (Entry a) -> [String]+drawEntry (Node (Deleted sspan _pg eg ) _ ) = [(showForestSpan sspan) ++ (show eg) ++ "D"]+drawEntry (Node (Entry sspan lay _toks) ts0) = ((showForestSpan sspan) ++ (showLayout lay)): drawSubTrees ts0+ where+ drawSubTrees [] = []+ drawSubTrees [t] =+ "|" : shft "`- " " " (drawEntry t)+ drawSubTrees (t:ts) =+ "|" : shft "+- " "| " (drawEntry t) ++ drawSubTrees ts++ shft first other = zipWith (++) (first : repeat other)++showLayout :: Layout -> String+showLayout NoChange = ""+showLayout (Above so p1 (r,c) eo) = "(Above "++ show so ++ " " ++ show p1 ++ " " ++ show (r,c) ++ " " ++ show eo ++ ")"+-- showLayout (Offset r c) = "(Offset " ++ show r ++ " " ++ show c ++ ")"++-- ---------------------------------------------------------------------++drawTreeCompact :: Tree (Entry a) -> String+drawTreeCompact = unlines . drawTreeCompact' 0++drawTreeCompact' :: Int -> Tree (Entry a) -> [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)++showForestSpan :: ForestSpan -> String+showForestSpan ((sr,sc),(er,ec))+ = show ((flToNum sr,sc),(flToNum er,ec))+ where+ flToNum (ForestLine ch tr v l) = (if ch then 10000000000::Integer else 0)+ + ((fromIntegral tr) * 100000000::Integer)+ + ((fromIntegral v) * 1000000::Integer)+ + (fromIntegral l)++-- ---------------------------------------------------------------------++drawTreeWithToks :: (IsToken a) => Tree (Entry a) -> String+drawTreeWithToks = unlines . drawTreeWithToks' 0++drawTreeWithToks' :: (IsToken a) => Int -> Tree (Entry a) -> [String]+drawTreeWithToks' level (Node (Deleted sspan _pg eg ) _ )+ = [(showLevel level) ++ ":" ++ (showForestSpan sspan) ++ (show eg) ++ "D"]+drawTreeWithToks' level (Node (Entry sspan lay toks) ts0)+ = ((showLevel level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay) ++ (showFriendlyToks toks))+-- = ((showLevel level) ++ ":" ++ (showForestSpan sspan) ++ (showLayout lay) ++ (show toks))+ : (concatMap (drawTreeWithToks' (level + 1)) ts0)++showLevel :: Int -> String+showLevel level = take level (repeat ' ')++
+ test/Spec.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-++See https://github.com/hspec/hspec/tree/master/hspec-discover#readme+to understand this module++-}