-- |
-- Module      :  Cryptol.Parser.Name
-- Copyright   :  (c) 2015-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternSynonyms #-}

module Cryptol.Parser.Name (
  NameSource(..)
  , PName(..)
  , Pass(..)
  , mkQual
  , mkUnqual
  , mkUnqualSystem
  , origNameToDefPName
  , getModName
  , getIdent
  , isSystemName
  , pattern UnQual
  ) where

import Cryptol.Utils.Fixity
import Cryptol.Utils.Ident
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)

import           Control.DeepSeq
import           GHC.Generics (Generic)


-- Names -----------------------------------------------------------------------

data NameSource = SystemName | UserName
                    deriving ((forall x. NameSource -> Rep NameSource x)
-> (forall x. Rep NameSource x -> NameSource) -> Generic NameSource
forall x. Rep NameSource x -> NameSource
forall x. NameSource -> Rep NameSource x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NameSource -> Rep NameSource x
from :: forall x. NameSource -> Rep NameSource x
$cto :: forall x. Rep NameSource x -> NameSource
to :: forall x. Rep NameSource x -> NameSource
Generic, Int -> NameSource -> ShowS
[NameSource] -> ShowS
NameSource -> String
(Int -> NameSource -> ShowS)
-> (NameSource -> String)
-> ([NameSource] -> ShowS)
-> Show NameSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameSource -> ShowS
showsPrec :: Int -> NameSource -> ShowS
$cshow :: NameSource -> String
show :: NameSource -> String
$cshowList :: [NameSource] -> ShowS
showList :: [NameSource] -> ShowS
Show, Eq NameSource
Eq NameSource =>
(NameSource -> NameSource -> Ordering)
-> (NameSource -> NameSource -> Bool)
-> (NameSource -> NameSource -> Bool)
-> (NameSource -> NameSource -> Bool)
-> (NameSource -> NameSource -> Bool)
-> (NameSource -> NameSource -> NameSource)
-> (NameSource -> NameSource -> NameSource)
-> Ord NameSource
NameSource -> NameSource -> Bool
NameSource -> NameSource -> Ordering
NameSource -> NameSource -> NameSource
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NameSource -> NameSource -> Ordering
compare :: NameSource -> NameSource -> Ordering
$c< :: NameSource -> NameSource -> Bool
< :: NameSource -> NameSource -> Bool
$c<= :: NameSource -> NameSource -> Bool
<= :: NameSource -> NameSource -> Bool
$c> :: NameSource -> NameSource -> Bool
> :: NameSource -> NameSource -> Bool
$c>= :: NameSource -> NameSource -> Bool
>= :: NameSource -> NameSource -> Bool
$cmax :: NameSource -> NameSource -> NameSource
max :: NameSource -> NameSource -> NameSource
$cmin :: NameSource -> NameSource -> NameSource
min :: NameSource -> NameSource -> NameSource
Ord, NameSource -> NameSource -> Bool
(NameSource -> NameSource -> Bool)
-> (NameSource -> NameSource -> Bool) -> Eq NameSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameSource -> NameSource -> Bool
== :: NameSource -> NameSource -> Bool
$c/= :: NameSource -> NameSource -> Bool
/= :: NameSource -> NameSource -> Bool
Eq)
-- | Names that originate in the parser.
--   Note here that other kinds of PName do not need this kind of flag because: 
--   (1) NewName are generated by the system, so these should never be user visible.
--   (2) Qual names are user names use to refer to imported modules. Should these names
--       names ever be used to refer to system names, then there make be a bug in the renamer
--       that needs to be fixed.
data PName = UnQual' !Ident !NameSource
             -- ^ Unqualified names like @x@, @Foo@, or @+@.
           | Qual !ModName !Ident
             -- ^ Qualified names like @Foo::bar@ or @module::!@.
           | NewName !Pass !Int
             -- ^ Fresh names generated by a pass.
             deriving (PName -> PName -> Bool
(PName -> PName -> Bool) -> (PName -> PName -> Bool) -> Eq PName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PName -> PName -> Bool
== :: PName -> PName -> Bool
$c/= :: PName -> PName -> Bool
/= :: PName -> PName -> Bool
Eq,Eq PName
Eq PName =>
(PName -> PName -> Ordering)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> PName)
-> (PName -> PName -> PName)
-> Ord PName
PName -> PName -> Bool
PName -> PName -> Ordering
PName -> PName -> PName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PName -> PName -> Ordering
compare :: PName -> PName -> Ordering
$c< :: PName -> PName -> Bool
< :: PName -> PName -> Bool
$c<= :: PName -> PName -> Bool
<= :: PName -> PName -> Bool
$c> :: PName -> PName -> Bool
> :: PName -> PName -> Bool
$c>= :: PName -> PName -> Bool
>= :: PName -> PName -> Bool
$cmax :: PName -> PName -> PName
max :: PName -> PName -> PName
$cmin :: PName -> PName -> PName
min :: PName -> PName -> PName
Ord,Int -> PName -> ShowS
[PName] -> ShowS
PName -> String
(Int -> PName -> ShowS)
-> (PName -> String) -> ([PName] -> ShowS) -> Show PName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PName -> ShowS
showsPrec :: Int -> PName -> ShowS
$cshow :: PName -> String
show :: PName -> String
$cshowList :: [PName] -> ShowS
showList :: [PName] -> ShowS
Show,(forall x. PName -> Rep PName x)
-> (forall x. Rep PName x -> PName) -> Generic PName
forall x. Rep PName x -> PName
forall x. PName -> Rep PName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PName -> Rep PName x
from :: forall x. PName -> Rep PName x
$cto :: forall x. Rep PName x -> PName
to :: forall x. Rep PName x -> PName
Generic)

