{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-} {-# OPTIONS_GHC -fwarn-name-shadowing -fwarn-missing-signatures #-} module Id( Id, mkId, mkQId, qualId, dummyId, emptyId, unq_eqs, getIdString, getIdQualString, getIdPosition, isEmptyId, isUnqualId, getIdFString, setIdQual, setIdQualString, enumId, setIdPosition, getIdBase, getIdBaseString, setIdBase, setIdBaseString, getIdQFString, getIdQual, unQualId, getIdFStrings, getFixity, cloneId, mkUId, qualEq, getIdFStringP, mkIdPre, mkIdPost, flattenUSId, mkUSId, mk_homeless_id, {- mk_homeless_qid, -} mk_dangling_id, mkTCId, isTCId, splitTCId, mkStId, mkNumId, mkStrId, mkRdyId, isRdyId, isKeepId, setKeepId, rmKeepId, isHideId, setHideId, rmHideId, isHideAllId, setHideAllId, rmHideAllId, isBadId, setBadId, isFromRHSId, setFromRHSId, isSignedId, setSignedId, setInternal, isDictId, isInternal, isSplitRuleId, isRuleId, mkSplitId, isRenamingId, IdProp(..), addIdProp, rmIdProp, rmIdPropBy, addIdProps, copyIdProps, hasIdProp, hasAnyIdProp, getIdProps, setIdProps, mkIdCanFire, mkIdWillFire, isIdCanFire, isIdWillFire, isFire, isIdEnable, mkIdRule, addIdSuffix, addId_Suffix, addId_Suffixes, addId_SuffixPadded, stripId_Suffix, addSuffix, removeSuffix, removeAllSuffixes, getSuffixCount, isSuffixCountProp, cmpSuffixedIdByName, mkEnableId, getFromReady, dropRulePrefix, dropRulePrefixId, dropWillFirePrefix, dropWillFirePrefixId, dropCanFirePrefix, dropCanFirePrefixId, dropReadyPrefixId, getIdTuple, dummy_id, cmpIdByName, Longname, createPositionString, genUniqueIdsAndMap, mkConcatId, mkIdTempReturn, addToQual, addToBase, show_full, idCompareWithPos, setNakedInstId, isNakedInstId, setIdDisplayName, getIdDisplayName, addIdDisplayName, getIdInlinedPositions, addIdInlinedPositions, removeIdInlinedPositions ) where import Data.Char(isDigit, digitToInt) import Data.List import Data.Maybe import qualified Data.Generics as Generic import qualified Data.Map as Map import Util(headOrErr, lastOrErr, ToString(..)) import FileNameUtil(dropSuf, takeSuf, getRelativeFilePath) import Eval import ErrorUtil(internalError) import FStringCompat import Position import Fixity import PreStrings(fsUnderscore, fsUnderUnder, fsDot, fsTyJoin, fsEmpty, fsCanFire, fsWillFire, fsAVValue, fsMethodReturn, fs_unnamed) import PreStrings(fs_rdy, fsEnable, fs_rl) import IOUtil(progArgs) --import Util(traces) -- ############################################################################# -- # A new data type enumerating the various properties an Id might have. -- ############################################################################# 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, Generic.Data, Generic.Typeable) -- ############################################################################# -- # -- ############################################################################# data Id = Id { id_pos :: !Position, id_mfs :: !FString, id_fs :: !FString, id_props :: [IdProp] {- , id_stab :: Int -} } deriving (Generic.Data,Generic.Typeable) show_raw_id :: Bool show_raw_id = "-show-raw-id" `elem` progArgs instance Show Id where show | show_raw_id = show_full | otherwise = show_brief 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) -- show_full uses positional pattern-matching to make sure all parts are shown show_full :: Id -> String show_full (Id pos mfs fs props) = "(Id (" ++ show pos ++ ") (" ++ show mfs ++ ") (" ++ show fs ++ ") (" ++ show props ++ "))" -- ### base access routines setIdBase :: Id -> FString -> Id setIdBase a fs = a { id_fs = fs } getIdBase :: Id -> FString getIdBase a = id_fs a setIdQual :: Id -> FString -> Id setIdQual a fs = a { id_mfs = fs } getIdQual :: Id -> FString getIdQual a = id_mfs a getIdPosition :: Id -> Position getIdPosition a = id_pos a setIdPosition :: Position -> Id -> Id setIdPosition p a = a { id_pos = p } getIdProps :: Id -> [IdProp] getIdProps a = id_props a setIdProps :: Id -> [IdProp] -> Id setIdProps a l = a { id_props = l } instance Eq Id where a == b = idEq a b -- XXX marking identifiers internal we shouldn't -- tests fail with uncommenting -- isInternal a == isInternal b -- a separate function becomes a cost center for performance runs idEq :: Id -> Id -> Bool idEq a b = (id_fs a == id_fs b) && (id_mfs a == id_mfs b) qualEq :: Id -> Id -> Bool qualEq a b | getIdQual a == fsEmpty || getIdQual b == fsEmpty = getIdBase a == getIdBase b qualEq a b = a == b -- unqualified (base) Id equal-to-string unq_eqs :: Id -> String -> Bool unq_eqs idx str = getIdBaseString idx == str instance Ord Id where compare = idCompare -- a separate function becomes a cost center for performance runs 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 -- to use when position matters idCompareWithPos :: Id -> Id -> Ordering idCompareWithPos a b = case (compare a b) of EQ -> compare (getIdPosition a) (getIdPosition b) LT -> LT GT -> GT cmpIdByName :: Id -> Id -> Ordering i `cmpIdByName` i' = getIdString i `compare` getIdString i' cmpSuffixedIdByName :: Id -> Id -> Ordering cmpSuffixedIdByName x y = let count_x = getSuffixCount(x); count_y = getSuffixCount(y); default_x = (x, Nothing); default_y = (y, Nothing); addJust (a, b) = (a, Just b) pair_x = if (count_x == 0) then default_x else addJust $ removeSuffix x pair_y = if (count_y == 0) then default_y else addJust $ removeSuffix y in pair_x `compare` pair_y instance HasPosition Id where getPosition i = getIdPosition i mkId :: Position -> FString -> Id mkId pos fs = let value = Id pos fsEmpty fs [] in -- trace("ID: " ++ (ppReadable value)) $ value mk_homeless_id :: String -> Id mk_homeless_id s = mkId noPosition (mkFString s) mk_dangling_id :: String -> Position -> Id mk_dangling_id s p = mkId p (mkFString s) -- Long names type Longname = [Id] -- Qualified with a path. mkQId :: Position -> FString -> FString -> Id mkQId pos mfs fs | fs == fsEmpty = Id pos fsEmpty fsEmpty [] | isDigit (head (getFString fs)) = Id pos fsEmpty fs [] -- XXX | otherwise = Id pos mfs fs [] -- Qualify id(2) with the name from id(1) join id properties. qualId :: Id -> Id -> Id qualId a i = addIdProps (setIdQual i (getIdBase a)) (getIdProps a) -- remove qualification unQualId :: Id -> Id unQualId a = setIdQual a fsEmpty -- An id with just "_" as a name dummyId :: Position -> Id dummyId p = Id p fsEmpty fsUnderscore [] -- does an Id have no content whatsoever? isEmptyId :: Id -> Bool isEmptyId i = getIdBase i == fsEmpty isUnqualId :: Id -> Bool isUnqualId i = getIdQual i == fsEmpty dummy_id :: Id dummy_id = dummyId noPosition -- Create an id of the form "_". -- 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 []) createPositionString :: Position -> String createPositionString pos = let file = (getRelativeFilePath (getPositionFile pos)) in ((take 3 (dropSuf file)) ++ "." ++ (takeSuf file) ++ "_" ++ (show (getPositionLine pos)) ++ "_" ++ (show (getPositionColumn pos))) getIdString :: Id -> String getIdString a | mfs == fsEmpty = getFString fs | otherwise = getFString mfs ++ "." ++ getFString fs where mfs = getIdQual a fs = getIdBase a getIdBaseString :: Id -> String getIdBaseString a = getFString $ getIdBase a setIdBaseString :: Id -> String -> Id setIdBaseString idx str = setIdBase idx (mkFString str) getIdQualString :: Id -> String getIdQualString a = getFString $ getIdQual a setIdQualString :: Id -> String -> Id setIdQualString a str = setIdQual a (mkFString str) getIdFStrings :: Id -> (FString, FString) getIdFStrings a = (getIdQual a, getIdBase a) getIdQFString :: Id -> Maybe FString getIdQFString a = if getIdQual a == fsEmpty then Nothing else Just (getIdQual a) getIdFString :: Id -> FString getIdFString a = if getIdQual a == fsEmpty then getIdBase a else concatFString [getIdQual a, fsDot, getIdBase a] getIdFStringP :: Id -> FString getIdFStringP a = let mfs = getIdQual a fs = getIdBase a in if mfs == fsEmpty then fs else case getFString fs of "->" -> fs c:_ | isDigit c -> fs _ -> concatFString [mfs, fsDot, fs] getIdTuple :: Id -> (Position, String) getIdTuple i = (getIdPosition i, getIdString i) -- Join the names from the list on the second id cloneId :: [Id] -> Id -> Id cloneId is a = setIdBase a (cloneFString (map getIdFString is) (getIdBase a)) getFixity :: Id -> Fixity getFixity i = case getIdBaseString i of "," -> FInfixr (-1) {- "$" -> FInfixr 0 ":=" -> FInfixr 1 "||" -> FInfixr 2 "&&" -> FInfixr 3 "|" -> FInfixl 4 "&" -> FInfixl 5 "==" -> FInfix 6 "/=" -> FInfix 6 "<=" -> FInfix 6 ">=" -> FInfix 6 "<" -> FInfix 6 ">" -> FInfix 6 "<<" -> FInfix 7 ">>" -> FInfix 7 "++" -> FInfixr 8 ":>" -> FInfixr 8 "+" -> FInfixl 10 "-" -> FInfixl 10 "*" -> FInfixl 11 "/" -> FInfixl 11 "\xbb"-> FInfixr 12 -- https://en.wikipedia.org/wiki/Guillemet or '>>' "\xb7"-> FInfixr 13 -- https://en.wikipedia.org/wiki/Interpunct or '.' "|>" -> FInfixr 15 -} _ -> defaultFixity -- Prepends "_" to id name mkUId :: Id -> Id mkUId a = setIdBase a (concatFString [fsUnderscore, getIdBase a]) -- Join Ids join2ids :: Id -> Id -> FString -> Id -> Id join2ids pid a j b | isEmptyId a = b | isEmptyId b = a | otherwise = addIdProps (setIdBase pid (concatFString [getIdBase a, j, getIdBase b])) (union (getIdProps b) (getIdProps a)) -- Joins 2 ids with underscore connector mkUSId :: Id -> Id -> Id mkUSId a b = setIdQual (join2ids b a fsUnderscore b) (getIdQual a) -- Convert a Longname to an Id using underscore as a connector flattenUSId :: Longname -> Id flattenUSId [] = Id noPosition fsEmpty fsEmpty [] -- (empty ID) flattenUSId (i:is) = foldl mkUSId i is -- The null identifier (used in base case of recursive functions): emptyId :: Id emptyId = flattenUSId [] -- Joins 2 ids with TyJoin connector mkTCId :: Id -> Id -> Id mkTCId a b = setIdProps (setIdQual (join2ids b a fsTyJoin b) (getIdQual a)) [IdP_TypeJoin a b] isTCId :: Id -> Bool isTCId = isJust . splitTCId splitTCId :: Id -> Maybe (Id, Id) splitTCId i = listToMaybe [ (a,b) | IdP_TypeJoin a b <- getIdProps i ] mkStId :: Id -> Id -> Id mkStId a b = join2ids a a fsDot b mkNumId :: Integer -> Id mkNumId i = if i < 0 then internalError ("mkNumId: " ++ show i) else Id noPosition fsEmpty (mkNumFString i) [] mkStrId :: FString -> Id mkStrId s = Id noPosition fsEmpty s [] mkIdPre :: FString -> Id -> Id mkIdPre fs a = setIdBase a (concatFString [fs, getIdBase a]) mkIdPost :: Id -> FString -> Id mkIdPost a fs = setIdBase a (concatFString [getIdBase a, fs]) -- concatenate two Ids with the same package name (error if pkg names differ) mkConcatId :: Id -> Id -> Id mkConcatId a b | a_pkg /= b_pkg = internalError ("Id.mkConcatIds: " ++ show (getIdFStrings a) ++ " and " ++ show (getIdFStrings b)) | otherwise = mkQId (getPosition a) a_pkg (concatFString [a_name, b_name]) where (a_pkg, a_name) = getIdFStrings a (b_pkg, b_name) = getIdFStrings b mkSplitId :: Id -> FString -> Id mkSplitId idx fs = addIdProp (mkIdPost idx fs) IdPSplitRule -- Mark an identifier as being generated internally setInternal :: Id -> Id setInternal i = addIdProp i IdPInternal isInternal :: Id -> Bool isInternal i = hasIdProp i IdPInternal ---- addIdSuffix :: Id -> Integer -> Id addIdSuffix idx intx = mkIdPost idx (mkFString (show intx)) mkRdyId :: Id -> Id mkRdyId i = addIdProp (mkIdPre fs_rdy i) IdPReady isRdyId :: Id -> Bool isRdyId idx = hasIdProp idx IdPReady isKeepId :: Id -> Bool isKeepId idx = hasIdProp idx IdP_keep isHideId :: Id -> Bool isHideId idx = hasIdProp idx IdP_hide isHideAllId :: Id -> Bool isHideAllId idx = hasIdProp idx IdP_hide_all isDictId :: Id -> Bool isDictId i = hasIdProp i IdPDict isRuleId :: Id -> Bool isRuleId idx = hasIdProp idx IdPRule isBadId :: Id -> Bool isBadId idx = hasIdProp idx IdP_bad_name isFromRHSId :: Id -> Bool isFromRHSId idx = hasIdProp idx IdP_from_rhs isSplitRuleId :: Id -> Bool isSplitRuleId idx = hasIdProp idx IdPSplitRule isRenamingId :: Id -> Bool isRenamingId idx = hasIdProp idx IdPRenaming rmKeepId :: Id -> Id rmKeepId idx = rmIdProp idx IdP_keep setKeepId :: Id -> Id setKeepId idx = addIdProp idx IdP_keep rmHideId :: Id -> Id rmHideId idx = rmIdProp idx IdP_hide rmHideAllId :: Id -> Id rmHideAllId idx = rmIdProp idx IdP_hide_all setHideId :: Id -> Id setHideId idx = addIdProp idx IdP_hide setHideAllId :: Id -> Id setHideAllId idx = addIdProp idx IdP_hide_all setBadId :: Id -> Id setBadId idx = addIdProp idx IdP_bad_name setFromRHSId :: Id -> Id setFromRHSId idx = addIdProp idx IdP_from_rhs setSignedId :: Id -> Id setSignedId a = addIdProp a IdP_signed isSignedId :: Id -> Bool isSignedId a = hasIdProp a IdP_signed setNakedInstId :: Id -> Id setNakedInstId a = addIdProp a IdP_NakedInst isNakedInstId :: Id -> Bool isNakedInstId a = hasIdProp a IdP_NakedInst getIdDisplayName :: Id -> Maybe FString getIdDisplayName idx = let names = nub [ name | (IdPDisplayName name) <- getIdProps idx] get_one [a] = Just a get_one [] = Nothing get_one _ = internalError $ "Id:getIdDisplayName " ++ (show_full idx) in get_one names setIdDisplayName :: Id -> FString -> Id setIdDisplayName idx name = addIdProp idx (IdPDisplayName name) addIdDisplayName :: Id -> Id addIdDisplayName i | isNothing name' = i where name' = getIdDisplayName i addIdDisplayName i = i' where (Just name') = getIdDisplayName i i' = setIdBase i name' getFromReady :: Id -> String getFromReady idx = if ( isRdyId idx ) then drop ((length . getFString) fs_rdy) tmp else tmp where tmp = getIdString idx dropRulePrefixId :: Id -> Id dropRulePrefixId idx | isRuleId idx = idx { id_fs = mkFString new_name } | otherwise = idx where new_name = drop ((length . getFString) fs_rl) (getIdString idx) dropRulePrefix :: Id -> String dropRulePrefix = getIdString . dropRulePrefixId dropWillFirePrefixId :: Id -> Id dropWillFirePrefixId idx | hasIdProp idx IdPWillFire = idx { id_fs = mkFString new_name } | otherwise = idx where new_name = drop ((length . getFString) fsWillFire) (getIdString idx) dropWillFirePrefix :: Id -> String dropWillFirePrefix = getIdString . dropWillFirePrefixId dropCanFirePrefixId :: Id -> Id dropCanFirePrefixId idx | hasIdProp idx IdPCanFire = idx { id_fs = mkFString new_name } | otherwise = idx where new_name = drop ((length . getFString) fsCanFire) (getIdString idx) dropCanFirePrefix :: Id -> String dropCanFirePrefix = getIdString . dropCanFirePrefixId dropReadyPrefixId :: Id -> Id dropReadyPrefixId idx | hasIdProp idx IdPReady = idx { id_fs = mkFString new_name } | otherwise = idx where new_name = drop ((length . getFString) fs_rdy) (getIdString idx) mkEnableId :: Id -> Id mkEnableId idx = addIdProp (mkIdPre fsEnable idx) IdP_enable getIdInlinedPositions :: Id -> Maybe [Position] getIdInlinedPositions i = case [ poss | (IdPInlinedPositions poss) <- getIdProps i] of [] -> Nothing [poss] -> Just poss _ -> internalError("getIdInlinedPositions: " ++ show_full i) addIdInlinedPositions :: Id -> [Position] -> Id addIdInlinedPositions i [] = i addIdInlinedPositions i new_poss = let isIdPInlinedPositions (IdPInlinedPositions _) = True isIdPInlinedPositions _ = False (inlinedpos_ps, other_ps) = partition isIdPInlinedPositions (getIdProps i) new_p = case inlinedpos_ps of [] -> IdPInlinedPositions new_poss [IdPInlinedPositions poss] -> IdPInlinedPositions (new_poss ++ poss) _ -> internalError("addIdInlinedPosition: " ++ show_full i) in setIdProps i (new_p : other_ps) removeIdInlinedPositions :: Id -> Id removeIdInlinedPositions i = let isIdPInlinedPositions (IdPInlinedPositions _) = True isIdPInlinedPositions _ = False other_ps = filter (not . isIdPInlinedPositions) (getIdProps i) in setIdProps i other_ps instance Hyper Id where hyper a@(Id {}) y = y -- XXX -- ############################################################################# -- # Methods for adding properties to Id's, checking for them etc. -- ############################################################################# addIdProp :: Id -> IdProp -> Id addIdProp a prop = setIdProps a (union (getIdProps a) [prop]) rmIdProp :: Id -> IdProp -> Id rmIdProp a prop = setIdProps a (delete prop (getIdProps a)) rmIdPropBy :: Id -> (IdProp -> Bool) -> Id rmIdPropBy a predf = setIdProps a (filter predf (getIdProps a)) addIdProps :: Id -> [IdProp] -> Id addIdProps a propl = setIdProps a (union (getIdProps a) propl) hasIdProp :: Id -> IdProp -> Bool hasIdProp a prop = elem prop (getIdProps a) hasAnyIdProp :: Id -> [IdProp] -> Bool hasAnyIdProp a props = not $ null (intersect props (getIdProps a)) copyIdProps :: Id -> Id -> Id copyIdProps src_id dst_id = addIdProps dst_id (getIdProps src_id) -- ############################################################################# -- # -- ############################################################################# isFire :: Id -> Bool isFire i = hasAnyIdProp i [IdPCanFire, IdPWillFire] mkIdCanFire :: Id -> Id mkIdCanFire idx = addIdProp (mkIdPre fsCanFire idx) IdPCanFire isIdCanFire :: Id -> Bool isIdCanFire i = hasIdProp i IdPCanFire mkIdWillFire :: Id -> Id mkIdWillFire idx = addIdProp (mkIdPre fsWillFire idx) IdPWillFire isIdWillFire :: Id -> Bool isIdWillFire i = hasIdProp i IdPWillFire isIdEnable :: Id -> Bool isIdEnable i = hasIdProp i IdP_enable mkIdTempReturn :: Bool -> Id -> Integer -> Id mkIdTempReturn is_av idx n = let fn_type = if is_av then fsAVValue else fsMethodReturn raw = getIdBaseString idx --base = dropWhile (\c -> c `elem` ['$','_'] ) raw base = if ( headOrErr "mkIdTempReturn" raw `elem` ['$','_'] ) then "Task_" ++ raw else raw new_name = concatFString [ mkFString base , fsUnderUnder , fn_type , mkNumFString n ] in setInternal (setIdBase idx new_name) mkIdRule :: Id -> Id mkIdRule i = addIdProp (mkIdPre fs_rl i) IdPRule -- ############################################################################# -- # -- ############################################################################# instance ToString Id where itos a = internalError "itos applied to Id " ++ show a to_string a = getIdString a instance ToString [Id] where itos a = internalError "itos applied to [Id] " ++ show a to_string a = "[" ++ intercalate "," (map to_string a) ++ "]" instance ToString (Id, Id) where itos a = internalError "itos applied to (a) " ++ show a to_string (a, b) = "(" ++ to_string a ++ "," ++ to_string b ++ ")" ---------------------------- type IdMap = Map.Map Id Integer -- given a list of already used ids, and a list of potentially --conflicting id, generate a list of non-conflicting ids, and map to --rename ids. genUniqueIdsAndMap :: [Id] -> [Id] -> ([Id], [(Id,Id)]) genUniqueIdsAndMap usedIds newIds = (safeIds, changeMap) where usedMap :: IdMap usedMap = Map.fromList $ zip usedIds (repeat 0) (_, safeIds, changeMap) = foldl checkNewIds (usedMap,[],[]) newIds checkNewIds :: ( IdMap, [Id], [(Id,Id)] ) -> Id -> ( IdMap, [Id], [(Id,Id)] ) checkNewIds (idmap, safeids, transmap) checkid = (idmap', safeids', transmap') where (rootid,suffix) = stripId_Suffix checkid (idmap', safeids', transmap') = if (checkid `Map.member` idmap) then let (newerid,newmap) = genNewId rootid idmap in ( newmap, newerid : safeids, (checkid,newerid):transmap ) else ( (Map.insert checkid suffix idmap), checkid: safeids, transmap ) -- strip out the suffix from an Id returning the base, and the Integer -- suffix. The Id must be flagged with IdP_suffixed. stripId_Suffix :: Id -> (Id,Integer) stripId_Suffix idin = idout where idout = if (idin `hasIdProp` IdP_suffixed) then -- strip the suffix off the name let idstr = getIdString idin unders = elemIndices '_' idstr under = lastOrErr ("Name within Id does not match suffix attribute: " ++ show idin) unders root = take under idstr suff = drop (under+1) idstr ints = map ( toInteger . digitToInt) suff tenx i j = (10 * i) + j base = foldl1 tenx ints in ( rmIdProp (setIdBase idin (mkFString root)) IdP_suffixed, base ) else (idin,0) -- add an underscore suffix to the ids, and the flag that it has been added. Do not add more than 1 suffix! addId_Suffix :: Id -> Integer -> Id addId_Suffix idx intx = addId_SuffixPadded idx intx 0 -- the same, allowing multiple suffixes. addId_Suffixes :: Id -> Integer -> Id addId_Suffixes idx intx = mkIdPost idx (mkFString ("_" ++ (show intx))) addId_SuffixPadded :: Id -> Integer -> Integer ->Id addId_SuffixPadded idx intx chars = newId where newId = if ( idx `hasIdProp` IdP_suffixed ) then internalError("addId_Suffix: suffix already exists: " ++ show idx ) else withProp withProp = addIdProp id1 IdP_suffixed -- insure that the id has a name ! WTF givename = if ( isEmptyId idx ) then setIdBase idx fs_unnamed else idx id1 = mkIdPost givename (mkFString ("_" ++ (addZeros (show intx) chars))) addZeros :: String -> Integer -> String addZeros digitString size = if (size > (toInteger (length digitString))) then "0" ++ (addZeros digitString (size - 1)) else digitString -- ############################################################################# -- # Yet another flavor of "add suffix" that allows multiple suffixes. -- ############################################################################# addSuffix :: Id -> Integer -> Id addSuffix idx n = let count = getSuffixCount idx id_init = if (isEmptyId idx) then setIdBase idx fs_unnamed else idx keep_prop prop = not (isSuffixCountProp prop) id_clean = rmIdPropBy id_init keep_prop id_suffixed = mkIdPost (addIdProp id_clean (IdP_SuffixCount (count + 1))) (mkFString ("_" ++ (show n))) out = if (hasIdProp id_suffixed IdP_suffixed) then internalError("Id:addSuffix: Inconsistent use of suffix forms: " ++ show idx) else id_suffixed in out isSuffixCountProp :: IdProp -> Bool isSuffixCountProp (IdP_SuffixCount _) = True isSuffixCountProp _ = False getSuffixCount :: Id -> Integer getSuffixCount idx = let count_list = nub [ count | (IdP_SuffixCount count) <- getIdProps idx] get_count [a] = a get_count [] = 0 get_count _ = internalError "Id:getSuffixCount" in get_count count_list removeSuffix :: Id -> (Id, Integer) removeSuffix idx = let count = getSuffixCount idx keep_prop prop = not (isSuffixCountProp prop) id_clean = rmIdPropBy idx keep_prop out | hasIdProp id_clean IdP_suffixed = internalError("Id:removeSuffix: Inconsistent use of suffix forms: " ++ show idx) | count == 0 = internalError("Id:removeSuffix: Id has no suffix: " ++ show idx) | otherwise = let (fstring, suffix) = removeFStringSuffix (getIdBase id_clean) in ((addIdProp (setIdBase id_clean fstring) (IdP_SuffixCount (count - 1))), suffix) in out removeFStringSuffix :: FString -> (FString, Integer) removeFStringSuffix fstring = let string = getFString fstring unders = elemIndices '_' string under = lastOrErr ("Name does not have a suffix: " ++ show string) unders root = take under string suff = drop (under+1) string ints = map ( toInteger . digitToInt) suff tenx i j = (10 * i) + j base = foldl1 tenx ints in (mkFString root ,base) removeAllSuffixes :: Id -> Id removeAllSuffixes idx = let count = getSuffixCount idx (idx', _) = removeSuffix idx in if (count > 0) then removeAllSuffixes idx' else idx -- ############################################################################# -- # -- ############################################################################# -- generate a new id with a numerical suffix, based in the original id The new id will not be in -- the IdMap, but will be added, along with an update of the max suffix genNewId :: Id -> IdMap -> ( Id, IdMap ) genNewId origId idmap = (newid, newMap) where (rootid,suffix) = stripId_Suffix origId (newid,newsuff) = tryThisId rootid (suffix + 1) newMap = Map.insert newid newsuff (Map.insert rootid newsuff idmap) tryThisId :: Id -> Integer -> (Id,Integer) tryThisId baseId suff = let genId = addId_Suffix baseId suff in if (genId `Map.member` idmap) then tryThisId baseId (suff+1) else (genId,suff) -- Add a path string to an existing Id's qualified path -- This is used during the Bluesim backend, when Id qualifiers -- hold instance path information. It should not be used -- with the module qualifiers used in the rest of the compiler. addToQual :: String -> Id -> Id addToQual prefix a = let fsPrefix = mkFString prefix fsQual = getIdQual a fsQual' | fsQual == fsEmpty = fsPrefix | fsPrefix == fsEmpty = fsQual | otherwise = concatFString [fsPrefix, fsDot, fsQual] in setIdQual a fsQual' -- This is used in ASchedule, to qualify rules from submodules with their -- instance name. Unlike "addToQual" in the Bluesim backend, the base is -- the name that is important (the qualifier, if it exists at all, might -- be a package name; and place which print rule Ids probably use -- "getIdBaseString", and if they used "pfpString" they'd print the -- qualifier with "::" and not "."). addToBase :: Id -> Id -> Id addToBase prefix a = let fsPrefix = getIdBase prefix fsBase = getIdBase a fsBase' = if (fsPrefix == fsEmpty) then fsBase else concatFString [fsPrefix, fsDot, fsBase] in setIdBase a fsBase'