{-# 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 ds = fold (concat [ exportedNames d | d <- ds ])

exportedNames :: Ord name => TopDecl name -> [ExportSpec name]
exportedNames decl =
    case decl of
      Decl td -> map exportBind  (names  namesD td)
              ++ map exportType (names tnamesD td)
      DPrimType t -> [ exportType (thing . primTName <$> t) ]
      TDNewtype nt -> map exportType (names tnamesNT nt) ++
                      map exportCon (names namesNT nt)
      TDEnum en -> map exportType (names tnamesEnum en)
                ++ map exportCon (names namesEnum en)
      Include {}  -> []
      DImport {} -> []
      DParamDecl {} -> []
      DInterfaceConstraint {} -> []
      DModule nested ->
        case tlValue nested of
          NestedModule x ->
            [exportName NSModule nested { tlValue = thing (mName x) }]
      DModParam {} -> []
  where
  names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ]



newtype ExportSpec name = ExportSpec (Map Namespace (Set name))
                                        deriving (Show, Generic)

instance NFData name => NFData (ExportSpec name)

instance Ord name => Semigroup (ExportSpec name) where
  ExportSpec l <> ExportSpec r = ExportSpec (Map.unionWith Set.union l r)

instance Ord name => Monoid (ExportSpec name) where
  mempty  = ExportSpec Map.empty

exportName :: Ord name => Namespace -> TopLevel name -> ExportSpec name
exportName ns n
  | tlExport n == Public = ExportSpec
                         $ Map.singleton ns
                         $ Set.singleton (tlValue n)
  | otherwise = mempty

allExported :: Ord name => ExportSpec name -> Set name
allExported (ExportSpec mp) = Set.unions (Map.elems mp)

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

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

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

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



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

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

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