module Cryptol.ModuleSystem.Interface (
Iface(..)
, IfaceDecls(..)
, IfaceTySyn, ifTySynName
, IfaceNewtype
, IfaceDecl(..), mkIfaceDecl
, shadowing
, interpImport
, unqualified
, genIface
) where
import Cryptol.Parser.AST (mkQual)
import Cryptol.TypeCheck.AST
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
data Iface = Iface
{ ifModName :: ModName
, ifPublic :: IfaceDecls
, ifPrivate :: IfaceDecls
} deriving (Show)
data IfaceDecls = IfaceDecls
{ ifTySyns :: Map.Map QName [IfaceTySyn]
, ifNewtypes :: Map.Map QName [IfaceNewtype]
, ifDecls :: Map.Map QName [IfaceDecl]
} deriving (Show)
instance Monoid IfaceDecls where
mempty = IfaceDecls Map.empty Map.empty Map.empty
mappend l r = IfaceDecls
{ ifTySyns = Map.unionWith (mergeByName ifTySynName) (ifTySyns l) (ifTySyns r)
, ifNewtypes = Map.unionWith (mergeByName ntName) (ifNewtypes l) (ifNewtypes r)
, ifDecls = Map.unionWith (mergeByName ifDeclName) (ifDecls l) (ifDecls r)
}
mconcat ds = IfaceDecls
{ ifTySyns = Map.unionsWith (mergeByName ifTySynName) (map ifTySyns ds)
, ifNewtypes = Map.unionsWith (mergeByName ntName) (map ifNewtypes ds)
, ifDecls = Map.unionsWith (mergeByName ifDeclName) (map ifDecls ds)
}
mergeByName :: (a -> QName) -> [a] -> [a] -> [a]
mergeByName f ls rs
| [l] <- ls, [r] <- rs, f l == f r = ls
| otherwise = ls ++ rs
shadowing :: IfaceDecls -> IfaceDecls -> IfaceDecls
shadowing l r = IfaceDecls
{ ifTySyns = Map.union (ifTySyns l) (ifTySyns r)
, ifNewtypes = Map.union (ifNewtypes l) (ifNewtypes r)
, ifDecls = Map.union (ifDecls l) (ifDecls r)
}
type IfaceTySyn = TySyn
ifTySynName :: TySyn -> QName
ifTySynName = tsName
type IfaceNewtype = Newtype
data IfaceDecl = IfaceDecl
{ ifDeclName :: QName
, ifDeclSig :: Schema
, ifDeclPragmas :: [Pragma]
} deriving (Show)
mkIfaceDecl :: Decl -> IfaceDecl
mkIfaceDecl d = IfaceDecl
{ ifDeclName = dName d
, ifDeclSig = dSignature d
, ifDeclPragmas = dPragmas d
}
mapIfaceDecls :: (QName -> QName) -> IfaceDecls -> IfaceDecls
mapIfaceDecls f decls = IfaceDecls
{ ifTySyns = Map.mapKeys f (ifTySyns decls)
, ifNewtypes = Map.mapKeys f (ifNewtypes decls)
, ifDecls = Map.mapKeys f (ifDecls decls)
}
filterIfaceDecls :: (QName -> Bool) -> IfaceDecls -> IfaceDecls
filterIfaceDecls p decls = IfaceDecls
{ ifTySyns = Map.filterWithKey check (ifTySyns decls)
, ifNewtypes = Map.filterWithKey check (ifNewtypes decls)
, ifDecls = Map.filterWithKey check (ifDecls decls)
}
where
check :: QName -> a -> Bool
check k _ = p k
unqualified :: IfaceDecls -> IfaceDecls
unqualified = mapIfaceDecls (mkUnqual . unqual)
genIface :: Module -> Iface
genIface m = Iface
{ ifModName = mName m
, ifPublic = IfaceDecls
{ ifTySyns = tsPub
, ifNewtypes = ntPub
, ifDecls = dPub
}
, ifPrivate = IfaceDecls
{ ifTySyns = tsPriv
, ifNewtypes = ntPriv
, ifDecls = dPriv
}
}
where
(tsPub,tsPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
$ fmap return (mTySyns m)
(ntPub,ntPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
$ fmap return (mNewtypes m)
(dPub,dPriv) =
Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m)
$ Map.fromList [ (qn,[mkIfaceDecl d]) | dg <- mDecls m
, d <- groupDecls dg
, let qn = dName d
]
interpImport :: Import -> Iface -> Iface
interpImport i iface = Iface
{ ifModName = ifModName iface
, ifPublic = qualify restricted
, ifPrivate = mempty
}
where
public = unqualified (ifPublic iface)
qualify | Just n <- iAs i = \ names -> qualifyNames n names
| otherwise = id
restricted
| Just (Hiding names) <- iSpec i =
let qnames = map mkUnqual names
in filterIfaceDecls (\qn -> not (qn `elem` qnames)) public
| Just (Only names) <- iSpec i =
let qnames = map mkUnqual names
in filterIfaceDecls (\qn -> qn `elem` qnames) public
| otherwise = public
qualifyNames pfx = mapIfaceDecls (\ n -> mkQual pfx (unqual n))