{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Safe #-}
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,namesNT,tnamesNT)
import Cryptol.ModuleSystem.Name

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

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



newtype ExportSpec name = ExportSpec (Map Namespace (Set name))
                                        deriving (Int -> ExportSpec name -> ShowS
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 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 = forall name. Map Namespace (Set name) -> ExportSpec name
ExportSpec (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith 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  = forall name. Map Namespace (Set name) -> ExportSpec name
ExportSpec forall k a. Map k a
Map.empty

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

allExported :: Ord name => ExportSpec name -> Set name
allExported :: forall name. Ord name => ExportSpec name -> Set name
allExported (ExportSpec Map Namespace (Set name)
mp) = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall k a. Map k a -> [a]
Map.elems Map Namespace (Set name)
mp)

exported :: Namespace -> ExportSpec name -> Set name
exported :: forall name. Namespace -> ExportSpec name -> Set name
exported Namespace
ns (ExportSpec Map Namespace (Set name)
mp) = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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 :: forall name. Ord name => TopLevel name -> ExportSpec name
exportBind = 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 :: forall name. Ord name => TopLevel name -> ExportSpec name
exportType = forall name.
Ord name =>
Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
NSType



isExported :: Ord name => Namespace -> name -> ExportSpec name -> Bool
isExported :: forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
ns name
x (ExportSpec Map Namespace (Set name)
s) =
  case 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 -> 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 :: forall name. Ord name => name -> ExportSpec name -> Bool
isExportedBind = 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 :: forall name. Ord name => name -> ExportSpec name -> Bool
isExportedType = forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSType