{-# 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 (Int -> NamingEnv -> ShowS
[NamingEnv] -> ShowS
NamingEnv -> String
(Int -> NamingEnv -> ShowS)
-> (NamingEnv -> String)
-> ([NamingEnv] -> ShowS)
-> Show NamingEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamingEnv -> ShowS
showsPrec :: Int -> NamingEnv -> ShowS
$cshow :: NamingEnv -> String
show :: NamingEnv -> String
$cshowList :: [NamingEnv] -> ShowS
showList :: [NamingEnv] -> ShowS
Show,(forall x. NamingEnv -> Rep NamingEnv x)
-> (forall x. Rep NamingEnv x -> NamingEnv) -> Generic NamingEnv
forall x. Rep NamingEnv x -> NamingEnv
forall x. NamingEnv -> Rep NamingEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NamingEnv -> Rep NamingEnv x
from :: forall x. NamingEnv -> Rep NamingEnv x
$cto :: forall x. Rep NamingEnv x -> NamingEnv
to :: forall x. Rep NamingEnv x -> NamingEnv
Generic,NamingEnv -> ()
(NamingEnv -> ()) -> NFData NamingEnv
forall a. (a -> ()) -> NFData a
$crnf :: NamingEnv -> ()
rnf :: NamingEnv -> ()
NFData)

instance Monoid NamingEnv where
  mempty :: NamingEnv
mempty = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv Map Namespace (Map PName Names)
forall k a. Map k a
Map.empty
  {-# INLINE mempty #-}

instance Semigroup NamingEnv where
  NamingEnv Map Namespace (Map PName Names)
l <> :: NamingEnv -> NamingEnv -> NamingEnv
<> NamingEnv Map Namespace (Map PName Names)
r =
    Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Map PName Names -> Map PName Names -> Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Names -> Names -> Names)
-> Map PName Names -> Map PName Names -> Map PName Names
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
(<>)) Map Namespace (Map PName Names)
l Map Namespace (Map PName Names)
r)

instance PP NamingEnv where
  ppPrec :: Int -> NamingEnv -> Doc
ppPrec Int
_ (NamingEnv Map Namespace (Map PName Names)
mps)   = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Namespace, Map PName Names) -> Doc)
-> [(Namespace, Map PName Names)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Namespace, Map PName Names) -> Doc
forall {a} {a}. (PP a, PP a) => (a, Map a Names) -> Doc
ppNS ([(Namespace, Map PName Names)] -> [Doc])
-> [(Namespace, Map PName Names)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Map Namespace (Map PName Names) -> [(Namespace, Map PName Names)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Namespace (Map PName Names)
mps
    where ppNS :: (a, Map a Names) -> Doc
ppNS (a
ns,Map a Names
xs) = Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (a -> Doc
forall a. PP a => a -> Doc
pp a
ns Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: ((a, Names) -> Doc) -> [(a, Names)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (a, Names) -> Doc
forall {a}. PP a => (a, Names) -> Doc
ppNm (Map a Names -> [(a, Names)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a Names
xs)))
          ppNm :: (a, Names) -> Doc
ppNm (a
x,Names
as)  = a -> Doc
forall a. PP a => a -> Doc
pp a
x Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> [Doc] -> Doc
commaSep ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. PP a => a -> Doc
pp (Names -> [Name]
namesToList Names
as))

-- | Move names in the constructor namespace to the value namespace.
-- This is handy when checking for ambiguities.
consToValues :: NamingEnv -> NamingEnv
consToValues :: NamingEnv -> NamingEnv
consToValues (NamingEnv Map Namespace (Map PName Names)
mps) =
  Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (Map Namespace (Map PName Names) -> NamingEnv)
-> Map Namespace (Map PName Names) -> NamingEnv
forall a b. (a -> b) -> a -> b
$
  case (Namespace -> Map PName Names -> Maybe (Map PName Names))
-> Namespace
-> Map Namespace (Map PName Names)
-> (Maybe (Map PName Names), Map Namespace (Map PName Names))
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Namespace
_ Map PName Names
_ -> Maybe (Map PName Names)
forall a. Maybe a
Nothing) Namespace
NSConstructor Map Namespace (Map PName Names)
mps of
    (Maybe (Map PName Names)
Nothing, Map Namespace (Map PName Names)
mp1) -> Map Namespace (Map PName Names)
mp1
    (Just Map PName Names
conMap, Map Namespace (Map PName Names)
mp1) -> (Map PName Names -> Map PName Names -> Map PName Names)
-> Namespace
-> Map PName Names
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Names -> Names -> Names)
-> Map PName Names -> Map PName Names -> Map PName Names
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
(<>)) Namespace
NSValue Map PName Names
conMap Map Namespace (Map PName Names)
mp1