ProductionRule.hs

{-  Copyright 2010 Dominique Devriese

    This file is part of the grammar-combinators library.

    The grammar-combinators library is free software: you can
    redistribute it and/or modify it under the terms of the GNU
    Lesser General Public License as published by the Free
    Software Foundation, either version 3 of the License, or (at
    your option) any later version.

    Foobar is distributed in the hope that it will be useful, but
    WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General
    Public License along with Foobar. If not, see
    <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Text.GrammarCombinators.Base.ProductionRule where

import Text.GrammarCombinators.Base.Domain
import Text.GrammarCombinators.Base.Token
import Text.GrammarCombinators.Base.MultiRec

import Language.Haskell.TH.Syntax (Q, Exp, Lift, lift)

infixl 1 |||
infixl 3 >>>
infixl 3 *>>>
infixl 3 >>>*
infixl 3 $>>
infixl 3 $>>*

-- | Base type class for production rule interpretations. A production rule
-- interpretation that is an instance of the 'ProductionRule' type class supports
-- sequencing and disjunction of rules, empty rules, dead rules and end-of-input 
-- rules.
class ProductionRule p where
  -- | Sequence two rules. Result of the sequenced rule is the application
  -- of the result of the first rule to the result of the second.
  (>>>) :: p (a -> b) -> p a -> p b
  -- | Disjunction of two rules.
  (|||) :: p va -> p va -> p va
  -- | End of input rule. Matches only at end of input, consumes nothing,
  -- produces '()' as result.
  endOfInput :: p ()
  -- | Dead rule. Never matches.
  die :: p a

class (ProductionRule p) => LiftableProductionRule p where
  -- | Epsilon rule with lifted value. Always matches, consumes nothing, produces
  --   the given value (with its lifted version) as result.
  epsilonL :: a -> Q Exp -> p a
  -- | Optionally match a given rule.
  optionally :: p v -> p (Maybe v)
  optionally r =   epsilonL Just [|Just|] >>> r
               ||| epsilonL Nothing [|Nothing|]

epsilonLS :: (Lift v, LiftableProductionRule p) => v -> p v
epsilonLS v = epsilonL v $ lift v

class (LiftableProductionRule p) => EpsProductionRule p where
  -- | Epsilon rule. Always matches, consumes nothing, produces
  --   the given value as result.
  epsilon :: a -> p a

-- | Type class for production rules matching tokens of a certain
-- token type 't'.
-- 't' should be an instance of the 'Token' type class.
class TokenProductionRule p t | p -> t where
  -- | Match a given token of type 't' and produce its concrete
  -- value (of type 'ConcreteToken' t).
  token :: t -> p (ConcreteToken t)
  anyToken :: p (ConcreteToken t)
 
class PenaltyProductionRule p where
  penalty :: Int -> p a -> p a

-- | Sequence two rules, but drop the result of the first.
(*>>>) :: (ProductionRule p, LiftableProductionRule p) => p a -> p b -> p b
a *>>> b = epsilonL (flip const) [| flip const |] >>> a >>> b
-- | Sequence two rules, but drop the result of the second.
(>>>*) :: (ProductionRule p, LiftableProductionRule p) => p a -> p b -> p a
a >>>* b = epsilonL const [|const|] >>> a >>> b

-- | Apply a given function to the result of a given rule.
($>>) :: EpsProductionRule p => (a -> b) -> p a -> p b
v $>> r = epsilon v >>> r
-- | Replace a rule's result value with a given value.
($>>*) :: EpsProductionRule p => a -> p b -> p a
v $>>* r = epsilon v >>>* r

-- | Apply a given function to the result of a given rule.
($|>>) :: LiftableProductionRule p => (a -> b, Q Exp) -> p a -> p b
(v,q) $|>> r = epsilonL v q >>> r
-- | Replace a rule's result value with a given value.
($|>>*) :: LiftableProductionRule p => (a, Q Exp) -> p b -> p a
(v,q) $|>>* r = epsilonL v q >>>* r

-- | Production rule interpretations supporting the 'RecProductionRule' type class support references
-- to non-terminals in a given domain 'phi'. The type of the result values of the rules is determined
-- by semantic value family 'r'.
class RecProductionRule p phi r | p -> phi, p -> r where
  -- | Reference a given non-terminal in a production rule.
  ref :: phi ix -> p (r ix)

-- | Production rule interpretations supporting the 'LoopProductionRule' 
-- type class allow for Kleene-star quantified references to 
-- non-terminals (zero or more, see the 'manyRef' function) as well
-- as '+'-quantified references to non-terminals (one or more, see
-- the 'many1Ref' function).
--
-- An instance can implement either manyRef or many1Ref,
-- both or neither. Not implementing either produces 
-- old-style many and many1 combinator behaviour (discouraged
-- for most situations)
class (ProductionRule p, LiftableProductionRule p, RecProductionRule p phi r) =>
      LoopProductionRule p phi r | p -> phi, p -> r where
  -- | Match a given non-terminal zero or more times.
  manyRef :: phi ix -> p [r ix]
  manyRef idx = epsilonL [] [| [] |] ||| many1Ref idx
  -- | Match a given non-terminal one or more times.
  many1Ref :: phi ix -> p [r ix] 
  many1Ref idx = ((:), [| (:) |]) $|>> ref idx >>> manyRef idx

-- | The 'SuperProductionRule| type class is in an experimental state, and 
-- currently not intended for general use.
class SuperProductionRule p where
  subref :: (DomainEmbedding phi phi' supIxT,
             HFunctor phi (PF phi),
             ProductionRule (p phi ixT r t),
             ProductionRule (p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t)) =>
            (forall ix'. phi' ix' -> p phi' (IxMapSeq ixT supIxT) (SubVal supIxT r) t (PF phi' (SubVal supIxT r) ix')) ->
            phi' ix -> phi (supIxT ix) ->
            p phi ixT r t (PF phi r (supIxT ix))

-- | Match any token in a given range of tokens.
tokenRange :: forall p t . (ProductionRule p, TokenProductionRule p t) => [t] -> p (ConcreteToken t)
tokenRange [] = error "empty range"
tokenRange [c] = token c
tokenRange (c : r) = token c ||| tokenRange r

-- | Consecutively match a given list of tokens and return their concrete token values as a list.
string :: forall p t . (ProductionRule p, LiftableProductionRule p, TokenProductionRule p t) => [t] -> p [ConcreteToken t]
string = foldr ((>>>) . (((:),[|(:)|]) $|>>) . token) (epsilonL [] [|[]|])

-- | An old style 'many' combinator. Produces an infinite rule similar to Parsec's many rule. 
-- Prefer to use the 'manyRef' function whenever possible.
manyInf :: (ProductionRule p, LiftableProductionRule p) => p a -> p [a]
manyInf r =     epsilonL (:) [|(:)|] >>> r >>> manyInf r
            ||| epsilonL [] [|[]|]


-- | An old style 'many' combinator. Produces an infinite rule similar to Parsec's many rule. 
-- Prefer to use the 'manyRef' function whenever possible.
many1Inf :: (ProductionRule p, LiftableProductionRule p) => p a -> p [a]
many1Inf r = epsilonL (:) [|(:)|] >>> r >>> manyInf r


class ProductionRuleWithLibrary p phi r | p -> phi, p -> r where
  lib :: phi ix -> p (r ix)

class BiasedProductionRule p where
  -- | Left-biased choice
  (>|||) :: p a -> p a -> p a
  (>|||) = flip (<|||)
  -- | Right-biased choice
  (<|||) :: p a -> p a -> p a
  (<|||) = flip (>|||)