language-bluespec-0.1: src/Language/Bluespec/Classic/AST/Id.hs
-- 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_pos :: !Position,
id_mfs :: !FString,
id_fs :: !FString,
id_props :: [IdProp] {- , id_stab :: Int -}
}
idEq :: Id -> Id -> Bool
idEq a b = (id_fs a == id_fs b) && (id_mfs a == id_mfs b)
idCompare :: Id -> Id -> Ordering
idCompare a b = case (compare (id_fs a) (id_fs b)) of
EQ -> compare (id_mfs a) (id_mfs b)
LT -> LT
GT -> GT
instance Eq Id where
a == b = idEq a b
instance Ord Id where
compare = idCompare
instance Show Id where
show = show_brief
instance Pretty Id where
pPrintPrec d _p i
| d == pdDebug
= text (local_show i)
| otherwise
= if (dbgLevel >= 1)
then text ((getIdString i) ++
"_" ++
(createPositionString (getIdPosition i)))
else text (getIdString i)
instance HasPosition Id where
getPosition i = getIdPosition i
local_show :: Id -> String
local_show id' =
let
pos = getIdPosition id'
mfs = getIdQualString id'
fs = getIdBaseString id'
str = show pos ++ " " ++
show mfs ++ " " ++
show fs
in str
show_brief :: Id -> String
show_brief i =
case (getFString (id_mfs i), getFString (id_fs i)) of
("", str) -> add_props str
(pkg, str) -> add_props (pkg ++ "::" ++ str)
where add_props str | null (id_props i) = str
| otherwise = str ++ show (id_props i)
createPositionString :: Position -> String
createPositionString _ = "<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 str pos index =
let id_str = tmpFString index ("_" ++ str ++ itos index)
in setBadId
(Id pos fsEmpty id_str [])
getIdBase :: Id -> FString
getIdBase a = id_fs a
getIdBaseString :: Id -> String
getIdBaseString a = getFString $ getIdBase a
getIdPosition :: Id -> Position
getIdPosition a = id_pos a
getIdProps :: Id -> [IdProp]
getIdProps a = id_props a
getIdQual :: Id -> FString
getIdQual a = id_mfs a
getIdQualString :: Id -> String
getIdQualString a = getFString $ getIdQual a
getIdString :: Id -> String
getIdString a | mfs == fsEmpty = getFString fs
| otherwise = getFString mfs ++ "." ++ getFString fs
where mfs = getIdQual a
fs = getIdBase a
mkId :: Position -> FString -> Id
mkId pos fs =
let value = Id pos fsEmpty fs []
in -- trace("ID: " ++ (ppReadable value)) $
value
-- Qualified with a path.
mkQId :: Position -> FString -> FString -> Id
mkQId pos mfs fs
| fs == fsEmpty = Id pos fsEmpty fsEmpty []
| fHead:_ <- getFString fs
, isDigit fHead = Id pos fsEmpty fs [] -- XXX
| otherwise = Id pos mfs fs []
ppConId :: PDetail -> Id -> Doc
ppConId d i
| d == pdDebug
= pPrintPrec pdDebug 0 i
| otherwise
= -- text ( "props:" ++ show (getIdProps i)) <>
case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(_:_) | all isDigit s -> text s -- numbers
_ -> text (getIdStringCon i) -- constructor-identifiers
ppId :: PDetail -> Id -> Doc
ppId d i
| d == pdDebug
= pPrintPrec pdDebug 0 i
| otherwise
= if (dbgLevel >= 1)
then case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(c:_) | isDigit c -> text( s ++ "_" ++ (createPositionString (getIdPosition i)))
c:_ | isIdChar c -> text ((getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
'$':c:_ | isIdChar c -> text (getIdString i) -- task names
_ -> text ("(" ++ (getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))
else case (getIdBaseString i) of
"->" -> text "(->)" -- arrow
s@(c:_) | isDigit c -> text s -- numbers
c:_ | isIdChar c -> text (getIdString i) -- identifiers
'$':c:_ | isIdChar c -> text (getIdString i) -- task names
_ -> text ("("++getIdString i++")") -- infix operators
ppVarId :: PDetail -> Id -> Doc
ppVarId d i
| d == pdDebug
= pPrintPrec pdDebug 0 i
| otherwise
= if (dbgLevel >= 1)
then case (getIdBaseString i) of
s | all isSym s -> text ("("++ (getIdStringOp i) ++ (createPositionString (getIdPosition i)) ++
")") -- infix operators
'$':c:_ | isIdChar c -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
_ -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))
else case (getIdBaseString i) of
s | all isSym s -> text ("("++getIdStringOp i ++ ")") -- infix operators
'$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names
_ -> text (getIdStringVar i)
qualEq :: Id -> Id -> Bool
qualEq a b | getIdQual a == fsEmpty || getIdQual b == fsEmpty = getIdBase a == getIdBase b
qualEq a b = a == b
setBadId :: Id -> Id
setBadId idx = addIdProp idx IdP_bad_name
setIdProps :: Id -> [IdProp] -> Id
setIdProps a l = a { id_props = l }
-- These used to encode properties in .bi files
getIdStringCon :: Id -> String
getIdStringCon = getIdString
getIdStringVar :: Id -> String
getIdStringVar = getIdString
getIdStringOp :: Id -> String
getIdStringOp = 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 (Eq, Ord, Show)
instance Pretty IdProp where
pPrintPrec d _ (IdPInlinedPositions poss) =
pparen True (text "IdPInlinedPositions" <+> pPrintPrec d 0 poss)
pPrintPrec _ _ prop = text (show prop)
-- #############################################################################
-- # Methods for adding properties to Id's, checking for them etc.
-- #############################################################################
addIdProp :: Id -> IdProp -> Id
addIdProp a prop = setIdProps a (L.union (getIdProps a) [prop])
addIdProps :: Id -> [IdProp] -> Id
addIdProps a propl = setIdProps a (L.union (getIdProps a) propl)
-- Long names
type Longname = [Id]