File: Exports.hs

package info (click to toggle)
haskell-cryptol 2.8.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,644 kB
  • sloc: haskell: 20,847; yacc: 652; makefile: 5
file content (65 lines) | stat: -rw-r--r-- 2,260 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
{-# 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 m = fold (concat [ exportedNames d | d <- mDecls m ])
  where
  names by td = [ td { tlValue = thing n } | n <- fst (by (tlValue td)) ]

  exportedNames (Decl td) = map exportBind  (names  namesD td)
                         ++ map exportType (names tnamesD td)
  exportedNames (DPrimType t) = [ exportType (thing . primTName <$> t) ]
  exportedNames (TDNewtype nt) = map exportType (names tnamesNT nt)
  exportedNames (Include {})  = []
  exportedNames (DParameterFun {}) = []
  exportedNames (DParameterType {}) = []
  exportedNames (DParameterConstraint {}) = []



data ExportSpec name = ExportSpec { eTypes  :: Set name
                                  , eBinds  :: Set name
                                  } deriving (Show, Generic)

instance NFData name => NFData (ExportSpec name)

instance Ord name => Semigroup (ExportSpec name) where
  l <> r = ExportSpec { eTypes = eTypes l <> eTypes r
                      , eBinds = eBinds l <> eBinds  r
                      }

instance Ord name => Monoid (ExportSpec name) where
  mempty  = ExportSpec { eTypes = mempty, eBinds = mempty }
  mappend = (<>)

-- | Add a binding name to the export list, if it should be exported.
exportBind :: Ord name => TopLevel name -> ExportSpec name
exportBind n
  | tlExport n == Public = mempty { eBinds = Set.singleton (tlValue n) }
  | otherwise            = mempty

-- | Add a type synonym name to the export list, if it should be exported.
exportType :: Ord name => TopLevel name -> ExportSpec name
exportType n
  | tlExport n == Public = mempty { eTypes = Set.singleton (tlValue n) }
  | otherwise            = mempty

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

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