module Text.Happy (runHappy, CLIFlags(..), HappyInfo(..)) where

import ProduceCode
import Parser
import ParseMonad
import AbsSyn
import LALR
import First
import Grammar
import GenUtils
import Target
-- import Text.Happy.HappyTemplate
import Data.Array( assocs, elems, (!) )
import Data.List( nub )

data HappyInfo = HappyInfo { unused :: ([Int],[String]), sr :: Int, rr :: Int}

runHappy :: [CLIFlags]
            -> String
            -> Either String (String, HappyInfo)
runHappy cli s =
 case runP ourParser s 1 of
  FailP err -> Left err
  OkP abssyn@(AbsSyn _ _ _ tl) -> Right $
    case {-# SCC "Mangler" #-} (mangler "" abssyn) of
      Failed e -> die (unlines e ++ "\n")
      Succeeded g -> let
        first     = {-# SCC "First" #-} (mkFirst g)
        closures  = {-# SCC "Closures" #-} (precalcClosure0 g)
        sets      = {-# SCC "LR0_Sets" #-} (genLR0items g closures)
        _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first)
        la      = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop)
        items2  = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets)
        goto    = {-# SCC "Goto" #-} (genGotoTable g sets)
        action  = {-# SCC "Action" #-} (genActionTable g first items2)
        (conflictArray,(sr,rr))   = {-# SCC "Conflict" #-} (countConflicts action)

        reduction_filter | OptGLR `elem` cli = any_reduction
                         | otherwise         = first_reduction
        (unused_rules, unused_terminals)
                                  = find_redundancies reduction_filter g action

        target = getTarget cli

        opt_coerce = getCoerce target cli
        opt_strict = getStrict cli
        opt_ghc = getGhc cli


        -- templ   = getTemplate 
        outfile = produceParser
          g
          action
          goto
          (optsToInject target cli)
          Nothing
          tl
          TargetHaskell
          opt_coerce
          opt_ghc
          opt_strict
        in
          (outfile,HappyInfo (unused_rules, unused_terminals) sr rr)



die :: String -> a
die s = error s

find_redundancies
        :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies extract_reductions g action_table =
        (unused_rules, map (env !) unused_terminals)
    where
        Grammar { terminals = terms,
                  token_names = env,
                  eof_term = eof,
                  starts = starts',
                  productions = productions'
                } = g

        actions          = concat (map assocs (elems action_table))
        start_rules      = [ 0 .. (length starts' - 1) ]
        used_rules       = start_rules ++
                           nub [ r | (_,a) <- actions, r <- extract_reductions a ]
        used_tokens      = errorTok : eof :
                               nub [ t | (t,a) <- actions, is_shift a ]
        n_prods          = length productions'
        unused_terminals = filter (`notElem` used_tokens) terms
        unused_rules     = filter (`notElem` used_rules ) [0..n_prods-1]

is_shift :: LRAction -> Bool
is_shift (LR'Shift _ _)             = True
is_shift (LR'Multiple _ LR'Shift{}) = True
is_shift _                          = False

-- selects what counts as a reduction when calculating used/unused

any_reduction :: LRAction -> [Int]
any_reduction (LR'Reduce r _)    = [r]
any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as)
any_reduction _                  = []

first_reduction :: LRAction -> [Int]
first_reduction (LR'Reduce r _)   = [r]
first_reduction (LR'Multiple _ a) = first_reduction a   -- eg R/R conflict
first_reduction _                 = []

optsToInject :: Target -> [CLIFlags] -> String
optsToInject tgt cli
        | OptGhcTarget `elem` cli   = "-fglasgow-exts -cpp"
        | tgt == TargetArrayBased   = "-cpp"
        | OptDebugParser `elem` cli = "-cpp"
        | otherwise                 = ""

optToTarget :: CLIFlags -> Maybe Target
optToTarget OptArrayTarget      = Just TargetArrayBased
optToTarget _                   = Nothing

data CLIFlags =
                DumpVersion
                | DumpHelp
                | OptInfoFile (Maybe String)
                | OptTemplate String
                | OptMagicName String

                | OptGhcTarget
                | OptArrayTarget
                | OptUseCoercions
                | OptDebugParser
                | OptStrict
                | OptOutputFile String
                | OptGLR
                | OptGLR_Decode
                | OptGLR_Filter
  deriving Eq


getTarget :: [CLIFlags] -> Target
getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of
                        (t:ts) | all (==t) ts -> t
                        []  -> TargetHaskell
                        _   -> error "getTarget: multiple target options"

-- > getTemplate :: IO String -> [CLIFlags] -> IO String
-- > getTemplate def cli
-- > 	= case [ s | (OptTemplate s) <- cli ] of
-- >		[]	   -> def
-- >		f:fs       -> return (last (f:fs))
{-
> getMagicName :: [CLIFlags] -> IO (Maybe String)
> getMagicName cli
> 	= case [ s | (OptMagicName s) <- cli ] of
>		[]	   -> return Nothing
>		f:fs       -> return (Just (map toLower (last (f:fs))))
-}
getCoerce :: Target -> [CLIFlags] -> Bool
getCoerce _target cli
        = if OptUseCoercions `elem` cli
             then if OptGhcTarget `elem` cli
                        then True
                        else error ("-c/--coerce may only be used " ++
                                       "in conjunction with -g/--ghc\n")
             else False

getGhc :: [CLIFlags] ->  Bool
getGhc cli = OptGhcTarget `elem` cli

getStrict :: [CLIFlags] -> Bool
getStrict cli = OptStrict `elem` cli