content: -- Copyright 2018 Bose Corporation.
  -- This software is released under the 3-Clause BSD License.
  -- The license can be viewed at https://github.com/smudgelang/smudge/blob/master/LICENSE
  
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE TypeFamilies #-}
  
  module Language.Smudge.Passes.DeclaredEventNames (
      DeclaredEventNames
  ) where
  
  import Language.Smudge.Grammar (
    StateMachine(..),
    Event(..),
    QEvent,
    Function(..),
    SideEffect,
    WholeState,
    )
  import Language.Smudge.Semantics.Model (TaggedName, disqualifyTag)
  import Language.Smudge.Parsers.Id (at)
  import Language.Smudge.Passes.Passes (Passable(..), Severity(..), Fault(..))
  
  import Data.Semigroup (Semigroup(..))
  import Data.Set (Set, fromList, toList, map, (\\))
  import Prelude hiding (map)
  
  data DeclaredEventNames = DeclaredEventNames (Set (QEvent TaggedName)) (Set (QEvent TaggedName))
  instance Semigroup DeclaredEventNames where
      (DeclaredEventNames eh se) <> (DeclaredEventNames eh' se') =
          DeclaredEventNames (eh <> eh') (se <> se')
  instance Monoid DeclaredEventNames where
      mempty = DeclaredEventNames mempty mempty
      mappend = (<>)
  
  qesOfSes :: [SideEffect TaggedName] -> [QEvent TaggedName]
  qesOfSes ses = [qe | (_, FuncTyped qe@(_, Event _)) <- ses] ++
                 [qe | (_, FuncEvent qe@(_, Event _)) <- ses]
  
  instance Passable DeclaredEventNames where
      type Representation DeclaredEventNames = [(StateMachine TaggedName, [WholeState TaggedName])]
      accumulate (sm, wss) = mappend $ foldr go mempty wss
          where go (_, _, en, eh, ex) =
                  mappend $ DeclaredEventNames (fromList [(sm, e) | (e@(Event _), _, _) <- eh])
                      (fromList $ qesOfSes en ++ concat [qesOfSes ses | (_, ses, _) <- eh] ++ qesOfSes ex)
      test _ (DeclaredEventNames eh se) =
          case toList (se \\ eh) of
          [] -> []
          es -> [Fault ERROR (at name) $ (disqualifyTag sm_name) ++ ": Event name not declared: " ++
                 disqualifyTag name | (StateMachine sm_name, Event name) <- es]
  