-- This corresponds to src/comp/Id.hs and src/comp/IdPrint.hs in bsc.
module Language.Bluespec.Classic.AST.Id
  ( Id
  , addIdProp
  , addIdProps
  , createPositionString
  , enumId
  , getIdBase
  , getIdBaseString
  , getIdPosition
  , getIdProps
  , getIdQual
  , getIdQualString
  , getIdString
  , mkId
  , mkQId
  , ppConId
  , ppId
  , ppVarId
  , qualEq
  , setBadId
  , setIdProps

  , IdProp(..)

  , Longname
  ) where

import Data.Char (isDigit)
import qualified Data.List as L
import Text.PrettyPrint.HughesPJClass

import Language.Bluespec.Classic.AST.Builtin.FStrings
import Language.Bluespec.Classic.AST.FString
import Language.Bluespec.Classic.AST.Position
import Language.Bluespec.Lex
import Language.Bluespec.Prelude
import Language.Bluespec.Pretty
import Language.Bluespec.Util

data Id = Id { Id -> Position
id_pos :: !Position,
               Id -> FString
id_mfs :: !FString,
               Id -> FString
id_fs :: !FString,
               Id -> [IdProp]
id_props :: [IdProp] {- , id_stab :: Int -}
             }

idEq :: Id -> Id -> Bool
idEq :: Id -> Id -> Bool
idEq Id
a Id
b = (Id -> FString
id_fs Id
a FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> FString
id_fs Id
b) Bool -> Bool -> Bool
&& (Id -> FString
id_mfs Id
a FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> FString
id_mfs Id
b)

idCompare :: Id -> Id -> Ordering
idCompare :: Id -> Id -> Ordering
idCompare Id
a Id
b = case (FString -> FString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Id -> FString
id_fs Id
a) (Id -> FString
id_fs Id
b)) of
                Ordering
EQ -> FString -> FString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Id -> FString
id_mfs Id
a) (Id -> FString
id_mfs Id
b)
                Ordering
LT -> Ordering
LT
                Ordering
GT -> Ordering
GT

instance Eq Id where
        Id
a == :: Id -> Id -> Bool
== Id
b = Id -> Id -> Bool
idEq Id
a Id
b

instance Ord Id where
    compare :: Id -> Id -> Ordering
compare  = Id -> Id -> Ordering
idCompare

instance Show Id where
    show :: Id -> String
show = Id -> String
show_brief

instance Pretty Id where
    pPrintPrec :: PDetail -> Rational -> Id -> Doc
pPrintPrec PDetail
d Rational
_p Id
i
      | PDetail
d PDetail -> PDetail -> Bool
forall a. Eq a => a -> a -> Bool
== PDetail
pdDebug
      = String -> Doc
text (Id -> String
local_show Id
i)
      | Bool
otherwise
      = if (Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1)
             then String -> Doc
