Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
2a65272a
Commit
2a65272a
authored
Feb 19, 2015
by
Jan Rasmus Tikovsky
Browse files
Removed some commented-out code
parent
599ca9d1
Changes
3
Hide whitespace changes
Inline
Side-by-side
src/Checks/KindCheck.hs
View file @
2a65272a
...
...
@@ -200,12 +200,12 @@ checkExpr (RecordUpdate e fs) = RecordUpdate <$> checkExpr e
<*>
mapM
checkFieldExpr
fs
checkExpr
(
Tuple
p
es
)
=
Tuple
p
<$>
mapM
checkExpr
es
checkExpr
(
List
p
es
)
=
List
p
<$>
mapM
checkExpr
es
checkExpr
(
ListCompr
p
e
qs
)
=
ListCompr
p
<$>
checkExpr
e
checkExpr
(
ListCompr
p
e
qs
)
=
ListCompr
p
<$>
checkExpr
e
<*>
mapM
checkStmt
qs
checkExpr
(
EnumFrom
e
)
=
EnumFrom
<$>
checkExpr
e
checkExpr
(
EnumFromThen
e1
e2
)
=
EnumFromThen
<$>
checkExpr
e1
<*>
checkExpr
e2
checkExpr
(
EnumFromTo
e1
e2
)
=
EnumFromTo
<$>
checkExpr
e1
<*>
checkExpr
e2
checkExpr
(
EnumFromThenTo
e1
e2
e3
)
=
EnumFromThenTo
<$>
checkExpr
e1
checkExpr
(
EnumFromThenTo
e1
e2
e3
)
=
EnumFromThenTo
<$>
checkExpr
e1
<*>
checkExpr
e2
<*>
checkExpr
e3
checkExpr
(
UnaryMinus
op
e
)
=
UnaryMinus
op
<$>
checkExpr
e
checkExpr
(
Apply
e1
e2
)
=
Apply
<$>
checkExpr
e1
<*>
checkExpr
e2
...
...
@@ -216,9 +216,9 @@ checkExpr (RightSection op e) = RightSection op <$> checkExpr e
checkExpr
(
Lambda
r
ts
e
)
=
Lambda
r
ts
<$>
checkExpr
e
checkExpr
(
Let
ds
e
)
=
Let
<$>
mapM
checkDecl
ds
<*>
checkExpr
e
checkExpr
(
Do
sts
e
)
=
Do
<$>
mapM
checkStmt
sts
<*>
checkExpr
e
checkExpr
(
IfThenElse
r
e1
e2
e3
)
=
IfThenElse
r
<$>
checkExpr
e1
checkExpr
(
IfThenElse
r
e1
e2
e3
)
=
IfThenElse
r
<$>
checkExpr
e1
<*>
checkExpr
e2
<*>
checkExpr
e3
checkExpr
(
Case
r
ct
e
alts
)
=
Case
r
ct
<$>
checkExpr
e
checkExpr
(
Case
r
ct
e
alts
)
=
Case
r
ct
<$>
checkExpr
e
<*>
mapM
checkAlt
alts
checkStmt
::
Statement
->
KCM
Statement
...
...
src/Checks/SyntaxCheck.hs
View file @
2a65272a
...
...
@@ -488,7 +488,6 @@ checkDecls bindDecl ds = do
-- -- ---------------------------------------------------------------------------
checkDeclRhs
::
[
Ident
]
->
Decl
->
SCM
Decl
-- jrt: added for Haskell's record syntax
checkDeclRhs
_
(
DataDecl
p
tc
tvs
cs
)
=
DataDecl
p
tc
tvs
<$>
mapM
checkDeclLabels
cs
checkDeclRhs
bvs
(
TypeSig
p
vs
ty
)
=
...
...
@@ -499,7 +498,6 @@ checkDeclRhs _ (PatternDecl p t rhs) =
PatternDecl
p
t
<$>
checkRhs
rhs
checkDeclRhs
_
d
=
return
d
-- jrt: added for Haskell's record syntax
checkDeclLabels
::
ConstrDecl
->
SCM
ConstrDecl
checkDeclLabels
rd
@
(
RecordDecl
_
_
_
fs
)
=
do
onJust
(
report
.
errDuplicateLabel
"declaration"
)
...
...
src/Imports.hs
View file @
2a65272a
...
...
@@ -224,7 +224,7 @@ bindTy m (IDataDecl _ tc tvs cs hs) env =
bindTy
m
(
INewtypeDecl
_
tc
tvs
nc
hs
)
env
|
(
nconstrId
nc
)
`
notElem
`
hs
=
mBindLabel
nc
$
bindNewConstr
m
tc'
tvs
ty'
nc
env
|
otherwise
=
mBindLabel
nc
env
|
otherwise
=
mBindLabel
nc
env
where
tc'
=
qualQualify
m
tc
ty'
=
constrType
tc'
tvs
mBindLabel
(
NewConstrDecl
_
_
_
_
)
env'
=
env'
...
...
@@ -271,7 +271,7 @@ bindLabel m tc tvs ty (l, cs, lty) = Map.insert l $ Label ql qcs tysc
where
ql
=
qualifyLike
tc
l
qcs
=
map
(
qualifyLike
tc
)
cs
tysc
=
(
polyType
(
toQualType
m
tvs
(
ArrowType
ty
lty
)))
constrType
::
QualIdent
->
[
Ident
]
->
TypeExpr
constrType
tc
tvs
=
ConstructorType
tc
$
map
VariableType
tvs
...
...
@@ -432,20 +432,11 @@ visibleElems (RecordConstr c _ ls _) = c : ls
errUndefinedElement
::
Ident
->
Ident
->
Message
errUndefinedElement
tc
c
=
posMessage
c
$
hsep
$
map
text
[
idName
c
,
"is not a constructor or label of type "
,
idName
tc
]
errUndefinedEntity
::
ModuleIdent
->
Ident
->
Message
errUndefinedEntity
m
x
=
posMessage
x
$
hsep
$
map
text
[
"Module"
,
moduleName
m
,
"does not export"
,
idName
x
]
-- jrt 2015-01-26 no longer needed
-- errUndefinedDataConstr :: Ident -> Ident -> Message
-- errUndefinedDataConstr tc c = posMessage c $ hsep $ map text
-- [ idName c, "is not a data constructor of type", idName tc ]
--
-- errUndefinedLabel :: Ident -> Ident -> Message
-- errUndefinedLabel tc c = posMessage c $ hsep $ map text
-- [ idName c, "is not a label of record type", idName tc ]
errNonDataType
::
Ident
->
Message
errNonDataType
tc
=
posMessage
tc
$
hsep
$
map
text
[
idName
tc
,
"is not a data type"
]
...
...
@@ -517,128 +508,3 @@ importInterfaceIntf i@(Interface m _ _) env = env
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
mTCEnv
=
intfEnv
bindTCHidden
i
-- all type constructors
mTyEnv
=
intfEnv
bindTy
i
-- all values
-- ---------------------------------------------------------------------------
-- Record stuff
-- ---------------------------------------------------------------------------
-- jrt 2015-01-26: no longer needed for Haskell's record syntax
-- expandTCValueEnv :: Options -> CompilerEnv -> CompilerEnv
-- expandTCValueEnv opts env
-- | enabled = env' { tyConsEnv = tcEnv' }
-- | otherwise = env
-- where
-- enabled = Records `elem` (optExtensions opts ++ extensions env)
-- tcEnv' = fmap (expandRecordTC tcEnv) tcEnv
-- tcEnv = tyConsEnv env'
-- env' = expandValueEnv opts env
--
-- expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo
-- expandRecordTC tcEnv (DataType qid n args) =
-- DataType qid n $ map (fmap expandData) args
-- where
-- expandData (DataConstr c m tys) =
-- DataConstr c m $ map (expandRecords tcEnv) tys
-- expandRecordTC tcEnv (RenamingType qid n (DataConstr c m [ty])) =
-- RenamingType qid n (DataConstr c m [expandRecords tcEnv ty])
-- expandRecordTC _ (RenamingType _ _ (DataConstr _ _ _)) =
-- internalError "Imports.expandRecordTC"
-- expandRecordTC tcEnv (AliasType qid n ty) =
-- AliasType qid n (expandRecords tcEnv ty)
--
-- expandValueEnv :: Options -> CompilerEnv -> CompilerEnv
-- expandValueEnv opts env
-- | enabled = env { valueEnv = tyEnv' }
-- | otherwise = env
-- where
-- tcEnv = tyConsEnv env
-- tyEnv = valueEnv env
-- enabled = Records `elem` (optExtensions opts ++ extensions env)
-- tyEnv' = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
-- m = moduleIdent env
--
-- -- TODO: This is necessary as currently labels are unqualified.
-- -- Without this additional import the labels would no longer be known.
-- addImportedLabels :: ModuleIdent -> ValueEnv -> ValueEnv
-- addImportedLabels m tyEnv = foldr addLabelType tyEnv (allImports tyEnv)
-- where
-- addLabelType (_, lbl@(Label l r ty))
-- = importTopEnv mid l' lbl
-- -- the following is necessary to be available during generation
-- -- of flat curry.
-- . importTopEnv mid (recSelectorId r l') sel
-- . qualImportTopEnv mid (recSelectorId r l') sel
-- . importTopEnv mid (recUpdateId r l') upd
-- . qualImportTopEnv mid (recUpdateId r l') upd
-- where
-- l' = unqualify l
-- mid = fromMaybe m (qidModule r)
-- sel = Value (qualRecSelectorId m r l') 1 ty
-- upd = Value (qualRecUpdateId m r l') 2 ty
-- addLabelType _ = id
--
-- expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
-- expandRecordTypes tcEnv (DataConstructor qid a (ForAllExist n m ty)) =
-- DataConstructor qid a (ForAllExist n m (expandRecords tcEnv ty))
-- expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =
-- NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
-- expandRecordTypes tcEnv (Value qid a (ForAll n ty)) =
-- Value qid a (ForAll n (expandRecords tcEnv ty))
-- expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
-- Label qid r (ForAll n (expandRecords tcEnv ty))
--
-- expandRecords :: TCEnv -> Type -> Type
-- jrt 2014-10-16: Deactivated to enable declaration of recursive record types
-- expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of
-- [AliasType _ _ rty@(TypeRecord _ _)]
-- -> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty
-- _ -> TypeConstructor qid $ map (expandRecords tcEnv) tys
-- expandRecords tcEnv (TypeConstructor qid tys) =
-- TypeConstructor qid $ map (expandRecords tcEnv) tys
-- expandRecords tcEnv (TypeConstrained tys v) =
-- TypeConstrained (map (expandRecords tcEnv) tys) v
-- expandRecords tcEnv (TypeArrow ty1 ty2) =
-- TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)
-- expandRecords tcEnv (TypeRecord fs) =
-- TypeRecord (map (\ (l, ty) -> (l, expandRecords tcEnv ty)) fs)
-- expandRecords _ ty = ty
-- Unlike usual identifiers like in functions, types etc., identifiers
-- of labels are always represented unqualified within the whole context
-- of compilation. Since the common type environment (type \texttt{ValueEnv})
-- has some problems with handling imported unqualified identifiers, it is
-- necessary to add the type information for labels seperately. For this reason
-- the function \texttt{importLabels} generates an environment containing
-- all imported labels and the function \texttt{addImportedLabels} adds this
-- content to a value environment.
-- importLabels :: InterfaceEnv -> [ImportDecl] -> LabelEnv
-- importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
-- where
-- importLabelTypes :: LabelEnv -> ImportDecl -> LabelEnv
-- importLabelTypes lEnv (ImportDecl _ m _ asM is) = case Map.lookup m mEnv of
-- Just (Interface _ _ ds') ->
-- foldl (importLabelType (fromMaybe m asM) is) lEnv ds'
-- Nothing ->
-- internalError "Records.importLabels"
--
-- importLabelType m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
-- foldl (insertLabelType r' (getImportSpec r' is)) lEnv fs
-- where r' = qualifyWith m $ fromRecordExtId $ unqualify r
-- importLabelType _ _ lEnv _ = lEnv
--
-- insertLabelType r (Just (ImportTypeAll _)) lEnv ([l], ty) =
-- bindLabelType l r (toType [] ty) lEnv
-- insertLabelType r (Just (ImportTypeWith _ ls)) lEnv ([l], ty)
-- | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
-- | otherwise = lEnv
-- insertLabelType _ _ lEnv _ = lEnv
--
-- getImportSpec r (Just (Importing _ is')) = find (isImported (unqualify r)) is'
-- getImportSpec r Nothing = Just $ ImportTypeAll $ unqualify r
-- getImportSpec _ _ = Nothing
--
-- isImported r (Import r' ) = r == r'
-- isImported r (ImportTypeWith r' _) = r == r'
-- isImported r (ImportTypeAll r' ) = r == r'
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment