module Curry.Base.Ident
(
ModuleIdent (..), mkMIdent, moduleName, escModuleName
, fromModuleName, isValidModuleName, addPositionModuleIdent
, Ident (..), mkIdent, showIdent, escName, identSupply
, globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent
, updIdentName, addPositionIdent, addRefId, isInfixOp
, QualIdent (..), qualName, escQualName, qidPosition, isQInfixOp, qualify
, qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify
, localIdent, isLocalIdent, updQualIdent, addRef
, emptyMIdent, mainMIdent, preludeMIdent
, unitId, boolId, charId, intId, floatId, listId, ioId, successId
, trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity
, mainId, minusId, fminusId, anonId, isAnonId
, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId, qSuccessId
, qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity
, fpSelectorId, isFpSelectorId, isQualFpSelectorId
, recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId
, recordExt, recordExtId, isRecordExtId, fromRecordExtId
, labelExt, labelExtId, isLabelExtId, fromLabelExtId
, renameLabel, mkLabelIdent
) where
import Data.Char (isAlpha, isAlphaNum)
import Data.Function (on)
import Data.Generics (Data, Typeable)
import Data.List (intercalate, isInfixOf, isPrefixOf)
import Data.Maybe (isJust, fromMaybe)
import Curry.Base.Position
import Curry.Base.Pretty
data ModuleIdent = ModuleIdent
{ midPosition :: Position
, midQualifiers :: [String]
} deriving (Read, Show, Data, Typeable)
instance Eq ModuleIdent where
(==) = (==) `on` midQualifiers
instance Ord ModuleIdent where
compare = compare `on` midQualifiers
instance HasPosition ModuleIdent where
getPosition = midPosition
setPosition = addPositionModuleIdent
instance Pretty ModuleIdent where
pPrint = hcat . punctuate dot . map text . midQualifiers
instance SrcRefOf ModuleIdent where
srcRefOf = srcRefOf . getPosition
mkMIdent :: [String] -> ModuleIdent
mkMIdent = ModuleIdent NoPos
moduleName :: ModuleIdent -> String
moduleName = intercalate "." . midQualifiers
escModuleName :: ModuleIdent -> String
escModuleName m = '`' : moduleName m ++ "'"
addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
addPositionModuleIdent pos mi = mi { midPosition = pos }
isValidModuleName :: String -> Bool
isValidModuleName [] = False
isValidModuleName qs = all isModuleIdentifier $ splitIdentifiers qs
where
isModuleIdentifier [] = False
isModuleIdentifier (c:cs) = isAlpha c && all isIdent cs
isIdent c = isAlphaNum c || c `elem` "'_"
fromModuleName :: String -> ModuleIdent
fromModuleName = mkMIdent . splitIdentifiers
splitIdentifiers :: String -> [String]
splitIdentifiers s = let (pref, rest) = break (== '.') s in
pref : case rest of
[] -> []
(_:s') -> splitIdentifiers s'
data Ident = Ident
{ idPosition :: Position
, idName :: String
, idUnique :: Integer
} deriving (Read, Show, Data, Typeable)
instance Eq Ident where
Ident _ m i == Ident _ n j = (m, i) == (n, j)
instance Ord Ident where
Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j)
instance HasPosition Ident where
getPosition = idPosition
setPosition = addPositionIdent
instance Pretty Ident where
pPrint (Ident _ x n) | n == globalScope = text x
| otherwise = text x <> dot <> integer n
instance SrcRefOf Ident where
srcRefOf = srcRefOf . getPosition
globalScope :: Integer
globalScope = 0
mkIdent :: String -> Ident
mkIdent x = Ident NoPos x globalScope
identSupply :: [Ident]
identSupply = [ mkNewIdent c i | i <- [0 ..] :: [Integer], c <- ['a'..'z'] ]
where mkNewIdent c 0 = mkIdent [c]
mkNewIdent c n = mkIdent $ c : show n
showIdent :: Ident -> String
showIdent (Ident _ x n) | n == globalScope = x
| otherwise = x ++ '.' : show n
escName :: Ident -> String
escName i = '`' : idName i ++ "'"
hasGlobalScope :: Ident -> Bool
hasGlobalScope = (== globalScope) . idUnique
isRenamed :: Ident -> Bool
isRenamed = (/= globalScope) . idUnique
renameIdent :: Ident -> Integer -> Ident
renameIdent ident n = ident { idUnique = n }
unRenameIdent :: Ident -> Ident
unRenameIdent ident = renameIdent ident globalScope
updIdentName :: (String -> String) -> Ident -> Ident
updIdentName f (Ident p n i) = Ident p (f n) i
addPositionIdent :: Position -> Ident -> Ident
addPositionIdent pos (Ident NoPos x n) = Ident pos x n
addPositionIdent (AST sr) (Ident pos x n) = Ident pos { astRef = sr } x n
addPositionIdent pos (Ident _ x n) = Ident pos x n
addRefId :: SrcRef -> Ident -> Ident
addRefId = addPositionIdent . AST
isInfixOp :: Ident -> Bool
isInfixOp (Ident _ ('<' : c : cs) _) =
last (c : cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
isInfixOp (Ident _ (c : _) _) = not (isAlphaNum c) && c `notElem` "_(["
isInfixOp (Ident _ _ _) = False
data QualIdent = QualIdent
{ qidModule :: Maybe ModuleIdent
, qidIdent :: Ident
} deriving (Eq, Ord, Read, Show, Data, Typeable)
instance HasPosition QualIdent where
getPosition = getPosition . qidIdent
setPosition p q = q { qidIdent = setPosition p $ qidIdent q }
instance Pretty QualIdent where
pPrint = text . qualName
instance SrcRefOf QualIdent where
srcRefOf = srcRefOf . unqualify
qualName :: QualIdent -> String
qualName (QualIdent Nothing x) = idName x
qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ idName x
escQualName :: QualIdent -> String
escQualName qn = '`' : qualName qn ++ "'"
qidPosition :: QualIdent -> Position
qidPosition = idPosition . qidIdent
isQInfixOp :: QualIdent -> Bool
isQInfixOp = isInfixOp . qidIdent
qualify :: Ident -> QualIdent
qualify = QualIdent Nothing
qualifyWith :: ModuleIdent -> Ident -> QualIdent
qualifyWith = QualIdent . Just
qualQualify :: ModuleIdent -> QualIdent -> QualIdent
qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x
qualQualify _ x = x
qualifyLike :: QualIdent -> Ident -> QualIdent
qualifyLike (QualIdent Nothing _) x = qualify x
qualifyLike (QualIdent (Just m) _) x = qualifyWith m x
isQualified :: QualIdent -> Bool
isQualified = isJust . qidModule
unqualify :: QualIdent -> Ident
unqualify = qidIdent
qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent
qualUnqualify _ qid@(QualIdent Nothing _) = qid
qualUnqualify m (QualIdent (Just m') x) = QualIdent m'' x
where m'' | m == m' = Nothing
| otherwise = Just m'
localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
localIdent _ (QualIdent Nothing x) = Just x
localIdent m (QualIdent (Just m') x)
| m == m' = Just x
| otherwise = Nothing
isLocalIdent :: ModuleIdent -> QualIdent -> Bool
isLocalIdent mid qid = isJust (localIdent mid qid)
updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident)
-> QualIdent -> QualIdent
updQualIdent f g (QualIdent m x) = QualIdent (fmap f m) (g x)
addRef :: SrcRef -> QualIdent -> QualIdent
addRef = updQualIdent id . addRefId
emptyMIdent :: ModuleIdent
emptyMIdent = ModuleIdent NoPos []
mainMIdent :: ModuleIdent
mainMIdent = ModuleIdent NoPos ["main"]
preludeMIdent :: ModuleIdent
preludeMIdent = ModuleIdent NoPos ["Prelude"]
unitId :: Ident
unitId = mkIdent "()"
boolId :: Ident
boolId = mkIdent "Bool"
charId :: Ident
charId = mkIdent "Char"
intId :: Ident
intId = mkIdent "Int"
floatId :: Ident
floatId = mkIdent "Float"
listId :: Ident
listId = mkIdent "[]"
ioId :: Ident
ioId = mkIdent "IO"
successId :: Ident
successId = mkIdent "Success"
tupleId :: Int -> Ident
tupleId n
| n > 1 = mkIdent $ '(' : replicate (n 1) ',' ++ ")"
| otherwise = error $ "Curry.Base.Ident.tupleId: wrong arity " ++ show n
isTupleId :: Ident -> Bool
isTupleId (Ident _ x _) = n > 1 && x == idName (tupleId n)
where n = length x 1
tupleArity :: Ident -> Int
tupleArity i@(Ident _ x _)
| n > 1 && x == idName (tupleId n) = n
| otherwise = error $
"Curry.Base.Ident.tupleArity: no tuple identifier: " ++ showIdent i
where n = length x 1
trueId :: Ident
trueId = mkIdent "True"
falseId :: Ident
falseId = mkIdent "False"
nilId :: Ident
nilId = mkIdent "[]"
consId :: Ident
consId = mkIdent ":"
mainId :: Ident
mainId = mkIdent "main"
minusId :: Ident
minusId = mkIdent "-"
fminusId :: Ident
fminusId = mkIdent "-."
anonId :: Ident
anonId = mkIdent "_"
isAnonId :: Ident -> Bool
isAnonId = (== anonId) . unRenameIdent
qPreludeIdent :: Ident -> QualIdent
qPreludeIdent = qualifyWith preludeMIdent
qUnitId :: QualIdent
qUnitId = qualify unitId
qListId :: QualIdent
qListId = qualify listId
qBoolId :: QualIdent
qBoolId = qPreludeIdent boolId
qCharId :: QualIdent
qCharId = qPreludeIdent charId
qIntId :: QualIdent
qIntId = qPreludeIdent intId
qFloatId :: QualIdent
qFloatId = qPreludeIdent floatId
qIOId :: QualIdent
qIOId = qPreludeIdent ioId
qSuccessId :: QualIdent
qSuccessId = qPreludeIdent successId
qTrueId :: QualIdent
qTrueId = qPreludeIdent trueId
qFalseId :: QualIdent
qFalseId = qPreludeIdent falseId
qNilId :: QualIdent
qNilId = qualify nilId
qConsId :: QualIdent
qConsId = qualify consId
qTupleId :: Int -> QualIdent
qTupleId = qualify . tupleId
isQTupleId :: QualIdent -> Bool
isQTupleId = isTupleId . unqualify
qTupleArity :: QualIdent -> Int
qTupleArity = tupleArity . unqualify
fpSelExt :: String
fpSelExt = "_#selFP"
fpSelectorId :: Int -> Ident
fpSelectorId n = mkIdent $ fpSelExt ++ show n
isFpSelectorId :: Ident -> Bool
isFpSelectorId = (fpSelExt `isInfixOf`) . idName
isQualFpSelectorId :: QualIdent -> Bool
isQualFpSelectorId = isFpSelectorId . unqualify
recSelExt :: String
recSelExt = "_#selR@"
recSelectorId :: QualIdent
-> Ident
-> Ident
recSelectorId = mkRecordId recSelExt
qualRecSelectorId :: ModuleIdent
-> QualIdent
-> Ident
-> QualIdent
qualRecSelectorId m r l = qualRecordId m r $ recSelectorId r l
recUpdExt :: String
recUpdExt = "_#updR@"
recUpdateId :: QualIdent
-> Ident
-> Ident
recUpdateId = mkRecordId recUpdExt
qualRecUpdateId :: ModuleIdent
-> QualIdent
-> Ident
-> QualIdent
qualRecUpdateId m r l = qualRecordId m r $ recUpdateId r l
mkRecordId :: String -> QualIdent -> Ident -> Ident
mkRecordId ann r l = mkIdent $ concat
[ann, idName (unqualify r), ".", idName l]
qualRecordId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
qualRecordId m r = qualifyWith (fromMaybe m $ qidModule r)
recordExt :: String
recordExt = "_#Rec:"
recordExtId :: Ident -> Ident
recordExtId r = mkIdent $ recordExt ++ idName r
isRecordExtId :: Ident -> Bool
isRecordExtId = (recordExt `isPrefixOf`) . idName
fromRecordExtId :: Ident -> Ident
fromRecordExtId r
| p == recordExt = mkIdent r'
| otherwise = r
where (p, r') = splitAt (length recordExt) (idName r)
labelExt :: String
labelExt = "_#Lab:"
labelExtId :: Ident -> Ident
labelExtId l = mkIdent $ labelExt ++ idName l
isLabelExtId :: Ident -> Bool
isLabelExtId = (labelExt `isPrefixOf`) . idName
fromLabelExtId :: Ident -> Ident
fromLabelExtId l
| p == labelExt = mkIdent l'
| otherwise = l
where (p, l') = splitAt (length labelExt) (idName l)
mkLabelIdent :: String -> Ident
mkLabelIdent c = renameIdent (mkIdent c) (1)
renameLabel :: Ident -> Ident
renameLabel l = renameIdent l (1)