-- UUAGC 0.9.5 (Transform.ag)


import qualified UU.DData.Map as Map
import UU.Util.Utils
import UU.Pretty
import UU.DData.Set as Set
import UU.DData.Seq as Seq
import UU.DData.Map (Map)
import ConcreteSyntax
import AbstractSyntax
import Patterns
import ErrorMessages
import List (partition)
import Maybe
import UU.Scanner.Position(noPos)
import Options
import qualified SemRules  
import SemRules(DefinedAttrs, FieldMap, checkDef, hasAttr)  


import CommonTypes
import Patterns
import Rules
import UU.Pretty
import UU.Scanner.Position(Pos)
import Expression

checkDuplicate :: (Identifier -> Identifier -> Error) 
               -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) 
checkDuplicate dupError key val m
  = case Map.lookupIndex key m of
     Just ix -> let (key',_) = Map.elemAt ix m
                in  (m,Seq.single (dupError key key'))
     Nothing -> (Map.insert key val m,Seq.empty)  

checkDuplicates :: (Identifier -> Identifier -> Error) 
                -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error)
checkDuplicates dupError new m = foldErrors check m new
 where  check = uncurry (checkDuplicate dupError) 
         
foldErrors f e xs = foldl g (e,Seq.empty) xs 
  where g ~(e,es) x = let (e',es') = f x e
                      in (e', es <> es')  


type DataTypes = Map.Map Nonterminal DataAlts
type DataAlts  = Map.Map Constructor FieldMap


type DefinedSets = Map Name (Set Nonterminal)


flattenDatas :: DataTypes -> Map Nonterminal (Set Nonterminal)
flattenDatas ds = Map.map flatten ds
  where flatten cs =  Set.fromList [ nt | (_,NT nt) <- concatMap snd (Map.toList cs)]

reachableFrom :: Map Nonterminal (Set Nonterminal) -> Set Nonterminal -> Set Nonterminal
reachableFrom table nts = reach nts
  where reach nts = let nts' = Set.unions (nts : [ ns  | nt <- Set.toList nts
                                                 , let ns = Map.findWithDefault Set.empty nt table ]) 
                    in if Set.size nts' > Set.size nts
                          then reach nts'
                          else nts
invert :: Map Nonterminal (Set Nonterminal) -> Map Nonterminal (Set Nonterminal)
invert m = foldr inv Map.empty (Map.toList m)
  where inv (x,ns) m = fold (\n m -> Map.insertWith Set.union n (Set.single x) m) m ns

path :: Map Nonterminal (Set Nonterminal) -> Nonterminal -> Nonterminal -> Set Nonterminal
path table from to = let children = Map.findWithDefault Set.empty from table                                      
                         forward  = reachableFrom table children
                         backward = reachableFrom (invert table) 
                                                  (Set.single to)
                     in  Set.intersection forward backward


mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1)


merge x y = foldr f y (Map.toList x) 
 where f ~(k,v) m = Map.insertWith (Map.union) k v m


checkAttrs datatypes nts inherited synthesized decls = foldErrors check decls nts where
  check nt decls | not (nt `Map.member` datatypes) = (decls,Seq.single(UndefNont nt))
                 | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls
                                   (inh',einh) = checkDuplicates (DupInhAttr nt) inherited   inh
                                   (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn 
                               in (Map.insert nt (inh',syn') decls,einh <> esyn)


type RuleMap    = Map Nonterminal RuleMapAlt
type RuleMapAlt = Map Constructor (Rules,DefinedAttrs)


checkUndef err key m errs | Map.member key m = errs
                          | otherwise        = Seq.single (err key)


addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap
                     in  Map.insert name (eInh, Map.insert (Ident "self" noPos) (NT _SELF) eSyn)atMap


makeType :: Set Nonterminal -> Type -> Type
makeType nts tp@(NT x) | x == _SELF       = tp
                       | Set.member x nts = tp
                       | otherwise        = Haskell (getName x)
makeType _   tp                           = tp                       


constructGrammar nts gram attrs uses derivings wrappers rules tsyns = 
   let gr = [ (nt,Map.toList alts) | (nt,alts) <- Map.toList gram] 
       prods = map prod gr
       prod (nt,alts) =  let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs
                             rmap      = Map.findWithDefault Map.empty             nt rules
                             alt (con,flds) =
                                   let rules = maybe [] fst (Map.lookup con rmap)                                       
                                       child (nm, tp) =
                                          let (inh,syn) = case tp of 
                                                 NT nt -> Map.findWithDefault (Map.empty,Map.empty) nt attrs
                                                 _     -> (Map.empty,Map.empty)
                                          in Child nm tp inh syn 
                                   in Alternative con (map child flds) rules 
                            in Production nt inh syn (map alt alts)
   in Grammar tsyns uses derivings wrappers prods
 


type Blocks = Map.Map Name [String]
-- AG ----------------------------------------------------------
-- Alt ---------------------------------------------------------
-- Alts --------------------------------------------------------
-- Attrs -------------------------------------------------------
-- ConstructorSet ----------------------------------------------
-- Elem --------------------------------------------------------
-- Elems -------------------------------------------------------
-- NontSet -----------------------------------------------------
-- SemAlt ------------------------------------------------------
-- SemAlts -----------------------------------------------------