Quote.hs

module Text.Happy.Quote (
    parseHappy
  , compileHappy
  , happy
  , HappyStk(..)
  ) where

import Text.Happy(runHappy)
import Text.Happy.HappyTemplate

import Language.Haskell.TH.Quote
import Language.Haskell.TH
import Language.Haskell.TH.Lift

import Language.Haskell.Meta

-- Runtime
data HappyStk a = HappyStk a (HappyStk a)
infixr 9 `HappyStk`


type Happy = String

compileHappy :: Happy -> Q [Dec]
compileHappy = return . either error id . parseDecs

happy :: QuasiQuoter
happy = QuasiQuoter (lift . parseHappy) (error "happy: pattern quoting is not supported") 

parseHappy :: String -> Happy
parseHappy s = subst old "" $ fst (runHappy [] s) ++ "\n" ++ happyTemplate
  where
    old = unlines ["infixr 9 `HappyStk`",
                     "data HappyStk a = HappyStk a (HappyStk a)"]

subst _    _  [       ] = []
subst from to xs@(a:as) =
    if isPrefixOf from xs
        then to ++ drop (length from) xs
        else a : subst from to as
    where isPrefixOf as bs = and $ zipWith (==) as bs