{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE RankNTypes            #-}
{-# 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
  , mkToken

  -- * Span conversion functions
  , gs2f,f2gs
  , gs2ss,ss2gs

  , insertForestLineInSrcSpan
  , showSrcSpan
  , showSrcSpanF

  , newNameTok

  , GhcPosToken

  -- * For testing
  ) 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 GHC.Paths     as GHC
import qualified Lexer         as GHC
import qualified Name          as GHC
import qualified NameSet       as GHC
import qualified Outputable    as GHC
import qualified RdrName       as GHC
import qualified SrcLoc        as GHC
import qualified StringBuffer  as GHC
import qualified UniqSet       as GHC
import qualified Unique        as GHC
import qualified Var           as GHC

-- import Outputable

import qualified GHC.SYB.Utils as SYB
import qualified Data.Generics as SYB

import Control.Exception
import Data.Generics hiding (GT)
import Data.List
import Data.Monoid
import Data.Tree

import System.IO.Unsafe

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

import Debug.Trace

-- ---------------------------------------------------------------------

-- | 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

-- ---------------------------------------------------------------------

-- |Construct the initial `LayoutTree' for use by 'initTokenCacheLayout'
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')
         )]
#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)

-- ---------------------------------------------------------------------

-- | 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

-- ---------------------------------------------------------------------

-- |Compose a new token using the given arguments.
mkToken::GHC.Token -> SimpPos -> String -> GhcPosToken
mkToken t (row,col) c = ((GHC.L l t),c)
  where
    filename = (GHC.mkFastString "f")
    l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) ))

ghcZeroToken :: GhcPosToken
ghcZeroToken = mkToken GHC.ITsemi (0,0) ""

-- ---------------------------------------------------------------------

nullSrcSpan :: GHC.SrcSpan
nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan"

g2s :: GHC.SrcSpan -> SimpSpan
g2s ss = ((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 :: SimpSpan -> GHC.SrcSpan
s2g ((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
  -- 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
  mkZeroToken = ghcZeroToken
  isDo = ghcIsDo
  isElse = ghcIsElse
  isIn = ghcIsIn
  isLet = ghcIsLet
  isOf = ghcIsOf
  isThen = ghcIsThen
  isWhere = ghcIsWhere

  tokenToString (_,s) = s
  showTokenStream = GHC.showRichTokenStream

  lexStringToTokens = ghcLexStringToTokens

  markToken = ghcMarkToken
  isMarked  = ghcIsMarked

instance (HasLoc (GHC.Located a)) where
  getLoc    (GHC.L l _) = start where ( start,_end) = g2s l
  getLocEnd (GHC.L l _) = end   where (_start, end) = g2s l

  -- getSpan = ghcGetSpan
  putSpan (GHC.L l v)  ns = GHC.L (putSpan l ns) v

instance HasLoc GHC.SrcSpan where
  getLoc = getGhcLoc
  getLocEnd = getGhcLocEnd

  putSpan _ss ns = s2g ns

instance (HasLoc (GHC.Located GHC.Token, String)) where
  getLoc (lt,_)    = getLoc lt
  getLocEnd (lt,_) = getLocEnd lt

  putSpan (lt,s)  ns = (ghcPutSpan lt ns,s)


-- 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)
  -- show t@(GHC.L _l tok) = show ((getLocatedStart t),tok)

-- ---------------------------------------------------------------------

-- |Used as a marker in the filename part of the SrcSpan on modified
-- tokens, to trigger re-alignment when retrieving the tokens.
tokenFileMark :: GHC.FastString
tokenFileMark = GHC.mkFastString "HaRe"

-- |Mark a token so that it can be use to trigger layout checking
-- later when the toks are retrieved
ghcMarkToken :: GhcPosToken -> GhcPosToken
ghcMarkToken tok = tok'
  where
      (GHC.L l t,s) = tok
      tok' = (GHC.L (GHC.RealSrcSpan l') t,s)

      l' = case l of
            GHC.RealSrcSpan ss ->
                 GHC.mkRealSrcSpan
                      (GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanStartLine ss)  (GHC.srcSpanStartCol ss))
                      (GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanEndLine ss)  (GHC.srcSpanEndCol ss))

            _ -> error $ "markToken: expecting a real SrcSpan, got" -- ++ (showGhc l)


-- |Does a token have the file mark in it
ghcIsMarked :: GhcPosToken -> Bool
ghcIsMarked (GHC.L l _,_) =
  case l of
    GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark
    _                  -> False

-- ---------------------------------------------------------------------

ghcGetSpan :: GhcPosToken -> SimpSpan
ghcGetSpan (GHC.L l _,_) = g2s l

ghcPutSpan :: (GHC.Located a) -> SimpSpan -> (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


-- ---------------------------------------------------------------------

-- |Get the current length of the token, based on its String, rather
-- than the original span length.
ghcTokenLen :: (t, [a]) -> Int
ghcTokenLen (_,s) = length s


-- ---------------------------------------------------------------------

gs2f :: GHC.SrcSpan -> ForestSpan
gs2f = ghcSrcSpanToForestSpan

f2gs :: ForestSpan -> GHC.SrcSpan
f2gs = forestSpanToGhcSrcSpan

gs2ss :: GHC.SrcSpan -> SimpSpan
gs2ss ss = ((getGhcLoc ss),(getGhcLocEnd ss))

ss2gs :: SimpSpan -> GHC.SrcSpan
ss2gs ((sr,sc),(er,ec)) = GHC.mkSrcSpan locStart locEnd
  where
    fname = GHC.mkFastString "foo"
    locStart = GHC.mkSrcLoc fname sr sc
    locEnd   = GHC.mkSrcLoc fname er ec

-- ---------------------------------------------------------------------

ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan
ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol))
  where
    (startRow,startCol) = getGhcLoc sspan
    (endRow,endCol)     = getGhcLocEnd sspan

-- ---------------------------------------------------------------------

forestSpanToGhcSrcSpan :: ForestSpan -> GHC.SrcSpan
forestSpanToGhcSrcSpan ((fls,sc),(fle,ec)) = sspan
  where
    lineStart = forestLineToGhcLine fls
    lineEnd   = forestLineToGhcLine fle
    locStart = GHC.mkSrcLoc (GHC.mkFastString "foo") lineStart sc
    locEnd   = GHC.mkSrcLoc (GHC.mkFastString "foo") lineEnd   ec
    sspan = GHC.mkSrcSpan locStart locEnd

-- ---------------------------------------------------------------------


-- | Replace any ForestLine flags already in a SrcSpan with the given ones
-- TODO ++AZ++ : should not be required, convert to SimSpan then use that
insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan
insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss'
  where
    lineStart = forestLineToGhcLine fl
    (_,(ForestLine _ _ _ le,_)) = ghcSrcSpanToForestSpan (GHC.RealSrcSpan ss)
    lineEnd   = forestLineToGhcLine (ForestLine ch tr v le)
    locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
    locEnd   = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd   (GHC.srcSpanEndCol ss)
    ss' = GHC.mkSrcSpan locStart locEnd

insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:" -- ++ (showGhc ss)

-- ---------------------------------------------------------------------

showSrcSpan :: GHC.SrcSpan -> String
showSrcSpan sspan = show (getGhcLoc sspan, (r,c))
  where
    (r,c) = getGhcLocEnd sspan

showSrcSpanF :: GHC.SrcSpan -> String
showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce))
  where
    ((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = ghcSrcSpanToForestSpan sspan
    -- chsn = if chs then 1 else 0
    -- chen = if che then 1 else 0


-- ---------------------------------------------------------------------


-- | Create a new name token. If 'useQual' then use the qualified
-- name, if it exists.
-- The end position is not changed, so the eventual realignment can
-- know what the difference in length in the token is
newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> GhcPosToken
newNameTok useQual l newName =
  ((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr)
  where
   newNameStr = if useQual then (showGhc newName)
                           else (GHC.occNameString $ GHC.getOccName newName)

   l' =  case l of
     GHC.RealSrcSpan ss ->
       let
         ((ForestLine _ _ _ startRow,startCol),_) = ghcSrcSpanToForestSpan l

         locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol
         locEnd   = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol)
       in
         GHC.mkSrcSpan locStart locEnd
     _ -> l

-- =====================================================================
-- Trying approach used in HSE version

-- ---------------------------------------------------------------------

ghcAllocTokens' :: GHC.ParsedSource-> [GhcPosToken] -> LayoutTree GhcPosToken
ghcAllocTokens' parsed toks = r
  where
    parsed' = sanitize parsed
    ss = allocTokensSrcSpans parsed'
    ss1 = (ghead "ghcAllocTokens" ss)
    ss2 = addEndOffsets ss1 toks
    ss3 = decorate ss2 toks

    ss4 = addLayout parsed ss3

    -- r = error $ "foo=" ++ show ss
    -- r = error $ "foo=" ++ drawTreeCompact (head ss)
    r = error $ "foo=" ++ drawTreeWithToks ss4
    -- r = undefined
    -- r = ss4

-- ---------------------------------------------------------------------

allocTokensSrcSpans :: Data a => a -> [LayoutTree GhcPosToken]
allocTokensSrcSpans modu = r
  where
    start :: [LayoutTree (GhcPosToken)] -> [LayoutTree (GhcPosToken)]
    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
    r = synthesizelStaged SYB.Parser [] [] redf (start `mkQ` bb
    --                        `extQ` localBinds
                           ) modu

    -- ends up as GenericQ (SrcSpanInfo -> LayoutTree TuToken)
    bb :: GHC.SrcSpan -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
    bb ss@(GHC.RealSrcSpan _) vv = [Node (Entry (gs2f ss) NoChange []) vv]
    bb ss vv = vv -- error $ "allocTokensSrcSpans:got weird ss:" ++ show ss

    -- --------------
{-
    localBinds :: GHC.HsLocalBinds GHC.RdrName -> [LayoutTree a] -> [LayoutTree a]
    localBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) vv = 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 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

        r = undefined
    localBinds _ vv = vv
-}
    -- --------------

    mergeSubs as bs = as ++ bs


    -- TODO: redf exists identically in the HSE version, harvest commonality
    redf :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
    redf [] b = b
    redf a [] = a

    redf [a@(Node e1@(Entry s1 l1 []) sub1)]  [b@(Node _e2@(Entry s2 l2 []) sub2)]
      =
        let
          (as,ae) = treeStartEnd a
          (bs,be) = 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),(f2ss $ treeStartEnd a,l1,length sub1)
                                                   ,(f2ss $ treeStartEnd b,l2,length sub2)
                                            --        , (as,ae,bs,be,ss)
                                                   ))

         -}
         ret

    redf new  old = error $ "bar2.redf:" ++ show (new,old)

-- ---------------------------------------------------------------------
-- | 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))

-- Staged version of synthesizel
synthesizelStaged :: SYB.Stage -> t -> s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t
synthesizelStaged stage zt z o f x
  | checkItemStage stage x = zt
  | otherwise = f x (foldl' o z (gmapQ ((synthesizelStaged stage zt) z o f) x))

-- ---------------------------------------------------------------------

-- | Checks whether the current item is undesirable for analysis in the current
-- AST Stage.
checkItemStage :: (Typeable a, Data a) => SYB.Stage -> a -> Bool
checkItemStage stage x = (checkItemStage1 stage x)
#if __GLASGOW_HASKELL__ > 704
                      || (checkItemStage2 stage x)
#endif

-- Check the Typeable items
checkItemStage1 :: (Typeable a) => SYB.Stage -> a -> Bool
checkItemStage1 stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x
  where nameSet     = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet       -> Bool
        postTcType  = const (stage < SYB.TypeChecker                  ) :: GHC.PostTcType    -> Bool
        fixity      = const (stage < SYB.Renamer                      ) :: GHC.Fixity        -> Bool

#if __GLASGOW_HASKELL__ > 704
-- | Check the Typeable1 items
checkItemStage2 :: Data a => SYB.Stage -> a -> Bool
checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x
  where
        hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool
#endif

-- ---------------------------------------------------------------------

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)


-- ---------------------------------------------------------------------
-- |sanitize the GHC ParsedSource by purging it of undefineds
-- These can occur in (at least one place)
--   HsCmdTop - last field
sanitize :: (Typeable a,Data a) => a -> a
sanitize t = r
  where
    r = everywhereStaged SYB.Parser (SYB.mkT cmdTopR `SYB.extT` cmdTopN
#if __GLASGOW_HASKELL__ > 704
                                    `SYB.extT` parStmt
#endif
                                    ) t

    cmdTopN :: GHC.HsCmdTop GHC.Name -> GHC.HsCmdTop GHC.Name
    cmdTopN (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ [])

    cmdTopR :: GHC.HsCmdTop GHC.RdrName -> GHC.HsCmdTop GHC.RdrName
    cmdTopR (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ [])

#if __GLASGOW_HASKELL__ > 704
    parStmt :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName
    parStmt (GHC.ParStmtBlock stmts _ typ) = (GHC.ParStmtBlock stmts [] typ)
#endif

-- ---------------------------------------------------------------------

-- TODO: These are duplicates of those in HaRe, we need one only,
-- hopefully can move to ghc-syb-utils

-- | Bottom-up transformation
everywhereStaged ::  SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged stage f x
  | checkItemStage stage x = x
  | otherwise = (f . gmapT (everywhereStaged stage f)) x

-- | Top-down version of everywhereStaged
everywhereStaged' ::  SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged' stage f x
  | checkItemStage stage x = x
  | otherwise = (gmapT (everywhereStaged stage f) . f) x

-- | Staged variation of SYB.everything
-- The stage must be provided to avoid trying to modify elements which
-- may not be present at all stages of AST processing.
-- Note: Top-down order
everythingStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ r -> SYB.GenericQ r
everythingStaged stage k z f x
  | checkItemStage stage x = z
  | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)

-- ---------------------------------------------------------------------

-- |Traverse the parsed source looking for points requiring layout,
-- and insert them into the LayoutTree at the appropriate point
addLayout :: GHC.ParsedSource -> LayoutTree GhcPosToken -> LayoutTree GhcPosToken
addLayout parsed tree = r
  where
    ztree = Z.fromTree tree

    [r] = everythingStaged SYB.Parser combine [tree] ([] `SYB.mkQ` lgrhs
                                    `SYB.extQ` lmatch
                                    ) parsed

    combine :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
    combine [] rs = rs
    combine ls [] = ls
    combine [l] [rt] = trace ("addLayout.combine1:" ++ show (rootLabel l,rootLabel rt)) [rt]
    combine ls rs = trace ("addLayout.combine2:" ++ show (ls,rs)) []

    lgrhs :: GHC.Located (GHC.GRHSs GHC.RdrName) -> [LayoutTree GhcPosToken]
    -- lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))) = tt
    lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds binds))) = tt
      where
        z = openZipperToSpan (gs2f l) ztree

        tt = trace ("lgrhs:z=" ++ show (Z.label z)) undefined
    lgrhs _ = []

    lmatch :: GHC.LMatch GHC.RdrName -> [LayoutTree GhcPosToken]
    -- lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))) = tt
    lmatch (GHC.L l (GHC.Match pats mtyp (GHC.GRHSs rhs (GHC.HsValBinds binds)) )) = tt
      where
        z = openZipperToSpan (gs2f l) ztree

        -- Need to get tokens, look for the where, and identify how it
        -- fits in

        -- tt = trace ("lmatch:z=" ++ show (Z.label z)) undefined
        -- tt = trace ("lmatch:z=" ++ show (Z.tree z)) undefined
        tt = trace ("lmatch:z=" ++ drawTreeWithToks (Z.tree z)) undefined
    lmatch _ = []

-- ---------------------------------------------------------------------

ghcLexStringToTokens :: SimpSpan -> String -> [GhcPosToken]
ghcLexStringToTokens startLoc str = r
  where
    rsl = case ss2gs startLoc of
            GHC.RealSrcSpan x -> GHC.realSrcSpanStart x
            _ -> undefined
    r = unsafePerformIO $ lexStringToRichTokens rsl str

-- ---------------------------------------------------------------------


lexStringToRichTokens :: GHC.RealSrcLoc -> String -> IO [GhcPosToken]
lexStringToRichTokens startLoc str = do
#if __GLASGOW_HASKELL__ > 704
  GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do
#else
  GHC.defaultErrorHandler GHC.defaultLogAction $ do
#endif
    GHC.runGhc (Just GHC.libdir) $ do
      dflags <- GHC.getSessionDynFlags
      let dflags' = foldl GHC.xopt_set dflags
                    [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash]
      _ <- GHC.setSessionDynFlags dflags'

      let res = GHC.lexTokenStream (GHC.stringToStringBuffer str) startLoc dflags'
      case res of
        GHC.POk _ toks -> return $ GHC.addSourceToTokens startLoc (GHC.stringToStringBuffer str) toks 
        GHC.PFailed _srcSpan _msg -> error $ "lexStringToRichTokens:" -- ++ (show $ GHC.ppr msg)




-- ---------------------------------------------------------------------

-- EOF