module Annotations.F.ParserCombinators (
    -- * Parser combinators for bounds parsers
    mkBounded, unit, chainr, chainl
  ) where

import Annotations.Bounds
import Annotations.BoundsParser
import Annotations.F.Annotated

import qualified Text.Parsec as P

import Data.Function

import Debug.Trace

-- | Given the left margin of a structure, asks the parser for the right
--   margin and wraps the position information around the root of the tree.
mkBounded :: (Monad m, Show s) => (Range, [s], [s]) -> AnnFix1 (Bounds s) f -> P s m (AnnFix (Bounds s) f)
mkBounded (left, strl, bs) x = do -- (\right -> mkAnnFix (Bounds left right) x) <$> getPos
  (right, strl', bs') <- getPos
  return (mkAnnFix (Bounds (take (length strl - length strl') strl) bs) x)

-- | Wrap an unnotated tree with position information from the parse state.
unit :: (Monad m, Show s) => P s m (AnnFix1 (Bounds s) f) -> P s m (AnnFix (Bounds s) f)
unit p = do
  left <- getPos
  x <- p
  mkBounded left x

-- | Parse right-recursive structures.
chainr :: (Monad m, Show s) => P s m (AnnFix (Bounds s) f) ->
  P s m (AnnFix (Bounds s) f -> AnnFix (Bounds s) f -> AnnFix1 (Bounds s) f) -> P s m (AnnFix (Bounds s) f)
chainr px pf = fix $ \loop -> do
  left <- getPos
  x <- px
  P.option x $ do
    f <- pf
    y <- loop
    mkBounded left (f x y)

-- | Parse left-recursive structures.
chainl :: (Monad m, Show s) => P s m (AnnFix (Bounds s) f) ->
  P s m (AnnFix (Bounds s) f -> AnnFix (Bounds s) f -> AnnFix1 (Bounds s) f) -> P s m (AnnFix (Bounds s) f)
chainl px pf = do
    left <- getPos
    px >>= rest left
  where
    rest left = fix $ \loop x -> P.option x $ do
      f <- pf
      y <- px
      mkBounded left (f x y) >>= loop