Name.hs

-- |
-- 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 (Generic, Show, Ord, 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 (Eq,Ord,Show,Generic)

-- | Passes that can generate fresh names.
data Pass = NoPat
          | MonoValues
          | ExpandPropGuards String
            deriving (Eq,Ord,Show,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 UnQual i <- UnQual' i _

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

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

mkQual :: ModName -> Ident -> PName
mkQual  = 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 og vis = toPName (ogName og)
  where
  toPName =
    case ogFromParam og of
      Nothing -> (`UnQual'` vis)
      Just sig -> Qual (identToModName sig)

getModName :: PName -> Maybe ModName
getModName (Qual ns _) = Just ns
getModName _           = Nothing

getIdent :: PName -> Ident
getIdent (UnQual' n _)    = n
getIdent (Qual _ n)    = n
getIdent (NewName p i) = packIdent ("__" ++ pass ++ show i)
  where
  pass = case p of
           NoPat              -> "p"
           MonoValues         -> "mv"
           ExpandPropGuards _ -> "epg"



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

instance PP PName where
  ppPrec _ = ppPrefixName

instance PPName PName where
  ppNameFixity n
    | isInfixIdent i = Just (Fixity NonAssoc 0) -- FIXME?
    | otherwise      = Nothing
    where
    i   = getIdent n

  ppPrefixName n = optParens (isInfixIdent i) (pfx <.> pp i)
    where
    i   = getIdent n
    pfx = case getModName n of
            Just ns -> pp ns <.> text "::"
            Nothing -> mempty

  ppInfixName n
    | isInfixIdent i = pfx <.> pp i
    | otherwise      = panic "AST" [ "non-symbol infix name:" ++ show n ]
    where
    i   = getIdent n
    pfx = case getModName n of
            Just ns -> pp ns <.> text "::"
            Nothing -> mempty