content: {-# LANGUAGE DeriveAnyClass    #-}
  {-# LANGUAGE DeriveGeneric     #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Cryptol.ModuleSystem.NamingEnv.Types where
  
  import           Data.Map.Strict            (Map)
  import qualified Data.Map.Strict            as Map
  
  import           Control.DeepSeq            (NFData)
  import           GHC.Generics               (Generic)
  
  import           Cryptol.ModuleSystem.Names
  import           Cryptol.Parser.Name
  import           Cryptol.Utils.Ident
  import           Cryptol.Utils.PP
  
  -- | The 'NamingEnv' is used by the renamer to determine what
  -- identifiers refer to.
  newtype NamingEnv = NamingEnv (Map Namespace (Map PName Names))
    deriving (Show,Generic,NFData)
  
  instance Monoid NamingEnv where
    mempty = NamingEnv Map.empty
    {-# INLINE mempty #-}
  
  instance Semigroup NamingEnv where
    NamingEnv l <> NamingEnv r =
      NamingEnv (Map.unionWith (Map.unionWith (<>)) l r)
  
  instance PP NamingEnv where
    ppPrec _ (NamingEnv mps)   = vcat $ map ppNS $ Map.toList mps
      where ppNS (ns,xs) = nest 2 (vcat (pp ns : map ppNm (Map.toList xs)))
            ppNm (x,as)  = pp x <+> "->" <+> commaSep (map pp (namesToList as))
  
  -- | Move names in the constructor namespace to the value namespace.
  -- This is handy when checking for ambiguities.
  consToValues :: NamingEnv -> NamingEnv
  consToValues (NamingEnv mps) =
    NamingEnv $
    case Map.updateLookupWithKey (\_ _ -> Nothing) NSConstructor mps of
      (Nothing, mp1) -> mp1
      (Just conMap, mp1) -> Map.insertWith (Map.unionWith (<>)) NSValue conMap mp1
  