{
{-# OPTIONS -fglasgow-exts #-}

module ParseTree where

import Control.Arrow ((***))
import Data.Maybe (fromJust)

}

DATA ParseTree s w
  | Symbol  symbol : {s}
  | Branch  children : (ParseTrees {s} {w})
  | Unit    value : {w}         q : (ParseTree {s} {w})

DERIVING ParseTree: Show, Eq

TYPE ParseTrees s w = [ParseTree {s} {w}]

{

-- Smart constructor.

branch :: [ParseTree s w] -> ParseTree s w
branch [q] = q
branch qs = Branch qs


overwriteSymbols :: [t] -> ParseTree s w -> (ParseTree t w, [t])
overwriteSymbols ~ts@(t:ts') p = case p of
  Symbol _  -> (Symbol t, ts')
  Branch ps -> (Branch *** id) (overwriteManySymbols ts ps)
  Unit v q  -> (Unit v *** id) (overwriteSymbols ts q)

overwriteManySymbols :: [t] -> [ParseTree s w] -> ([ParseTree t w], [t])
overwriteManySymbols ts [] = ([], ts)
overwriteManySymbols ts (p:ps) = (q:qs, ts'')
  where
    (q, ts') = overwriteSymbols ts p
    (qs, ts'') = overwriteManySymbols ts' ps

-- Utils.

compute :: Symbol s => Int -> ParseTree s w -> Syn_ParseTree s w
compute off q = wrap_ParseTree (sem_ParseTree q) (Inh_ParseTree off (root q))


-- Zipper.

type QLoc s w = (ParseTree s w, QThread s w)

data QThread s w
  = QTRoot
  | QTUnit (QThread s w) w
  | QTBranch (QThread s w) [ParseTree s w] [ParseTree s w]
  deriving (Eq, Show)

root :: ParseTree s w -> QLoc s w
root q = (q, QTRoot)

type QNav s w = QLoc s w -> Maybe (QLoc s w)

down :: QNav s w
down (Branch (c:cs), t) = Just (c, QTBranch t [] cs)
down (Unit v c, t) = Just (c, QTUnit t v)
down _ = Nothing

up :: QNav s w
up (q, QTUnit p v) = Just (Unit v q, p)
up (q, QTBranch p ls rs) = Just (Branch (reverse ls ++ q : rs), p)
up _ = Nothing

left :: QNav s w
left (q, QTBranch p (l:ls) rs) = Just (l, QTBranch p ls (q:rs))
left _ = Nothing

right :: QNav s w
right (q, QTBranch p ls (r:rs)) = Just (r, QTBranch p (q:ls) rs)
right _ = Nothing

into :: Int -> QNav s w
into n loc = foldl (>>=) (down loc) (replicate n right)


-- Symbol

class Symbol a where
  symbolSize      :: a -> Int
  spaceBeforeSize :: a -> Int
  spaceAfterSize  :: a -> Int

instance Symbol Char where
  symbolSize '\t'   = 8
  symbolSize _      = 1
  spaceBeforeSize _ = 0
  spaceAfterSize  _ = 0

}


-- Source

ATTR ParseTree ParseTrees [ | | source : {[s]} ]

SEM ParseTree
  | Symbol  lhs.source = [@symbol]
  | Branch  lhs.source = @children.source

SEM ParseTrees
  | Nil     lhs.source = []
  | Cons    lhs.source = @hd.source ++ @tl.source


-- Left offset of outer range

ATTR ParseTree ParseTrees [ offset : Int | | ]

SEM ParseTrees
  | Cons    hd.offset  = @lhs.offset
            tl.offset  = snd @hd.innerRange


-- Inner and outer range

ATTR ParseTree ParseTrees [ | | innerRange : {Range}  outerRange : {Range} ]

SEM Symbol s => ParseTree
  | Symbol  loc.innerLeft = @lhs.offset + spaceBeforeSize @symbol
            loc.innerRight = @loc.innerLeft + symbolSize @symbol
            loc.outerRight = @loc.innerRight + spaceAfterSize @symbol
            lhs.outerRange = (@lhs.offset, @loc.outerRight)
            lhs.innerRange = (@loc.innerLeft, @loc.innerRight)

SEM Symbol s => ParseTrees
  | Nil     lhs.outerRange = undefined
            lhs.innerRange = undefined
  | Cons    lhs.outerRange = (@lhs.offset, snd (if @tl.nil then @hd.outerRange else @tl.outerRange))
            lhs.innerRange = (fst @hd.innerRange, snd (if @tl.nil then @hd.outerRange else @tl.outerRange))


-- Nil

ATTR ParseTrees [ | | nil : Bool ]

SEM ParseTrees
  | Nil   lhs.nil = True
  | Cons  lhs.nil = False


-- Size

ATTR ParseTree ParseTrees [ | | size : Int ]

SEM ParseTree
  | Symbol  lhs.size = symbolSize @symbol
  | Branch  lhs.size = @children.size

SEM ParseTrees
  | Cons    lhs.size = @hd.size + @tl.size
  | Nil     lhs.size = 0


-- Units

{
type Unit s w = (Range, [s], w)
type Range = (Int, Int)

inRange :: Range -> Range -> Bool
inRange (t0, t1) (s0, s1) = s0 <= t0 && t1 <= s1
}

ATTR ParseTree ParseTrees [ | | units : {[Unit s w]} ]

SEM ParseTree
  | Unit    lhs.units = ((@lhs.offset, @lhs.offset + @q.size), @q.source, @value) : @q.units
  | Symbol  lhs.units = []

SEM ParseTrees
  | Nil     lhs.units = []
  | Cons    lhs.units = @hd.units ++ @tl.units



-- Zipper

ATTR ParseTree ParseTrees [ zipper : {QLoc s w} | | ]

SEM ParseTree
  | Branch  children.zipper = (fromJust . down) @lhs.zipper
  | Unit    q.zipper = (fromJust . down) @lhs.zipper

SEM ParseTrees
  | Cons    hd.zipper = @lhs.zipper
            tl.zipper = (fromJust . right) @lhs.zipper


-- Select

ATTR ParseTree ParseTrees [ | | select : {Range -> [QLoc s w]} ]

SEM ParseTree
  | Symbol  lhs.select = const []
  | Branch  lhs.select = @children.select
  | Unit    lhs.select = \t@(t0, t1) ->
                            let (o0, o1) = @q.outerRange
                                (i0, i1) = @q.innerRange
                             in if o0 <= t0 && t0 <= i0 && i1 <= t1 && t1 <= o1
                                  then [@lhs.zipper]
                                  else []
                                ++ @q.select t

SEM ParseTrees
  | Nil     lhs.select = const []
  | Cons    lhs.select = \r ->
                          case (r `inRange` @hd.outerRange, r `inRange` @tl.outerRange) of
                            (True, _)       -> @hd.select r
                            (False, True)   -> @tl.select r
                            (False, False)  -> []