diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +haskell-token-utils +=================== + +Utilities to tie up tokens to an AST + +[![Build Status](https://travis-ci.org/alanz/haskell-token-utils.png?branch=master)](https://travis-ci.org/alanz/haskell-token-utils) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-token-utils.cabal b/haskell-token-utils.cabal new file mode 100644 --- /dev/null +++ b/haskell-token-utils.cabal @@ -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 + diff --git a/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs b/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs new file mode 100644 --- /dev/null +++ b/src-ghc/Language/Haskell/TokenUtils/GHC/Layout.hs @@ -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 + + diff --git a/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs b/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs new file mode 100644 --- /dev/null +++ b/src-hse/Language/Haskell/TokenUtils/HSE/Layout.hs @@ -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 "" 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 -> " "/>" + 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) + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/TokenUtils/API.hs b/src/Language/Haskell/TokenUtils/API.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/API.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +module Language.Haskell.TokenUtils.API + ( + IsToken(..) + , HasLoc(..) + ) where + +import Language.Haskell.TokenUtils.Types + + + + + + + + diff --git a/src/Language/Haskell/TokenUtils/DualTree.hs b/src/Language/Haskell/TokenUtils/DualTree.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/DualTree.hs @@ -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 + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/TokenUtils/Layout.hs b/src/Language/Haskell/TokenUtils/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/Layout.hs @@ -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 + +-- --------------------------------------------------------------------- + diff --git a/src/Language/Haskell/TokenUtils/Pretty.hs b/src/Language/Haskell/TokenUtils/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/Pretty.hs @@ -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) + + diff --git a/src/Language/Haskell/TokenUtils/TokenUtils.hs b/src/Language/Haskell/TokenUtils/TokenUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/TokenUtils.hs @@ -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) +-} + +-- --------------------------------------------------------------------- + diff --git a/src/Language/Haskell/TokenUtils/Types.hs b/src/Language/Haskell/TokenUtils/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/Types.hs @@ -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 +-} + diff --git a/src/Language/Haskell/TokenUtils/Utils.hs b/src/Language/Haskell/TokenUtils/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TokenUtils/Utils.hs @@ -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 ' ') + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + +-}