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

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

import Cryptol.Parser.AST
import Cryptol.Parser.Names

modExports :: Ord name => Module name -> ExportSpec name
modExports :: Module name -> ExportSpec name
modExports Module 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 <- Module name -> [TopDecl name]
forall name. Module name -> [TopDecl name]
mDecls Module name
m ])
  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 = 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)) ]

  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 (DParameterFun {}) = []
  exportedNames (DParameterType {}) = []
  exportedNames (DParameterConstraint {}) = []



data ExportSpec name = ExportSpec { ExportSpec name -> Set name
eTypes  :: Set name
                                  , ExportSpec name -> Set name
eBinds  :: 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 name
l <> :: ExportSpec name -> ExportSpec name -> ExportSpec name
<> ExportSpec name
r = ExportSpec :: forall name. Set name -> Set name -> ExportSpec name
ExportSpec { eTypes :: Set name
eTypes = ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eTypes ExportSpec name
l Set name -> Set name -> Set name
forall a. Semigroup a => a -> a -> a
<> ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eTypes ExportSpec name
r
                      , eBinds :: Set name
eBinds = ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eBinds ExportSpec name
l Set name -> Set name -> Set name
forall a. Semigroup a => a -> a -> a
<> ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eBinds  ExportSpec name
r
                      }

instance Ord name => Monoid (ExportSpec name) where
  mempty :: ExportSpec name
mempty  = ExportSpec :: forall name. Set name -> Set name -> ExportSpec name
ExportSpec { eTypes :: Set name
eTypes = Set name
forall a. Monoid a => a
mempty, eBinds :: Set name
eBinds = Set name
forall a. Monoid a => a
mempty }
  mappend :: ExportSpec name -> ExportSpec name -> ExportSpec name
mappend = ExportSpec name -> ExportSpec name -> ExportSpec name
forall a. Semigroup a => a -> a -> a
(<>)

-- | 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 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 = ExportSpec name
forall a. Monoid a => a
mempty { eBinds :: Set name
eBinds = 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

-- | 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 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 = ExportSpec name
forall a. Monoid a => a
mempty { eTypes :: Set name
eTypes = 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

-- | Check to see if a binding is exported.
isExportedBind :: Ord name => name -> ExportSpec name -> Bool
isExportedBind :: name -> ExportSpec name -> Bool
isExportedBind name
n = name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member name
n (Set name -> Bool)
-> (ExportSpec name -> Set name) -> ExportSpec name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eBinds

-- | Check to see if a type synonym is exported.
isExportedType :: Ord name => name -> ExportSpec name -> Bool
isExportedType :: name -> ExportSpec name -> Bool
isExportedType name
n = name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member name
n (Set name -> Bool)
-> (ExportSpec name -> Set name) -> ExportSpec name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExportSpec name -> Set name
forall name. ExportSpec name -> Set name
eTypes