-----------------------------------------------------------------------------
Generating info files.

(c) 1993-2001 Andy Gill, Simon Marlow
-----------------------------------------------------------------------------

> module Info (genInfoFile) where

> import Paths_happy            ( version )
> import LALR                   ( Lr0Item(..) )
> import GenUtils               ( str, interleave, interleave' )
> import Data.Set ( Set )
> import qualified Data.Set as Set hiding ( Set )
> import Grammar

> import Data.Array
> import Data.List (nub)
> import Data.Version           ( showVersion )

Produce a file of parser information, useful for debugging the parser.

> genInfoFile
>       :: [Set Lr0Item]
>       -> Grammar
>       -> ActionTable
>       -> GotoTable
>       -> [(Int,String)]
>       -> Array Int (Int,Int)
>       -> String
>       -> [Int]                        -- unused rules
>       -> [String]                     -- unused terminals
>       -> String

> genInfoFile items
>       (Grammar { productions = prods
>                , lookupProdNo = lookupProd
>                , lookupProdsOfName = lookupProdNos
>                , non_terminals = nonterms
>                , token_names = env
>                })
>        action goto tokens conflictArray filename unused_rules unused_terminals
>       = (showHeader
>       . showConflicts
>       . showUnused
>       . showProductions
>       . showTerminals
>       . showNonTerminals
>       . showStates
>       . showStats
>       ) ""
>   where

>   showHeader
>       = banner ("Info file generated by Happy Version " ++
>                 showVersion version ++ " from " ++ filename)

>   showConflicts
>       = str "\n"
>       . foldr (.) id (map showConflictsState (assocs conflictArray))
>       . str "\n"

>   showConflictsState (_,     (0,0)) = id
>   showConflictsState (state, (sr,rr))
>       = str "state "
>       . shows state
>       . str " contains "
>       . interleave' " and " (
>               (if sr /= 0
>                       then [ shows sr . str " shift/reduce conflicts" ]
>                       else []) ++
>                if rr /= 0
>                       then [ shows rr . str " reduce/reduce conflicts" ]
>                       else [])
>       . str ".\n"

>   showUnused =
>         (case unused_rules of
>           [] -> id
>           _  ->   interleave "\n" (
>                       map (\r ->   str "rule "
>                                  . shows r
>                                  . str " is unused")
>                               unused_rules)
>                 . str "\n")
>       . (case unused_terminals of
>           [] -> id
>           _  ->   interleave "\n" (
>                       map (\t ->   str "terminal "
>                                  . str t
>                                  . str " is unused")
>                               unused_terminals)
>                 . str "\n")

>   showProductions =
>         banner "Grammar"
>       . interleave "\n" (zipWith showProduction prods [ 0 :: Int .. ])
>       . str "\n"

>   showProduction (nt, toks, _sem, _prec) i
>       = ljuststr 50 (
>         str "\t"
>       . showName nt
>       . str " -> "
>       . interleave " " (map showName toks))
>       . str "  (" . shows i . str ")"

>   showStates =
>         banner "States"
>       . interleave "\n" (zipWith showState
>               (map Set.toAscList items) [ 0 :: Int .. ])

>   showState state n
>       = str "State ". shows n
>       . str "\n\n"
>       . interleave "\n" (map showItem [ (Lr0 r d) | (Lr0 r d) <- state, d /= 0 ])
>       . str "\n"
>       . foldr (.) id (map showAction (assocs (action ! n)))
>       . str "\n"
>       . foldr (.) id (map showGoto (assocs (goto ! n)))

>   showItem (Lr0 rule dot)
>       = ljuststr 50 (
>                 str "\t"
>               . showName nt
>               . str " -> "
>               . interleave " " (map showName beforeDot)
>               . str ". "
>               . interleave " " (map showName afterDot))
>       . str "   (rule " . shows rule . str ")"
>       where
>               (nt, toks, _sem, _prec) = lookupProd rule
>               (beforeDot, afterDot) = splitAt dot toks

>   showAction (_, LR'Fail)
>       = id
>   showAction (t, act)
>       = str "\t"
>       . showJName 15 t
>       . showAction' act
>       . str "\n"

>   showAction' LR'MustFail
>       = str "fail"
>   showAction' (LR'Shift n _)
>       = str "shift, and enter state "
>       . shows n
>   showAction' LR'Accept
>       = str "accept"
>   showAction' (LR'Reduce n _)
>       = str "reduce using rule "
>       . shows n
>   showAction' (LR'Multiple as a)
>       = showAction' a
>       . str "\n"
>       . interleave "\n"
>               (map (\a' -> str "\t\t\t(" . showAction' a' . str ")")
>                (nub (filter (/= a) as)))
>   showAction' LR'Fail = error "showAction' LR'Fail: Unhandled case"

>   showGoto (_, NoGoto)
>       = id
>   showGoto (nt, Goto n)
>       = str "\t"
>       . showJName 15 nt
>       . str "goto state "
>       . shows n
>       . str "\n"

>   showTerminals
>       = banner "Terminals"
>       . interleave "\n" (map showTerminal tokens)
>       . str "\n"

>   showTerminal (t,s)
>       = str "\t"
>       . showJName 15 t
>       . str "{ " . str s . str " }"

>   showNonTerminals
>       = banner "Non-terminals"
>       . interleave "\n" (map showNonTerminal nonterms)
>       . str "\n"

>   showNonTerminal nt
>       = str "\t"
>       . showJName 15 nt
>       . (if (length nt_rules == 1)
>               then str " rule  "
>               else str " rules ")
>       . foldr1 (\a b -> a . str ", " . b) nt_rules
>       where nt_rules = map shows (lookupProdNos nt)

>   showStats
>       = banner "Grammar Totals"
>       . str   "Number of rules: " . shows (length prods)
>       . str "\nNumber of terminals: " . shows (length tokens)
>       . str "\nNumber of non-terminals: " . shows (length nonterms)
>       . str "\nNumber of states: " . shows (length items)
>       . str "\n"

>   nameOf n    = env ! n
>   showName    = str . nameOf
>   showJName j = str . ljustify j . nameOf

> ljustify :: Int -> String -> String
> ljustify n s = s ++ replicate (max 0 (n - length s)) ' '

> ljuststr :: Int -> (String -> String) -> String -> String
> ljuststr n s = str (ljustify n (s ""))

> banner :: String -> String -> String
> banner s
>       = str "-----------------------------------------------------------------------------\n"
>       . str s
>       . str "\n-----------------------------------------------------------------------------\n"