text ((Id -> String
getIdString Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        String
"_"  String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
             else String -> Doc
text (Id -> String
getIdString Id
i)

instance HasPosition Id where
    getPosition :: Id -> Position
getPosition Id
i = Id -> Position
getIdPosition Id
i

local_show :: Id -> String
local_show :: Id -> String
local_show Id
id' =
    let
        pos :: Position
pos = Id -> Position
getIdPosition Id
id'
        mfs :: String
mfs = Id -> String
getIdQualString Id
id'
        fs :: String
fs = Id -> String
getIdBaseString Id
id'
        str :: String
str = Position -> String
forall a. Show a => a -> String
show Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                ShowS
forall a. Show a => a -> String
show String
mfs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                ShowS
forall a. Show a => a -> String
show String
fs
    in String
str

show_brief :: Id -> String
show_brief :: Id -> String
show_brief Id
i =
    case (FString -> String
getFString (Id -> FString
id_mfs Id
i), FString -> String
getFString (Id -> FString
id_fs Id
i)) of
    (String
"", String
str) -> ShowS
add_props String
str
    (String
pkg, String
str) -> ShowS
add_props (String
pkg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"::" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
  where add_props :: ShowS
add_props String
str | [IdProp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Id -> [IdProp]
id_props Id
i) = String
str
                      | Bool
otherwise = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ [IdProp] -> String
forall a. Show a => a -> String
show (Id -> [IdProp]
id_props Id
i)

createPositionString :: Position -> String
createPositionString :: Position -> String
createPositionString Position
_ = String
"<NoPos>"

-- Create an id of the form "<str>_<index>".
-- This is used to ENUMerate a list of Ids with the same name,
-- but with uniquifying numbers.
--
-- Note: The Ids created with this are marked as "bad".  If these Ids
-- need to be created from a user-given name, consider creating a new
-- interface for this which takes Id and not String, and derives its
-- properties from that Id.
enumId :: String -> Position -> Int -> Id
enumId :: String -> Position -> Int -> Id
enumId String
str Position
pos Int
index =
    let id_str :: FString
id_str = Int -> String -> FString
tmpFString Int
index (String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. ToString a => a -> String
itos Int
index)
    in  Id -> Id
setBadId
            (Position -> FString -> FString -> [IdProp] -> Id
Id Position
pos FString
fsEmpty FString
id_str [])

getIdBase :: Id -> FString
getIdBase :: Id -> FString
getIdBase Id
a = Id -> FString
id_fs Id
a

getIdBaseString :: Id -> String
getIdBaseString :: Id -> String
getIdBaseString Id
a = FString -> String
getFString (FString -> String) -> FString -> String
forall a b. (a -> b) -> a -> b
$ Id -> FString
getIdBase Id
a

getIdPosition :: Id -> Position
getIdPosition :: Id -> Position
getIdPosition Id
a = Id -> Position
id_pos Id
a

getIdProps :: Id -> [IdProp]
getIdProps :: Id -> [IdProp]
getIdProps Id
a = Id -> [IdProp]
id_props Id
a

getIdQual :: Id -> FString
getIdQual :: Id -> FString
getIdQual Id
a = Id -> FString
id_mfs Id
a

getIdQualString :: Id -> String
getIdQualString :: Id -> String
getIdQualString Id
a = FString -> String
getFString (FString -> String) -> FString -> String
forall a b. (a -> b) -> a -> b
$ Id -> FString
getIdQual Id
a

getIdString :: Id -> String
getIdString :: Id -> String
getIdString Id
a | FString
mfs FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== FString
fsEmpty = FString -> String
getFString FString
fs
              | Bool
otherwise = FString -> String
getFString FString
mfs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ FString -> String
getFString FString
fs
    where mfs :: FString
mfs = Id -> FString
getIdQual Id
a
          fs :: FString
fs = Id -> FString
getIdBase Id
a

mkId :: Position -> FString -> Id
mkId :: Position -> FString -> Id
mkId Position
pos FString
fs =
    let value :: Id
value = Position -> FString -> FString -> [IdProp] -> Id
Id Position
pos FString
fsEmpty FString
fs []
    in -- trace("ID: " ++ (ppReadable value)) $
       Id
value

-- Qualified with a path.
mkQId :: Position -> FString -> FString -> Id
mkQId :: Position -> FString -> FString -> Id
mkQId Position
pos FString
mfs FString
fs
    | FString
fs FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== FString
fsEmpty = Position -> FString -> FString -> [IdProp] -> Id
Id Position
pos FString
fsEmpty FString
fsEmpty []
    | Char
fHead:String
_ <- FString -> String
getFString FString
fs
    , Char -> Bool
isDigit Char
fHead = Position -> FString -> FString -> [IdProp] -> Id
Id Position
pos FString
fsEmpty FString
fs [] -- XXX
    | Bool
otherwise = Position -> FString -> FString -> [IdProp] -> Id
Id Position
pos FString
mfs FString
fs []

ppConId :: PDetail -> Id -> Doc
ppConId :: PDetail -> Id -> Doc
ppConId PDetail
d Id
i
  | PDetail
d PDetail -> PDetail -> Bool
forall a. Eq a => a -> a -> Bool
== PDetail
pdDebug
  = PDetail -> Rational -> Id -> Doc
forall a. Pretty a => PDetail -> Rational -> a -> Doc
pPrintPrec PDetail
pdDebug Rational
0 Id
i
  | Bool
otherwise
  = -- text ( "props:" ++ show (getIdProps i)) <>
    case (Id -> String
getIdBaseString Id
i) of
    String
"->" -> String -> Doc
text String
"(->)"                -- arrow
    s :: String
s@(Char
_:String
_) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s -> String -> Doc
text String
s  -- numbers
    String
_ -> String -> Doc
text (Id -> String
getIdStringCon Id
i)       -- constructor-identifiers

ppId :: PDetail -> Id -> Doc
ppId :: PDetail -> Id -> Doc
ppId PDetail
d Id
i
  | PDetail
d PDetail -> PDetail -> Bool
forall a. Eq a => a -> a -> Bool
== PDetail
pdDebug
  = PDetail -> Rational -> Id -> Doc
forall a. Pretty a => PDetail -> Rational -> a -> Doc
pPrintPrec PDetail
pdDebug Rational
0 Id
i
  | Bool
otherwise
  = if (Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1)
    then case (Id -> String
getIdBaseString Id
i) of
          String
"->" -> String -> Doc
text String
"(->)"                          -- arrow
          s :: String
s@(Char
c:String
_) | Char -> Bool
isDigit Char
c -> String -> Doc
text( String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
          Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text ((Id -> String
getIdString Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
          Char
'$':Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text (Id -> String
getIdString Id
i) -- task names
          String
_ -> String -> Doc
text (String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Id -> String
getIdString Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
    else case (Id -> String
getIdBaseString Id
i) of
          String
"->" -> String -> Doc
text String
"(->)"                          -- arrow
          s :: String
s@(Char
c:String
_) | Char -> Bool
isDigit Char
c -> String -> Doc
text String
s                -- numbers
          Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text (Id -> String
getIdString Id
i)     -- identifiers
          Char
'$':Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text (Id -> String
getIdString Id
i) -- task names
          String
_ -> String -> Doc
text (String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++Id -> String
getIdString Id
iString -> ShowS
forall a. [a] -> [a] -> [a]
++String
")")          -- infix operators

ppVarId :: PDetail -> Id -> Doc
ppVarId :: PDetail -> Id -> Doc
ppVarId PDetail
d Id
i
  | PDetail
d PDetail -> PDetail -> Bool
forall a. Eq a => a -> a -> Bool
== PDetail
pdDebug
  = PDetail -> Rational -> Id -> Doc
forall a. Pretty a => PDetail -> Rational -> a -> Doc
pPrintPrec PDetail
pdDebug Rational
0 Id
i
  | Bool
otherwise
  = if (Int
dbgLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1)
    then case (Id -> String
getIdBaseString Id
i) of
    String
s | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSym String
s -> String -> Doc
text (String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Id -> String
getIdStringOp Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                             String
")") -- infix operators
    Char
'$':Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text ((Id -> String
getIdStringVar Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
    String
_ -> String -> Doc
text ((Id -> String
getIdStringVar Id
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Position -> String
createPositionString (Id -> Position
getIdPosition Id
i)))
    else case (Id -> String
getIdBaseString Id
i) of
    String
s | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSym String
s -> String -> Doc
text (String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++Id -> String
getIdStringOp Id
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")") -- infix operators
    Char
'$':Char
c:String
_ | Char -> Bool
isIdChar Char
c -> String -> Doc
text (Id -> String
getIdStringVar Id
i) -- task names
    String
_ -> String -> Doc
text (Id -> String
getIdStringVar Id
i)

qualEq :: Id -> Id -> Bool
qualEq :: Id -> Id -> Bool
qualEq Id
a Id
b | Id -> FString
getIdQual Id
a FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== FString
fsEmpty Bool -> Bool -> Bool
|| Id -> FString
getIdQual Id
b FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== FString
fsEmpty = Id -> FString
getIdBase Id
a FString -> FString -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> FString
getIdBase Id
b
qualEq Id
a Id
b = Id
a Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b

setBadId :: Id -> Id
setBadId :: Id -> Id
setBadId Id
idx = Id -> IdProp -> Id
addIdProp Id
idx IdProp
IdP_bad_name

setIdProps :: Id -> [IdProp] -> Id
setIdProps :: Id -> [IdProp] -> Id
setIdProps Id
a [IdProp]
l = Id
a { id_props = l }

-- These used to encode properties in .bi files
getIdStringCon :: Id -> String
getIdStringCon :: Id -> String
getIdStringCon = Id -> String
getIdString
getIdStringVar :: Id -> String
getIdStringVar :: Id -> String
getIdStringVar = Id -> String
getIdString
getIdStringOp :: Id -> String
getIdStringOp :: Id -> String
getIdStringOp  = Id -> String
getIdString

data IdProp = IdPCanFire
              | IdPWillFire
              | IdPProbe
              | IdPInternal
              | IdPReady                -- interface ready signal
              | IdPGeneratedIfc         -- generated interface name
              | IdPMeth
              | IdPCommutativeTCon      -- commutative type constructor
              | IdP_enable
              | IdP_keep
              | IdP_keepEvenUnused
              | IdPRule
              | IdPSplitRule
              | IdPDict                 -- is a dictionary
              | IdPRenaming             -- id for temporary renaming
              | IdP_suffixed            -- a _nn suffix has been added
              | IdP_SuffixCount Integer -- the number of suffixes added ... not to be used with IdP_suffixed
              | IdP_bad_name            -- a name generated without good information (e.g., __d5)
              | IdP_from_rhs            -- a name generated from the right-hand-side of an assignment (e.g., x_PLUS_5__d32)
              | IdP_signed              -- in C backend, an id created from $signed()
              | IdP_NakedInst           -- id associated with a "naked" instantiation (i.e. without a bind)
              | IdPDisplayName FString  -- provide an alternate display string
              | IdP_hide
              | IdP_hide_all
              | IdP_TypeJoin Id Id      -- Internally generated type name (anonymous structs)
                                        -- Arguments are the original type and constructor name
              | IdPMethodPredicate      -- is a predicate of a method call in a rule
              -- the Id of meth calls on imported/synthesized modules
              -- can be tagged with the position of inlined method calls
              -- that it was contained in (the top methods are last)
              | IdPInlinedPositions [Position]
              -- used by the BSV parser to keep track of which array types
              -- were introduced from bracket syntax
              | IdPParserGenerated
        deriving (IdProp -> IdProp -> Bool
(IdProp -> IdProp -> Bool)
-> (IdProp -> IdProp -> Bool) -> Eq IdProp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdProp -> IdProp -> Bool
== :: IdProp -> IdProp -> Bool
$c/= :: IdProp -> IdProp -> Bool
/= :: IdProp -> IdProp -> Bool
Eq, Eq IdProp
Eq IdProp =>
(IdProp -> IdProp -> Ordering)
-> (IdProp -> IdProp -> Bool)
-> (IdProp -> IdProp -> Bool)
-> (IdProp -> IdProp -> Bool)
-> (IdProp -> IdProp -> Bool)
-> (IdProp -> IdProp -> IdProp)
-> (IdProp -> IdProp -> IdProp)
-> Ord IdProp
IdProp -> IdProp -> Bool
IdProp -> IdProp -> Ordering
IdProp -> IdProp -> IdProp
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 :: IdProp -> IdProp -> Ordering
compare :: IdProp -> IdProp -> Ordering
$c< :: IdProp -> IdProp -> Bool
< :: IdProp -> IdProp -> Bool
$c<= :: IdProp -> IdProp -> Bool
<= :: IdProp -> IdProp -> Bool
$c> :: IdProp -> IdProp -> Bool
> :: IdProp -> IdProp -> Bool
$c>= :: IdProp -> IdProp -> Bool
>= :: IdProp -> IdProp -> Bool
$cmax :: IdProp -> IdProp -> IdProp
max :: IdProp -> IdProp -> IdProp
$cmin :: IdProp -> IdProp -> IdProp
min :: IdProp -> IdProp -> IdProp
Ord, Int -> IdProp -> ShowS
[IdProp] -> ShowS
IdProp -> String
(Int -> IdProp -> ShowS)
-> (IdProp -> String) -> ([IdProp] -> ShowS) -> Show IdProp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdProp -> ShowS
showsPrec :: Int -> IdProp -> ShowS
$cshow :: IdProp -> String
show :: IdProp -> String
$cshowList :: [IdProp] -> ShowS
showList :: [IdProp] -> ShowS
Show)

instance Pretty IdProp where
    pPrintPrec :: PDetail -> Rational -> IdProp -> Doc
pPrintPrec PDetail
d Rational
_ (IdPInlinedPositions [Position]
poss) =
        Bool -> Doc -> Doc
pparen Bool
True (String -> Doc
text String
"IdPInlinedPositions" Doc -> Doc -> Doc
<+> PDetail -> Rational -> [Position] -> Doc
forall a. Pretty a => PDetail -> Rational -> a -> Doc
pPrintPrec PDetail
d Rational
0 [Position]
poss)
    pPrintPrec PDetail
_ Rational
_ IdProp
prop = String -> Doc
text (IdProp -> String
forall a. Show a => a -> String
show IdProp
prop)

-- #############################################################################
-- # Methods for adding properties to Id's, checking for them etc.
-- #############################################################################

addIdProp :: Id -> IdProp -> Id
addIdProp :: Id -> IdProp -> Id
addIdProp Id
a IdProp
prop = Id -> [IdProp] -> Id
setIdProps Id
a ([IdProp] -> [IdProp] -> [IdProp]
forall a. Eq a => [a] -> [a] -> [a]
L.union (Id -> [IdProp]
getIdProps Id
a) [IdProp
prop])

addIdProps :: Id -> [IdProp] -> Id
addIdProps :: Id -> [IdProp] -> Id
addIdProps Id
a [IdProp]
propl = Id -> [IdProp] -> Id
setIdProps Id
a ([IdProp] -> [IdProp] -> [IdProp]
forall a. Eq a => [a] -> [a] -> [a]
L.union (Id -> [IdProp]
getIdProps Id
a) [IdProp]
propl)

-- Long names

type Longname = [Id]