{-# Language MultiParamTypeClasses #-}
{-# Language FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module Language.Haskell.TokenUtils.HSE.Layout
  (
    loadFile
  , loadFileWithMode
  , templateHaskellMode
  , TuToken(..)
  , s2ss
  , ss2s
  ) where

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

import Language.Haskell.Exts.Annotated

import Language.Haskell.TokenUtils.Types
import Language.Haskell.TokenUtils.Utils

-- import SrcExtsKure

import Debug.Trace

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

-- parseFileContentsWithComments :: ParseMode -> String -> ParseResult (Module, [Comment])

-- Parse a source file from a string using a custom parse mode and retaining comments. 

data TuToken = T Token | C Comment
             deriving (Show,Eq)

-- |Load a file using 'haskell-src-exts' to provide both the AST and tokens
loadFile :: FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))
loadFile file = loadFileWithMode defaultParseMode file

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

-- |Load a file using 'haskell-src-exts' to provide both the AST and
-- tokens, using a custom loading mode allowing extensions to be
-- enabled
loadFileWithMode :: ParseMode -> FilePath -> IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))
loadFileWithMode parseMode file = do
  src <- readFile file
  let mtoks = lexTokenStream src
  let res = case parseFileContentsWithComments parseMode src of
              ParseOk (modu,comments) -> case mtoks of
                ParseOk toks -> ParseOk (modu,comments,toks)
                ParseFailed l s -> ParseFailed l s
              ParseFailed l s -> ParseFailed l s
  case res of
    ParseOk (m, comments,toks) -> return $ ParseOk (m, (mergeToksAndComments toks comments))
    ParseFailed l s -> return (ParseFailed l s)

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

templateHaskellMode :: ParseMode
templateHaskellMode
  = defaultParseMode { extensions = (EnableExtension TemplateHaskell):(extensions defaultParseMode)}


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

mergeToksAndComments :: [Loc Token] -> [Comment] -> [Loc TuToken]
mergeToksAndComments toks comments = go toks comments
  where
    tokToTu (Loc l t) = Loc l (T t)
    commentToTu c@(Comment _ l _) = Loc l (C c)

    go :: [Loc Token] -> [Comment] -> [Loc TuToken]
    go ts [] = map tokToTu ts
    go [] cs = map commentToTu cs
    go (ht:ts) (hc@(Comment _ l _):cs)
      = if loc ht < l
          then tokToTu ht : go ts (hc:cs)
          else commentToTu hc : go (ht:ts) cs

-- tf :: IO (ParseResult (Module SrcSpanInfo, [Loc TuToken]))
-- tf = loadFile "../test/testdata/Layout/LetExpr.hs"

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

instance IsToken (Loc TuToken) where
  -- getSpan a = ss2s $ loc a
  -- putSpan (Loc _ss v) s = Loc (s2ss s) v

  tokenLen (Loc l (T t)) = hseTokenLen (Loc l t)
  tokenLen (Loc _l (C (Comment _ _ s))) = length s -- beware of newlines

  isComment (Loc _ (C _)) = True
  isComment _ = False

  -- No empty tokens in HSE
  isEmpty _ = False

  mkZeroToken = (Loc (s2ss ((0,0),(0,0))) (T (VarId "")))

  isDo (Loc _ (T KW_Do))  = True
  isDo (Loc _ (T KW_MDo)) = True
  isDo _                  = False

  isElse (Loc _ (T KW_Else))  = True
  isElse _                    = False

  isIn (Loc _ (T KW_In))  = True
  isIn _                  = False

  isLet (Loc _ (T KW_Let))  = True
  isLet _                   = False

  isOf (Loc _ (T KW_Of))  = True
  isOf _                  = False

  isThen (Loc _ (T KW_Then)) = True
  isThen _                   = False

  isWhere (Loc _ (T KW_Where)) = True
  isWhere _                    = False

  tokenToString   = hseTokenToString
  showTokenStream = hseShowTokenStream
  lexStringToTokens = hseLexStringToTokens

  markToken = assert False undefined
  isMarked  = assert False undefined

instance HasLoc (Loc a) where
  getLoc = getLoc . loc
  getLocEnd = getLocEnd . loc

  putSpan (Loc l v) ns = (Loc (putSpan l ns) v)

