{-# LANGUAGE DeriveGeneric #-}
module Cryptol.ModuleSystem.Exports where

import Data.Set(Set)
import qualified Data.Set as Set
import Data.Map(Map)
import qualified Data.Map as Map
import Data.Foldable(fold)
import Control.DeepSeq(NFData)
import GHC.Generics (Generic)

import Cryptol.Parser.AST
import Cryptol.Parser.Names(namesD,tnamesD,tnamesNT)
import Cryptol.ModuleSystem.Name

modExports :: Ord name => ModuleG mname name -> ExportSpec name
modExports :: ModuleG mname name -> ExportSpec name
modExports ModuleG mname name
m = [ExportSpec name] -> ExportSpec name
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[ExportSpec name]] -> [ExportSpec name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ TopDecl name -> [ExportSpec name]
forall name. Ord name => TopDecl name -> [ExportSpec name]
exportedNames TopDecl name
d | TopDecl name
d <- ModuleG mname name -> [TopDecl name]
forall mname name. ModuleG mname name -> [TopDecl name]
mDecls ModuleG mname name
m ])


exportedNames :: Ord name => TopDecl name -> [ExportSpec name]
exportedNames :: TopDecl name -> [ExportSpec name]
exportedNames (Decl TopLevel (Decl name)
td) = (TopLevel name -> ExportSpec name)
-> [TopLevel name] -> [ExportSpec name]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel name -> ExportSpec name
forall name. Ord name => TopLevel name -> ExportSpec name
exportBind  ((Decl name -> ([Located name], Set name))
-> TopLevel (Decl name) -> [TopLevel name]
forall a a' b.
(a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a']
names Decl name -> ([Located name], Set name)
forall name. Ord name => Decl name -> ([Located name], Set name)
namesD TopLevel (Decl name)
td)
                       [ExportSpec name] -> [ExportSpec name] -> [ExportSpec name]
forall a. [a] -> [a] -> [a]
++ (TopLevel name -> ExportSpec name)
-> [TopLevel name] -> [ExportSpec name]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel name -> ExportSpec name
forall name. Ord name => TopLevel name -> ExportSpec name
exportType ((Decl name -> ([Located name], Set name))
-> TopLevel (Decl name) -> [TopLevel name]
forall a a' b.
(a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a']
names Decl name -> ([Located name], Set name)
forall name. Ord name => Decl name -> ([Located name], Set name)
tnamesD TopLevel (Decl name)
td)
exportedNames (DPrimType TopLevel (PrimType name)
t) = [ TopLevel name -> ExportSpec name
forall name. Ord name => TopLevel name -> ExportSpec name
exportType (Located name -> name
forall a. Located a -> a
thing (Located name -> name)
-> (PrimType name -> Located name) -> PrimType name -> name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimType name -> Located name
forall name. PrimType name -> Located name
primTName (PrimType name -> name)
-> TopLevel (PrimType name) -> TopLevel name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (PrimType name)
t) ]
exportedNames (TDNewtype TopLevel (Newtype name)
nt) = (TopLevel name -> ExportSpec name)
-> [TopLevel name] -> [ExportSpec name]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel name -> ExportSpec name
forall name. Ord name => TopLevel name -> ExportSpec name
exportType ((Newtype name -> ([Located name], ()))
-> TopLevel (Newtype name) -> [TopLevel name]
forall a a' b.
(a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a']
names Newtype name -> ([Located name], ())
forall name. Newtype name -> ([Located name], ())
tnamesNT TopLevel (Newtype name)
nt)
exportedNames (Include {})  = []
exportedNames (DImport {}) = []
exportedNames (DParameterFun {}) = []
exportedNames (DParameterType {}) = []
exportedNames (DParameterConstraint {}) = []
exportedNames (DModule TopLevel (NestedModule name)
nested) =
  case TopLevel (NestedModule name) -> NestedModule name
forall a. TopLevel a -> a
tlValue TopLevel (NestedModule name)
nested of
    NestedModule ModuleG name name
x ->
      [Namespace -> TopLevel name -> ExportSpec name
forall name.
Ord name =>
Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
NSModule TopLevel (NestedModule name)
nested { tlValue :: name
tlValue = Located name -> name
forall a. Located a -> a
thing (ModuleG name name -> Located name
forall mname name. ModuleG mname name -> Located mname
mName ModuleG name name
x) }]

names :: (a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a']
names :: (a -> ([Located a'], b)) -> TopLevel a -> [TopLevel a']
names a -> ([Located a'], b)
by TopLevel a
td = [ TopLevel a
td { tlValue :: a'
tlValue = Located a' -> a'
forall a. Located a -> a
thing Located a'
n } | Located a'
n <- ([Located a'], b) -> [Located a']
forall a b. (a, b) -> a
fst (a -> ([Located a'], b)
by (TopLevel a -> a
forall a. TopLevel a -> a
tlValue TopLevel a
td)) ]


newtype ExportSpec name = ExportSpec (Map Namespace (Set name))
                                        deriving (Int -> ExportSpec name -> ShowS
[ExportSpec name] -> ShowS
ExportSpec name -> String
(Int -> ExportSpec name -> ShowS)
-> (ExportSpec name -> String)
-> ([ExportSpec name] -> ShowS)
-> Show (ExportSpec name)
forall name. Show name => Int -> ExportSpec name -> ShowS
forall name. Show name => [ExportSpec name] -> ShowS
forall name. Show name => ExportSpec name -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExportSpec name] -> ShowS
$cshowList :: forall name. Show name => [ExportSpec name] -> ShowS
show :: ExportSpec name -> String
$cshow :: forall name. Show name => ExportSpec name -> String
showsPrec :: Int -> ExportSpec name -> ShowS
$cshowsPrec :: forall name. Show name => Int -> ExportSpec name -> ShowS
Show, (forall x. ExportSpec name -> Rep (ExportSpec name) x)
-> (forall x. Rep (ExportSpec name) x -> ExportSpec name)
-> Generic (ExportSpec name)
forall x. Rep (ExportSpec name) x -> ExportSpec name
forall x. ExportSpec name -> Rep (ExportSpec name) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall name x. Rep (ExportSpec name) x -> ExportSpec name
forall name x. ExportSpec name -> Rep (ExportSpec name) x
$cto :: forall name x. Rep (ExportSpec name) x -> ExportSpec name
$cfrom :: forall name x. ExportSpec name -> Rep (ExportSpec name) x
Generic)

instance NFData name => NFData (ExportSpec name)

instance Ord name => Semigroup (ExportSpec name) where
  ExportSpec Map Namespace (Set name)
l <> :: ExportSpec name -> ExportSpec name -> ExportSpec name
<> ExportSpec Map Namespace (Set name)
r = Map Namespace (Set name) -> ExportSpec name
forall name. Map Namespace (Set name) -> ExportSpec name
ExportSpec ((Set name -> Set name -> Set name)
-> Map Namespace (Set name)
-> Map Namespace (Set name)
-> Map Namespace (Set name)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set name -> Set name -> Set name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map Namespace (Set name)
l Map Namespace (Set name)
r)

instance Ord name => Monoid (ExportSpec name) where
  mempty :: ExportSpec name
mempty  = Map Namespace (Set name) -> ExportSpec name
forall name. Map Namespace (Set name) -> ExportSpec name
ExportSpec Map Namespace (Set name)
forall k a. Map k a
Map.empty

exportName :: Ord name => Namespace -> TopLevel name -> ExportSpec name
exportName :: Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
ns TopLevel name
n
  | TopLevel name -> ExportType
forall a. TopLevel a -> ExportType
tlExport TopLevel name
n ExportType -> ExportType -> Bool
forall a. Eq a => a -> a -> Bool
== ExportType
Public = Map Namespace (Set name) -> ExportSpec name
forall name. Map Namespace (Set name) -> ExportSpec name
ExportSpec
                         (Map Namespace (Set name) -> ExportSpec name)
-> Map Namespace (Set name) -> ExportSpec name
forall a b. (a -> b) -> a -> b
$ Namespace -> Set name -> Map Namespace (Set name)
forall k a. k -> a -> Map k a
Map.singleton Namespace
ns
                         (Set name -> Map Namespace (Set name))
-> Set name -> Map Namespace (Set name)
forall a b. (a -> b) -> a -> b
$ name -> Set name
forall a. a -> Set a
Set.singleton (TopLevel name -> name
forall a. TopLevel a -> a
tlValue TopLevel name
n)
  | Bool
otherwise = ExportSpec name
forall a. Monoid a => a
mempty

exported :: Namespace -> ExportSpec name -> Set name
exported :: Namespace -> ExportSpec name -> Set name
exported Namespace
ns (ExportSpec Map Namespace (Set name)
mp) = Set name -> Namespace -> Map Namespace (Set name) -> Set name
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set name
forall a. Set a
Set.empty Namespace
ns Map Namespace (Set name)
mp

-- | Add a binding name to the export list, if it should be exported.
exportBind :: Ord name => TopLevel name -> ExportSpec name
exportBind :: TopLevel name -> ExportSpec name
exportBind = Namespace -> TopLevel name -> ExportSpec name
forall name.
Ord name =>
Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
NSValue

-- | Add a type synonym name to the export list, if it should be exported.
exportType :: Ord name => TopLevel name -> ExportSpec name
exportType :: TopLevel name -> ExportSpec name
exportType = Namespace -> TopLevel name -> ExportSpec name
forall name.
Ord name =>
Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
NSType



isExported :: Ord name => Namespace -> name -> ExportSpec name -> Bool
isExported :: Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
ns name
x (ExportSpec Map Namespace (Set name)
s) =
  case Namespace -> Map Namespace (Set name) -> Maybe (Set name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Namespace
ns Map Namespace (Set name)
s of
    Maybe (Set name)
Nothing -> Bool
False
    Just Set name
mp -> name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member name
x Set name
mp

-- | Check to see if a binding is exported.
isExportedBind :: Ord name => name -> ExportSpec name -> Bool
isExportedBind :: name -> ExportSpec name -> Bool
isExportedBind = Namespace -> name -> ExportSpec name -> Bool
forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSValue

-- | Check to see if a type synonym is exported.
isExportedType :: Ord name => name -> ExportSpec name -> Bool
isExportedType :: name -> ExportSpec name -> Bool
isExportedType = Namespace -> name -> ExportSpec name -> Bool
forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSType