{-# LANGUAGE TypeOperators #-}

module BoundsParser (Range, Bounds(..), contains, searchRange, getLeftBounds, getRightBounds, mkBounded, chainl, chainr, unit) where

import Annotations
import Token

import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as PP

import Data.Function

-- Invariant: Parsec position equals left side of outer range.
-- Maybe later: Parsec position equals left side of inner range? Will yield nicer error messages, but is troublesome for first token.

-- Some types

-- | A text selection: (start, end), 0-relative. The size of a range is defined as @end - start@.
type Range = (Int, Int)

-- | Bounds of a subexpression. The outer bounds exclude whitespace while the inner bounds don't.
data Bounds = Bounds { outerBounds :: Range, innerBounds :: Range }
  deriving (Eq, Show)

-- -- | A functor recursively annotated with bounds.
-- type Ann Bounds f = AnnFix Bounds f
-- 
-- -- | A recursively annotated functor, except for the top level.
-- type Ann1 Bounds f = f (Ann Bounds f)

type LeftBounds = (Int, Int)
type RightBounds = (Int, Int)

-- | Check whether the second range completely contains the first range.
contains :: Range -> Range -> Bool
contains (outer0, outer1) (inner0, inner1) = outer0 <= inner0 && inner1 <= outer1

-- | Provides search hints for bound annotations based on a query range.
searchRange :: Range -> Bounds -> SearchHint
searchRange query bounds
  | outerBounds bounds `contains` query &&
      query `contains` innerBounds bounds   = Here
  | innerBounds bounds `contains` query     = Down
  | otherwise                               = Skip

mkBounded :: (Symbol t, Show t, P.Stream s m t) => LeftBounds -> Ann1 Bounds f -> P.ParsecT s u m (Ann Bounds f)
mkBounded lb x = do
  rb <- getRightBounds
  return (mkAnn (mkBounds lb rb) x)

-- -- | Given a parser that produces a tree, annotate the result with bounds if necessary.
-- mark :: (Symbol t, Show t, P.Stream s m t) =>
--   P.ParsecT s u m (Ann Bounds f `Either` Ann1 Bounds f) -> P.ParsecT s u m (Ann Bounds f)
-- mark p = do
--   leftBounds <- getLeftBounds
--   eith <- p
--   case eith of
--     Left wf   -> return wf
--     Right fwf -> mkBounded leftBounds fwf

unit :: (Symbol t, Show t, P.Stream s m t) => P.ParsecT s u m (Ann1 Bounds f) -> P.ParsecT s u m (Ann Bounds f)
unit px = do
  lb <- getLeftBounds
  px >>= mkBounded lb

-- | Parse right-recursive structures.
chainr :: (Symbol t, Show t, P.Stream s m t) => P.ParsecT s u m (Ann Bounds f) ->
  P.ParsecT s u m (Ann Bounds f -> Ann Bounds f -> Ann1 Bounds f) -> P.ParsecT s u m (Ann Bounds f)
chainr px pf = fix $ \loop -> do
  lb <- getLeftBounds
  x <- px
  P.option x $ do
    f <- pf
    y <- loop
    mkBounded lb (f x y)

-- | Parse left-recursive structures.
chainl :: (Symbol t, Show t, P.Stream s m t) => P.ParsecT s u m (Ann Bounds f) ->
  P.ParsecT s u m (Ann Bounds f -> Ann Bounds f -> Ann1 Bounds f) -> P.ParsecT s u m (Ann Bounds f)
chainl px pf = do
    lb <- getLeftBounds
    px >>= rest lb
  where
    rest lb = fix $ \loop x -> P.option x $ do
      f <- pf
      y <- px
      mkBounded lb (f x y) >>= loop

getLeftBounds :: (Show t, P.Stream s m t, Symbol t) => P.ParsecT s u m LeftBounds
getLeftBounds = do
  leftOuter <- getOffset
  Just la <- lookAhead1
  let leftInner = leftOuter + spaceBeforeSize la
  return (leftOuter, leftInner)

getRightBounds :: (Show t, P.Stream s m t, Symbol t) => P.ParsecT s u m RightBounds
getRightBounds = do
  rightInner <- getOffset
  mla <- lookAhead1
  let rightOuter = case mla of
        Nothing -> rightInner
        Just la -> rightInner + spaceBeforeSize la
  return (rightInner, rightOuter)

mkBounds :: LeftBounds -> RightBounds -> Bounds
mkBounds (leftOuter, leftInner) (rightInner, rightOuter) =
  Bounds (leftOuter, rightOuter) (leftInner, rightInner)

lookAhead1 :: (Show t, P.Stream s m t) => P.ParsecT s u m (Maybe t)
lookAhead1 = P.lookAhead (P.optionMaybe P.anyToken)

getOffset :: Monad m => P.ParsecT s u m Int
getOffset = (pred . PP.sourceColumn) `fmap` P.getPosition