{-# 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,tnamesEnum,namesEnum)
import Cryptol.ModuleSystem.Name

exportedDecls :: Ord name => [TopDecl name] -> ExportSpec name
exportedDecls :: forall name. Ord name => [TopDecl name] -> ExportSpec name
exportedDecls [TopDecl name]
ds = [ExportSpec name] -> ExportSpec name
forall m. Monoid m => [m] -> m
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 <- [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 -> (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 {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [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 {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names Decl name -> ([Located name], Set name)
forall name. Ord name => Decl name -> ([Located name], Set name)
tnamesD TopLevel (Decl name)
td)
      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) ]
      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 {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names Newtype name -> ([Located name], ())
forall name. Newtype name -> ([Located name], ())
tnamesNT TopLevel (Newtype name)
nt) [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
exportCon ((Newtype name -> ([Located name], ()))
-> TopLevel (Newtype name) -> [TopLevel name]
forall {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names Newtype name -> ([Located name], ())
forall name. Newtype name -> ([Located name], ())
namesNT TopLevel (Newtype name)
nt)
      TDEnum TopLevel (EnumDecl name)
en -> (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 ((EnumDecl name -> ([Located name], ()))
-> TopLevel (EnumDecl name) -> [TopLevel name]
forall {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names EnumDecl name -> ([Located name], ())
forall name. EnumDecl name -> ([Located name], ())
tnamesEnum TopLevel (EnumDecl name)
en)
                [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
exportCon ((EnumDecl name -> ([Located name], ()))
-> TopLevel (EnumDecl name) -> [TopLevel name]
forall {t} {a} {b}.
(t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names EnumDecl name -> ([Located name], ())
forall name. EnumDecl name -> ([Located name], ())
namesEnum TopLevel (EnumDecl name)
en)
      Include {}  -> []
      DImport {} -> []
      DParamDecl {} -> []
      DInterfaceConstraint {} -> []
      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 = thing (mName x) }]
      DModParam {} -> []
  where
  names :: (t -> ([Located a], b)) -> TopLevel t -> [TopLevel a]
names t -> ([Located a], b)
by TopLevel t
td = [ TopLevel t
td { tlValue = thing n } | Located a
n <- ([Located a], b) -> [Located a]
forall a b. (a, b) -> a
fst (t -> ([Located a], b)
by (TopLevel t -> t
forall a. TopLevel a -> a
tlValue TopLevel t
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
$cshowsPrec :: forall name. Show name => Int -> ExportSpec name -> ShowS
showsPrec :: Int -> ExportSpec name -> ShowS
$cshow :: forall name. Show name => ExportSpec name -> String
show :: ExportSpec name -> String
$cshowList :: forall name. Show name => [ExportSpec name] -> ShowS
showList :: [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
$cfrom :: forall name x. ExportSpec name -> Rep (ExportSpec name) x
from :: forall x. ExportSpec name -> Rep (ExportSpec name) x
$cto :: forall name x. Rep (ExportSpec name) x -> ExportSpec name
to :: forall x. Rep (ExportSpec name) x -> ExportSpec name
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 :: forall name.
Ord name =>
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

allExported :: Ord name => ExportSpec name -> Set name
allExported :: forall name. Ord name => ExportSpec name -> Set name
allExported (ExportSpec Map Namespace (Set name)
mp) = [Set name] -> Set name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Map Namespace (Set name) -> [Set name]
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) = 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 :: forall name. Ord name => TopLevel name -> ExportSpec name
exportBind = Namespace -> TopLevel name -> ExportSpec name
forall name.
Ord name =>
Namespace -> TopLevel name -> ExportSpec name
exportName Namespace
NSValue

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

-- | 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 = 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 :: forall name.
Ord name =>
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 :: forall name. Ord name => name -> ExportSpec name -> Bool
isExportedBind name
x ExportSpec name
s = Namespace -> name -> ExportSpec name -> Bool
forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSValue name
x ExportSpec name
s Bool -> Bool -> Bool
|| Namespace -> name -> ExportSpec name -> Bool
forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSConstructor name
x ExportSpec name
s

-- | 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 = Namespace -> name -> ExportSpec name -> Bool
forall name.
Ord name =>
Namespace -> name -> ExportSpec name -> Bool
isExported Namespace
NSType