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 { HappyInfo -> ([Int], [String])
unused :: ([Int],[String]), HappyInfo -> Int
sr :: Int, HappyInfo -> Int
rr :: Int}
 
runHappy :: [CLIFlags]
            -> String
            -> Either String (String, HappyInfo)
runHappy :: [CLIFlags] -> String -> Either String (String, HappyInfo)
runHappy [CLIFlags]
cli String
s = 
 case forall a. P a -> String -> Int -> ParseResult a
runP P AbsSyn
ourParser String
s Int
1 of
  FailP String
err -> forall a b. a -> Either a b
Left String
err
  OkP abssyn :: AbsSyn
abssyn@(AbsSyn Maybe String
_ [Directive String]
_ [Rule]
_ Maybe String
tl) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    case {-# SCC "Mangler" #-} (String -> AbsSyn -> MaybeErr Grammar [String]
mangler String
"" AbsSyn
abssyn) of
      Failed [String]
e -> forall a. String -> a
die ([String] -> String
unlines [String]
e forall a. [a] -> [a] -> [a]
++ String
"\n")
      Succeeded Grammar
g -> let 
        first :: [Int] -> NameSet
first     = {-# SCC "First" #-} (Grammar -> [Int] -> NameSet
mkFirst Grammar
g)
        closures :: Int -> RuleList
closures  = {-# SCC "Closures" #-} (Grammar -> Int -> RuleList
precalcClosure0 Grammar
g)
        sets :: [ItemSetWithGotos]
sets      = {-# SCC "LR0_Sets" #-} (Grammar -> (Int -> RuleList) -> [ItemSetWithGotos]
genLR0items Grammar
g Int -> RuleList
closures)
        _lainfo :: ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
_lainfo@([(Int, Lr0Item, NameSet)]
spont,Array Int [(Lr0Item, Int, Lr0Item)]
prop) = {-# SCC "Prop" #-} (Grammar
-> [ItemSetWithGotos]
-> ([Int] -> NameSet)
-> ([(Int, Lr0Item, NameSet)], Array Int [(Lr0Item, Int, Lr0Item)])
propLookaheads Grammar
g [ItemSetWithGotos]
sets [Int] -> NameSet
first)
        la :: Array Int [(Lr0Item, NameSet)]
la      = {-# SCC "Calc" #-} (Int
-> [(Int, Lr0Item, NameSet)]
-> Array Int [(Lr0Item, Int, Lr0Item)]
-> Array Int [(Lr0Item, NameSet)]
calcLookaheads (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ItemSetWithGotos]
sets) [(Int, Lr0Item, NameSet)]
spont Array Int [(Lr0Item, Int, Lr0Item)]
prop)
        items2 :: [([Lr1Item], [(Int, Int)])]
items2	= {-# SCC "Merge" #-} (Array Int [(Lr0Item, NameSet)]
-> [ItemSetWithGotos] -> [([Lr1Item], [(Int, Int)])]
mergeLookaheadInfo Array Int [(Lr0Item, NameSet)]
la [ItemSetWithGotos]
sets)
        goto :: GotoTable
goto   	= {-# SCC "Goto" #-} (Grammar -> [ItemSetWithGotos] -> GotoTable
genGotoTable Grammar
g [ItemSetWithGotos]
sets)
        action :: ActionTable
action 	= {-# SCC "Action" #-} (Grammar
-> ([Int] -> NameSet) -> [([Lr1Item], [(Int, Int)])] -> ActionTable
genActionTable Grammar
g [Int] -> NameSet
first [([Lr1Item], [(Int, Int)])]
items2)
        (Array Int (Int, Int)
conflictArray,(Int
sr,Int
rr))   = {-# SCC "Conflict" #-} (ActionTable -> (Array Int (Int, Int), (Int, Int))
countConflicts ActionTable
action)

	reduction_filter :: LRAction -> [Int]
reduction_filter | CLIFlags
OptGLR forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = LRAction -> [Int]
any_reduction
	                 | Bool
otherwise         = LRAction -> [Int]
first_reduction
        ([Int]
unused_rules, [String]
unused_terminals) 
                                  = (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies LRAction -> [Int]
reduction_filter Grammar
g ActionTable
action

	target :: Target
target = [CLIFlags] -> Target
getTarget [CLIFlags]
cli

	opt_coerce :: Bool
opt_coerce = Target -> [CLIFlags] -> Bool
getCoerce Target
target [CLIFlags]
cli
	opt_strict :: Bool
opt_strict = [CLIFlags] -> Bool
getStrict [CLIFlags]
cli
	opt_ghc :: Bool
opt_ghc = [CLIFlags] -> Bool
getGhc [CLIFlags]
cli


        -- templ   = getTemplate 
        outfile :: String
outfile = Grammar
-> ActionTable
-> GotoTable
-> String
-> Maybe String
-> Maybe String
-> Target
-> Bool
-> Bool
-> Bool
-> String
produceParser 
          Grammar
g
          ActionTable
action
          GotoTable
goto
          (Target -> [CLIFlags] -> String
optsToInject Target
target [CLIFlags]
cli)
          forall a. Maybe a
Nothing
          Maybe String
tl
          Target
TargetHaskell
          Bool
opt_coerce
          Bool
opt_ghc
          Bool
opt_strict
        in
          (String
outfile,([Int], [String]) -> Int -> Int -> HappyInfo
HappyInfo ([Int]
unused_rules, [String]
unused_terminals) Int
sr Int
rr)



die :: String -> a
die :: forall a. String -> a
die String
s = forall a. HasCallStack => String -> a
error String
s

find_redundancies 
        :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])
