LiftGrammar.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 FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Text.GrammarCombinators.Utils.LiftGrammar (
  liftGrammar,
  unfoldAndLiftGrammar
  ) where

import Text.GrammarCombinators.Base

import Language.Haskell.TH.Syntax

import Control.Monad

data LiftedRule (phi :: * -> *) (r :: * -> *) t v = 
    MkLR { liftRule :: Q Exp -> Q Exp -> Q Exp -> Q Exp }

instance ProductionRule (LiftedRule phi r t) where
  endOfInput = MkLR $ \_ _ _ -> [| endOfInput |]
  a >>> b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) >>> $(liftRule b r mr m1r) |]
  a ||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) ||| $(liftRule b r mr m1r) |]
  die = MkLR $ \_ _ _ -> [| die |]

instance BiasedProductionRule (LiftedRule phi r t) where
  a >||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) >||| $(liftRule b r mr m1r) |]
  a <||| b = MkLR $ \r mr m1r -> [| $(liftRule a r mr m1r) <||| $(liftRule b r mr m1r) |]

instance PenaltyProductionRule (LiftedRule phi r t) where
  penalty p br = MkLR $ \r mr m1r -> [| penalty p $(liftRule br r mr m1r) |]

instance LiftableProductionRule (LiftedRule phi r t) where
  epsilonL _ q = MkLR $ \_ _ _ -> [|epsilon $(q)|]

instance (Token t) => TokenProductionRule (LiftedRule phi r t) t where
  token tt = MkLR $ \_ _ _ -> [| token $(lift tt) |]
  anyToken = MkLR $ \_ _ _ -> [| anyToken |]

instance (LiftFam phi) =>
         RecProductionRule (LiftedRule phi r t) phi r where
  ref idx = MkLR $ \r _ _ -> [| $(r) $(return $ liftIdxE idx) |]

instance (LiftFam phi) =>
         LoopProductionRule (LiftedRule phi r t) phi r where
  manyRef idx = MkLR $ \_ mr _ -> [| $(mr) $(return $ liftIdxE idx) |]
  many1Ref idx = MkLR $ \_ _ m1r -> [| $(m1r) $(return $ liftIdxE idx) |]

liftGrammar' :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
               GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
               Q Exp -> Q Exp -> Q Exp ->
               Q Dec
liftGrammar' gram name refQ manyRefQ many1RefQ = 
  let 
    clause :: phi ix -> Q Clause
    clause idx = do lr <- liftRule (gram idx) refQ manyRefQ many1RefQ
                    return $ Clause [liftIdxP idx] (NormalB lr) []
    addClause idx b = do c <- clause idx
                         cs <- b
                         return (c:cs)
    clauses = foldFam addClause (return [])
  in liftM (FunD name) clauses

-- | Lift a given grammar to Template Haskell 
liftGrammar :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
               GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
               Q Type -> 
               Q [Dec]
liftGrammar gram name grammarType =
  let sig = do t <- grammarType
               return $ SigD name t
      fundef = liftGrammar' gram name [|ref|] [|manyRef|] [|many1Ref|]
  in do s <- sig
        f <- fundef
        return [s,f]

-- | Lift a given grammar to Template Haskell and replace recursion and loops with 
-- infinite-tree style recursive calls to the grammar itself. This allows GHC to do
-- a much better optimization (x20 speed-ups in one realistic test, compared with
-- result of 'liftGrammar').
unfoldAndLiftGrammar :: forall phi t r rr. (FoldFam phi, LiftFam phi, Token t) =>
                        GLAnyExtendedContextFreeGrammar phi t r rr -> Name ->
                        Q Type -> 
                        Q [Dec]
unfoldAndLiftGrammar gram name gramType =
  let refQ = return $ VarE name
      manyRefQ = return $ AppE (AppE (VarE '(.)) (VarE 'manyInf)) $ VarE name
      many1RefQ = return $ AppE (AppE (VarE '(.)) (VarE 'many1Inf)) $ (VarE name)
      sig = do t <- gramType
               return $ SigD name t
      fundef = liftGrammar' gram name refQ manyRefQ many1RefQ
  in do s <- sig
        d <- fundef
        return [s,d]