Skip to content

GitLab

Commit 43f6528a authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Adapted renamings in curry-base

parent fabe4f47
Hide whitespace changes
Inline Side-by-side
Showing with 142 additions and 143 deletions
src/Base/Messages.hs
View file @ 43f6528a
......@@ -11,8 +11,7 @@ import Control.Monad (unless)
import System.IO (hPutStrLn, stderr)
import System.Exit (ExitCode (..), exitWith)
import Curry.Base.Ident (ModuleIdent (..), Ident (..), QualIdent
, positionOfQualIdent)
import Curry.Base.Ident (ModuleIdent (..), Ident (..), QualIdent, qidPosition)
import Curry.Base.MessageMonad (Message, toMessage)
import CompilerOpts (Options (optVerbosity), Verbosity (..))
......@@ -48,10 +47,10 @@ errorMessages :: [Message] -> a
errorMessages = error . unlines . map show
posErr :: Ident -> String -> Message
posErr i errMsg = toMessage (positionOfIdent i) errMsg
posErr i errMsg = toMessage (idPosition i) errMsg
qposErr :: QualIdent -> String -> Message
qposErr i errMsg = toMessage (positionOfQualIdent i) errMsg
qposErr i errMsg = toMessage (qidPosition i) errMsg
mposErr :: ModuleIdent -> String -> Message
mposErr m errMsg = toMessage (positionOfModuleIdent m) errMsg
mposErr m errMsg = toMessage (midPosition m) errMsg
src/Base/OldScopeEnv.hs
View file @ 43f6528a
......@@ -12,11 +12,11 @@ type IdEnv = Map.Map IdRep Integer
data IdRep = Name String | Index Integer deriving (Eq, Ord)
insertId :: Integer -> Ident -> IdEnv -> IdEnv
insertId level ident = Map.insert (Name (name ident)) level
. Map.insert (Index (uniqueId ident)) level
insertId level ident = Map.insert (Name (idName ident)) level
. Map.insert (Index (idUnique ident)) level
nameExists :: String -> IdEnv -> Bool
nameExists idName = Map.member (Name idName)
nameExists name = Map.member (Name name)
indexExists :: Integer -> IdEnv -> Bool
indexExists index = Map.member (Index index)
......@@ -57,7 +57,7 @@ beginScope (topleveltab, leveltabs, level) = case leveltabs of
-- the prefix 'name' followed by an index (i.e. "var3" if 'name' was "var").
-- All returned identifiers are unique within the current scope.
genIdentList :: Int -> String -> ScopeEnv -> [Ident]
genIdentList size idName scopeenv = p_genIdentList size idName scopeenv 0
genIdentList size name scopeenv = p_genIdentList size name scopeenv 0
where
p_genIdentList :: Int -> String -> ScopeEnv -> Int -> [Ident]
p_genIdentList s n env i
......@@ -73,9 +73,9 @@ genIdentList size idName scopeenv = p_genIdentList size idName scopeenv 0
-- unique within the current scope. If no identifier can be generated for
-- 'name' then 'Nothing' will be returned
genIdent :: String -> ScopeEnv -> Maybe Ident
genIdent idName (topleveltab, leveltabs, _) = case leveltabs of
[] -> genId idName topleveltab
(lt:_) -> genId idName lt
genIdent name (topleveltab, leveltabs, _) = case leveltabs of
[] -> genId name topleveltab
(lt:_) -> genId name lt
-- -- Return the declaration level of an identifier if it exists
-- getIdentLevel :: Ident -> ScopeEnv -> Maybe Integer
......
src/Checks/ExportCheck.hs
View file @ 43f6528a
......@@ -254,17 +254,17 @@ errMultipleExportType :: [Ident] -> Message
errMultipleExportType [] = internalError
"Checks.ExportCheck.errMultipleExportType: empty list"
errMultipleExportType (i:is) = posErr i $
"Multiple exports of type " ++ name i ++ " at:\n"
"Multiple exports of type " ++ idName i ++ " at:\n"
++ unlines (map showPos (i:is))
where showPos = (" " ++) . showLine . positionOfIdent
where showPos = (" " ++) . showLine . idPosition
errMultipleExportValue :: [Ident] -> Message
errMultipleExportValue [] = internalError
"Checks.ExportCheck.errMultipleExportValue: empty list"
errMultipleExportValue (i:is) = posErr i $
"Multiple exports of " ++ name i ++ " at:\n"
"Multiple exports of " ++ idName i ++ " at:\n"
++ unlines (map showPos (i:is))
where showPos = (" " ++) . showLine . positionOfIdent
where showPos = (" " ++) . showLine . idPosition
errAmbiguousType :: QualIdent -> Message
errAmbiguousType tc = qposErr tc $ "Ambiguous type " ++ qualName tc
......@@ -281,8 +281,8 @@ errNonDataType tc = qposErr tc $ qualName tc ++ " is not a data type"
errUndefinedDataConstr :: QualIdent -> Ident -> Message
errUndefinedDataConstr tc c = posErr c $
name c ++ " is not a data constructor of type " ++ qualName tc
idName c ++ " is not a data constructor of type " ++ qualName tc
errUndefinedLabel :: QualIdent -> Ident -> Message
errUndefinedLabel r l = posErr l $
name l ++ " is not a label of the record " ++ qualName r
idName l ++ " is not a label of the record " ++ qualName r
src/Checks/KindCheck.lhs
View file @ 43f6528a
......@@ -323,16 +323,16 @@ Error messages:
> errMultipleDeclaration [] = internalError
> "KindCheck.errMultipleDeclaration: empty list"
> errMultipleDeclaration (i:is) = posErr i $
> "Multiple declarations for type `" ++ name i ++ "` at:\n"
> "Multiple declarations for type `" ++ idName i ++ "` at:\n"
> ++ unlines (map showPos (i:is))
> where showPos = (" " ++) . showLine . positionOfIdent
> where showPos = (" " ++) . showLine . idPosition
> errNonLinear :: Ident -> Message
> errNonLinear tv = posErr tv $ "Type variable " ++ name tv ++
> errNonLinear tv = posErr tv $ "Type variable " ++ idName tv ++
> " occurs more than once on left hand side of type declaration"
> errNoVariable :: Ident -> Message
> errNoVariable tv = posErr tv $ "Type constructor " ++ name tv ++
> errNoVariable tv = posErr tv $ "Type constructor " ++ idName tv ++
> " used in left hand side of type declaration"
> errWrongArity :: QualIdent -> Int -> Int -> Message
......@@ -344,6 +344,6 @@ Error messages:
> arguments n = show n ++ " arguments"
> errUnboundVariable :: Ident -> Message
> errUnboundVariable tv = posErr tv $ "Unbound type variable " ++ name tv
> errUnboundVariable tv = posErr tv $ "Unbound type variable " ++ idName tv
\end{verbatim}
src/Checks/PrecCheck.lhs
View file @ 43f6528a
......@@ -491,20 +491,20 @@ Error messages.
> errUndefinedOperator :: Ident -> Message
> errUndefinedOperator op = posErr op $
> "no definition for " ++ name op ++ " in this scope"
> "no definition for " ++ idName op ++ " in this scope"
> errDuplicatePrecedence :: Ident -> Message
> errDuplicatePrecedence op = posErr op $
> "More than one fixity declaration for " ++ name op
> "More than one fixity declaration for " ++ idName op
> errInvalidParse :: String -> Ident -> QualIdent -> Message
> errInvalidParse what op1 op2 = posErr op1 $
> "Invalid use of " ++ what ++ " " ++ name op1
> ++ " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2)
> "Invalid use of " ++ what ++ " " ++ idName op1
> ++ " with " ++ qualName op2 ++ (showLine $ qidPosition op2)
> errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
> errAmbiguousParse what op1 op2 = qposErr op1 $
> "Ambiguous use of " ++ what ++ " " ++ qualName op1
> ++ " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2)
> ++ " with " ++ qualName op2 ++ (showLine $ qidPosition op2)
\end{verbatim}
src/Checks/SyntaxCheck.lhs
View file @ 43f6528a
......@@ -92,7 +92,7 @@ renaming literals and underscore to disambiguate them.
> -- |Identifier for global (top-level) declarations
> globalScopeId :: Integer
> globalScopeId = uniqueId (mkIdent "")
> globalScopeId = idUnique (mkIdent "")
> -- |Run the syntax check monad
> runSC :: SCM a -> SCState -> (a, [Message])
......@@ -296,7 +296,7 @@ Furthermore, it is not allowed to declare a label more than once.
> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
> qualLookupListCons v env
> | v == qualifyWith preludeMIdent consId
> = qualLookupNestEnv (qualify $ qualidId v) env
> = qualLookupNestEnv (qualify $ qidIdent v) env
> | otherwise
> = []
......@@ -316,10 +316,10 @@ local declarations.
> checkTypeDecl :: Decl -> SCM Decl
> checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
> checkRecordExtension $ positionOfIdent r
> checkRecordExtension $ idPosition r
> when (isJust rty) $ internalError
> "SyntaxCheck.checkTypeDecl: illegal record type"
> when (null fs) $ report $ errEmptyRecord $ positionOfIdent r
> when (null fs) $ report $ errEmptyRecord $ idPosition r
> return rec
> checkTypeDecl d = return d
......@@ -435,7 +435,7 @@ top-level.
> = checkOpLhs k env (f . InfixPattern t1 op) t2
> | otherwise
> = Left (op'', OpLhs (f t1) op'' t2)
> where (m,op') = (qualidMod op, qualidId op)
> where (m,op') = (qidModule op, qidIdent op)
> op'' = renameIdent op' k
> checkOpLhs _ _ f t = Right (f t)
......@@ -499,7 +499,7 @@ top-level.
> checkLhs p (OpLhs t1 op t2) = do
> let wrongCalls = concatMap (checkParenConstrTerm (Just $ qualify op)) [t1,t2]
> unless (null wrongCalls) $ report $ errInfixWithoutParens
> (positionOfIdent op) wrongCalls
> (idPosition op) wrongCalls
> liftM2 (flip OpLhs op) (checkConstrTerm p t1) (checkConstrTerm p t2)
> checkLhs p (ApLhs lhs ts) =
> liftM2 ApLhs (checkLhs p lhs) (mapM (checkConstrTerm p) ts)
......@@ -648,7 +648,7 @@ checkParen
> if isNothing t
> then do
> when (not $ null missings) $ report $ errMissingLabel
> (positionOfIdent l) (head missings) r "record pattern"
> (idPosition l) (head missings) r "record pattern"
> flip RecordPattern t `liftM` mapM (checkFieldPatt r) fs
> else if t == Just (VariablePattern anonId)
> then liftM2 RecordPattern
......@@ -671,7 +671,7 @@ checkParen
> [] -> report $ errUndefinedLabel l
> [_] -> report $ errNotALabel l
> _ -> report $ errDuplicateDefinition l
> Field p l `liftM` checkConstrTerm (positionOfIdent l) t
> Field p l `liftM` checkConstrTerm (idPosition l) t
> -- Note: process decls first
> checkRhs :: Rhs -> SCM Rhs
......@@ -730,7 +730,7 @@ checkParen
> [RecordLabel r ls] -> do
> unless (null dups) $ report $ errDuplicateLabel $ head dups
> unless (null missings) $ report $ errMissingLabel
> (positionOfIdent l) (head missings) r "record construction"
> (idPosition l) (head missings) r "record construction"
> RecordConstr `liftM` mapM (checkFieldExpr r) fs
> where ls' = map fieldLabel fs
> dups = maybeToList (findDouble ls')
......@@ -757,7 +757,7 @@ checkParen
> [RecordLabel r _] -> do
> unless (null dups) $ report $ errDuplicateLabel $ head dups
> liftM2 RecordUpdate (mapM (checkFieldExpr r) fs)
> (checkExpr (positionOfIdent l) e)
> (checkExpr (idPosition l) e)
> where dups = maybeToList $ findDouble $ map fieldLabel fs
> [] -> report (errUndefinedLabel l) >> return rec
> [_] -> report (errNotALabel l) >> return rec
......@@ -766,7 +766,7 @@ checkParen
> checkVariable :: QualIdent -> SCM Expression
> checkVariable v
> | unqualify v == anonId = do
> checkAnonFreeVarsExtension $ positionOfQualIdent v
> checkAnonFreeVarsExtension $ qidPosition v
> return $ Variable v
> | otherwise = do
> env <- getRenameEnv
......@@ -839,7 +839,7 @@ checkParen
> [] -> report $ errUndefinedLabel l
> [_] -> report $ errNotALabel l
> _ -> report $ errDuplicateDefinition l
> Field p l `liftM` checkExpr (positionOfIdent l) e
> Field p l `liftM` checkExpr (idPosition l) e
\end{verbatim}
Auxiliary definitions.
......@@ -986,7 +986,7 @@ Error messages.
> errUndefinedData c = qposErr c $ "Undefined data constructor " ++ qualName c
> errUndefinedLabel :: Ident -> Message
> errUndefinedLabel l = posErr l $ "Undefined record label `" ++ name l ++ "`"
> errUndefinedLabel l = posErr l $ "Undefined record label `" ++ idName l ++ "`"
> errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
> errAmbiguousIdent rs | any isConstr rs = errAmbiguousData
......@@ -1000,67 +1000,67 @@ Error messages.
> errDuplicateDefinition :: Ident -> Message
> errDuplicateDefinition v = posErr v $
> "More than one definition for `" ++ name v ++ "`"
> "More than one definition for `" ++ idName v ++ "`"
> errDuplicateVariable :: Ident -> Message
> errDuplicateVariable v = posErr v $
> name v ++ " occurs more than once in pattern"
> idName v ++ " occurs more than once in pattern"
> errMultipleDataConstructor :: [Ident] -> Message
> errMultipleDataConstructor [] = internalError
> "SyntaxCheck.errMultipleDataDeclaration: empty list"
> errMultipleDataConstructor (i:is) = posErr i $
> "Multiple definitions for data constructor `" ++ name i ++ "` at:\n"
> "Multiple definitions for data constructor `" ++ idName i ++ "` at:\n"
> ++ unlines (map showPos (i:is))
> where showPos = (" " ++) . showLine . positionOfIdent
> where showPos = (" " ++) . showLine . idPosition
> errDuplicateTypeSig :: Ident -> Message
> errDuplicateTypeSig v = posErr v $
> "More than one type signature for `" ++ name v ++ "`"
> "More than one type signature for `" ++ idName v ++ "`"
> errDuplicateEvalAnnot :: Ident -> Message
> errDuplicateEvalAnnot v = posErr v $
> "More than one eval annotation for `" ++ name v ++ "`"
> "More than one eval annotation for `" ++ idName v ++ "`"
> errDuplicateLabel :: Ident -> Message
> errDuplicateLabel l = posErr l $
> "Multiple occurrence of record label `" ++ name l ++ "`"
> "Multiple occurrence of record label `" ++ idName l ++ "`"
> errMissingLabel :: Position -> Ident -> QualIdent -> String -> Message
> errMissingLabel p l r what = toMessage p $
> "Missing label `" ++ name l
> ++ "` in the " ++ what ++ " of `" ++ name (unqualify r) ++ "`"
> "Missing label `" ++ idName l
> ++ "` in the " ++ what ++ " of `" ++ idName (unqualify r) ++ "`"
> errIllegalLabel :: Ident -> QualIdent -> Message
> errIllegalLabel l r = posErr l $
> "Label `" ++ name l ++ "` is not defined in record `"
> ++ name (unqualify r) ++ "`"
> "Label `" ++ idName l ++ "` is not defined in record `"
> ++ idName (unqualify r) ++ "`"
> errIllegalRecordId :: Ident -> Message
> errIllegalRecordId r = posErr r $ "Record identifier `" ++ name r
> errIllegalRecordId r = posErr r $ "Record identifier `" ++ idName r
> ++ "` already assigned to a data constructor"
> errNonVariable :: String -> Ident -> Message
> errNonVariable what c = posErr c $
> "Data constructor `" ++ name c ++ "` in left hand side of " ++ what
> "Data constructor `" ++ idName c ++ "` in left hand side of " ++ what
> errNoBody :: Ident -> Message
> errNoBody v = posErr v $ "No body for `" ++ name v ++ "`"
> errNoBody v = posErr v $ "No body for `" ++ idName v ++ "`"
> errNoTypeSig :: Ident -> Message
> errNoTypeSig f = posErr f $
> "No type signature for external function `" ++ name f ++ "`"
> "No type signature for external function `" ++ idName f ++ "`"
> errToplevelPattern :: Position -> Message
> errToplevelPattern p = toMessage p
> "Pattern declaration not allowed at top-level"
> errNotALabel :: Ident -> Message
> errNotALabel l = posErr l $ "`" ++ name l ++ "` is not a record label"
> errNotALabel l = posErr l $ "`" ++ idName l ++ "` is not a record label"
> errDifferentArity :: Ident -> Message
> errDifferentArity f = posErr f $
> "Equations for `" ++ name f ++ "` have different arities"
> "Equations for `" ++ idName f ++ "` have different arities"
> errWrongArity :: QualIdent -> Int -> Int -> Message
> errWrongArity c arity' argc = qposErr c $
......@@ -1086,7 +1086,7 @@ Error messages.
> errInfixWithoutParens p calls = toMessage p $
> "Missing parens in infix patterns: \n" ++ unlines (map showCall calls)
> where showCall (q1, q2) =
> show q1 ++ " " ++ showLine (positionOfQualIdent q1)
> ++ "calls " ++ show q2 ++ " " ++ showLine (positionOfQualIdent q2)
> show q1 ++ " " ++ showLine (qidPosition q1)
> ++ "calls " ++ show q2 ++ " " ++ showLine (qidPosition q2)
\end{verbatim}
src/Checks/TypeCheck.lhs
View file @ 43f6528a
......@@ -504,12 +504,12 @@ signature the declared type must be too general.
> Nothing -> modifyValueEnv $ rebindFun m v arity sigma
> Just sigTy -> do
> sigma' <- expandPolyType sigTy
> unless (eqTyScheme sigma sigma') $ report $ errTypeSigTooGeneral (positionOfIdent v) m what sigTy sigma
> unless (eqTyScheme sigma sigma') $ report $ errTypeSigTooGeneral (idPosition v) m what sigTy sigma
> modifyValueEnv $ rebindFun m v arity sigma
> where
> what = text (if poly then "Function:" else "Variable:") <+> ppIdent v
> genType poly' (ForAll n ty)
> | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty
> | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (idPosition v) ++ show v ++ " :: " ++ show ty
> | poly' = gen lvs ty
> | otherwise = monoType ty
> eqTyScheme (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2
......@@ -723,7 +723,7 @@ because of possibly multiple occurrences of variables.
> -> Field ConstrTerm -> TCM (Ident, Type)
> tcFieldPatt tcPatt m f@(Field _ l t) = do
> tyEnv <- getValueEnv
> let p = positionOfIdent l
> let p = idPosition l
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
> modifyValueEnv
......@@ -775,7 +775,7 @@ because of possibly multiple occurrences of variables.
> case qualLookupTypeSig m v sigs of
> Just ty -> expandPolyType ty >>= inst
> Nothing -> getValueEnv >>= inst . funType m v
> where v' = qualidId v
> where v' = qidIdent v
> tcExpr _ (Constructor c) = do
> m <- getModuleIdent
> getValueEnv >>= instExist . constrType m c
......@@ -847,7 +847,7 @@ because of possibly multiple occurrences of variables.
> where opType op'
> | op' == minusId = freshConstrained [intType,floatType]
> | op' == fminusId = return floatType
> | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ name op'
> | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ idName op'
> tcExpr p e@(Apply e1 e2) = do
> ty1 <- tcExpr p e1
> ty2 <- tcExpr p e2
......@@ -985,7 +985,7 @@ because of possibly multiple occurrences of variables.
> tcFieldExpr comb f@(Field _ l e) = do
> m <- getModuleIdent
> tyEnv <- getValueEnv
> let p = positionOfIdent l
> let p = idPosition l
> lty <- maybe (freshTypeVar
> >>= (\lty' ->
> modifyValueEnv (bindLabel l (qualifyWith m (mkIdent "#Rec"))
......@@ -1320,20 +1320,20 @@ Error functions.
> errRecursiveTypes [] = internalError
> "TypeCheck.recursiveTypes: empty list"
> errRecursiveTypes [tc] = posErr tc $
> "Recursive synonym type " ++ name tc
> "Recursive synonym type " ++ idName tc
> errRecursiveTypes (tc : tcs) = posErr tc $
> "Recursive synonym types " ++ name tc ++ types "" tcs
> "Recursive synonym types " ++ idName tc ++ types "" tcs
> where
> types _ [] = ""
> types comm [tc1] = comm ++ " and " ++ name tc1
> ++ showLine (positionOfIdent tc1)
> types _ (tc1:tcs1) = ", " ++ name tc1
> ++ showLine (positionOfIdent tc1)
> types comm [tc1] = comm ++ " and " ++ idName tc1
> ++ showLine (idPosition tc1)
> types _ (tc1:tcs1) = ", " ++ idName tc1
> ++ showLine (idPosition tc1)
> ++ types "," tcs1
> errPolymorphicFreeVar :: Ident -> Message
> errPolymorphicFreeVar v = posErr v $
> "Free variable " ++ name v ++ " has a polymorphic type"
> "Free variable " ++ idName v ++ " has a polymorphic type"
> errTypeSigTooGeneral :: Position -> ModuleIdent -> Doc -> TypeExpr -> TypeScheme
> -> Message
......
src/Checks/WarnCheck.hs
View file @ 43f6528a
......@@ -517,7 +517,7 @@ insertConstrTerm fp (VariablePattern ident)
| fp = do
c <- isConsId ident
v <- isVarId ident
unless c $ if name ident /= "_" && v then visitId ident else insertVar ident
unless c $ if idName ident /= "_" && v then visitId ident else insertVar ident
| otherwise = do
c <- isConsId ident
unless c $ insertVar ident
......@@ -744,7 +744,7 @@ typeId ident = qualify (renameIdent ident 1)
-- ---------------------------------------------------------------------------
warnMultiplyImportedModule :: ModuleIdent -> Message
warnMultiplyImportedModule mid = toMessage (positionOfModuleIdent mid) $
warnMultiplyImportedModule mid = toMessage (midPosition mid) $
"Module \"" ++ show mid ++ "\" is imported more than once"
warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message
......@@ -783,4 +783,4 @@ overlappingCaseAlt :: Position -> Message
overlappingCaseAlt p = toMessage p "Redundant overlapping case alternative"
posWarn :: Ident -> String -> Message
posWarn i msg = toMessage (positionOfIdent i) msg
posWarn i msg = toMessage (idPosition i) msg
src/CurryBuilder.hs
View file @ 43f6528a
......@@ -56,7 +56,7 @@ findCurry opts str = do
Just fn -> return $ Right fn
where
canBeFile = isCurryFilePath str
canBeModule = isModuleName str
canBeModule = isValidModuleName str
moduleFile = moduleNameToFile $ fromModuleName str
paths = optImportPaths opts
fileSearch = if canBeFile
......
src/Env/OpPrec.hs
View file @ 43f6528a
......@@ -53,7 +53,7 @@ type PEnv = TopEnv PrecInfo
bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv
bindP m op p
| uniqueId op == 0 = bindTopEnv fun op info . qualBindTopEnv fun qop info
| idUnique op == 0 = bindTopEnv fun op info . qualBindTopEnv fun qop info
| otherwise = bindTopEnv fun op info
where qop = qualifyWith m op
info = PrecInfo qop p
......
src/Env/Value.hs
View file @ 43f6528a
......@@ -83,7 +83,7 @@ bindGlobalInfo f m c ty = bindTopEnv fun c v . qualBindTopEnv fun qc v
bindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun m f a ty
| uniqueId f == 0 = bindTopEnv fun f v . qualBindTopEnv fun qf v
| idUnique f == 0 = bindTopEnv fun f v . qualBindTopEnv fun qf v
| otherwise = bindTopEnv fun f v
where qf = qualifyWith m f
v = Value qf a ty
......@@ -97,7 +97,7 @@ qualBindFun m f a ty = qualBindTopEnv "Env.Value.qualBindFun" qf $
rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv
-> ValueEnv
rebindFun m f a ty
| uniqueId f == 0 = rebindTopEnv f v . qualRebindTopEnv qf v
| idUnique f == 0 = rebindTopEnv f v . qualRebindTopEnv qf v
| otherwise = rebindTopEnv f v
where qf = qualifyWith m f
v = Value qf a ty
......@@ -122,7 +122,7 @@ qualLookupCons x tyEnv
| mmid == Just preludeMIdent && qid == consId
= qualLookupTopEnv (qualify qid) tyEnv
| otherwise = []
where (mmid, qid) = (qualidMod x, qualidId x)
where (mmid, qid) = (qidModule x, qidIdent x)
lookupTuple :: Ident -> [ValueInfo]
lookupTuple c
......
src/Exports.hs
View file @ 43f6528a
......@@ -68,7 +68,7 @@ exportInterface' (Module _ Nothing _ _) _ _ _
infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds
infixDecl m pEnv (ExportTypeWith tc cs) ds =
foldr (iInfixDecl m pEnv . qualifyLike (qualidMod tc)) ds cs
foldr (iInfixDecl m pEnv . qualifyLike (qidModule tc)) ds cs
where qualifyLike = maybe qualify qualifyWith
infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
......@@ -144,7 +144,7 @@ funDecl _ _ _ _ = internalError "Exports.funDecl: no pattern match"
-- the interface for module @C@ will import module @A@ but not module @B@.
usedModules :: [IDecl] -> [ModuleIdent]
usedModules ds = nub' (catMaybes (map qualidMod (foldr identsDecl [] ds)))
usedModules ds = nub' (catMaybes (map qidModule (foldr identsDecl [] ds)))
where nub' = Set.toList . Set.fromList
identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
......
src/Generators/GenAbstractCurry.hs
View file @ 43f6528a
......@@ -134,7 +134,7 @@ genTypeDecl env (DataDecl _ n vs cs)
= ( resetScope env2
, CType (genQName True env2 $ qualifyWith (moduleId env) n)
(genVisibility env2 n)
(zip idxs $ map name vs)
(zip idxs $ map idName vs)
cs'
)
where (env1, idxs) = mapAccumL genTVarIndex env vs
......@@ -143,7 +143,7 @@ genTypeDecl env (TypeDecl _ n vs ty)
= ( resetScope env2
, CTypeSyn (genQName True env2 $ qualifyWith (moduleId env) n)
(genVisibility env2 n)
(zip idxs $ map name vs)
(zip idxs $ map idName vs)
ty'
)
where (env1, idxs) = mapAccumL genTVarIndex env vs
......@@ -172,8 +172,8 @@ genTypeExpr env (ConstructorType q vs)
= (env', CTCons (genQName True env' q) vs')
where (env', vs') = mapAccumL genTypeExpr env vs
genTypeExpr env (VariableType ident) = case getTVarIndex env ident of
Just ix -> (env , CTVar (ix , name ident))
Nothing -> (env', CTVar (idx, name ident))
Just ix -> (env , CTVar (ix , idName ident))
Nothing -> (env', CTVar (idx, idName ident))
where (env', idx) = genTVarIndex env ident
genTypeExpr env (TupleType tys) = genTypeExpr env $ case tys of
[] -> ConstructorType qUnitId []
......@@ -197,7 +197,7 @@ genTypeExpr env (RecordType fss mr) = case mr of
where
(ls , ts ) = unzip $ concatMap (\ (ls1,ty) -> map (\l -> (l,ty)) ls1) fss
(env1, ts') = mapAccumL genTypeExpr env ts
ls' = map name ls
ls' = map idName ls
genOpDecl :: AbstractEnv -> Decl -> [COpDecl]
genOpDecl env (InfixDecl _ fix prec ops) = map genCOp (reverse ops)
......@@ -259,9 +259,9 @@ genFuncDecl isLocal env (ident, decls)
internalError "GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"
genExternal (ExternalDecl _ _ mname ident' _)
= CExternal (fromMaybe (name ident') mname)
= CExternal (fromMaybe (idName ident') mname)
genExternal (FlatExternalDecl _ [ident'])
= CExternal (name ident')
= CExternal (idName ident')
genExternal _
= internalError $ "GenAbstractCurry.genExternal: "
++ "illegal external declaration occured"
......@@ -375,7 +375,7 @@ genLocalDecls env decls
(getVarIndex env' ident)
decls' = ExtraVariables pos (tail idents) : decls1
(env'', locals) = genLocals env' fdecls decls'
in (env'', CLocalVar (idx, name ident) : locals)
in (env'', CLocalVar (idx, idName ident) : locals)
genLocals env' fdecls ((TypeSig _ _ _):decls1)
= genLocals env' fdecls decls1
genLocals _ _ decl = internalError ("GenAbstractCurry.genLocals: unexpected local declaration: \n" ++ show (head decl))
......@@ -398,7 +398,7 @@ genLocalDecls env decls
genLocalPattern _ env' (VariablePattern v) = case getVarIndex env' v of
Nothing -> internalError $ "GenAbstractCurry.genLocalPattern: "
++ "cannot find index" ++ " for pattern variable \"" ++ show v ++ "\""
Just idx -> (env', CPVar (idx, name v))
Just idx -> (env', CPVar (idx, idName v))
genLocalPattern pos env' (ConstructorPattern qident args)
= let (env'', args') = mapAccumL (genLocalPattern pos) env' args
in (env'', CPComb (genQName False env' qident) args')
......@@ -425,7 +425,7 @@ genLocalDecls env decls