{-# LANGUAGE CPP, RecursiveDo #-}
module Text.Earley.Mixfix
  ( Associativity(..)
  , Holey
  , mixfixExpression
  , mixfixExpressionSeparate
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Traversable(sequenceA)
#endif
import Data.Either
import Data.Foldable(asum, foldrM)
import Text.Earley

replicateA :: Applicative f => Int -> f a -> f [a]
replicateA n = sequenceA . replicate n

consA :: Applicative f => f a -> f [a] -> f [a]
consA p q = (:) <$> p <*> q

data Associativity
  = LeftAssoc
  | NonAssoc
  | RightAssoc
  deriving (Eq, Show)

-- | An identifier with identifier parts ('Just's), and holes ('Nothing's)
-- representing the positions of its arguments.
--
-- Example (commonly written "if_then_else_"):
-- @['Just' "if", 'Nothing', 'Just' "then", 'Nothing', 'Just' "else", 'Nothing'] :: 'Holey' 'String'@
type Holey a = [Maybe a]

-- | Create a grammar for parsing mixfix expressions.
mixfixExpression
  :: [[(Holey (Prod r e t ident), Associativity)]]
  -- ^ A table of holey identifier parsers, with associativity information.
  -- The identifiers should be in groups of precedence levels listed from
  -- binding the least to the most tightly.
  --
  -- The associativity is taken into account when an identifier starts or ends
  -- with holes, or both. Internal holes (e.g. after "if" in "if_then_else_")
  -- start from the beginning of the table.
  --
  -- Note that this rule also applies to identifiers with multiple consecutive
  -- holes, e.g. "if__" --- the associativity then applies to both holes.
  -> Prod r e t expr
  -- ^ An atom, i.e. what is parsed at the lowest level. This will
  -- commonly be a (non-mixfix) identifier or a parenthesised expression.
  -> (Holey ident -> [expr] -> expr)
  -- ^ How to combine the successful application of a holey identifier to its
  -- arguments into an expression.
  -> Grammar r (Prod r e t expr)
mixfixExpression table atom app = mixfixExpressionSeparate table' atom
  where
    table' = [[(holey, assoc, app) | (holey, assoc) <- row] | row <- table]

-- | A version of 'mixfixExpression' with a separate semantic action for each
-- individual 'Holey' identifier.
mixfixExpressionSeparate
  :: [[(Holey (Prod r e t ident), Associativity, Holey ident -> [expr] -> expr)]]
  -- ^ A table of holey identifier parsers, with associativity information and
  -- semantic actions.  The identifiers should be in groups of precedence
  -- levels listed from binding the least to the most tightly.
  --
  -- The associativity is taken into account when an identifier starts or ends
  -- with holes, or both. Internal holes (e.g. after "if" in "if_then_else_")
  -- start from the beginning of the table.
  --
  -- Note that this rule also applies to identifiers with multiple consecutive
  -- holes, e.g. "if__" --- the associativity then applies to both holes.
  -> Prod r e t expr
  -- ^ An atom, i.e. what is parsed at the lowest level. This will
  -- commonly be a (non-mixfix) identifier or a parenthesised expression.
  -> Grammar r (Prod r e t expr)
mixfixExpressionSeparate table atom = mdo
  expr <- foldrM ($) atom $ map (level expr) table
  return expr
  where
    level expr idents next = mdo
      same <- rule $ asum $ next : map (mixfixIdent same) idents
      return same
      where
        -- Group consecutive holes and ident parts.
        grp [] = []
        grp (Nothing:ps) = case grp ps of
          Left n:rest -> (Left $! (n + 1)) : rest
          rest        -> Left 1            : rest
        grp (Just p:ps) = case grp ps of
          Right ps':rest -> Right (consA p ps')       : rest
          rest           -> Right (consA p $ pure []) : rest

        mixfixIdent same (ps, a, f) = f' <$> go (grp ps)
          where
            f' xs = f (concatMap (either (map $ const Nothing) $ map Just) xs)
                   $ concat $ lefts xs
            go ps' = case ps' of
              [] -> pure []
              [Right p] -> pure . Right <$> p
              Left n:rest -> consA
                (Left <$> replicateA n (if a == RightAssoc then next
                                                           else same))
                $ go rest
              [Right p, Left n] -> consA
                (Right <$> p)
                $ pure . Left <$> replicateA n (if a == LeftAssoc then next
                                                                  else same)
              Right p:Left n:rest -> consA (Right <$> p)
                $ consA (Left <$> replicateA n expr)
                $ go rest
              Right _:Right _:_ -> error
                $  "Earley.mixfixExpression: The impossible happened. "
                ++ "Please report this as a bug."