-- | Passes that can generate fresh names.
data Pass = NoPat
          | MonoValues
          | ExpandPropGuards String
            deriving (Pass -> Pass -> Bool
(Pass -> Pass -> Bool) -> (Pass -> Pass -> Bool) -> Eq Pass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pass -> Pass -> Bool
== :: Pass -> Pass -> Bool
$c/= :: Pass -> Pass -> Bool
/= :: Pass -> Pass -> Bool
Eq,Eq Pass
Eq Pass =>
(Pass -> Pass -> Ordering)
-> (Pass -> Pass -> Bool)
-> (Pass -> Pass -> Bool)
-> (Pass -> Pass -> Bool)
-> (Pass -> Pass -> Bool)
-> (Pass -> Pass -> Pass)
-> (Pass -> Pass -> Pass)
-> Ord Pass
Pass -> Pass -> Bool
Pass -> Pass -> Ordering
Pass -> Pass -> Pass
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pass -> Pass -> Ordering
compare :: Pass -> Pass -> Ordering
$c< :: Pass -> Pass -> Bool
< :: Pass -> Pass -> Bool
$c<= :: Pass -> Pass -> Bool
<= :: Pass -> Pass -> Bool
$c> :: Pass -> Pass -> Bool
> :: Pass -> Pass -> Bool
$c>= :: Pass -> Pass -> Bool
>= :: Pass -> Pass -> Bool
$cmax :: Pass -> Pass -> Pass
max :: Pass -> Pass -> Pass
$cmin :: Pass -> Pass -> Pass
min :: Pass -> Pass -> Pass
Ord,Int -> Pass -> ShowS
[Pass] -> ShowS
Pass -> String
(Int -> Pass -> ShowS)
-> (Pass -> String) -> ([Pass] -> ShowS) -> Show Pass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pass -> ShowS
showsPrec :: Int -> Pass -> ShowS
$cshow :: Pass -> String
show :: Pass -> String
$cshowList :: [Pass] -> ShowS
showList :: [Pass] -> ShowS
Show,(forall x. Pass -> Rep Pass x)
-> (forall x. Rep Pass x -> Pass) -> Generic Pass
forall x. Rep Pass x -> Pass
forall x. Pass -> Rep Pass x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Pass -> Rep Pass x
from :: forall x. Pass -> Rep Pass x
$cto :: forall x. Rep Pass x -> Pass
to :: forall x. Rep Pass x -> Pass
Generic)

instance NFData PName
instance NFData Pass
instance NFData NameSource