instance HasLoc SrcSpan where
  getLoc    (SrcSpan _  sl  sc _el _ec) = (sl,sc)
  getLocEnd (SrcSpan _ _sl _sc  el  ec) = (el,ec)

  putSpan _ ss = s2ss ss

ss2s :: SrcSpan -> SimpSpan
ss2s (SrcSpan _fn sr sc er ec) = ((sr,sc),(er,ec))

s2ss :: SimpSpan -> SrcSpan
s2ss ((sr,sc),(er,ec)) = (SrcSpan "<unknown>" sr sc er ec)

s2f :: SrcSpan -> ForestSpan
s2f = ss2f . ss2s

f2s :: ForestSpan -> SrcSpan
f2s = s2ss .f2ss

-- |Return the length of the token, using the string representation
-- where possible as it may have changed during a refactoing.
hseTokenLen :: Loc Token -> Int
hseTokenLen (Loc _ t) = length (showToken' t)

hseTokenToString :: Loc TuToken -> String
hseTokenToString (Loc _ (C (Comment True _ s))) = "{-" ++ s ++ "-}"
hseTokenToString (Loc _ (C (Comment False _ s))) = "--" ++ s
hseTokenToString (Loc _ (T tok)) = showToken' tok


{-
data Comment

  A Haskell comment. The Bool is True if the comment is multi-line, i.e. {- -}.

  Constructors
    Comment Bool SrcSpan String
-}

hseShowTokenStream :: [Loc TuToken] -> String
hseShowTokenStream ts2 = (go startLoc ts2 "") ++ "\n"
    where startLoc =  (1,1)
          go _ [] = id
          go (locLine,locCol) (tok@(Loc ss _):ts1)
              = case ss of
                SrcSpan _ tokLine tokCol er ec
                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
                                       . (str ++)
                                       . go tokEnd ts1
                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
                              . ((replicate (tokCol - 1) ' ') ++)
                              . (str ++)
                              . go tokEnd ts1
                  where tokEnd = (er,ec)
                        str = tokenToString tok

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

hseLexStringToTokens :: SimpSpan -> String -> [Loc TuToken]
hseLexStringToTokens startLoc str = r
  where
    -- lexTokenStream :: String -> ParseResult [Loc Token]
    mtoks = lexTokenStream str
    r = case mtoks of
          ParseOk toks -> addOffsetToToks offset $ mergeToksAndComments toks []
             where
               ((sr,sc),_) = startLoc
               offset = (sr - 1, sc - 1)
          ParseFailed _l _s -> []

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

-- This function is copied here from haskell-src-exts
-- module Language.Haskell.Exts.InternalLexer until issue
-- https://github.com/haskell-suite/haskell-src-exts/issues/119 is
-- resolved

------------------------------------------------------------------
-- "Pretty" printing for tokens

showToken' :: Token -> String
showToken' t = case t of
  VarId s           -> s
  QVarId (q,s)      -> q ++ '.':s
  IDupVarId s       -> '?':s
  ILinVarId s       -> '%':s
  ConId s           -> s
  QConId (q,s)      -> q ++ '.':s
  DVarId ss         -> concat $ intersperse "-" ss
  VarSym s          -> s
  ConSym s          -> s
  QVarSym (q,s)     -> q ++ '.':s
  QConSym (q,s)     -> q ++ '.':s
  IntTok (_, s)         -> s
  FloatTok (_, s)       -> s
  Character (_, s)      -> '\'':s ++ "'"
  StringTok (_, s)      -> '"':s ++ "\""
  IntTokHash (_, s)     -> s ++ "#"
  WordTokHash (_, s)    -> s ++ "##"
  FloatTokHash (_, s)   -> s ++ "#"
  DoubleTokHash (_, s)  -> s ++ "##"
  CharacterHash (_, s)  -> '\'':s ++ "'#"
  StringHash (_, s)     -> '"':s ++ "\"#"
  LeftParen         -> "("
  RightParen        -> ")"
  LeftHashParen     -> "(#"
  RightHashParen    -> "#)"
  SemiColon         -> ";"
  LeftCurly         -> "{"
  RightCurly        -> "}"
  VRightCurly       -> "virtual }"
  LeftSquare        -> "["
  RightSquare       -> "]"
  Comma             -> ","
  Underscore        -> "_"
  BackQuote         -> "`"
  Dot               -> "."
  DotDot            -> ".."
  Colon             -> ":"
  DoubleColon       -> "::"
  Equals            -> "="
  Backslash         -> "\\"
  Bar               -> "|"
  LeftArrow         -> "<-"
  RightArrow        -> "->"
  At                -> "@"
  Tilde             -> "~"
  DoubleArrow       -> "=>"
  Minus             -> "-"
  Exclamation       -> "!"
  Star              -> "*"
  LeftArrowTail     -> ">-"
  RightArrowTail    -> "-<"
  LeftDblArrowTail  -> ">>-"
  RightDblArrowTail -> "-<<"
  THExpQuote        -> "[|"
  THPatQuote        -> "[p|"
  THDecQuote        -> "[d|"
  THTypQuote        -> "[t|"
  THCloseQuote      -> "|]"
  THIdEscape s      -> '$':s
  THParenEscape     -> "$("
  THVarQuote        -> "'"
  THTyQuote         -> "''"
  THQuasiQuote (n,q) -> "[$" ++ n ++ "|" ++ q ++ "]"
  RPGuardOpen       -> "(|"
  RPGuardClose      -> "|)"
  RPCAt             -> "@:"
  XCodeTagOpen      -> "<%"
  XCodeTagClose     -> "%>"
  XStdTagOpen       -> "<"
  XStdTagClose      -> ">"
  XCloseTagOpen     -> "</"
  XEmptyTagClose    -> "/>"
  XPCDATA s         -> "PCDATA " ++ s
  XRPatOpen         -> "<["
  XRPatClose        -> "]>"
  PragmaEnd         -> "#-}"
  RULES             -> "{-# RULES"
  INLINE b          -> "{-# " ++ if b then "INLINE" else "NOINLINE"
  INLINE_CONLIKE    -> "{-# " ++ "INLINE_CONLIKE"
  SPECIALISE        -> "{-# SPECIALISE"
  SPECIALISE_INLINE b -> "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE"
  SOURCE            -> "{-# SOURCE"
  DEPRECATED        -> "{-# DEPRECATED"
  WARNING           -> "{-# WARNING"
  SCC               -> "{-# SCC"
  GENERATED         -> "{-# GENERATED"
  CORE              -> "{-# CORE"
  UNPACK            -> "{-# UNPACK"
  OPTIONS (mt,_s)   -> "{-# OPTIONS" ++ maybe "" (':':) mt ++ " ..."
--  CFILES  s         -> "{-# CFILES ..."
--  INCLUDE s         -> "{-# INCLUDE ..."
  LANGUAGE          -> "{-# LANGUAGE"
  ANN               -> "{-# ANN"
  KW_As         -> "as"
  KW_By         -> "by"
  KW_Case       -> "case"
  KW_Class      -> "class"
  KW_Data       -> "data"
  KW_Default    -> "default"
  KW_Deriving   -> "deriving"
  KW_Do         -> "do"
  KW_MDo        -> "mdo"
  KW_Else       -> "else"
  KW_Family     -> "family"
  KW_Forall     -> "forall"
  KW_Group      -> "group"
  KW_Hiding     -> "hiding"
  KW_If         -> "if"
  KW_Import     -> "import"
  KW_In         -> "in"
  KW_Infix      -> "infix"
  KW_InfixL     -> "infixl"
  KW_InfixR     -> "infixr"
  KW_Instance   -> "instance"
  KW_Let        -> "let"
  KW_Module     -> "module"
  KW_NewType    -> "newtype"
  KW_Of         -> "of"
  KW_Proc       -> "proc"
  KW_Rec        -> "rec"
  KW_Then       -> "then"
  KW_Type       -> "type"
  KW_Using      -> "using"
  KW_Where      -> "where"
  KW_Qualified  -> "qualified"
  KW_Foreign    -> "foreign"
  KW_Export     -> "export"
  KW_Safe       -> "safe"
  KW_Unsafe     -> "unsafe"
  KW_Threadsafe -> "threadsafe"
  KW_Interruptible -> "interruptible"
  KW_StdCall    -> "stdcall"
  KW_CCall      -> "ccall"
  XChildTagOpen -> "<%>"
  KW_CPlusPlus  -> "cplusplus"
  KW_DotNet     -> "dotnet"
  KW_Jvm        -> "jvm"
  KW_Js         -> "js"
  KW_CApi       -> "capi"

  EOF           -> "EOF"


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

-- |This instance is the purpose of this module
instance Allocatable (Module SrcSpanInfo) (Loc TuToken) where
  allocTokens = hseAllocTokens


hseAllocTokens :: Module SrcSpanInfo -> [Loc TuToken] -> LayoutTree (Loc TuToken)
hseAllocTokens modu toks = r
  where
    ss = allocTokens' modu
    ss1 = (ghead "hseAllocTokens" ss)
    ss2 = addEndOffsets ss1 toks
    ss3 = decorate ss2 toks
    -- r = error $ "foo=" ++ show ss2
    -- r = error $ "foo=" ++ drawTreeCompact (Node nullSpan ss)
    -- r = error $ "foo=" ++ drawForestEntry ss
    -- r = error $ "foo toks=" ++ show toks
    -- r = error $ "foo modu=" ++ show modu
    r = ss3


-- ---------------------------------------------------------------------
{- moved to TokenUtils.Utils
-- Allocate all the tokens to the given tree
decorate :: LayoutTree (Loc TuToken) -> [Loc TuToken] -> LayoutTree (Loc TuToken)
decorate tree toks = go toks tree
  where
    go :: [Loc TuToken] -> LayoutTree (Loc TuToken) -> LayoutTree (Loc TuToken)
    go ts (Node e subs) = (Node e subs'')
      where
        -- b = map (\t -> let f = treeStartEnd t in (getLoc f, getLocEnd f)) subs

        doOne :: ([Loc TuToken],[LayoutTree (Loc TuToken)]) -> LayoutTree (Loc TuToken) -> ([Loc TuToken],[LayoutTree (Loc TuToken)])
        doOne (ts1,acc) tree1 = (ts1',acc')
          where
            ss = treeStartEnd tree1
            (before,middle,after) = splitToksIncComments (getLoc ss,getLocEnd ss) ts1
            ts1' = after
            tree' = case tree1 of
              Node (Entry ss1 lo []) [] -> [Node (Entry ss1 lo middle) []]
              _ -> [go middle tree1]
            acc' = acc ++ makeLeafFromToks before ++ tree'

        (end,subs') = foldl' doOne (ts,[]) subs
        -- (end,subs') = doOne (ts,[]) (head subs)
        subs'' = subs' ++ makeLeafFromToks end

    -- go ts tr = error $ "decorate:not processing :" ++ show (ts,tr)
-}

-- ---------------------------------------------------------------------
{-
Notes re HSE let binds

data Exp l
    ....
    | Let l (Binds l) (Exp l)               -- ^ local declarations with @let@ ... @in@ ...

instance ExactP Exp where
  exactP exp = case exp of
    .....
    Let l bs e      ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "let"
            exactPC bs
            printStringAt (pos b) "in"
            exactPC e
         _ -> errorEP "ExactP: Exp: Let is given wrong number of srcInfoPoints"
    ....
    Case l e alts   ->
        case srcInfoPoints l of
         a:b:pts -> do
            printString "case"
            exactPC e
            printStringAt (pos b) "of"
            layoutList pts alts
         _ -> errorEP "ExactP: Exp: Case is given too few srcInfoPoints"
    Do l stmts      ->
        case srcInfoPoints l of
         a:pts -> do
            printString "do"
            layoutList pts stmts
         _ -> errorEP "ExactP: Exp: Do is given too few srcInfoPoints"
    MDo l stmts     ->
        case srcInfoPoints l of
         a:pts -> do
            printString "mdo"
            layoutList pts stmts
         _ -> errorEP "ExactP: Exp: Mdo is given wrong number of srcInfoPoints"

Need let/in
     where
     do
     case
-}

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

-- allocTokens' :: Module SrcSpanInfo -> [LayoutTree (Loc TuToken)]
allocTokens' :: Data a => a -> [LayoutTree (Loc TuToken)]
allocTokens' modu = r
  where
    start :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    start old = old

    -- r = synthesize [] redf (start `mkQ` bb
    -- NOTE: the token re-alignement needs a left-biased tree, not a right-biased one, hence synthesizel
    r = synthesizel [] redf (start `mkQ` bb
                           `extQ` letExp
                           `extQ` expr
                           `extQ` match
                           `extQ` bind
                           `extQ` decl
                           `extQ` stmt
                           ) modu


    -- ends up as GenericQ (SrcSpanInfo -> LayoutTree TuToken)
    bb :: SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    bb (SrcSpanInfo ss _sss) vv = [Node (Entry (s2f ss) NoChange []) vv]

    letExp :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    letExp (Let l@(SrcSpanInfo ss _) _bs _e) vv =
        case srcInfoPoints l of
          [letPos,inPos] ->
            let
              (letStart, _letEnd) = ss2s letPos
              (_inStart, inEnd)   = ss2s inPos
              io = FromAlignCol letStart
              (lstart, lend) = ss2s ss
              eo = FromAlignCol inEnd
            in
               -- trace ("let:" ++ show (ss,map treeStartEnd (subTreeOnly vv)))
               [Node (Entry (s2f ss) (Above io lstart lend eo) []) [(makeGroup vv)]]
          _ -> vv
    letExp _ vv = vv

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

    expr :: Exp SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    expr (Do l@(SrcSpanInfo _ss _) stmts) vv =
      case srcInfoPoints l of
        (doPos:_) ->
          let
            (doStart, _doEnd) = ss2s doPos
            io = FromAlignCol doStart
            s = makeSpanFromTrees subs
            (lstart, lend) = f2ss s
            eo = None -- will be calculated later
            subs = concatMap allocTokens' stmts
          in
             -- trace ("do:" ++ show (ss,map treeStartEnd (subTreeOnly vv),srcInfoPoints l))
             [makeGroup [Node (Entry (s2f doPos) NoChange []) [],
                         Node (Entry s (Above io lstart lend eo) []) subs]]
        _ -> vv

    expr _ vv = vv

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

    match :: Match SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    match (InfixMatch l@(SrcSpanInfo ss _) pat name pats rhs mWhere) vv = vv
    match (Match l@(SrcSpanInfo _ss _) fname pats rhs mWhere) _vv =
      let
        treeName = allocTokens' fname
        treePats = allocTokens' pats
        treeRhs  = subTreeOnly (allocTokens' rhs)
        treeWhereClause = case mWhere of
          (Just bd@(BDecls (SrcSpanInfo _bs _) _)) -> [makeGroup (treeWhere ++ treeDecls)]
            where
              wherePos = ghead "redf.match" (srcInfoPoints l)
              treeWhere = [Node (Entry (s2f wherePos) NoChange []) [] ]
              treeSubDecls = subTreeOnly (allocTokens' bd)
              treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]
              s = makeSpanFromTrees treeSubDecls
              (lstart, lend) = f2ss s

              (whereStart, _whereEnd) = ss2s wherePos
              io = FromAlignCol whereStart
          Just (IPBinds l binds) -> []
          Nothing -> []
        -- (Span start end) = ss2s ss
        -- (Span start end) = ss2s bs
        eo = None -- will be calculated later FromAlignCol (0,0)
        subs = treeName ++ treePats ++ treeRhs ++ treeWhereClause

      in
         -- trace ("match:" ++ show (ss,map treeStartEnd subs))
         [makeGroup subs]


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

    bind :: Binds SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    bind (BDecls  (SrcSpanInfo _ss _) bs) _vv =
      let
        -- TODO: properly calculate `so` and `eo`
        -- ro = 0
        -- co = 0
        -- so = makeOffset ro co
        -- (Span start end) = ss2s ss
        -- eo = FromAlignCol (1,-39)
        -- eo = None -- will be added later
        -- vv' = case vv of
        --  [Node (Entry fss _ _) sub] ->
        --    if fss == (sf $ ss2s ss) then sub else vv
        --  _ -> vv
        subs = concatMap allocTokens' bs

      in
        -- trace ("binds:BDecls" ++ show (ss, map treeStartEnd subs))
        [makeGroup subs]
    bind (IPBinds l@(SrcSpanInfo ss _) bs) vv = vv

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

    decl :: Decl SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    decl (FunBind (SrcSpanInfo _ss _) matches) _vv =
      let
        subs = concatMap allocTokens' matches
      in
        -- trace ("decl:FunBind" ++ show (ss, map treeStartEnd subs))
        [makeGroup subs]

    --  PatBind      l (Pat l) (Rhs l) {-where-} (Maybe (Binds l))
    decl (PatBind   (SrcSpanInfo _  _) _        _    Nothing) vv = vv
    decl (PatBind l@(SrcSpanInfo _ss _) pat rhs (Just bd@(BDecls (SrcSpanInfo _bs _) _))) vv =
      case srcInfoPoints l of
        (wherePos:_) ->
          let
            treePat  = allocTokens' pat
            -- treeType = allocTokens' mtyp
            treeRhs  = allocTokens' rhs
            treeWhereClause = [makeGroup (treeWhere ++ treeDecls)]
              where
                treeWhere = [Node (Entry (s2f wherePos) NoChange []) [] ]
                treeSubDecls = subTreeOnly (allocTokens' bd)
                treeDecls = [makeGroupLayout (Above io lstart lend eo) treeSubDecls]
                s = makeSpanFromTrees treeSubDecls
                (lstart,lend) = f2ss s
            (whereStart,_whereEnd) = ss2s wherePos
            io = FromAlignCol whereStart
            eo = None -- will be calculated later FromAlignCol (0,0)
            subs = treePat ++ treeRhs ++ treeWhereClause
          in
             -- trace ("decl:patBind:" ++ show (ss))
             [makeGroup subs]

        _ -> vv

    decl _ vv = vv

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

    stmt :: Stmt SrcSpanInfo -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    stmt (LetStmt l@(SrcSpanInfo _ss _) _binds) vv =
      case srcInfoPoints l of
        (letPos:_) ->
          let
            (letStart, _letEnd) = ss2s letPos
            io = FromAlignCol letStart
            (lstart, lend) = f2ss $ makeSpanFromTrees (subTreeOnly vv)

            eo = None -- will be calculated later
          in
             -- trace ("stmt:LetStmt:" ++ show (ss,map treeStartEnd (subTreeOnly vv),srcInfoPoints l))
             [makeGroup [Node (Entry (s2f letPos) NoChange []) [],
                         makeGroupLayout (Above io lstart lend eo) (subTreeOnly vv)]]
        _ -> error $ "allocTokens'.stmt:LetStmt:missing statements:" ++ show (l,_binds)
        -- _ -> vv

    stmt _ vv = vv

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

    mergeSubs as bs = as ++ bs

    redf :: [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)] -> [LayoutTree (Loc TuToken)]
    redf [] b = b
    redf a [] = a

    redf [a@(Node e1@(Entry s1 l1 []) sub1)]  [b@(Node _e2@(Entry s2 l2 []) sub2)]
      =
        let
          (as,ae) = 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),(fs $ treeStartEnd a,l1,length sub1)
                                                   ,(fs $ treeStartEnd b,l2,length sub2)
                                                   ,(fs $ treeStartEnd (head ret),lr)))
         -}
         ret

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


-- synthesize :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t
-- synthesize z o f

-- Bottom-up synthesis of a data structure;
--  1st argument z is the initial element for the synthesis;
--  2nd argument o is for reduction of results from subterms;
--  3rd argument f updates the synthesised data according to the given term

-- synthesize :: s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t
-- synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))

-- foldr :: (b -> a -> a) -> a -> [b] -> a
-- foldl :: (a -> b -> a) -> a -> [b] -> a


-- | Bottom-up synthesis of a data structure;
--   1st argument z is the initial element for the synthesis;
--   2nd argument o is for reduction of results from subterms;
--   3rd argument f updates the synthesised data according to the given term
--
synthesizel :: s  -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t
synthesizel z o f x = f x (foldl o z (gmapQ (synthesizel z o f) x))

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

instance Monoid Layout where
  mempty = NoChange

  mappend NoChange NoChange = NoChange
  mappend NoChange x = x
  mappend x NoChange = x
  mappend (Above bo1 ps1 pe1 eo1) (Above bo2 ps2 pe2 eo2)
    = (Above bo ps pe eo)
      where
        (bo,ps) = if ps1 <= ps2 then (bo1,ps1)
                                else (bo2,ps2)

        (eo,pe) = if pe1 >= pe2 then (eo1,pe1)
                                else (eo2,pe2)



-- nullSpan :: SrcSpan
-- nullSpan = (SrcSpan "" 0 0 0 0)

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