module Cryptol.ModuleSystem.Name (
Name(), NameInfo(..)
, nameUnique
, nameIdent
, nameInfo
, nameLoc
, nameFixity
, asPrim
, cmpNameLexical
, cmpNameDisplay
, ppLocName
, mkDeclared
, mkParameter
, FreshM(..), nextUniqueM
, SupplyT(), runSupplyT
, Supply(), emptySupply, nextUnique
, PrimMap(..)
, lookupPrimDecl
, lookupPrimType
) where
import Cryptol.Parser.AST( Fixity(..) )
import Cryptol.Parser.Position (Range,Located(..))
import Cryptol.Utils.Ident
import Cryptol.Utils.Panic
import Cryptol.Utils.PP
import Control.DeepSeq
import Control.Monad.Fix (MonadFix(mfix))
import qualified Data.Map as Map
import qualified Data.Monoid as M
import Data.Ord (comparing)
import GHC.Generics (Generic)
import MonadLib
import Prelude ()
import Prelude.Compat
data NameInfo = Declared !ModName
| Parameter
deriving (Eq, Show, Generic, NFData)
data Name = Name { nUnique :: !Int
, nInfo :: !NameInfo
, nIdent :: !Ident
, nFixity :: !(Maybe Fixity)
, nLoc :: !Range
} deriving (Show, Generic, NFData)
instance Eq Name where
a == b = compare a b == EQ
a /= b = compare a b /= EQ
instance Ord Name where
compare a b = compare (nUnique a) (nUnique b)
cmpNameLexical :: Name -> Name -> Ordering
cmpNameLexical l r =
case (nameInfo l, nameInfo r) of
(Declared nsl,Declared nsr) ->
case compare nsl nsr of
EQ -> comparing nameIdent l r
cmp -> cmp
(Parameter,Parameter) -> comparing nameIdent l r
(Declared nsl,Parameter) -> compare nsl (identText (nameIdent r))
(Parameter,Declared nsr) -> compare (identText (nameIdent l)) nsr
cmpNameDisplay :: NameDisp -> Name -> Name -> Ordering
cmpNameDisplay disp l r =
case (nameInfo l, nameInfo r) of
(Declared nsl, Declared nsr) ->
let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp)
pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp)
in case compare pfxl pfxr of
EQ -> compare (nameIdent l) (nameIdent r)
cmp -> cmp
(Parameter,Parameter) ->
compare (nameIdent l) (nameIdent r)
(Declared nsl,Parameter) ->
let pfxl = fmtModName nsl (getNameFormat nsl (nameIdent l) disp)
in case compare pfxl (identText (nameIdent r)) of
EQ -> GT
cmp -> cmp
(Parameter,Declared nsr) ->
let pfxr = fmtModName nsr (getNameFormat nsr (nameIdent r) disp)
in case compare (identText (nameIdent l)) pfxr of
EQ -> LT
cmp -> cmp
ppName :: Name -> Doc
ppName Name { .. } =
case nInfo of
Declared m -> withNameDisp $ \disp ->
case getNameFormat m nIdent disp of
Qualified m' -> pp m' <> text "::" <> pp nIdent
UnQualified -> pp nIdent
NotInScope -> pp m <> text "::" <> pp nIdent
Parameter -> pp nIdent
instance PP Name where
ppPrec _ = ppPrefixName
instance PPName Name where
ppNameFixity n = fmap (\(Fixity a i) -> (a,i)) $ nameFixity n
ppInfixName n @ Name { .. }
| isInfixIdent nIdent = ppName n
| otherwise = panic "Name" [ "Non-infix name used infix"
, show nIdent ]
ppPrefixName n @ Name { .. } = optParens (isInfixIdent nIdent) (ppName n)
ppLocName :: Name -> Doc
ppLocName n = pp Located { srcRange = nameLoc n, thing = n }
nameUnique :: Name -> Int
nameUnique = nUnique
nameIdent :: Name -> Ident
nameIdent = nIdent
nameInfo :: Name -> NameInfo
nameInfo = nInfo
nameLoc :: Name -> Range
nameLoc = nLoc
nameFixity :: Name -> Maybe Fixity
nameFixity = nFixity
asPrim :: Name -> Maybe Ident
asPrim Name { .. }
| nInfo == Declared preludeName = Just nIdent
| otherwise = Nothing
class Monad m => FreshM m where
liftSupply :: (Supply -> (a,Supply)) -> m a
instance FreshM m => FreshM (ExceptionT i m) where
liftSupply f = lift (liftSupply f)
instance (M.Monoid i, FreshM m) => FreshM (WriterT i m) where
liftSupply f = lift (liftSupply f)
instance FreshM m => FreshM (ReaderT i m) where
liftSupply f = lift (liftSupply f)
instance FreshM m => FreshM (StateT i m) where
liftSupply f = lift (liftSupply f)
instance Monad m => FreshM (SupplyT m) where
liftSupply f = SupplyT $
do s <- get
let (a,s') = f s
set $! s'
return a
newtype SupplyT m a = SupplyT { unSupply :: StateT Supply m a }
runSupplyT :: Monad m => Supply -> SupplyT m a -> m (a,Supply)
runSupplyT s (SupplyT m) = runStateT s m
instance Monad m => Functor (SupplyT m) where
fmap f (SupplyT m) = SupplyT (fmap f m)
instance Monad m => Applicative (SupplyT m) where
pure x = SupplyT (pure x)
f <*> g = SupplyT (unSupply f <*> unSupply g)
instance Monad m => Monad (SupplyT m) where
return = pure
m >>= f = SupplyT (unSupply m >>= unSupply . f)
instance MonadT SupplyT where
lift m = SupplyT (lift m)
instance BaseM m n => BaseM (SupplyT m) n where
inBase m = SupplyT (inBase m)
instance RunM m (a,Supply) r => RunM (SupplyT m) a (Supply -> r) where
runM (SupplyT m) s = runM m s
instance MonadFix m => MonadFix (SupplyT m) where
mfix f = SupplyT (mfix (unSupply . f))
nextUniqueM :: FreshM m => m Int
nextUniqueM = liftSupply nextUnique
data Supply = Supply !Int
deriving (Show, Generic, NFData)
emptySupply :: Supply
emptySupply = Supply 0
nextUnique :: Supply -> (Int,Supply)
nextUnique (Supply n) = s' `seq` (n,s')
where
s' = Supply (n + 1)
mkDeclared :: ModName -> Ident -> Maybe Fixity -> Range -> Supply -> (Name,Supply)
mkDeclared m nIdent nFixity nLoc s =
let (nUnique,s') = nextUnique s
nInfo = Declared m
in (Name { .. }, s')
mkParameter :: Ident -> Range -> Supply -> (Name,Supply)
mkParameter nIdent nLoc s =
let (nUnique,s') = nextUnique s
nFixity = Nothing
in (Name { nInfo = Parameter, .. }, s')
data PrimMap = PrimMap { primDecls :: Map.Map Ident Name
, primTypes :: Map.Map Ident Name
} deriving (Show, Generic, NFData)
lookupPrimDecl, lookupPrimType :: Ident -> PrimMap -> Name
lookupPrimDecl name PrimMap { .. } = Map.findWithDefault err name primDecls
where
err = panic "Cryptol.ModuleSystem.Name.lookupPrimDecl"
[ "Unknown declaration: " ++ show name
, show primDecls ]
lookupPrimType name PrimMap { .. } = Map.findWithDefault err name primTypes
where
err = panic "Cryptol.ModuleSystem.Name.lookupPrimType"
[ "Unknown type: " ++ show name
, show primTypes ]