-- | Pattern synonym for when we are trying to deconstruct
--   unqualified PNames to get their identifiers.
pattern UnQual :: Ident -> PName
pattern $mUnQual :: forall {r}. PName -> (Ident -> r) -> ((# #) -> r) -> r
UnQual i <- UnQual' i _

mkUnqual :: Ident -> PName
mkUnqual :: Ident -> PName
mkUnqual  = (Ident -> NameSource -> PName
`UnQual'` NameSource
UserName)

mkUnqualSystem :: Ident -> PName
mkUnqualSystem :: Ident -> PName
mkUnqualSystem = (Ident -> NameSource -> PName
`UnQual'` NameSource
SystemName)

mkQual :: ModName -> Ident -> PName
mkQual :: ModName -> Ident -> PName
mkQual  = ModName -> Ident -> PName
Qual

-- | Compute a `PName` for the definition site corresponding to the given
-- `OrigName`.   Usually this is an unqualified name, but names that come
-- from module parameters are qualified with the corresponding parameter name.
origNameToDefPName :: OrigName -> NameSource -> PName
origNameToDefPName :: OrigName -> NameSource -> PName
origNameToDefPName OrigName
og NameSource
vis = Ident -> PName
toPName (OrigName -> Ident
ogName OrigName
og)
  where
  toPName :: Ident -> PName
toPName =
    case OrigName -> Maybe Ident
ogFromParam OrigName
og of
      Maybe Ident
Nothing -> (Ident -> NameSource -> PName
`UnQual'` NameSource
vis)
      Just Ident
sig -> ModName -> Ident -> PName
Qual (Ident -> ModName
identToModName Ident
sig)

getModName :: PName -> Maybe ModName
getModName :: PName -> Maybe ModName
getModName (Qual ModName
ns Ident
_) = ModName -> Maybe ModName
forall a. a -> Maybe a
Just ModName
ns
getModName PName
_           = Maybe ModName
forall a. Maybe a
Nothing

getIdent :: PName -> Ident
getIdent :: PName -> Ident
getIdent (UnQual' Ident
n NameSource
_)    = Ident
n
getIdent (Qual ModName
_ Ident
n)    = Ident
n
getIdent (NewName Pass
p Int
i) = String -> Ident
packIdent (String
"__" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pass String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
  where
  pass :: String
pass = case Pass
p of
           Pass
NoPat              -> String
"p"
           Pass
MonoValues         -> String
"mv"
           ExpandPropGuards String
_ -> String
"epg"



isSystemName :: PName -> Bool
isSystemName :: PName -> Bool
isSystemName PName
x =
  case PName
x of
    UnQual' Ident
_id NameSource
ns ->   case NameSource
ns of
                          NameSource
SystemName -> Bool
True
                          NameSource
UserName -> Bool
False
    Qual ModName
_md Ident
_id -> Bool
False
    NewName Pass
_p Int
_i -> Bool
True

instance PP PName where
  ppPrec :: Int -> PName -> Doc
ppPrec Int
_ = PName -> Doc
forall a. PPName a => a -> Doc
ppPrefixName

instance PPName PName where
  ppNameFixity :: PName -> Maybe Fixity
ppNameFixity PName
n
    | Ident -> Bool
isInfixIdent Ident
i = Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just (Assoc -> Int -> Fixity
Fixity Assoc
NonAssoc Int
0) -- FIXME?
    | Bool
otherwise      = Maybe Fixity
forall a. Maybe a
Nothing
    where
    i :: Ident
i   = PName -> Ident
getIdent PName
n

  ppPrefixName :: PName -> Doc
ppPrefixName PName
n = Bool -> Doc -> Doc
optParens (Ident -> Bool
isInfixIdent Ident
i) (Doc
pfx Doc -> Doc -> Doc
<.> Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
i)
    where
    i :: Ident
i   = PName -> Ident
getIdent PName
n
    pfx :: Doc
pfx = case PName -> Maybe ModName
getModName PName
n of
            Just ModName
ns -> ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
ns Doc -> Doc -> Doc
<.> String -> Doc
text String
"::"
            Maybe ModName
Nothing -> Doc
forall a. Monoid a => a
mempty

  ppInfixName :: PName -> Doc
ppInfixName PName
n
    | Ident -> Bool
isInfixIdent Ident
i = Doc
pfx Doc -> Doc -> Doc
<.> Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
i
    | Bool
otherwise      = String -> [String] -> Doc
forall a. HasCallStack => String -> [String] -> a
panic String
"AST" [ String
"non-symbol infix name:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PName -> String
forall a. Show a => a -> String
show PName
n ]
    where
    i :: Ident
i   = PName -> Ident
getIdent PName
n
    pfx :: Doc
pfx = case PName -> Maybe ModName
getModName PName
n of
            Just ModName
ns -> ModName -> Doc
forall a. PP a => a -> Doc
pp ModName
ns Doc -> Doc -> Doc
<.> String -> Doc
text String
"::"
            Maybe ModName
Nothing -> Doc
forall a. Monoid a => a
mempty