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 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
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
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
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"
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