{-# 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