{-# LANGUAGE FlexibleContexts #-}

module BoundsParser where

import Generics.Annotations.Yield
import Control.Monad.Trans

import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import Generics.MultiRec hiding (show)

import Debug.Trace
import Data.Function


-- | A structural selection expressed as a textual selection. The margins indicate the whitespace directly around the selected structure.
data  Bounds        = Bounds { leftMargin :: Range, rightMargin :: Range }
  deriving (Eq, Show)

-- | A simple textual selection: starting offset and ending offset, respectively. Offsets are 0-based.
type  Range         = (Int, Int)  -- left, right

-- | Symbols form input for parsers. Minimal complete definition: 'unparse'.
class Symbol s where
  -- | Unparses a symbol, converting it back to text.
  unparse :: s -> String

  -- | Yields the size of a symbol. Default implementation is @length . unparse@.
  symbolSize :: s -> Int
  symbolSize = length . unparse

instance Symbol s => Symbol [s] where
  unparse = concatMap unparse
  symbolSize = sum . fmap symbolSize

-- | Given a predicate that tells what tokens to discard, keeps only the meaningful tokens and couples them with position information.
collapse :: Symbol s => (s -> Bool) -> [s] -> [(s, Bounds)]
collapse space ts = collapse' (0, symbolSize lefts) space rest
  where
    (lefts, rest) = span space ts

collapse' :: Symbol s => Range -> (s -> Bool) -> [s] -> [(s, Bounds)]
collapse' _ _ [] = []
collapse' left space (t:ts) = new : collapse' right space rest
  where
    (_, leftInner)  = left
    rightInner      = leftInner   + symbolSize t
    rightOuter      = rightInner  + symbolSize rights
    right           = (rightInner, rightOuter)
    (rights, rest)  = span space ts
    new             = (t, Bounds left right)

-- | A parser that works on symbols coupled with token information. The state maintains the current position in the stream. This position is between two tokens; it is a range because there might be whitespace between these two tokens.
type P s = P.ParsecT [(s, Bounds)] Range

-- | Yield the current position in the input.
getPos :: Monad m => P s m Range
getPos = P.getState

-- | Recognise a symbol matching a predicate.
satisfy :: (Monad m, Symbol s) => (s -> Bool) -> P s m s
satisfy ok = do
  let pos _ (_, bounds) _ = P.newPos "" 0 (fst (rightMargin bounds) + 1)
  let match x@(tok, _)
        | ok tok    = Just x
        | otherwise = Nothing
  (tok, bounds) <- P.tokenPrim (unparse . fst) pos match
  P.setState (rightMargin bounds)
  return tok

-- | Recognise a specific symbol.
pToken :: (Monad m, Symbol s, Eq s) => s -> P s m s
pToken = satisfy . (==)


type YP s fam m = P s (YieldT Bounds fam m)

unit :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m) =>
  fam a ->
  YP s fam m a ->
  YP s fam m a
unit w p = do
  left <- getPos
  x <- p
  mkBounded w left x

mkBounded :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m) => fam a -> Range -> a -> YP s fam m a
mkBounded w left x = do
  right <- getPos
  lift $ yield w (Bounds left right) x

chainl :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m, Show a) =>
  fam a ->
  YP s fam m a ->
  YP s fam m (a -> a -> a) ->
  YP s fam m a
chainl w px pf = do
  left <- getPos
  let rest x = P.option x $ do
        f <- pf
        y <- px
        let z = f x y
        mkBounded w left z
        rest z
  x <- px
  rest x

chainr :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m, Show a) =>
  fam a ->
  YP s fam m a ->
  YP s fam m (a -> a -> a) ->
  YP s fam m a
chainr w px pf = fix $ \loop -> do
  left <- getPos
  x <- px
  P.option x $ do
    f <- pf
    y <- loop
    mkBounded w left (f x y)

traceM :: Monad m => String -> m ()
traceM msg = trace msg (return ())

traceShowM :: (Show a, Monad m) => a -> m ()
traceShowM x = traceM (show x)