{-# LANGUAGE CPP #-}
module Curry.Base.Ident
(
ModuleIdent (..), mkMIdent, moduleName, escModuleName
, fromModuleName, isValidModuleName, addPositionModuleIdent, mIdentLength
, Ident (..), mkIdent, showIdent, escName, identSupply
, globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent
, updIdentName, addPositionIdent, isInfixOp, identLength
, QualIdent (..), qualName, escQualName, isQInfixOp, qualify
, qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify
, localIdent, isLocalIdent, updQualIdent, qIdentLength
, emptyMIdent, mainMIdent, preludeMIdent
, arrowId, unitId, boolId, charId, intId, floatId, listId, ioId, successId
, eqId, ordId, enumId, boundedId, readId, showId
, numId, fractionalId
, monadId, monadFailId
, dataId
, trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity
, mainId, minusId, fminusId, applyId, errorId, failedId, idId
, succId, predId, toEnumId, fromEnumId, enumFromId, enumFromThenId
, enumFromToId, enumFromThenToId
, maxBoundId, minBoundId
, lexId, readsPrecId, readParenId
, showsPrecId, showParenId, showStringId
, andOpId, eqOpId, leqOpId, ltOpId, orOpId, appendOpId, dotOpId
, aValueId, dataEqId
, anonId, isAnonId
, qArrowId, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId
, qSuccessId, isPrimTypeId
, qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId
, qNumId, qFractionalId
, qMonadId, qMonadFailId
, qDataId
, qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity
, qApplyId, qErrorId, qFailedId, qIdId
, qFromEnumId, qEnumFromId, qEnumFromThenId, qEnumFromToId, qEnumFromThenToId
, qMaxBoundId, qMinBoundId
, qLexId, qReadsPrecId, qReadParenId
, qShowsPrecId, qShowParenId, qShowStringId
, qAndOpId, qEqOpId, qLeqOpId, qLtOpId, qOrOpId, qAppendOpId, qDotOpId
, qAValueId, qDataEqId
, fpSelectorId, isFpSelectorId, isQualFpSelectorId
, recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId
, recordExt, recordExtId, isRecordExtId, fromRecordExtId
, labelExt, labelExtId, isLabelExtId, fromLabelExtId
, renameLabel, mkLabelIdent
) where
import Prelude hiding ((<>))
import Data.Char (isAlpha, isAlphaNum)
import Data.Function (on)
import Data.List (intercalate, isInfixOf, isPrefixOf)
import Data.Maybe (isJust, fromMaybe)
import Data.Binary
import Control.Monad
import Curry.Base.Position
import Curry.Base.Span hiding (file)
import Curry.Base.SpanInfo
import Curry.Base.Pretty
data ModuleIdent = ModuleIdent
{ midSpanInfo :: SpanInfo
, midQualifiers :: [String]
} deriving (Read, Show)
instance Eq ModuleIdent where
(==) = (==) `on` midQualifiers
instance Ord ModuleIdent where
compare = compare `on` midQualifiers
instance HasSpanInfo ModuleIdent where
getSpanInfo = midSpanInfo
setSpanInfo spi a = a { midSpanInfo = spi }
updateEndPos i =
setEndPosition (incr (getPosition i) (mIdentLength i - 1)) i
instance HasPosition ModuleIdent where
getPosition = getStartPosition
setPosition = setStartPosition
instance Pretty ModuleIdent where
pPrint = hcat . punctuate dot . map text . midQualifiers
instance Binary ModuleIdent where
put (ModuleIdent sp qs) = put sp >> put qs
get = liftM2 ModuleIdent get get
mIdentLength :: ModuleIdent -> Int
mIdentLength a = length (concat (midQualifiers a))
+ length (midQualifiers a)
mkMIdent :: [String] -> ModuleIdent
mkMIdent = ModuleIdent NoSpanInfo
moduleName :: ModuleIdent -> String
moduleName = intercalate "." . midQualifiers
escModuleName :: ModuleIdent -> String
escModuleName m = '`' : moduleName m ++ "'"
addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
addPositionModuleIdent = setPosition
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
{ idSpanInfo :: SpanInfo
, idName :: String
, idUnique :: Integer
} deriving (Read, Show)
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 HasSpanInfo Ident where
getSpanInfo = idSpanInfo
setSpanInfo spi a = a { idSpanInfo = spi }
updateEndPos i@(Ident (SpanInfo _ [_,ss]) _ _) =
setEndPosition (end ss) i
updateEndPos i =
setEndPosition (incr (getPosition i) (identLength i - 1)) i
instance HasPosition Ident where
getPosition = getStartPosition
setPosition = setStartPosition
instance Pretty Ident where
pPrint (Ident _ x n) | n == globalScope = text x
| otherwise = text x <> dot <> integer n
instance Binary Ident where
put (Ident sp qs i) = put sp >> put qs >> put i
get = liftM3 Ident get get get
identLength :: Ident -> Int
identLength a = length (idName a)
globalScope :: Integer
globalScope = 0
mkIdent :: String -> Ident
mkIdent x = Ident NoSpanInfo 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 = setPosition
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
{ qidSpanInfo :: SpanInfo
, qidModule :: Maybe ModuleIdent
, qidIdent :: Ident
} deriving (Read, Show)
instance Eq QualIdent where
QualIdent _ m i == QualIdent _ n j = (m, i) == (n, j)
instance Ord QualIdent where
QualIdent _ m i `compare` QualIdent _ n j = (m, i) `compare` (n, j)
instance HasSpanInfo QualIdent where
getSpanInfo = qidSpanInfo
setSpanInfo spi a = a { qidSpanInfo = spi }
updateEndPos i@(QualIdent (SpanInfo _ [_,ss]) _ _) =
setEndPosition (end ss) i
updateEndPos i =
setEndPosition (incr (getPosition i) (qIdentLength i - 1)) i
instance HasPosition QualIdent where
getPosition = getStartPosition
setPosition = setStartPosition
instance Pretty QualIdent where
pPrint = text . qualName
instance Binary QualIdent where
put (QualIdent sp mid idt) = put sp >> put mid >> put idt
get = liftM3 QualIdent get get get
qIdentLength :: QualIdent -> Int
qIdentLength (QualIdent _ (Just m) i) = identLength i + mIdentLength m
qIdentLength (QualIdent _ Nothing i) = identLength i
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 ++ "'"
isQInfixOp :: QualIdent -> Bool
isQInfixOp = isInfixOp . qidIdent
qualify :: Ident -> QualIdent
qualify i = QualIdent (fromSrcSpan (getSrcSpan i)) Nothing i
qualifyWith :: ModuleIdent -> Ident -> QualIdent
qualifyWith mid i = updateEndPos $
QualIdent (fromSrcSpan (getSrcSpan mid)) (Just mid) i
qualQualify :: ModuleIdent -> QualIdent -> QualIdent
qualQualify m (QualIdent _ Nothing x) = qualifyWith 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 spi (Just m') x) = QualIdent spi 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 spi m x) = QualIdent spi (fmap f m) (g x)
emptyMIdent :: ModuleIdent
emptyMIdent = ModuleIdent NoSpanInfo []
mainMIdent :: ModuleIdent
mainMIdent = ModuleIdent NoSpanInfo ["main"]
preludeMIdent :: ModuleIdent
preludeMIdent = ModuleIdent NoSpanInfo ["Prelude"]
arrowId :: Ident
arrowId = mkIdent "(->)"
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
eqId :: Ident
eqId = mkIdent "Eq"
ordId :: Ident
ordId = mkIdent "Ord"
enumId :: Ident
enumId = mkIdent "Enum"
boundedId :: Ident
boundedId = mkIdent "Bounded"
readId :: Ident
readId = mkIdent "Read"
showId :: Ident
showId = mkIdent "Show"
numId :: Ident
numId = mkIdent "Num"
fractionalId :: Ident
fractionalId = mkIdent "Fractional"
monadId :: Ident
monadId = mkIdent "Monad"
monadFailId :: Ident
monadFailId = mkIdent "MonadFail"
dataId :: Ident
dataId = mkIdent "Data"
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 "-."
applyId :: Ident
applyId = mkIdent "apply"
errorId :: Ident
errorId = mkIdent "error"
failedId :: Ident
failedId = mkIdent "failed"
idId :: Ident
idId = mkIdent "id"
maxBoundId :: Ident
maxBoundId = mkIdent "maxBound"
minBoundId :: Ident
minBoundId = mkIdent "minBound"
predId :: Ident
predId = mkIdent "pred"
succId :: Ident
succId = mkIdent "succ"
toEnumId :: Ident
toEnumId = mkIdent "toEnum"
fromEnumId :: Ident
fromEnumId = mkIdent "fromEnum"
enumFromId :: Ident
enumFromId = mkIdent "enumFrom"
enumFromThenId :: Ident
enumFromThenId = mkIdent "enumFromThen"
enumFromToId :: Ident
enumFromToId = mkIdent "enumFromTo"
enumFromThenToId :: Ident
enumFromThenToId = mkIdent "enumFromThenTo"
lexId :: Ident
lexId = mkIdent "lex"
readsPrecId :: Ident
readsPrecId = mkIdent "readsPrec"
readParenId :: Ident
readParenId = mkIdent "readParen"
showsPrecId :: Ident
showsPrecId = mkIdent "showsPrec"
showParenId :: Ident
showParenId = mkIdent "showParen"
showStringId :: Ident
showStringId = mkIdent "showString"
andOpId :: Ident
andOpId = mkIdent "&&"
eqOpId :: Ident
eqOpId = mkIdent "=="
leqOpId :: Ident
leqOpId = mkIdent "<="
ltOpId :: Ident
ltOpId = mkIdent "<"
orOpId :: Ident
orOpId = mkIdent "||"
appendOpId :: Ident
appendOpId = mkIdent "++"
dotOpId :: Ident
dotOpId = mkIdent "."
aValueId :: Ident
aValueId = mkIdent "aValue"
dataEqId :: Ident
dataEqId = mkIdent "==="
anonId :: Ident
anonId = mkIdent "_"
isAnonId :: Ident -> Bool
isAnonId = (== anonId) . unRenameIdent
qPreludeIdent :: Ident -> QualIdent
qPreludeIdent = qualifyWith preludeMIdent
qArrowId :: QualIdent
qArrowId = qualify arrowId
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
isPrimTypeId :: QualIdent -> Bool
isPrimTypeId tc = tc `elem` [qArrowId, qUnitId, qListId] || isQTupleId tc
qEqId :: QualIdent
qEqId = qPreludeIdent eqId
qOrdId :: QualIdent
qOrdId = qPreludeIdent ordId
qEnumId :: QualIdent
qEnumId = qPreludeIdent enumId
qBoundedId :: QualIdent
qBoundedId = qPreludeIdent boundedId
qReadId :: QualIdent
qReadId = qPreludeIdent readId
qShowId :: QualIdent
qShowId = qPreludeIdent showId
qNumId :: QualIdent
qNumId = qPreludeIdent numId
qFractionalId :: QualIdent
qFractionalId = qPreludeIdent fractionalId
qMonadId :: QualIdent
qMonadId = qPreludeIdent monadId
qMonadFailId :: QualIdent
qMonadFailId = qPreludeIdent monadFailId
qDataId :: QualIdent
qDataId = qPreludeIdent dataId
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
qApplyId :: QualIdent
qApplyId = qPreludeIdent applyId
qErrorId :: QualIdent
qErrorId = qPreludeIdent errorId
qFailedId :: QualIdent
qFailedId = qPreludeIdent failedId
qIdId :: QualIdent
qIdId = qPreludeIdent idId
qMaxBoundId :: QualIdent
qMaxBoundId = qPreludeIdent maxBoundId
qMinBoundId :: QualIdent
qMinBoundId = qPreludeIdent minBoundId
qFromEnumId :: QualIdent
qFromEnumId = qPreludeIdent fromEnumId
qEnumFromId :: QualIdent
qEnumFromId = qPreludeIdent enumFromId
qEnumFromThenId :: QualIdent
qEnumFromThenId = qPreludeIdent enumFromThenId
qEnumFromToId :: QualIdent
qEnumFromToId = qPreludeIdent enumFromToId
qEnumFromThenToId :: QualIdent
qEnumFromThenToId = qPreludeIdent enumFromThenToId
qLexId :: QualIdent
qLexId = qPreludeIdent lexId
qReadsPrecId :: QualIdent
qReadsPrecId = qPreludeIdent readsPrecId
qReadParenId :: QualIdent
qReadParenId = qPreludeIdent readParenId
qShowsPrecId :: QualIdent
qShowsPrecId = qPreludeIdent showsPrecId
qShowParenId :: QualIdent
qShowParenId = qPreludeIdent showParenId
qShowStringId :: QualIdent
qShowStringId = qPreludeIdent showStringId
qAndOpId :: QualIdent
qAndOpId = qPreludeIdent andOpId
qEqOpId :: QualIdent
qEqOpId = qPreludeIdent eqOpId
qLeqOpId :: QualIdent
qLeqOpId = qPreludeIdent leqOpId
qLtOpId :: QualIdent
qLtOpId = qPreludeIdent ltOpId
qOrOpId :: QualIdent
qOrOpId = qPreludeIdent orOpId
qDotOpId :: QualIdent
qDotOpId = qPreludeIdent dotOpId
qAValueId :: QualIdent
qAValueId = qPreludeIdent aValueId
qDataEqId :: QualIdent
qDataEqId = qPreludeIdent dataEqId
qAppendOpId :: QualIdent
qAppendOpId = qPreludeIdent appendOpId
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)