{-#OPTIONS_GHC -fno-warn-missing-fields#-}
module Text.Happy.Quote (
    parseHappy
  , parseHappyInfo
  , compileHappy
  , happy
  , HappyStk(..)
  , HappyInfo
  , happyWarn
  ) where

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

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

import Language.Haskell.Meta

import Control.Monad(when)
import System.IO(hPutStrLn,stderr)

-- Runtime (The infixr declaration can not be spliced by TH)
data HappyStk a = HappyStk a (HappyStk a)
infixr 9 `HappyStk`


type Happy = String

compileHappy :: Happy -> Q [Dec]
compileHappy :: Happy -> Q [Dec]
compileHappy = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Happy -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. Happy -> Either Happy [Dec]
parseDecs

happy :: QuasiQuoter
happy :: QuasiQuoter
happy = QuasiQuoter {quoteExp :: Happy -> Q Exp
quoteExp = (Happy, HappyInfo) -> Q Exp
happyToExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Happy -> (Happy, HappyInfo)
parseHappyInfo} -- (error "happy: pattern quoting is not supported") 


parseHappy :: String -> Happy
parseHappy :: Happy -> Happy
parseHappy = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Happy -> (Happy, HappyInfo)
parseHappyInfo

parseHappyInfo :: String -> (Happy,HappyInfo)
parseHappyInfo :: Happy -> (Happy, HappyInfo)
parseHappyInfo Happy
s = (forall {a}. Eq a => [a] -> [a] -> [a] -> [a]
subst Happy
old Happy
"" forall a b. (a -> b) -> a -> b
$ Happy
code forall a. [a] -> [a] -> [a]
++ Happy
"\n" forall a. [a] -> [a] -> [a]
++ Happy
happyTemplate, HappyInfo
info)
  where
    (Happy
code,HappyInfo
info) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Happy -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [CLIFlags] -> Happy -> Either Happy (Happy, HappyInfo)
runHappy [] Happy
s
    old :: Happy
old = [Happy] -> Happy
unlines [Happy
"infixr 9 `HappyStk`",
                     Happy
"data HappyStk a = HappyStk a (HappyStk a)"]

happyWarn :: HappyInfo -> Q ()
happyWarn :: HappyInfo -> Q ()
happyWarn HappyInfo
i = do
  Loc
loc <- Q Loc
location
  let warnMsg :: Happy -> Q ()
warnMsg Happy
msg = do
      let (Int
row,Int
col)    = Loc -> (Int, Int)
loc_start Loc
loc
          (Happy
file)       = Loc -> Happy
loc_filename Loc
loc
      forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ Handle -> Happy -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ Happy
file forall a. [a] -> [a] -> [a]
++ Happy
":"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> Happy
show Int
rowforall a. [a] -> [a] -> [a]
++Happy
":"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> Happy
show Int
colforall a. [a] -> [a] -> [a]
++Happy
":"
      forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ Handle -> Happy -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ Happy
"    " forall a. [a] -> [a] -> [a]
++ Happy
msg
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HappyInfo -> Int
sr HappyInfo
i forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Happy -> Q ()
warnMsg forall a b. (a -> b) -> a -> b
$ Happy
"Warning: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> Happy
show (HappyInfo -> Int
sr HappyInfo
i)forall a. [a] -> [a] -> [a]
++Happy
"shift/reduce conflicts"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HappyInfo -> Int
rr HappyInfo
i forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Happy -> Q ()
warnMsg forall a b. (a -> b) -> a -> b
$ Happy
"Warning: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> Happy
show (HappyInfo -> Int
rr HappyInfo
i)forall a. [a] -> [a] -> [a]
++ Happy
"reduce/reduce conflicts"


happyToExp :: (Happy, HappyInfo) -> Q Exp
happyToExp (Happy
code,HappyInfo
info) = HappyInfo -> Q ()
happyWarn HappyInfo
info forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Happy -> Lit
StringL Happy
code)

--	optIO (not (null unused_rules))
--	   (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) >>
--	optIO (not (null unused_terminals))
--	   (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) >>


-- This is some really bad code but it works for this purpose.
subst :: [a] -> [a] -> [a] -> [a]
subst [a]
_    [a]
_  [       ] = []
subst [a]
from [a]
to xs :: [a]
xs@(a
a:[a]
as) =
    if forall {b}. Eq b => [b] -> [b] -> Bool
isPrefixOf [a]
from [a]
xs
        then [a]
to forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
from) [a]
xs
        else a
a forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
subst [a]
from [a]
to [a]
as
    where isPrefixOf :: [b] -> [b] -> Bool
isPrefixOf [b]
as [b]
bs = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [b]
as [b]
bs