find_redundancies LRAction -> [Int]
extract_reductions Grammar
g ActionTable
action_table = 
	([Int]
unused_rules, forall a b. (a -> b) -> [a] -> [b]
map (Array Int String
env forall i e. Ix i => Array i e -> i -> e
!) [Int]
unused_terminals)
    where
	Grammar { terminals :: Grammar -> [Int]
terminals = [Int]
terms,
		  token_names :: Grammar -> Array Int String
token_names = Array Int String
env,
		  eof_term :: Grammar -> Int
eof_term = Int
eof,
		  starts :: Grammar -> [(String, Int, Int, Bool)]
starts = [(String, Int, Int, Bool)]
starts',
		  productions :: Grammar -> [Production]
productions = [Production]
productions'
	        } = Grammar
g

	actions :: [(Int, LRAction)]
actions		 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map forall i e. Ix i => Array i e -> [(i, e)]
assocs (forall i e. Array i e -> [e]
elems ActionTable
action_table))
	start_rules :: [Int]
start_rules	 = [ Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Int, Int, Bool)]
starts' forall a. Num a => a -> a -> a
- Int
1) ]
	used_rules :: [Int]
used_rules       = [Int]
start_rules forall a. [a] -> [a] -> [a]
++
			   forall a. Eq a => [a] -> [a]
nub [ Int
r | (Int
_,LRAction
a) <- [(Int, LRAction)]
actions, Int
r <- LRAction -> [Int]
extract_reductions LRAction
a ]
	used_tokens :: [Int]
used_tokens      = Int
errorTok forall a. a -> [a] -> [a]
: Int
eof forall a. a -> [a] -> [a]
: 
			       forall a. Eq a => [a] -> [a]
nub [ Int
t | (Int
t,LRAction
a) <- [(Int, LRAction)]
actions, LRAction -> Bool
is_shift LRAction
a ]
	n_prods :: Int
n_prods		 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Production]
productions'
	unused_terminals :: [Int]
unused_terminals = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
used_tokens) [Int]
terms
	unused_rules :: [Int]
unused_rules     = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
used_rules ) [Int
0..Int
n_prodsforall a. Num a => a -> a -> a
-Int
1]

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

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

any_reduction :: LRAction -> [Int]
any_reduction :: LRAction -> [Int]
any_reduction (LR'Reduce Int
r Priority
_)    = [Int
r] 
any_reduction (LR'Multiple [LRAction]
as LRAction
a) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LRAction -> [Int]
any_reduction (LRAction
a forall a. a -> [a] -> [a]
: [LRAction]
as)
any_reduction LRAction
_                  = []

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

optsToInject :: Target -> [CLIFlags] -> String
optsToInject :: Target -> [CLIFlags] -> String
optsToInject Target
tgt [CLIFlags]
cli 
	| CLIFlags
OptGhcTarget forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli   = String
"-fglasgow-exts -cpp"
 	| Target
tgt forall a. Eq a => a -> a -> Bool
== Target
TargetArrayBased   = String
"-cpp"
	| CLIFlags
OptDebugParser forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = String
"-cpp"
	| Bool
otherwise                 = String
""

optToTarget :: CLIFlags -> Maybe Target
optToTarget :: CLIFlags -> Maybe Target
optToTarget CLIFlags
OptArrayTarget 	= forall a. a -> Maybe a
Just Target
TargetArrayBased
optToTarget CLIFlags
_			= forall a. Maybe a
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 CLIFlags -> CLIFlags -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CLIFlags -> CLIFlags -> Bool
$c/= :: CLIFlags -> CLIFlags -> Bool
== :: CLIFlags -> CLIFlags -> Bool
$c== :: CLIFlags -> CLIFlags -> Bool
Eq


getTarget :: [CLIFlags] -> Target
getTarget :: [CLIFlags] -> Target
getTarget [CLIFlags]
cli = case [ Target
t | (Just Target
t) <- forall a b. (a -> b) -> [a] -> [b]
map CLIFlags -> Maybe Target
optToTarget [CLIFlags]
cli ] of
			(Target
t:[Target]
ts) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Target
t) [Target]
ts -> Target
t
			[]  -> Target
TargetHaskell
			[Target]
_   -> forall a. HasCallStack => String -> a
error String
"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 -> [CLIFlags] -> Bool
getCoerce Target
_target [CLIFlags]
cli
	= if CLIFlags
OptUseCoercions forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli 
	     then if CLIFlags
OptGhcTarget forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli
			then Bool
True
			else forall a. HasCallStack => String -> a
error (String
"-c/--coerce may only be used " forall a. [a] -> [a] -> [a]
++
				       String
"in conjunction with -g/--ghc\n")
	     else Bool
False

getGhc :: [CLIFlags] ->  Bool
getGhc :: [CLIFlags] -> Bool
getGhc [CLIFlags]
cli = CLIFlags
OptGhcTarget forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli

getStrict :: [CLIFlags] -> Bool
getStrict :: [CLIFlags] -> Bool
getStrict [CLIFlags]
cli = CLIFlags
OptStrict forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli