{-# LANGUAGE OverloadedStrings #-} -- | Utilies for Haskell state initialitation. module BNFC.Backend.Haskell.Utilities.InitState ( getTokens , processFunctions , processParserRules , processRules , sortTokens ) where import BNFC.Prelude import Data.List (sortBy) import qualified Data.Map as Map import BNFC.Backend.Haskell.Utilities.ReservedWords import BNFC.Backend.Haskell.Utilities.Utils import BNFC.CF import BNFC.Types.Position -- | Process AST rules to generate Abstract Syntax and Printer. processRules :: ASTRulesAP -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] processRules rules = sorted where -- list sorted according to order categories are declaired in the .cf file. sorted = removePosition . snd <$> sortBy (compare `on` fst) withMinPos -- remove position from ARHS. removePosition :: (Type, [(Label, ([Type], (Integer, WithPosition ARHS)))]) -> (Type, [(Label, ([Type], (Integer, ARHS)))]) removePosition (t,l) = (t, ( \(la,(ts,tup)) -> (la,(ts, (\(i, WithPosition _ arhs) -> (i,arhs)) tup )) ) <$> l) -- associate first rhs position to each category (type). withMinPos :: [(Position, (Type, [(Label, ([Type], (Integer, WithPosition ARHS)))]))] withMinPos = zip (minRhsPos <$> rulesList) rulesList -- get position of first rhs associated to a rule. minRhsPos :: (Type, [(Label, ([Type], (Integer, WithPosition ARHS)))]) -> Position minRhsPos (_,l) = minimum $ wpPos <$> map ( \(_,(_,t)) -> snd t ) l -- AST rules list. rulesList :: [(Type, [(Label, ([Type], (Integer, WithPosition ARHS)))])] rulesList = (\(t,m) -> (t, Map.toList m)) <$> Map.toList rules -- | Sort tokens (token pragma) according to their -- definition order in the .cf file. sortTokens :: TokenDefs -> [(CatName,TokenDef)] sortTokens defs = sorted where sorted :: [(CatName, TokenDef)] sorted = removePosition . snd <$> sortBy (compare `on` fst) withPos removePosition :: (CatName, WithPosition TokenDef) -> (CatName, TokenDef) removePosition (c,pt) = (c, wpThing pt) withPos :: [(Position, (CatName, WithPosition TokenDef))] withPos = zip ( wpPos . snd <$> Map.toList defs) (Map.toList defs) -- | Get grammar tokens for lexer specification generation. getTokens :: LBNF -> [Token] getTokens lbnf = builtins ++ userDefined where hasIdent :: Bool hasIdent = hasIdentifier $ _lbnfTokenDefs lbnf builtins :: [Token] builtins = if hasIdent then Identifier : (Builtin <$> usedBuiltins) else Builtin <$> usedBuiltins userDefined :: [Token] userDefined = UserDefined . fst <$> sortTokens ( if hasIdent then Map.delete ('I':|"dent") (_lbnfTokenDefs lbnf) else _lbnfTokenDefs lbnf ) usedBuiltins :: [BuiltinCat] usedBuiltins = Map.keys $ _lbnfParserBuiltins lbnf -- | Sort functions (define pragma) and avoid reserved words. processFunctions :: Functions -> [(LabelName,Function)] processFunctions funs = checkFunction <$> sortFunctions funs -- | Sort functions (define pragma) according to their -- definition order in the .cf file. sortFunctions :: Functions -> [(LabelName,Function)] sortFunctions funs = sorted where sorted :: [(LabelName, Function)] sorted = removePosition . snd <$> sortBy (compare `on` fst) withPos removePosition :: (LabelName, WithPosition Function) -> (LabelName, Function) removePosition (c,pt) = (c, wpThing pt) withPos :: [(Position, (LabelName, WithPosition Function))] withPos = zip ( wpPos . snd <$> Map.toList funs) (Map.toList funs) -- | Sort parser rules and avoid reserved words. processParserRules :: ParserRules -> [(Cat, Map RHS RuleLabel)] processParserRules rules = (\(c,rhs) -> (c, Map.map checkRuleLabel rhs)) <$> sortParserRules rules -- | Sort parser rules according to their -- definition order in the .cf file. sortParserRules :: ParserRules -> [(Cat, Map RHS RuleLabel)] sortParserRules rules = sorted where sorted :: [(Cat, Map RHS RuleLabel)] sorted = removePosition . snd <$> sortBy (compare `on` fst) withMinPos removePosition :: (Cat, Map RHS (WithPosition RuleLabel)) -> (Cat, Map RHS RuleLabel) removePosition (c,m) = (c, Map.map wpThing m) getMinPos :: (Cat, Map RHS (WithPosition RuleLabel)) -> Position getMinPos (_,m) = minimum $ map wpPos (Map.elems m) withMinPos :: [(Position, (Cat, Map RHS (WithPosition RuleLabel)))] withMinPos = zip ( getMinPos <$> Map.toList rules) (Map.toList rules) -- | Avoid reserved words in functions from @define@ pragmas. checkFunction :: (LabelName, Function) -> (LabelName, Function) checkFunction (l,f) = (avoidReservedWords1 l, checkFun f) checkFun :: Function -> Function checkFun f@Function {funPars=params, funBody=body} = f {funPars = checkPars params, funBody = checkBody body} checkPars :: [Parameter] -> [Parameter] checkPars pars = checkPar <$> pars checkPar :: Parameter -> Parameter checkPar p = p { paramName = avoidReservedWords1 $ paramName p} checkBody :: Exp -> Exp checkBody (App l t exps) = App (checkLabel l) t (checkBody <$> exps) checkBody (Var p) = Var $ checkPar p checkBody e@(LitInteger _) = e checkBody e@(LitDouble _) = e checkBody e@(LitChar _) = e checkBody e@(LitString _) = e -- | Avoid reserved words in parser rules labels. checkRuleLabel :: RuleLabel -> RuleLabel checkRuleLabel rl = rl { ruleLabel = checkLabel $ ruleLabel rl} checkLabel :: Label -> Label checkLabel l@(LId _) = l checkLabel (LDef lName) = LDef $ avoidReservedWords1 lName checkLabel LWild = LWild checkLabel LNil = LNil checkLabel LSg = LSg checkLabel LCons = LCons