module Reducer where

import Data
import List

reduce :: StartPoint -> [Module] -> Module
reduce (StartPoint initNT baseModuleName) modules =
  reduceModule basemodule modules
  where
    basemodule = case (findModule baseModuleName modules) of
                   Nothing -> error msg
                   Just m -> m
    msg = "Module '" ++ baseModuleName ++ "' not found."

reduceModule :: Module -> [Module] -> Module
reduceModule m ms | undefNT == [] = reducedModule
                   | otherwise = error (msg m)
  where
    reducedModule =
      applyOverrides
      $ flip applyImports ms
      $ rmAbstracts m
    undefNT = undefinedNT m
    msg (Module mname _) =
      "There are undefined nonterminals in module '"
      ++ mname
      ++ "': "
      ++ show (undefNTNames undefNT)
      ++ "\nYou have to declare them as 'abstract' or define add grammar rules."
    undefNTNames [] = []
    undefNTNames ((Nonterminal name):es) = union [name] (undefNTNames es)

rmAbstracts :: Module -> Module
rmAbstracts (Module m c) = Module m newc
  where
    newc = rmAbstract_ c
    rmAbstract_ [] = []
    rmAbstract_ ((Abstract _):ss) = rmAbstract_ ss
    rmAbstract_ (s:ss) = s : rmAbstract_ ss

applyImports :: Module -> [Module] -> Module
applyImports (Module m c) ms =
  if length (nubBy ntNames cnew) == length cnew
    then Module m cnew
    else error ("There are some clashing NTs while executing imports in '" ++ m ++ "' module.")
  where
    ntNames (Rule l1 _) (Rule l2 _) = l1 == l2
    ntNames _ _ = False
    cnew = applyImports_ c
    applyImports_ [] = []
    applyImports_ ((Import targetname ioptions):ss) =
      importedContent ++ applyImports_ ss
      where importedContent = importModule targetname ioptions ms
    applyImports_ (s:ss) = s : applyImports_ ss

importModule :: ModuleName -> [ImportOption] -> [Module] -> [Statement]
importModule mn ios ms = applyImportOptions ios c
  where
    (Module _ c) = reduceModule m ms
    m = case (findModule mn ms) of
          Nothing -> error msg
          Just m -> m
    msg = "Importing module '" ++ mn ++ "' failed. Not found."

applyImportOptions :: [ImportOption] -> [Statement] -> [Statement]
applyImportOptions [] sts = sts
applyImportOptions ((Rename (Nonterminal e1) (Nonterminal e2)):ios) sts =
  if isThereNT (Nonterminal e1) sts
    then if not (isThereNT (Nonterminal e2) sts)
      then applyImportOptions ios (renameNT (Nonterminal e1) (Nonterminal e2) sts)
      else error ("Cannot rename '" ++ e1 ++ "' as '" ++ e2 ++ "'. Already exists.")
    else error ("Cannot rename nonterminal " ++ e1 ++ ". Not found.")
applyImportOptions ((Drop (Nonterminal e)):ios) sts =
  if isThereNT (Nonterminal e) sts
    then applyImportOptions ios (dropNT (Nonterminal e) sts)
    else error ("Cannot rename nonterminal " ++ e ++ ". Not found.")

applyOverrides :: Module -> Module
applyOverrides (Module m c) = Module m newc
  where
    newc = applyOverrides_ overrides rules
    overrides = [Override r | Override r <- c]
    rules = [Rule l r | Rule l r <- c]
    applyOverrides_ [] rs = rs
    applyOverrides_ ((Override (Rule (Nonterminal l) r)):os) rs =
      if isThereNT (Nonterminal l) rs
        then applyOverrides_ os (override (Rule (Nonterminal l) r) rs)
        else error ("Cannot override nonterminal " ++ l ++ ". Not found")

override :: Statement -> [Statement] -> [Statement]
override _ [] = []
override (Rule l1 r1) ((Rule l2 r2):ss) | l1 == l2 = lr1 : override lr1 ss
                                        | l1 /= l2 = lr2 : override lr1 ss
  where
    lr1 = Rule l1 r1
    lr2 = Rule l2 r2
override r (s:ss) = s : override r ss

undefinedNT :: Module -> [Element]
undefinedNT (Module m c) =
  [nt | nt <- allUndefinedNT, notElem nt abstractedNT]
  where
    allUndefinedNT = undefinedNT_ c [] []
    abstractedNT = findAbstractedNTs c
    undefinedNT_ [] def undef = undef
    undefinedNT_ ((Rule l r):ss) def undef = undefinedNT_ ss newDef newUndef
      where
        newDef = def ++ [l]
        newUndef = filter (/= l) undef
                    ++ [e | e <- grepNT $ concat r, notElem e newDef]
          where
            grepNT [] = []
            grepNT ((Nonterminal nt):es) = Nonterminal nt : grepNT es
            grepNT ((Terminal _):es) = grepNT es
    undefinedNT_ (s:ss) def undef = undefinedNT_ ss def undef

findAbstractedNTs :: [Statement] -> [Element]
findAbstractedNTs [] = []
findAbstractedNTs ((Abstract e):ss) = e : findAbstractedNTs ss
findAbstractedNTs (s:ss) = findAbstractedNTs ss

findModule :: ModuleName -> [Module] -> Maybe Module
findModule mname = find (\(Module m c) -> m == mname)

isThereNT :: Element -> [Statement] -> Bool
isThereNT e [] = False
isThereNT e ((Rule l _):sts) | l == e = True
                             | otherwise = isThereNT e sts
isThereNT e (s:sts) = isThereNT e sts

dropNT :: Element -> [Statement] -> [Statement]
dropNT e [] = []
dropNT e ((Rule el els):sts) | el == e = dropNT e sts
                             | otherwise = Rule el els : dropNT e sts
dropNT e (st:sts) = st : dropNT e sts

renameNT :: Element -> Element -> [Statement] -> [Statement]
renameNT eFrom eTo [] = []
renameNT eFrom eTo ((Rule l rs):sts) = Rule newL newRs
                                         : renameNT eFrom eTo sts
  where
    newL = if l == eFrom
              then eTo
              else l
    newRs = map newR rs
    newR x = [if e == eFrom then eTo else e | e <- x]
renameNT eFrom eTo (st:sts) = st : renameNT eFrom eTo sts

-- EOF
