diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,12 @@
Change log for curry-frontend
=============================
+Version 1.0.4
+=============
+
+ * Fixed bug in type checking of instances
+ * Fixed bugs in deriving of `Bounded` instances.
+
Version 1.0.3
=============
@@ -308,4 +314,3 @@
* All compiler warnings removed.
* Fixed various implementation bugs (#9, #16, #19, #29, #289).
-
diff --git a/curry-frontend.cabal b/curry-frontend.cabal
--- a/curry-frontend.cabal
+++ b/curry-frontend.cabal
@@ -1,5 +1,5 @@
Name: curry-frontend
-Version: 1.0.3
+Version: 1.0.4
Cabal-Version: >= 1.10
Synopsis: Compile the functional logic language Curry to several
intermediate formats
@@ -43,13 +43,16 @@
Build-Depends:
base == 4.*
, containers
- , curry-base == 1.1.0
+ , curry-base == 1.1.1
, directory
+ , template-haskell >= 2.10 && < 3
+ , bytestring >= 0.10 && < 0.11
, extra >= 1.4.6
, filepath
, mtl
, pretty
, process
+ , file-embed
, set-extra
, transformers
if flag(network-uri)
@@ -130,9 +133,11 @@
, Transformations.Newtypes
, Transformations.Qual
, Transformations.Simplify
- Other-Modules:
+ other-modules:
Paths_curry_frontend
- ghc-options: -Wall -fno-warn-orphans
+ autogen-modules:
+ Paths_curry_frontend
+ ghc-options: -Wall
Executable curry-frontend
hs-source-dirs: src
@@ -141,26 +146,29 @@
Build-Depends:
base == 4.*
, containers
- , curry-base == 1.1.0
+ , curry-base == 1.1.1
, curry-frontend
, directory
+ , template-haskell >= 2.10 && < 3
+ , bytestring >= 0.10 && < 0.11
, extra >= 1.4.6
, filepath
, mtl
, pretty
, process
+ , file-embed
, set-extra
, transformers
if flag(network-uri)
build-depends: network-uri >= 2.6
else
build-depends: network < 2.6
- ghc-options: -Wall -fno-warn-orphans
+ ghc-options: -Wall
Test-Suite test-frontend
type: detailed-0.9
hs-source-dirs: test
default-language: Haskell2010
test-module: TestFrontend
- build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.1.0
+ build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.1.1
, curry-frontend, filepath
diff --git a/data/currysource.css b/data/currysource.css
--- a/data/currysource.css
+++ b/data/currysource.css
@@ -1,41 +1,51 @@
-/* Use always white background */
+/* Use always white background. */
body {
- background : white;
- color : black;
+ background: white;
+ color: black;
font-family: monospace;
+ text-size-adjust: none;
+ -moz-text-size-adjust: none;
+ -ms-text-size-adjust: none;
+ -webkit-text-size-adjust: none;
}
-/* Show hyperlinks without text decoration, but in light yellow */
-a:visited, a:link, a:active {
+table {
+ border-collapse: collapse;
+}
+
+/* Show hyperlinks without text decoration, but in light yellow. */
+a:link,
+a:visited,
+a:active {
+ background: lightyellow;
text-decoration: none;
- background : lightyellow;
}
/* Line numbers */
-.linenumbers {
- width : 40px;
- text-align : right;
- color : grey;
- padding-right: 10px;
- border-right : 1px solid grey;
+.line-numbers {
+ border-right: 1px solid grey;
+ color: grey;
+ min-width: 5ch;
+ padding-right: 1em;
+ text-align: right;
}
/* Source code */
-.sourcecode {
- padding-left: 10px;
+.source-code {
+ padding-left: 1em;
}
/* Code highlighting */
-.pragma { color : green }
-.comment { color : green }
-.keyword { color : blue }
-.symbol { color : red }
-.type { color : orange }
-.cons { color : magenta }
-.label { color : darkgreen }
-.func { color : purple }
-.ident { color : black }
-.module { color : brown }
-.number { color : teal }
-.string { color : maroon }
-.char { color : maroon }
+.pragma { color: green }
+.comment { color: green }
+.keyword { color: blue }
+.symbol { color: red }
+.type { color: orange }
+.cons { color: magenta }
+.label { color: darkgreen }
+.func { color: purple }
+.ident { color: black }
+.module { color: brown }
+.number { color: teal }
+.string { color: maroon }
+.char { color: maroon }
diff --git a/src/Base/CurryTypes.hs b/src/Base/CurryTypes.hs
--- a/src/Base/CurryTypes.hs
+++ b/src/Base/CurryTypes.hs
@@ -125,24 +125,14 @@
-- constructor. Hereby, it restricts the context to those type variables
-- which are free in the argument types.
-toConstrType :: QualIdent -> [Ident] -> CS.Context -> [CS.TypeExpr] -> PredType
-toConstrType tc tvs cx tys = toPredType tvs $
- CS.QualTypeExpr NoSpanInfo cx' ty'
- where tvs' = nub (fv tys)
- cx' = restrictContext tvs' cx
- ty' = foldr (CS.ArrowType NoSpanInfo) ty0 tys
+toConstrType :: QualIdent -> [Ident] -> [CS.TypeExpr] -> PredType
+toConstrType tc tvs tys = toPredType tvs $
+ CS.QualTypeExpr NoSpanInfo [] ty'
+ where ty' = foldr (CS.ArrowType NoSpanInfo) ty0 tys
ty0 = foldl (CS.ApplyType NoSpanInfo)
(CS.ConstructorType NoSpanInfo tc)
(map (CS.VariableType NoSpanInfo) tvs)
-restrictContext :: [Ident] -> CS.Context -> CS.Context
-restrictContext tvs cx =
- [CS.Constraint spi cls ty
- | CS.Constraint spi cls ty <- cx, classVar ty `elem` tvs]
- where classVar (CS.VariableType _ tv) = tv
- classVar (CS.ApplyType _ ty _) = classVar ty
- classVar _ = internalError "Base.CurryTypes.restrictContext.classVar"
-
-- The function 'toMethodType' returns the type of a type class method.
-- It adds the implicit type class constraint to the method's type signature
-- and ensures that the class' type variable is always assigned index 0.
@@ -173,9 +163,6 @@
foldl (CS.ApplyType NoSpanInfo)
(CS.ArrowType NoSpanInfo (fromType tvs ty1) (fromType tvs ty2)) tys
fromType' tvs (TypeConstrained tys _) tys' = fromType' tvs (head tys) tys'
-fromType' _ (TypeSkolem k) tys =
- foldl (CS.ApplyType NoSpanInfo)
- (CS.VariableType NoSpanInfo $ mkIdent $ "_?" ++ show k) tys
fromType' tvs (TypeForall tvs' ty) tys
| null tvs' = fromType' tvs ty tys
| otherwise = foldl (CS.ApplyType NoSpanInfo)
diff --git a/src/Base/PrettyKinds.hs b/src/Base/PrettyKinds.hs
--- a/src/Base/PrettyKinds.hs
+++ b/src/Base/PrettyKinds.hs
@@ -10,7 +10,7 @@
TODO
-}
-
+{-# OPTIONS_GHC -Wno-orphans #-}
module Base.PrettyKinds where
import Curry.Base.Pretty
diff --git a/src/Base/PrettyTypes.hs b/src/Base/PrettyTypes.hs
--- a/src/Base/PrettyTypes.hs
+++ b/src/Base/PrettyTypes.hs
@@ -10,7 +10,8 @@
TODO
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
module Base.PrettyTypes where
#if __GLASGOW_HASKELL__ >= 804
@@ -40,9 +41,9 @@
pPrint = ppQualTypeExpr . fromPredType identSupply
instance Pretty DataConstr where
- pPrint (DataConstr i _ _ tys) = pPrint i <+> hsep (map pPrint tys)
- pPrint (RecordConstr i _ _ ls tys) = pPrint i
- <+> braces (hsep (punctuate comma pLs))
+ pPrint (DataConstr i tys) = pPrint i <+> hsep (map pPrint tys)
+ pPrint (RecordConstr i ls tys) = pPrint i
+ <+> braces (hsep (punctuate comma pLs))
where
pLs = zipWith (\l ty -> pPrint l <+> colon <> colon <+> pPrint ty) ls tys
@@ -53,6 +54,3 @@
instance Pretty TypeScheme where
pPrint (ForAll _ ty) = pPrint ty
-
-instance Pretty ExistTypeScheme where
- pPrint (ForAllExist _ _ ty) = pPrint ty
diff --git a/src/Base/TypeExpansion.hs b/src/Base/TypeExpansion.hs
--- a/src/Base/TypeExpansion.hs
+++ b/src/Base/TypeExpansion.hs
@@ -57,7 +57,6 @@
expandType' _ _ tc@(TypeConstrained _ _) tys = applyType tc tys
expandType' m tcEnv (TypeArrow ty1 ty2) tys =
applyType (TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2)) tys
-expandType' _ _ ts@(TypeSkolem _) tys = applyType ts tys
expandType' m tcEnv (TypeForall tvs ty) tys =
applyType (TypeForall tvs (expandType m tcEnv ty)) tys
@@ -94,11 +93,11 @@
-- definition.
expandConstrType :: ModuleIdent -> TCEnv -> ClassEnv -> QualIdent -> [Ident]
- -> Context -> [TypeExpr] -> PredType
-expandConstrType m tcEnv clsEnv tc tvs cx tys =
+ -> [TypeExpr] -> PredType
+expandConstrType m tcEnv clsEnv tc tvs tys =
normalize n $ expandPredType m tcEnv clsEnv pty
where n = length tvs
- pty = toConstrType tc tvs cx tys
+ pty = toConstrType tc tvs tys
-- The function 'expandMethodType' converts the type of a type class method
-- Similar to function 'toMethodType' from 'CurryTypes', the implicit class
diff --git a/src/Base/TypeSubst.hs b/src/Base/TypeSubst.hs
--- a/src/Base/TypeSubst.hs
+++ b/src/Base/TypeSubst.hs
@@ -55,7 +55,6 @@
subst' sigma (TypeConstrained tys tv) = case substVar sigma tv of
TypeVariable tv' -> foldl TypeApply (TypeConstrained tys tv')
ty -> foldl TypeApply ty
-subst' _ ts@(TypeSkolem _) = foldl TypeApply ts
subst' sigma (TypeForall tvs ty) =
applyType (TypeForall tvs (subst sigma ty))
@@ -69,10 +68,6 @@
subst sigma (ForAll n ty) =
ForAll n (subst (foldr unbindSubst sigma [0 .. n-1]) ty)
-instance SubstType ExistTypeScheme where
- subst sigma (ForAllExist n n' ty) =
- ForAllExist n n' (subst (foldr unbindSubst sigma [0 .. n + n' - 1]) ty)
-
instance SubstType ValueInfo where
subst _ dc@(DataConstructor _ _ _ _) = dc
subst _ nc@(NewtypeConstructor _ _ _) = nc
@@ -107,7 +102,6 @@
expandAliasType' _ tc@(TypeConstrained _ _) = applyType tc
expandAliasType' tys (TypeArrow ty1 ty2) =
applyType (TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2))
-expandAliasType' _ ts@(TypeSkolem _) = applyType ts
expandAliasType' tys (TypeForall tvs ty) =
applyType (TypeForall tvs (expandAliasType tys ty))
diff --git a/src/Base/Types.hs b/src/Base/Types.hs
--- a/src/Base/Types.hs
+++ b/src/Base/Types.hs
@@ -34,7 +34,7 @@
-- * Representation of class methods
, ClassMethod (..), methodName, methodArity, methodType
-- * Representation of quantification
- , TypeScheme (..), ExistTypeScheme (..), monoType, polyType, typeScheme
+ , TypeScheme (..), monoType, polyType, typeScheme
, rawType
-- * Predefined types
, arrowType, unitType, predUnitType, boolType, predBoolType, charType
@@ -67,9 +67,6 @@
-- 'Float'. If the type is not restricted, it defaults to the first type
-- from the constraint list.
--- The case 'TypeSkolem' is used for handling skolem types, which
--- result from the use of existentially quantified data constructors.
-
-- Type variables are represented with deBruijn style indices. Universally
-- quantified type variables are assigned indices in the order of their
-- occurrence in the type from left to right. This leads to a canonical
@@ -88,7 +85,6 @@
= TypeConstructor QualIdent
| TypeVariable Int
| TypeConstrained [Type] Int
- | TypeSkolem Int
| TypeApply Type Type
| TypeArrow Type Type
| TypeForall [Int] Type
@@ -117,7 +113,6 @@
unapply (TypeConstrained tys tv) tys'
| dflt = unapply (head tys) tys'
| otherwise = (TypeConstrained tys tv, tys')
- unapply (TypeSkolem k) tys = (TypeSkolem k, tys)
unapply (TypeForall tvs ty') tys = (TypeForall tvs ty', tys)
-- The function 'rootOfType' returns the name of the type constructor at the
@@ -163,21 +158,17 @@
constrs (TypeVariable _) tcs = tcs
constrs (TypeConstrained _ _) tcs = tcs
constrs (TypeArrow ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs)
- constrs (TypeSkolem _) tcs = tcs
constrs (TypeForall _ ty') tcs = constrs ty' tcs
--- The methods 'typeVars' and 'typeSkolems' return a list of all type
--- variables and skolems occurring in a type t, respectively. Note that
--- 'TypeConstrained' variables are not included in the set of type
--- variables because they cannot be generalized.
+-- The method 'typeVars' returns a list of all type variables occurring in a
+-- type t. Note that 'TypeConstrained' variables are not included in the set of
+-- type variables because they cannot be generalized.
class IsType t where
typeVars :: t -> [Int]
- typeSkolems :: t -> [Int]
instance IsType Type where
typeVars = typeVars'
- typeSkolems = typeSkolems'
typeVars' :: Type -> [Int]
typeVars' ty = vars ty [] where
@@ -186,19 +177,8 @@
vars (TypeVariable tv) tvs = tv : tvs
vars (TypeConstrained _ _) tvs = tvs
vars (TypeArrow ty1 ty2) tvs = vars ty1 (vars ty2 tvs)
- vars (TypeSkolem _) tvs = tvs
vars (TypeForall tvs' ty') tvs = filter (`notElem` tvs') (typeVars' ty') ++ tvs
-typeSkolems' :: Type -> [Int]
-typeSkolems' ty = skolems ty [] where
- skolems (TypeConstructor _) sks = sks
- skolems (TypeApply ty1 ty2) sks = skolems ty1 (skolems ty2 sks)
- skolems (TypeVariable _) sks = sks
- skolems (TypeConstrained _ _) sks = sks
- skolems (TypeArrow ty1 ty2) sks = skolems ty1 (skolems ty2 sks)
- skolems (TypeSkolem k) sks = k : sks
- skolems (TypeForall _ ty') sks = skolems ty' sks
-
-- The functions 'qualifyType' and 'unqualifyType' add/remove the
-- qualification with a module identifier for type constructors.
@@ -211,7 +191,6 @@
TypeConstrained (map (qualifyType m) tys) tv
qualifyType m (TypeArrow ty1 ty2) =
TypeArrow (qualifyType m ty1) (qualifyType m ty2)
-qualifyType _ ts@(TypeSkolem _) = ts
qualifyType m (TypeForall tvs ty) = TypeForall tvs (qualifyType m ty)
unqualifyType :: ModuleIdent -> Type -> Type
@@ -223,7 +202,6 @@
TypeConstrained (map (unqualifyType m) tys) tv
unqualifyType m (TypeArrow ty1 ty2) =
TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)
-unqualifyType _ ts@(TypeSkolem _) = ts
unqualifyType m (TypeForall tvs ty) = TypeForall tvs (unqualifyType m ty)
qualifyTC :: ModuleIdent -> QualIdent -> QualIdent
@@ -249,7 +227,6 @@
instance IsType Pred where
typeVars (Pred _ ty) = typeVars ty
- typeSkolems (Pred _ ty) = typeSkolems ty
qualifyPred :: ModuleIdent -> Pred -> Pred
qualifyPred m (Pred qcls ty) = Pred (qualQualify m qcls) (qualifyType m ty)
@@ -273,7 +250,6 @@
instance (IsType a, Ord a) => IsType (Set.Set a) where
typeVars = concat . Set.toList . Set.map typeVars
- typeSkolems = concat . Set.toList . Set.map typeSkolems
emptyPredSet :: PredSet
emptyPredSet = Set.empty
@@ -321,7 +297,6 @@
instance IsType PredType where
typeVars (PredType ps ty) = typeVars ty ++ typeVars ps
- typeSkolems (PredType ps ty) = typeSkolems ty ++ typeSkolems ps
predType :: Type -> PredType
predType = PredType emptyPredSet
@@ -342,31 +317,30 @@
-- ---------------------------------------------------------------------------
-- The type 'DataConstr' is used to represent value or record constructors
--- introduced by data or newtype declarations. The 'Int' denotes the number
--- of existentially quantified type variables in the types.
+-- introduced by data or newtype declarations.
-data DataConstr = DataConstr Ident Int PredSet [Type]
- | RecordConstr Ident Int PredSet [Ident] [Type]
+data DataConstr = DataConstr Ident [Type]
+ | RecordConstr Ident [Ident] [Type]
deriving (Eq, Show)
constrIdent :: DataConstr -> Ident
-constrIdent (DataConstr c _ _ _) = c
-constrIdent (RecordConstr c _ _ _ _) = c
+constrIdent (DataConstr c _) = c
+constrIdent (RecordConstr c _ _) = c
constrTypes :: DataConstr -> [Type]
-constrTypes (DataConstr _ _ _ tys) = tys
-constrTypes (RecordConstr _ _ _ _ tys) = tys
+constrTypes (DataConstr _ tys) = tys
+constrTypes (RecordConstr _ _ tys) = tys
recLabels :: DataConstr -> [Ident]
-recLabels (DataConstr _ _ _ _) = []
-recLabels (RecordConstr _ _ _ ls _) = ls
+recLabels (DataConstr _ _) = []
+recLabels (RecordConstr _ ls _) = ls
recLabelTypes :: DataConstr -> [Type]
-recLabelTypes (DataConstr _ _ _ _) = []
-recLabelTypes (RecordConstr _ _ _ _ tys) = tys
+recLabelTypes (DataConstr _ _) = []
+recLabelTypes (RecordConstr _ _ tys) = tys
tupleData :: [DataConstr]
-tupleData = [DataConstr (tupleId n) 0 emptyPredSet (take n tvs) | n <- [2 ..]]
+tupleData = [DataConstr (tupleId n) (take n tvs) | n <- [2 ..]]
where tvs = map TypeVariable [0 ..]
-- ---------------------------------------------------------------------------
@@ -393,28 +367,16 @@
-- Quantification
-- ---------------------------------------------------------------------------
--- We support two kinds of quantifications of types here, universally
--- quantified type schemes (forall alpha . tau(alpha)) and universally
--- and existentially quantified type schemes
--- (forall alpha exists eta . tau(alpha,eta)). In both, quantified type
--- variables are assigned ascending indices starting from 0. Therefore it
--- is sufficient to record the numbers of quantified type variables in
--- the 'ForAll' and 'ForAllExist' constructors. In case of
--- the latter, the first of the two numbers is the number of universally
--- quantified variables and the second the number of existentially
--- quantified variables.
+-- We support only universally quantified type schemes
+-- (forall alpha . tau(alpha)). Quantified type variables are assigned
+-- ascending indices starting from 0. Therefore it is sufficient to record the
+-- numbers of quantified type variables in the 'ForAll' constructor.
data TypeScheme = ForAll Int PredType deriving (Eq, Show)
-data ExistTypeScheme = ForAllExist Int Int PredType deriving (Eq, Show)
instance IsType TypeScheme where
typeVars (ForAll _ pty) = [tv | tv <- typeVars pty, tv < 0]
- typeSkolems (ForAll _ pty) = typeSkolems pty
-instance IsType ExistTypeScheme where
- typeVars (ForAllExist _ _ pty) = [tv | tv <- typeVars pty, tv < 0]
- typeSkolems (ForAllExist _ _ pty) = typeSkolems pty
-
-- The functions 'monoType' and 'polyType' translate a type tau into a
-- monomorphic type scheme and a polymorphic type scheme, respectively.
-- 'polyType' assumes that all universally quantified variables in the type are
@@ -502,9 +464,9 @@
predefTypes :: [(Type, [DataConstr])]
predefTypes =
[ (arrowType a b, [])
- , (unitType , [ DataConstr unitId 0 emptyPredSet [] ])
- , (listType a , [ DataConstr nilId 0 emptyPredSet []
- , DataConstr consId 0 emptyPredSet [a, listType a]
+ , (unitType , [ DataConstr unitId [] ])
+ , (listType a , [ DataConstr nilId []
+ , DataConstr consId [a, listType a]
])
]
where a = TypeVariable 0
diff --git a/src/Base/Typing.hs b/src/Base/Typing.hs
--- a/src/Base/Typing.hs
+++ b/src/Base/Typing.hs
@@ -127,8 +127,6 @@
| tc1 == tc2 = Just id
matchType' (TypeConstrained _ tv1) (TypeConstrained _ tv2)
| tv1 == tv2 = Just id
-matchType' (TypeSkolem k1) (TypeSkolem k2)
- | k1 == k2 = Just id
matchType' (TypeApply ty11 ty12) (TypeApply ty21 ty22) =
fmap (. matchType ty12 ty22) (matchType' ty11 ty21)
matchType' (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =
diff --git a/src/Checks/DeriveCheck.hs b/src/Checks/DeriveCheck.hs
--- a/src/Checks/DeriveCheck.hs
+++ b/src/Checks/DeriveCheck.hs
@@ -33,7 +33,6 @@
checkDecl m tcEnv (DataDecl _ tc _ cs clss)
| null clss = []
| null cs = [errNoAbstractDerive tc]
- | any (not . null . existVars) cs = [errNoExistentialDerive tc]
| otherwise = concatMap (checkDerivable m tcEnv cs) clss
checkDecl m tcEnv (NewtypeDecl _ _ _ nc clss) =
concatMap (checkDerivable m tcEnv [toConstrDecl nc]) clss
@@ -67,19 +66,14 @@
-- ---------------------------------------------------------------------------
toConstrDecl :: NewConstrDecl -> ConstrDecl
-toConstrDecl (NewConstrDecl p c ty) = ConstrDecl p [] [] c [ty]
+toConstrDecl (NewConstrDecl p c ty) = ConstrDecl p c [ty]
toConstrDecl (NewRecordDecl p c (l, ty)) =
- RecordDecl p [] [] c [FieldDecl p [l] ty]
+ RecordDecl p c [FieldDecl p [l] ty]
constrArity :: ConstrDecl -> Int
-constrArity (ConstrDecl _ _ _ _ tys) = length tys
-constrArity (ConOpDecl _ _ _ _ _ _) = 2
-constrArity c@(RecordDecl _ _ _ _ _) = length $ recordLabels c
-
-existVars :: ConstrDecl -> [Ident]
-existVars (ConstrDecl _ evs _ _ _ ) = evs
-existVars (ConOpDecl _ evs _ _ _ _) = evs
-existVars (RecordDecl _ evs _ _ _ ) = evs
+constrArity (ConstrDecl _ _ tys) = length tys
+constrArity (ConOpDecl _ _ _ _) = 2
+constrArity c@(RecordDecl _ _ _) = length $ recordLabels c
-- ---------------------------------------------------------------------------
-- Error messages
@@ -89,10 +83,6 @@
errNoAbstractDerive p = posMessage p $
text "Instances can only be derived for data types with" <+>
text "at least one constructor"
-
-errNoExistentialDerive :: HasPosition a => a -> Message
-errNoExistentialDerive p = posMessage p $
- text "Instances cannot be derived for existential data types"
errNotDerivable :: QualIdent -> Message
errNotDerivable cls = posMessage cls $ hsep $ map text
diff --git a/src/Checks/ExportCheck.hs b/src/Checks/ExportCheck.hs
--- a/src/Checks/ExportCheck.hs
+++ b/src/Checks/ExportCheck.hs
@@ -53,7 +53,7 @@
import Base.Types ( Type (..), unapplyType, arrowBase, PredType (..)
, DataConstr (..), constrIdent, recLabels
, ClassMethod, methodName
- , TypeScheme (..), ExistTypeScheme (..) )
+ , TypeScheme (..) )
import Base.Utils (findMultiples)
import Env.ModuleAlias (AliasEnv)
@@ -166,8 +166,8 @@
where
justTcOr errFun = maybe (report $ errFun f) (const ok) tcExport
- getTc (DataConstructor _ _ _ (ForAllExist _ _ (PredType _ ty))) = getTc' ty
- getTc (NewtypeConstructor _ _ (ForAllExist _ _ (PredType _ ty))) = getTc' ty
+ getTc (DataConstructor _ _ _ (ForAll _ (PredType _ ty))) = getTc' ty
+ getTc (NewtypeConstructor _ _ (ForAll _ (PredType _ ty))) = getTc' ty
getTc (Label _ _ (ForAll _ (PredType _ (TypeArrow tc' _)))) =
let (TypeConstructor tc, _) = unapplyType False tc' in tc
getTc err = internalError $ currentModuleName ++ ".checkThing'.getTc: " ++ show err
diff --git a/src/Checks/InstanceCheck.hs b/src/Checks/InstanceCheck.hs
--- a/src/Checks/InstanceCheck.hs
+++ b/src/Checks/InstanceCheck.hs
@@ -140,24 +140,24 @@
declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo
declDeriveInfo tcEnv clsEnv (DataDecl p tc tvs cs clss) =
- mkDeriveInfo tcEnv clsEnv p tc tvs (concat cxs) (concat tyss) clss
- where (cxs, tyss) = unzip (map constrDeclTypes cs)
- constrDeclTypes (ConstrDecl _ _ cx _ tys) = (cx, tys)
- constrDeclTypes (ConOpDecl _ _ cx ty1 _ ty2) = (cx, [ty1, ty2])
- constrDeclTypes (RecordDecl _ _ cx _ fs) = (cx, tys)
+ mkDeriveInfo tcEnv clsEnv p tc tvs (concat tyss) clss
+ where tyss = map constrDeclTypes cs
+ constrDeclTypes (ConstrDecl _ _ tys) = tys
+ constrDeclTypes (ConOpDecl _ ty1 _ ty2) = [ty1, ty2]
+ constrDeclTypes (RecordDecl _ _ fs) = tys
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
declDeriveInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc clss) =
- mkDeriveInfo tcEnv clsEnv p tc tvs [] [nconstrType nc] clss
+ mkDeriveInfo tcEnv clsEnv p tc tvs [nconstrType nc] clss
declDeriveInfo _ _ _ =
internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration"
-mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> Context
- -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo
-mkDeriveInfo tcEnv clsEnv spi tc tvs cx tys clss = do
+mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> [TypeExpr]
+ -> [QualIdent] -> INCM DeriveInfo
+mkDeriveInfo tcEnv clsEnv spi tc tvs tys clss = do
m <- getModuleIdent
let otc = qualifyWith m tc
oclss = map (flip (getOrigName m) tcEnv) clss
- PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs cx tys
+ PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs tys
(tys', ty') = arrowUnapply ty
return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss
where p = spanInfo2Pos spi
@@ -196,7 +196,7 @@
, (fromEnumId, 1), (enumFromId, 1)
, (enumFromThenId, 2)
]
- | cls == qBoundedId = [(maxBoundId, 1), (minBoundId, 1)]
+ | cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)]
| cls == qReadId = [(readsPrecId, 2)]
| cls == qShowId = [(showsPrecId, 2)]
| otherwise =
diff --git a/src/Checks/InterfaceCheck.hs b/src/Checks/InterfaceCheck.hs
--- a/src/Checks/InterfaceCheck.hs
+++ b/src/Checks/InterfaceCheck.hs
@@ -184,29 +184,29 @@
check ps' is' = ps == ps' && sort is == sort is'
checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()
-checkConstrImport tc tvs (ConstrDecl p evs cx c tys) = do
+checkConstrImport tc tvs (ConstrDecl p c tys) = do
m <- getModuleIdent
let qc = qualifyLike tc c
- check (DataConstructor c' _ _ (ForAllExist uqvs eqvs pty)) =
- qc == c' && length evs == eqvs && length tvs == uqvs &&
- qualifyPredType m (toConstrType tc tvs cx tys) == pty
+ check (DataConstructor c' _ _ (ForAll uqvs pty)) =
+ qc == c' && length tvs == uqvs &&
+ qualifyPredType m (toConstrType tc tvs tys) == pty
check _ = False
checkValueInfo "data constructor" check p qc
-checkConstrImport tc tvs (ConOpDecl p evs cx ty1 op ty2) = do
+checkConstrImport tc tvs (ConOpDecl p ty1 op ty2) = do
m <- getModuleIdent
let qc = qualifyLike tc op
- check (DataConstructor c' _ _ (ForAllExist uqvs eqvs pty)) =
- qc == c' && length evs == eqvs && length tvs == uqvs &&
- qualifyPredType m (toConstrType tc tvs cx [ty1, ty2]) == pty
+ check (DataConstructor c' _ _ (ForAll uqvs pty)) =
+ qc == c' && length tvs == uqvs &&
+ qualifyPredType m (toConstrType tc tvs [ty1, ty2]) == pty
check _ = False
checkValueInfo "data constructor" check p qc
-checkConstrImport tc tvs (RecordDecl p evs cx c fs) = do
+checkConstrImport tc tvs (RecordDecl p c fs) = do
m <- getModuleIdent
let qc = qualifyLike tc c
(ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels]
- check (DataConstructor c' _ ls' (ForAllExist uqvs eqvs pty)) =
- qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' &&
- qualifyPredType m (toConstrType tc tvs cx tys) == pty
+ check (DataConstructor c' _ ls' (ForAll uqvs pty)) =
+ qc == c' && length tvs == uqvs && ls == ls' &&
+ qualifyPredType m (toConstrType tc tvs tys) == pty
check _ = False
checkValueInfo "data constructor" check p qc
@@ -214,14 +214,14 @@
checkNewConstrImport tc tvs (NewConstrDecl p c ty) = do
m <- getModuleIdent
let qc = qualifyLike tc c
- check (NewtypeConstructor c' _ (ForAllExist uqvs _ (PredType _ ty'))) =
+ check (NewtypeConstructor c' _ (ForAll uqvs (PredType _ ty'))) =
qc == c' && length tvs == uqvs &&toQualType m tvs ty == head (arrowArgs ty')
check _ = False
checkValueInfo "newtype constructor" check p qc
checkNewConstrImport tc tvs (NewRecordDecl p c (l, ty)) = do
m <- getModuleIdent
let qc = qualifyLike tc c
- check (NewtypeConstructor c' l' (ForAllExist uqvs _ (PredType _ ty'))) =
+ check (NewtypeConstructor c' l' (ForAll uqvs (PredType _ ty'))) =
qc == c' && length tvs == uqvs && l == l' &&
toQualType m tvs ty == head (arrowArgs ty')
check _ = False
diff --git a/src/Checks/InterfaceSyntaxCheck.hs b/src/Checks/InterfaceSyntaxCheck.hs
--- a/src/Checks/InterfaceSyntaxCheck.hs
+++ b/src/Checks/InterfaceSyntaxCheck.hs
@@ -139,9 +139,6 @@
checkTypeLhs :: [Ident] -> ISC ()
checkTypeLhs = checkTypeVars "left hand side of type declaration"
-checkExistVars :: [Ident] -> ISC ()
-checkExistVars = checkTypeVars "list of existentially quantified type variables"
-
checkTypeVars :: String -> [Ident] -> ISC ()
checkTypeVars what tvs = do
tyEnv <- getTypeEnv
@@ -151,23 +148,14 @@
mapM_ (report . flip errNonLinear what . head) (findMultiples tvs')
checkConstrDecl :: [Ident] -> ConstrDecl -> ISC ConstrDecl
-checkConstrDecl tvs (ConstrDecl p evs cx c tys) = do
- checkExistVars evs
- cx' <- checkClosedContext tvs' cx
- liftM (ConstrDecl p evs cx' c) (mapM (checkClosedType tvs') tys)
- where tvs' = evs ++ tvs
-checkConstrDecl tvs (ConOpDecl p evs cx ty1 op ty2) = do
- checkExistVars evs
- cx' <- checkClosedContext tvs' cx
- liftM2 (\t1 t2 -> ConOpDecl p evs cx' t1 op t2)
- (checkClosedType tvs' ty1)
- (checkClosedType tvs' ty2)
- where tvs' = evs ++ tvs
-checkConstrDecl tvs (RecordDecl p evs cx c fs) = do
- checkExistVars evs
- cx' <- checkClosedContext tvs' cx
- liftM (RecordDecl p evs cx' c) (mapM (checkFieldDecl tvs') fs)
- where tvs' = evs ++ tvs
+checkConstrDecl tvs (ConstrDecl p c tys) = do
+ liftM (ConstrDecl p c) (mapM (checkClosedType tvs) tys)
+checkConstrDecl tvs (ConOpDecl p ty1 op ty2) = do
+ liftM2 (\t1 t2 -> ConOpDecl p t1 op t2)
+ (checkClosedType tvs ty1)
+ (checkClosedType tvs ty2)
+checkConstrDecl tvs (RecordDecl p c fs) = do
+ liftM (RecordDecl p c) (mapM (checkFieldDecl tvs) fs)
checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl
checkFieldDecl tvs (FieldDecl p ls ty) =
diff --git a/src/Checks/KindCheck.hs b/src/Checks/KindCheck.hs
--- a/src/Checks/KindCheck.hs
+++ b/src/Checks/KindCheck.hs
@@ -155,9 +155,9 @@
fts m cx . fts m cls . fts m inst . fts m ds
instance HasType ConstrDecl where
- fts m (ConstrDecl _ _ cx _ tys) = fts m cx . fts m tys
- fts m (ConOpDecl _ _ cx ty1 _ ty2) = fts m cx . fts m ty1 . fts m ty2
- fts m (RecordDecl _ _ cx _ fs) = fts m cx . fts m fs
+ fts m (ConstrDecl _ _ tys) = fts m tys
+ fts m (ConOpDecl _ ty1 _ ty2) = fts m ty1 . fts m ty2
+ fts m (RecordDecl _ _ fs) = fts m fs
instance HasType FieldDecl where
fts m (FieldDecl _ _ ty) = fts m ty
@@ -314,30 +314,28 @@
bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs _) =
bindTypeConstructor DataType tc tvs (Just KindStar) (map mkData cs) tcEnv
where
- mkData (ConstrDecl _ evs cx c tys) = mkData' evs cx c tys
- mkData (ConOpDecl _ evs cx ty1 op ty2) = mkData' evs cx op [ty1, ty2]
- mkData (RecordDecl _ evs cx c fs) =
+ mkData (ConstrDecl _ c tys) = mkData' c tys
+ mkData (ConOpDecl _ ty1 op ty2) = mkData' op [ty1, ty2]
+ mkData (RecordDecl _ c fs) =
let (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
- in mkRec evs cx c labels tys
- mkData' evs cx c tys = DataConstr c (length evs) ps tys'
+ in mkRec c labels tys
+ mkData' c tys = DataConstr c tys'
where qtc = qualifyWith m tc
- tvs' = tvs ++ evs
- PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys
+ PredType _ ty = expandConstrType m tcEnv' clsEnv qtc tvs tys
tys' = arrowArgs ty
- mkRec evs cx c ls tys =
- RecordConstr c (length evs) ps ls tys'
+ mkRec c ls tys =
+ RecordConstr c ls tys'
where qtc = qualifyWith m tc
- tvs' = tvs ++ evs
- PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys
+ PredType _ ty = expandConstrType m tcEnv' clsEnv qtc tvs tys
tys' = arrowArgs ty
bindKind _ _ _ tcEnv (ExternalDataDecl _ tc tvs) =
bindTypeConstructor DataType tc tvs (Just KindStar) [] tcEnv
bindKind m tcEnv' _ tcEnv (NewtypeDecl _ tc tvs nc _) =
bindTypeConstructor RenamingType tc tvs (Just KindStar) (mkData nc) tcEnv
where
- mkData (NewConstrDecl _ c ty) = DataConstr c 0 emptyPredSet [ty']
+ mkData (NewConstrDecl _ c ty) = DataConstr c [ty']
where ty' = expandMonoType m tcEnv' tvs ty
- mkData (NewRecordDecl _ c (l, ty)) = RecordConstr c 0 emptyPredSet [l] [ty']
+ mkData (NewRecordDecl _ c (l, ty)) = RecordConstr c [l] [ty']
where ty' = expandMonoType m tcEnv' tvs ty
bindKind m tcEnv' _ tcEnv (TypeDecl _ tc tvs ty) =
bindTypeConstructor aliasType tc tvs Nothing ty' tcEnv
@@ -471,25 +469,19 @@
doc = ppDecl (InstanceDecl p cx qcls inst [])
kcConstrDecl :: TCEnv -> ConstrDecl -> KCM ()
-kcConstrDecl tcEnv d@(ConstrDecl p evs cx _ tys) = do
- tcEnv' <- foldM bindFreshKind tcEnv evs
- kcContext tcEnv' p cx
- mapM_ (kcValueType tcEnv' p what doc) tys
+kcConstrDecl tcEnv d@(ConstrDecl p _ tys) = do
+ mapM_ (kcValueType tcEnv p what doc) tys
where
what = "data constructor declaration"
doc = ppConstr d
-kcConstrDecl tcEnv d@(ConOpDecl p evs cx ty1 _ ty2) = do
- tcEnv' <- foldM bindFreshKind tcEnv evs
- kcContext tcEnv' p cx
- kcValueType tcEnv' p what doc ty1
- kcValueType tcEnv' p what doc ty2
+kcConstrDecl tcEnv d@(ConOpDecl p ty1 _ ty2) = do
+ kcValueType tcEnv p what doc ty1
+ kcValueType tcEnv p what doc ty2
where
what = "data constructor declaration"
doc = ppConstr d
-kcConstrDecl tcEnv (RecordDecl p evs cx _ fs) = do
- tcEnv' <- foldM bindFreshKind tcEnv evs
- kcContext tcEnv' p cx
- mapM_ (kcFieldDecl tcEnv') fs
+kcConstrDecl tcEnv (RecordDecl _ _ fs) = do
+ mapM_ (kcFieldDecl tcEnv) fs
kcFieldDecl :: TCEnv -> FieldDecl -> KCM ()
kcFieldDecl tcEnv d@(FieldDecl p _ ty) =
diff --git a/src/Checks/SyntaxCheck.hs b/src/Checks/SyntaxCheck.hs
--- a/src/Checks/SyntaxCheck.hs
+++ b/src/Checks/SyntaxCheck.hs
@@ -333,13 +333,13 @@
bindTypeDecl _ = ok
bindConstr :: ConstrDecl -> SCM ()
-bindConstr (ConstrDecl _ _ _ c tys) = do
+bindConstr (ConstrDecl _ c tys) = do
m <- getModuleIdent
modifyRenameEnv $ bindGlobal False m c (Constr (qualifyWith m c) $ length tys)
-bindConstr (ConOpDecl _ _ _ _ op _) = do
+bindConstr (ConOpDecl _ _ op _) = do
m <- getModuleIdent
modifyRenameEnv $ bindGlobal False m op (Constr (qualifyWith m op) 2)
-bindConstr (RecordDecl _ _ _ c fs) = do
+bindConstr (RecordDecl _ c fs) = do
m <- getModuleIdent
modifyRenameEnv $ bindGlobal False m c (Constr (qualifyWith m c) (length labels))
where labels = [l | FieldDecl _ ls _ <- fs, l <- ls]
@@ -678,7 +678,7 @@
checkDeclRhs _ d = return d
checkDeclLabels :: ConstrDecl -> SCM ConstrDecl
-checkDeclLabels rd@(RecordDecl _ _ _ _ fs) = do
+checkDeclLabels rd@(RecordDecl _ _ fs) = do
onJust (report . errDuplicateLabel "declaration")
(findDouble $ map qualify labels)
return rd
diff --git a/src/Checks/TypeCheck.hs b/src/Checks/TypeCheck.hs
--- a/src/Checks/TypeCheck.hs
+++ b/src/Checks/TypeCheck.hs
@@ -256,24 +256,24 @@
bindData _ vEnv' = vEnv'
bindConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
-bindConstr m n ty (DataConstr c n' ps tys) =
+bindConstr m n ty (DataConstr c tys) =
bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m c
- (ForAllExist n n' (PredType ps (foldr TypeArrow ty tys)))
+ (ForAll n (PredType emptyPredSet (foldr TypeArrow ty tys)))
where arity = length tys
ls = replicate arity anonId
-bindConstr m n ty (RecordConstr c n' ps ls tys) =
+bindConstr m n ty (RecordConstr c ls tys) =
bindGlobalInfo (\qc tyScheme -> DataConstructor qc arity ls tyScheme) m c
- (ForAllExist n n' (PredType ps (foldr TypeArrow ty tys)))
+ (ForAll n (PredType emptyPredSet (foldr TypeArrow ty tys)))
where arity = length tys
bindNewConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv
-> ValueEnv
-bindNewConstr m n cty (DataConstr c n' _ [lty]) =
+bindNewConstr m n cty (DataConstr c [lty]) =
bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc anonId tyScheme) m c
- (ForAllExist n n' (predType (TypeArrow lty cty)))
-bindNewConstr m n cty (RecordConstr c n' _ [l] [lty]) =
+ (ForAll n (predType (TypeArrow lty cty)))
+bindNewConstr m n cty (RecordConstr c [l] [lty]) =
bindGlobalInfo (\qc tyScheme -> NewtypeConstructor qc l tyScheme) m c
- (ForAllExist n n' (predType (TypeArrow lty cty)))
+ (ForAll n (predType (TypeArrow lty cty)))
bindNewConstr _ _ _ _ = internalError
"TypeCheck.bindConstrs'.bindNewConstr: newtype with illegal constructors"
@@ -293,7 +293,7 @@
checkFieldLabel (DataDecl _ _ tvs cs _) = do
ls' <- mapM (tcFieldLabel tvs) labels
mapM_ tcFieldLabels (groupLabels ls')
- where labels = [(l, p, ty) | RecordDecl _ _ _ _ fs <- cs,
+ where labels = [(l, p, ty) | RecordDecl _ _ fs <- cs,
FieldDecl p ls ty <- fs, l <- ls]
checkFieldLabel (NewtypeDecl _ _ tvs (NewRecordDecl p _ (l, ty)) _) = do
_ <- tcFieldLabel tvs (l, p, ty)
@@ -342,12 +342,12 @@
constr l = map (qualifyLike tc) $
[constrIdent c | c <- cs, l `elem` recLabels c]
sameLabel (l1,_,_) (l2,_,_) = l1 == l2
- bindData (RenamingType tc k (RecordConstr c _ _ [l] [lty])) vEnv' =
+ bindData (RenamingType tc k (RecordConstr c [l] [lty])) vEnv' =
bindLabel m n (constrType' tc n) (l, [qc], lty) vEnv'
where
n = kindArity k
qc = qualifyLike tc c
- bindData (RenamingType _ _ (RecordConstr _ _ _ _ _)) _ =
+ bindData (RenamingType _ _ (RecordConstr _ _ _)) _ =
internalError $ "Checks.TypeCheck.bindLabels'.bindData: " ++
"RenamingType with more than one record label"
bindData _ vEnv' = vEnv'
@@ -535,18 +535,17 @@
-> [Equation a] -> TCM (PredSet, (Type, PDecl PredType))
tcFunctionPDecl i ps tySc@(ForAll _ pty) p f eqs = do
(_, ty) <- inst tySc
- fs <- computeFsEnv
- (ps', eqs') <- mapAccumM (tcEquation fs ty) ps eqs
+ (ps', eqs') <- mapAccumM (tcEquation ty) ps eqs
return (ps', (ty, (i, FunctionDecl p pty f eqs')))
-tcEquation :: Set.Set Int -> Type -> PredSet -> Equation a
+tcEquation :: Type -> PredSet -> Equation a
-> TCM (PredSet, Equation PredType)
-tcEquation fs ty ps eqn@(Equation p lhs rhs) =
- tcEqn fs p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty
+tcEquation ty ps eqn@(Equation p lhs rhs) =
+ tcEqn p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty
-tcEqn :: Set.Set Int -> SpanInfo -> Lhs a -> Rhs a
+tcEqn :: SpanInfo -> Lhs a -> Rhs a
-> TCM (PredSet, Type, Equation PredType)
-tcEqn fs p lhs rhs = do
+tcEqn p lhs rhs = do
(ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do
bindLambdaVars lhs
(ps, tys, lhs') <- tcLhs p lhs
@@ -554,8 +553,7 @@
return (ps, tys, lhs', ps', ty, rhs')
ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs'))
(ps `Set.union` ps')
- checkSkolems p "Equation" ppEquation fs ps'' (foldr TypeArrow ty tys)
- (Equation p lhs' rhs')
+ return (ps'', foldr TypeArrow ty tys, Equation p lhs' rhs')
bindLambdaVars :: QuantExpr t => t -> TCM ()
bindLambdaVars t = do
@@ -676,12 +674,13 @@
where
-- @is@ is an AssocList of type variable indices
eq is (TypeConstructor qid1) (TypeConstructor qid2) = (qid1 == qid2, is)
- eq is (TypeVariable i1) (TypeVariable i2) = eqVar is i1 i2
+ eq is (TypeVariable i1) (TypeVariable i2)
+ | i1 < 0 = (False, is)
+ | otherwise = eqVar is i1 i2
eq is (TypeConstrained ts1 i1) (TypeConstrained ts2 i2)
= let (res1, is1) = eqs is ts1 ts2
(res2, is2) = eqVar is1 i1 i2
in (res1 && res2, is2)
- eq is (TypeSkolem i1) (TypeSkolem i2) = eqVar is i1 i2
eq is (TypeApply ta1 tb1) (TypeApply ta2 tb2)
= let (res1, is1) = eq is ta1 ta2
(res2, is2) = eq is1 tb1 tb2
@@ -869,7 +868,11 @@
tcTopPDecl (i, InstanceDecl p cx qcls ty ds) = do
tcEnv <- getTyConsEnv
pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty
- vpds' <- mapM (tcInstanceMethodPDecl qcls pty) vpds
+ mid <- getModuleIdent
+ let origCls = getOrigName mid qcls tcEnv
+ clsQual = head $ filter isQualified $ reverseLookupByOrigName origCls tcEnv
+ qQualCls = qualQualify (fromJust $ qidModule clsQual) qcls
+ vpds' <- mapM (tcInstanceMethodPDecl qQualCls pty) vpds
return (i, InstanceDecl p cx qcls ty $ fromPDecls $ map untyped opds ++ vpds')
where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds
tcTopPDecl _ = internalError "Checks.TypeCheck.tcTopDecl"
@@ -1100,7 +1103,7 @@
tcExpr _ (Constructor spi _ c) = do
m <- getModuleIdent
vEnv <- getValueEnv
- (ps, ty) <- instExist (constrType m c vEnv)
+ (ps, ty) <- inst (constrType m c vEnv)
return (ps, ty, Constructor spi (predType ty) c)
tcExpr p (Paren spi e) = do
(ps, ty, e') <- tcExpr p e
@@ -1122,7 +1125,7 @@
tcExpr _ e@(Record spi _ c fs) = do
m <- getModuleIdent
vEnv <- getValueEnv
- (ps, ty) <- liftM (fmap arrowBase) (instExist (constrType m c vEnv))
+ (ps, ty) <- liftM (fmap arrowBase) (inst (constrType m c vEnv))
(ps', fs') <- mapAccumM (tcField tcExpr "construction"
(\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs
return (ps', ty, Record spi (predType ty) c fs')
@@ -1140,14 +1143,12 @@
mapAccumM (flip (tcArg p "expression" (ppExpr 0 e)) ty) emptyPredSet es
return (ps, listType ty, List spi (predType $ listType ty) es')
tcExpr p (ListCompr spi e qs) = do
- fs <- computeFsEnv
(ps, qs', ps', ty, e') <- withLocalValueEnv $ do
(ps, qs') <- mapAccumM (tcQual p) emptyPredSet qs
(ps', ty, e') <- tcExpr p e
return (ps, qs', ps', ty, e')
ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')
- checkSkolems p "Expression" (ppExpr 0) fs ps'' (listType ty)
- (ListCompr spi e' qs')
+ return (ps'', listType ty, ListCompr spi e' qs')
tcExpr p e@(EnumFrom spi e1) = do
(ps, ty) <- freshEnumType
(ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1
@@ -1194,32 +1195,28 @@
(ps', e1') <- tcArg p "right section" (ppExpr 0 e) ps beta e1
return (ps', TypeArrow alpha gamma, RightSection spi op' e1')
tcExpr p (Lambda spi ts e) = do
- fs <- computeFsEnv
(pss, tys, ts', ps, ty, e')<- withLocalValueEnv $ do
bindLambdaVars ts
(pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts
(ps, ty, e') <- tcExpr p e
return (pss, tys, ts', ps, ty, e')
ps' <- reducePredSet p "expression" (ppExpr 0 e') (Set.unions $ ps : pss)
- checkSkolems p "Expression" (ppExpr 0) fs ps' (foldr TypeArrow ty tys)
- (Lambda spi ts' e')
+ return (ps', foldr TypeArrow ty tys, Lambda spi ts' e')
tcExpr p (Let spi ds e) = do
- fs <- computeFsEnv
(ps, ds', ps', ty, e') <- withLocalValueEnv $ do
(ps, ds') <- tcDecls ds
(ps', ty, e') <- tcExpr p e
return (ps, ds', ps', ty, e')
ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')
- checkSkolems p "Expression" (ppExpr 0) fs ps'' ty (Let spi ds' e')
+ return (ps'', ty, Let spi ds' e')
tcExpr p (Do spi sts e) = do
- fs <- computeFsEnv
(sts', ty, ps', e') <- withLocalValueEnv $ do
((ps, mTy), sts') <-
mapAccumM (uncurry (tcStmt p)) (emptyPredSet, Nothing) sts
ty <- liftM (maybe id TypeApply mTy) freshTypeVar
(ps', e') <- tcExpr p e >>- unify p "statement" (ppExpr 0 e) ps ty
return (sts', ty, ps', e')
- checkSkolems p "Expression" (ppExpr 0) fs ps' ty (Do spi sts' e')
+ return (ps', ty, Do spi sts' e')
tcExpr p e@(IfThenElse spi e1 e2 e3) = do
(ps, e1') <- tcArg p "expression" (ppExpr 0 e) emptyPredSet boolType e1
(ps', ty, e2') <- tcExpr p e2
@@ -1228,8 +1225,7 @@
tcExpr p (Case spi ct e as) = do
(ps, tyLhs, e') <- tcExpr p e
tyRhs <- freshTypeVar
- fs <- computeFsEnv
- (ps', as') <- mapAccumM (tcAlt fs tyLhs tyRhs) ps as
+ (ps', as') <- mapAccumM (tcAlt tyLhs tyRhs) ps as
return (ps', tyRhs, Case spi ct e' as')
tcArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Expression a
@@ -1237,15 +1233,15 @@
tcArg p what doc ps ty e =
tcExpr p e >>- unify p what (doc $-$ text "Term:" <+> ppExpr 0 e) ps ty
-tcAlt :: Set.Set Int -> Type -> Type -> PredSet -> Alt a
+tcAlt :: Type -> Type -> PredSet -> Alt a
-> TCM (PredSet, Alt PredType)
-tcAlt fs tyLhs tyRhs ps a@(Alt p t rhs) =
- tcAltern fs tyLhs p t rhs >>-
+tcAlt tyLhs tyRhs ps a@(Alt p t rhs) =
+ tcAltern tyLhs p t rhs >>-
unify p "case alternative" (ppAlt a) ps tyRhs
-tcAltern :: Set.Set Int -> Type -> SpanInfo -> Pattern a
+tcAltern :: Type -> SpanInfo -> Pattern a
-> Rhs a -> TCM (PredSet, Type, Alt PredType)
-tcAltern fs tyLhs p t rhs = do
+tcAltern tyLhs p t rhs = do
(ps, t', ps', ty', rhs') <- withLocalValueEnv $ do
bindLambdaVars t
(ps, t') <-
@@ -1254,7 +1250,7 @@
return (ps, t', ps', ty', rhs')
ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs'))
(ps `Set.union` ps')
- checkSkolems p "Alternative" ppAlt fs ps'' ty' (Alt p t' rhs')
+ return (ps'', ty', Alt p t' rhs')
tcQual :: HasPosition p => p -> PredSet -> Statement a
-> TCM (PredSet, Statement PredType)
@@ -1300,7 +1296,7 @@
tcInfixOp (InfixConstr _ op) = do
m <- getModuleIdent
vEnv <- getValueEnv
- (ps, ty) <- instExist (constrType m op vEnv)
+ (ps, ty) <- inst (constrType m op vEnv)
return (ps, ty, InfixConstr (predType ty) op)
-- The first unification in 'tcField' cannot fail; it serves only for
@@ -1403,8 +1399,6 @@
unifyTypes m (TypeApply (TypeApply (TypeConstructor qArrowId) ty11) ty12) ty2
unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =
unifyTypeLists m [ty11, ty12] [ty21, ty22]
-unifyTypes _ (TypeSkolem k1) (TypeSkolem k2)
- | k1 == k2 = Right idSubst
unifyTypes m ty1 ty2 = Left (errIncompatibleTypes m ty1 ty2)
unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
@@ -1530,33 +1524,6 @@
isNumClass :: ClassEnv -> QualIdent -> Bool
isNumClass = (elem qNumId .) . flip allSuperClasses
--- Whenever type inference succeeds for a function equation, case alternative,
--- etc., which may open an existentially quantified data type and thus bring
--- fresh skolem constants into scope, the compiler checks that none of those
--- skolem constants escape their scope through the result type or the type
--- environment. E.g., for the program
---
--- data Key a = forall b . Key b (b -> a)
--- f (Key x _) = x
--- g k x = fcase k of { Key _ f -> f x }
---
--- a skolem constant escapes in the (result) type of 'f' and in the type of the
--- environment variable 'x' for the fcase expression in the definition of 'g'.
-
-checkSkolems :: HasPosition p => p -> String -> (a -> Doc) -> Set.Set Int
- -> PredSet -> Type -> a -> TCM (PredSet, Type, a)
-checkSkolems p what pp fs ps ty x = do
- m <- getModuleIdent
- vEnv <- getValueEnv
- theta <- getTypeSubst
- let escape = any (`Set.notMember` fs) . typeSkolems . snd
- esc = filter escape $ [ (v, subst theta pty)
- | (v, pty) <- (empty, PredType ps ty) : ptys ]
- ptys = [ (text "Variable:" <+> ppIdent v, pty)
- | (v, Value _ _ _ (ForAll _ pty)) <- localBindings vEnv ]
- mapM_ (report . errSkolemEscapingScope p m what (pp x)) esc
- return (ps, ty, x)
-
-- Instantiation and Generalization:
-- We use negative offsets for fresh type variables.
@@ -1589,19 +1556,11 @@
freshConstrained :: [Type] -> TCM Type
freshConstrained = freshVar . TypeConstrained
-freshSkolem :: TCM Type
-freshSkolem = fresh TypeSkolem
-
inst :: TypeScheme -> TCM (PredSet, Type)
inst (ForAll n (PredType ps ty)) = do
tys <- replicateM n freshTypeVar
return (expandAliasType tys ps, expandAliasType tys ty)
-instExist :: ExistTypeScheme -> TCM (PredSet, Type)
-instExist (ForAllExist n n' (PredType ps ty)) = do
- tys <- replicateM (n + n') freshTypeVar
- return (expandAliasType tys ps, expandAliasType tys ty)
-
-- The function 'skol' instantiates the type of data and newtype
-- constructors in patterns. All universally quantified type variables
-- are instantiated with fresh type variables and all existentially
@@ -1610,15 +1569,13 @@
-- constructor's declaration are added to the dynamic instance
-- environment.
-skol :: ExistTypeScheme -> TCM (PredSet, Type)
-skol (ForAllExist n n' (PredType ps ty)) = do
+skol :: TypeScheme -> TCM (PredSet, Type)
+skol (ForAll n (PredType ps ty)) = do
tys <- replicateM n freshTypeVar
- tys' <- replicateM n' freshSkolem
- let tys'' = tys ++ tys'
clsEnv <- getClassEnv
modifyInstEnv $
- fmap $ bindSkolemInsts $ expandAliasType tys'' $ maxPredSet clsEnv ps
- return (emptyPredSet, expandAliasType tys'' ty)
+ fmap $ bindSkolemInsts $ expandAliasType tys $ maxPredSet clsEnv ps
+ return (emptyPredSet, expandAliasType tys ty)
where bindSkolemInsts = flip (foldr bindSkolemInst) . Set.toList
bindSkolemInst (Pred qcls ty') dInEnv =
Map.insert qcls (ty' : fromMaybe [] (Map.lookup qcls dInEnv)) dInEnv
@@ -1650,7 +1607,7 @@
-- data constructor. The function 'varArity' works like 'varType' but returns
-- a variable's arity instead of its type.
-constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
+constrType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType m c vEnv = case qualLookupValue c vEnv of
[DataConstructor _ _ _ tySc] -> tySc
[NewtypeConstructor _ _ tySc] -> tySc
@@ -1725,15 +1682,6 @@
vEnv <- getValueEnv
return $ fvEnv (subst theta vEnv)
-fsEnv :: ValueEnv -> Set.Set Int
-fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes
-
-computeFsEnv :: TCM (Set.Set Int)
-computeFsEnv = do
- theta <- getTypeSubst
- vEnv <- getValueEnv
- return $ fsEnv (subst theta vEnv)
-
localTypes :: ValueEnv -> [TypeScheme]
localTypes vEnv = [tySc | (_, Value _ _ _ tySc) <- localBindings vEnv]
@@ -1789,14 +1737,6 @@
errSkolemFieldLabel :: HasPosition a => a -> Ident -> Message
errSkolemFieldLabel p l = posMessage p $ hsep $ map text
["Existential type escapes with type of record selector", escName l]
-
-errSkolemEscapingScope :: HasPosition a => a -> ModuleIdent -> String -> Doc
- -> (Doc, PredType) -> Message
-errSkolemEscapingScope p m what doc (whence, pty) = posMessage p $ vcat
- [ text "Existential type escapes out of its scope"
- , sep [text what <> colon, nest 2 doc], whence
- , text "Type:" <+> ppPredType m pty
- ]
errRecursiveType :: ModuleIdent -> Int -> Type -> Doc
errRecursiveType m tv ty = errIncompatibleTypes m (TypeVariable tv) ty
diff --git a/src/Checks/TypeSyntaxCheck.hs b/src/Checks/TypeSyntaxCheck.hs
--- a/src/Checks/TypeSyntaxCheck.hs
+++ b/src/Checks/TypeSyntaxCheck.hs
@@ -205,16 +205,12 @@
InstanceDecl p <$> rename cx <*> pure cls <*> rename ty <*> renameReset ds
instance Rename ConstrDecl where
- rename (ConstrDecl p evs cx c tys) = withLocalEnv $ do
- bindVars evs
- ConstrDecl p <$> rename evs <*> rename cx <*> pure c <*> rename tys
- rename (ConOpDecl p evs cx ty1 op ty2) = withLocalEnv $ do
- bindVars evs
- ConOpDecl p <$> rename evs <*> rename cx <*> rename ty1 <*> pure op
- <*> rename ty2
- rename (RecordDecl p evs cx c fs) = withLocalEnv $ do
- bindVars evs
- RecordDecl p <$> rename evs <*> rename cx <*> pure c <*> rename fs
+ rename (ConstrDecl p c tys) = withLocalEnv $ do
+ ConstrDecl p <$> pure c <*> rename tys
+ rename (ConOpDecl p ty1 op ty2) = withLocalEnv $ do
+ ConOpDecl p <$> rename ty1 <*> pure op <*> rename ty2
+ rename (RecordDecl p c fs) = withLocalEnv $ do
+ RecordDecl p <$> pure c <*> rename fs
instance Rename FieldDecl where
rename (FieldDecl p ls ty) = FieldDecl p ls <$> rename ty
@@ -358,22 +354,16 @@
checkDecl d = return d
checkConstrDecl :: [Ident] -> ConstrDecl -> TSCM ConstrDecl
-checkConstrDecl tvs (ConstrDecl p evs cx c tys) = do
- checkExistVars evs
- tys' <- mapM (checkClosedType (evs ++ tvs)) tys
- cx' <- checkClosedContext (fv tys') cx
- return $ ConstrDecl p evs cx' c tys'
-checkConstrDecl tvs (ConOpDecl p evs cx ty1 op ty2) = do
- checkExistVars evs
- tys' <- mapM (checkClosedType (evs ++ tvs)) [ty1, ty2]
+checkConstrDecl tvs (ConstrDecl p c tys) = do
+ tys' <- mapM (checkClosedType tvs) tys
+ return $ ConstrDecl p c tys'
+checkConstrDecl tvs (ConOpDecl p ty1 op ty2) = do
+ tys' <- mapM (checkClosedType tvs) [ty1, ty2]
let [ty1', ty2'] = tys'
- cx' <- checkClosedContext (fv ty1' ++ fv ty2') cx
- return $ ConOpDecl p evs cx' ty1' op ty2'
-checkConstrDecl tvs (RecordDecl p evs cx c fs) = do
- checkExistVars evs
- fs' <- mapM (checkFieldDecl (evs ++ tvs)) fs
- cx' <- checkClosedContext (concatMap fv [ty | FieldDecl _ _ ty <- fs]) cx
- return $ RecordDecl p evs cx' c fs'
+ return $ ConOpDecl p ty1' op ty2'
+checkConstrDecl tvs (RecordDecl p c fs) = do
+ fs' <- mapM (checkFieldDecl tvs) fs
+ return $ RecordDecl p c fs'
checkFieldDecl :: [Ident] -> FieldDecl -> TSCM FieldDecl
checkFieldDecl tvs (FieldDecl p ls ty) =
@@ -417,12 +407,6 @@
checkTypeLhs :: [Ident] -> TSCM ()
checkTypeLhs = checkTypeVars "left hand side of type declaration"
-
-checkExistVars :: [Ident] -> TSCM ()
-checkExistVars evs = do
- unless (null evs) $ checkUsedExtension (getPosition $ head evs)
- "Existentially quantified types" ExistentialQuantification
- checkTypeVars "list of existentially quantified type variables" evs
-- |Checks a list of type variables for
-- * Anonymous type variables are allowed
diff --git a/src/Checks/WarnCheck.hs b/src/Checks/WarnCheck.hs
--- a/src/Checks/WarnCheck.hs
+++ b/src/Checks/WarnCheck.hs
@@ -273,24 +273,15 @@
--TODO: shadowing und context etc.
checkConstrDecl :: ConstrDecl -> WCM ()
-checkConstrDecl (ConstrDecl _ vs _ c tys) = inNestedScope $ do
- mapM_ checkTypeShadowing vs
- mapM_ insertTypeVar vs
+checkConstrDecl (ConstrDecl _ c tys) = inNestedScope $ do
visitId c
mapM_ checkTypeExpr tys
- reportUnusedTypeVars vs
-checkConstrDecl (ConOpDecl _ vs _ ty1 op ty2) = inNestedScope $ do
- mapM_ checkTypeShadowing vs
- mapM_ insertTypeVar vs
+checkConstrDecl (ConOpDecl _ ty1 op ty2) = inNestedScope $ do
visitId op
mapM_ checkTypeExpr [ty1, ty2]
- reportUnusedTypeVars vs
-checkConstrDecl (RecordDecl _ vs _ c fs) = inNestedScope $ do
- mapM_ checkTypeShadowing vs
- mapM_ insertTypeVar vs
+checkConstrDecl (RecordDecl _ c fs) = inNestedScope $ do
visitId c
mapM_ checkTypeExpr tys
- reportUnusedTypeVars vs
where
tys = [ty | FieldDecl _ _ ty <- fs]
@@ -793,8 +784,8 @@
tyEnv <- gets valueEnv
tcEnv <- gets tyConsEnv
case qualLookupValue q tyEnv of
- [DataConstructor _ _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
- [NewtypeConstructor _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
+ [DataConstructor _ _ _ (ForAll _ (PredType _ ty))] -> return ty
+ [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty
_ -> case qualLookupTypeInfo q tcEnv of
[AliasType _ _ _ ty] -> return ty
_ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q
@@ -1018,9 +1009,9 @@
insertTypeExpr (ForallType _ _ ty) = insertTypeExpr ty
insertConstrDecl :: ConstrDecl -> WCM ()
-insertConstrDecl (ConstrDecl _ _ _ c _) = insertConsId c
-insertConstrDecl (ConOpDecl _ _ _ _ op _) = insertConsId op
-insertConstrDecl (RecordDecl _ _ _ c _) = insertConsId c
+insertConstrDecl (ConstrDecl _ c _) = insertConsId c
+insertConstrDecl (ConOpDecl _ _ op _) = insertConsId op
+insertConstrDecl (RecordDecl _ c _) = insertConsId c
insertNewConstrDecl :: NewConstrDecl -> WCM ()
insertNewConstrDecl (NewConstrDecl _ c _) = insertConsId c
@@ -1250,20 +1241,14 @@
checkCaseModeDecl _ = ok
checkCaseModeConstr :: ConstrDecl -> WCM ()
-checkCaseModeConstr (ConstrDecl _ evs cx c tys) = do
- mapM_ (checkCaseModeID isVarName) evs
- checkCaseModeContext cx
+checkCaseModeConstr (ConstrDecl _ c tys) = do
checkCaseModeID isConstrName c
mapM_ checkCaseModeTypeExpr tys
-checkCaseModeConstr (ConOpDecl _ evs cx ty1 c ty2) = do
- mapM_ (checkCaseModeID isVarName) evs
- checkCaseModeContext cx
+checkCaseModeConstr (ConOpDecl _ ty1 c ty2) = do
checkCaseModeTypeExpr ty1
checkCaseModeID isConstrName c
checkCaseModeTypeExpr ty2
-checkCaseModeConstr (RecordDecl _ evs cx c fs) = do
- mapM_ (checkCaseModeID isVarName) evs
- checkCaseModeContext cx
+checkCaseModeConstr (RecordDecl _ c fs) = do
checkCaseModeID isConstrName c
mapM_ checkCaseModeFieldDecl fs
diff --git a/src/CompilerOpts.hs b/src/CompilerOpts.hs
--- a/src/CompilerOpts.hs
+++ b/src/CompilerOpts.hs
@@ -298,8 +298,6 @@
, "enable anonymous free variables" )
, ( CPP , "CPP"
, "run C preprocessor" )
- , ( ExistentialQuantification, "ExistentialQuantification"
- , "enable existentially quantified types" )
, ( FunctionalPatterns , "FunctionalPatterns"
, "enable functional patterns" )
, ( NegativeLiterals , "NegativeLiterals"
diff --git a/src/Env/TypeConstructor.hs b/src/Env/TypeConstructor.hs
--- a/src/Env/TypeConstructor.hs
+++ b/src/Env/TypeConstructor.hs
@@ -215,7 +215,7 @@
tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
where
- typeInfo dc@(DataConstr _ _ _ tys) =
+ typeInfo dc@(DataConstr _ tys) =
let n = length tys in DataType (qTupleId n) (simpleKind n) [dc]
- typeInfo (RecordConstr _ _ _ _ _) =
+ typeInfo (RecordConstr _ _ _) =
internalError "Env.TypeConstructor.tupleTCs: record constructor"
diff --git a/src/Env/Value.hs b/src/Env/Value.hs
--- a/src/Env/Value.hs
+++ b/src/Env/Value.hs
@@ -48,10 +48,10 @@
data ValueInfo
-- |Data constructor with original name, arity, list of record labels and type
- = DataConstructor QualIdent Int [Ident] ExistTypeScheme
+ = DataConstructor QualIdent Int [Ident] TypeScheme
-- |Newtype constructor with original name, record label and type
-- (arity is always 1)
- | NewtypeConstructor QualIdent Ident ExistTypeScheme
+ | NewtypeConstructor QualIdent Ident TypeScheme
-- |Value with original name, class method flag, arity and type
| Value QualIdent Bool Int TypeScheme
-- |Record label with original name, list of constructors for which label
@@ -161,11 +161,11 @@
tupleDCs :: [ValueInfo]
tupleDCs = map dataInfo tupleData
- where dataInfo (DataConstr _ _ _ tys) =
+ where dataInfo (DataConstr _ tys) =
let n = length tys
in DataConstructor (qTupleId n) n (replicate n anonId) $
- ForAllExist n 0 $ predType $ foldr TypeArrow (tupleType tys) tys
- dataInfo (RecordConstr _ _ _ _ _) =
+ ForAll n $ predType $ foldr TypeArrow (tupleType tys) tys
+ dataInfo (RecordConstr _ _ _) =
internalError $ "Env.Value.tupleDCs: " ++ show tupleDCs
-- Since all predefined types are free of existentially quantified type
@@ -175,12 +175,12 @@
initDCEnv :: ValueEnv
initDCEnv = foldr predefDC emptyTopEnv
[ (c, length tys, constrType (polyType ty) tys)
- | (ty, cs) <- predefTypes, DataConstr c _ _ tys <- cs ]
+ | (ty, cs) <- predefTypes, DataConstr c tys <- cs ]
where predefDC (c, a, ty) = predefTopEnv c' (DataConstructor c' a ls ty)
where ls = replicate a anonId
c' = qualify c
constrType (ForAll n (PredType ps ty)) =
- ForAllExist n 0 . PredType ps . foldr TypeArrow ty
+ ForAll n . PredType ps . foldr TypeArrow ty
-- The functions 'bindLocalVar' and 'bindLocalVars' add the type of one or
-- many local variables or functions to the value environment. In contrast
diff --git a/src/Exports.hs b/src/Exports.hs
--- a/src/Exports.hs
+++ b/src/Exports.hs
@@ -31,7 +31,7 @@
import Curry.Syntax
import Base.CurryKinds (fromKind')
-import Base.CurryTypes (fromQualType, fromQualPredSet, fromQualPredType)
+import Base.CurryTypes (fromQualType, fromQualPredType)
import Base.Messages
import Base.Types
@@ -147,28 +147,22 @@
k' = fromKind' k n
constrDecl :: ModuleIdent -> Int -> [Ident] -> DataConstr -> ConstrDecl
-constrDecl m n tvs (DataConstr c n' ps [ty1, ty2])
- | isInfixOp c = ConOpDecl NoSpanInfo evs cx ty1' c ty2'
- where evs = take n' $ drop n tvs
- cx = fromQualPredSet m tvs ps
- [ty1', ty2'] = map (fromQualType m tvs) [ty1, ty2]
-constrDecl m n tvs (DataConstr c n' ps tys) =
- ConstrDecl NoSpanInfo evs cx c tys'
- where evs = take n' $ drop n tvs
- cx = fromQualPredSet m tvs ps
- tys' = map (fromQualType m tvs) tys
-constrDecl m n tvs (RecordConstr c n' ps ls tys) =
- RecordDecl NoSpanInfo evs cx c fs
+constrDecl m _ tvs (DataConstr c [ty1, ty2])
+ | isInfixOp c = ConOpDecl NoSpanInfo ty1' c ty2'
+ where [ty1', ty2'] = map (fromQualType m tvs) [ty1, ty2]
+constrDecl m _ tvs (DataConstr c tys) =
+ ConstrDecl NoSpanInfo c tys'
+ where tys' = map (fromQualType m tvs) tys
+constrDecl m _ tvs (RecordConstr c ls tys) =
+ RecordDecl NoSpanInfo c fs
where
- evs = take n' $ drop n tvs
- cx = fromQualPredSet m tvs ps
tys' = map (fromQualType m tvs) tys
fs = zipWith (FieldDecl NoSpanInfo . return) ls tys'
newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl
-newConstrDecl m tvs (DataConstr c _ _ tys)
+newConstrDecl m tvs (DataConstr c tys)
= NewConstrDecl NoSpanInfo c (fromQualType m tvs (head tys))
-newConstrDecl m tvs (RecordConstr c _ _ ls tys)
+newConstrDecl m tvs (RecordConstr c ls tys)
= NewRecordDecl NoSpanInfo c (head ls, fromQualType m tvs (head tys))
-- When exporting a class method, we have to remove the implicit class context.
@@ -250,9 +244,9 @@
modules cx . modules cls . modules ty . modules mm
instance HasModule ConstrDecl where
- modules (ConstrDecl _ _ cx _ tys) = modules cx . modules tys
- modules (ConOpDecl _ _ cx ty1 _ ty2) = modules cx . modules ty1 . modules ty2
- modules (RecordDecl _ _ cx _ fs) = modules cx . modules fs
+ modules (ConstrDecl _ _ tys) = modules tys
+ modules (ConOpDecl _ ty1 _ ty2) = modules ty1 . modules ty2
+ modules (RecordDecl _ _ fs) = modules fs
instance HasModule FieldDecl where
modules (FieldDecl _ _ ty) = modules ty
@@ -398,10 +392,10 @@
usedTypes cx . (cls :) . usedTypes ty
instance HasType ConstrDecl where
- usedTypes (ConstrDecl _ _ cx _ tys) = usedTypes cx . usedTypes tys
- usedTypes (ConOpDecl _ _ cx ty1 _ ty2) =
- usedTypes cx . usedTypes ty1 . usedTypes ty2
- usedTypes (RecordDecl _ _ cx _ fs) = usedTypes cx . usedTypes fs
+ usedTypes (ConstrDecl _ _ tys) = usedTypes tys
+ usedTypes (ConOpDecl _ ty1 _ ty2) =
+ usedTypes ty1 . usedTypes ty2
+ usedTypes (RecordDecl _ _ fs) = usedTypes fs
instance HasType FieldDecl where
usedTypes (FieldDecl _ _ ty) = usedTypes ty
diff --git a/src/Generators/GenAbstractCurry.hs b/src/Generators/GenAbstractCurry.hs
--- a/src/Generators/GenAbstractCurry.hs
+++ b/src/Generators/GenAbstractCurry.hs
@@ -157,20 +157,21 @@
<$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs
trTypeDecl _ = return []
+
+-- TODO: Remove context and existential quantified type variables.
trConsDecl :: ConstrDecl -> GAC CConsDecl
-trConsDecl (ConstrDecl _ vs cx c tys) = inNestedTScope $ CCons
- <$> mapM genTVarIndex vs <*> trContext cx <*> trGlobalIdent c
- <*> getVisibility c <*> mapM trTypeExpr tys
-trConsDecl (ConOpDecl p vs cx ty1 op ty2) = inNestedTScope $ trConsDecl $
- ConstrDecl p vs cx op [ty1, ty2]
-trConsDecl (RecordDecl _ vs cx c fs) = inNestedTScope $ CRecord
- <$> mapM genTVarIndex vs <*> trContext cx <*> trGlobalIdent c
- <*> getVisibility c <*> concatMapM trFieldDecl fs
+trConsDecl (ConstrDecl _ c tys) = inNestedTScope $ CCons [] (CContext [])
+ <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
+trConsDecl (ConOpDecl p ty1 op ty2) = inNestedTScope $ trConsDecl $
+ ConstrDecl p op [ty1, ty2]
+trConsDecl (RecordDecl _ c fs) = inNestedTScope $ CRecord [] (CContext [])
+ <$> trGlobalIdent c <*> getVisibility c <*> concatMapM trFieldDecl fs
trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->
CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty
+-- TODO: Remove context and existential quantified type variables.
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl (NewConstrDecl _ nc ty) = CCons [] (CContext [])
<$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
diff --git a/src/Html/CurryHtml.hs b/src/Html/CurryHtml.hs
--- a/src/Html/CurryHtml.hs
+++ b/src/Html/CurryHtml.hs
@@ -12,38 +12,44 @@
This module defines a function for generating HTML documentation pages
for Curry source modules.
-}
+{-# LANGUAGE TemplateHaskell #-}
module Html.CurryHtml (source2html) where
+import Prelude as P
import Control.Monad.Writer
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, isJust)
+import Data.ByteString as BS (ByteString, writeFile)
+import Data.FileEmbed
import Network.URI (escapeURIString, isUnreserved)
-import System.Directory (copyFile, doesFileExist)
import System.FilePath (())
import Curry.Base.Ident ( ModuleIdent (..), Ident (..), QualIdent (..)
, unqualify, moduleName)
-import Curry.Base.Monad (CYIO, failMessages)
+import Curry.Base.Monad (CYIO)
import Curry.Base.Position (Position)
-import Curry.Base.Pretty ((<+>), text, vcat)
import Curry.Files.Filenames (htmlName)
import Curry.Syntax (Module (..), Token)
import Html.SyntaxColoring
-import Base.Messages (message)
+
import CompilerOpts (Options (..))
-import Paths_curry_frontend (getDataFileName)
--- |'FilePath' of the CSS style file to be added to the documentation.
-cssFile :: FilePath
-cssFile = "currysource.css"
+-- |Read file via TemplateHaskell at compile time
+cssContent :: ByteString
+cssContent = $(makeRelativeToProject "data/currysource.css" >>= embedFile)
+-- | Name of the css file
+-- NOTE: The relative path is given above
+cssFileName :: String
+cssFileName = "currysource.css"
+
-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> ModuleIdent -> [(Position, Token)] -> Module a
-> CYIO ()
source2html opts mid toks mdl = do
- liftIO $ writeFile (outDir htmlName mid) doc
+ liftIO $ P.writeFile (outDir htmlName mid) doc
updateCSSFile outDir
where
doc = program2html mid (genProgram mdl toks)
@@ -52,16 +58,8 @@
-- |Update the CSS file
updateCSSFile :: FilePath -> CYIO ()
updateCSSFile dir = do
- src <- liftIO $ getDataFileName cssFile
- let target = dir cssFile
- srcExists <- liftIO $ doesFileExist src
- if srcExists then liftIO $ copyFile src target
- else failMessages [message $ missingStyleFile src]
- where
- missingStyleFile f = vcat
- [ text "Could not copy CSS style file:"
- , text "File" <+> text ("`" ++ f ++ "'") <+> text "does not exist"
- ]
+ let target = dir cssFileName
+ liftIO $ BS.writeFile target cssContent
-- generates htmlcode with syntax highlighting
-- @param modulname
@@ -70,15 +68,17 @@
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
[ ""
- , "", ""
- , ""
+ , ""
+ , ""
+ , ""
+ , ""
, "" ++ titleHtml ++ ""
- , ""
+ , ""
, ""
, ""
, ""
- , "" ++ lineHtml ++ " | "
- , "" ++ codeHtml ++ " | "
+ , "" ++ lineHtml ++ " | "
+ , "" ++ codeHtml ++ " | "
, "
"
, ""
, ""
diff --git a/src/Html/SyntaxColoring.hs b/src/Html/SyntaxColoring.hs
--- a/src/Html/SyntaxColoring.hs
+++ b/src/Html/SyntaxColoring.hs
@@ -331,15 +331,12 @@
TypeCons TypeRefer False c : idsTypeExpr ty ++ concatMap idsInstanceDecl ds
idsConstrDecl :: ConstrDecl -> [Code]
-idsConstrDecl (ConstrDecl _ vs cx c tys) =
- map (Identifier IdDeclare False . qualify) vs ++ idsContext cx ++
- DataCons ConsDeclare False (qualify c) : concatMap idsTypeExpr tys
-idsConstrDecl (ConOpDecl _ vs cx ty1 op ty2) =
- map (Identifier IdDeclare False . qualify) vs ++ idsContext cx ++
+idsConstrDecl (ConstrDecl _ c tys) =
+ DataCons ConsDeclare False (qualify c) : concatMap idsTypeExpr tys
+idsConstrDecl (ConOpDecl _ ty1 op ty2) =
idsTypeExpr ty1 ++ (DataCons ConsDeclare False $ qualify op) : idsTypeExpr ty2
-idsConstrDecl (RecordDecl _ vs cx c fs) =
- map (Identifier IdDeclare False . qualify) vs ++ idsContext cx ++
- DataCons ConsDeclare False (qualify c) : concatMap idsFieldDecl fs
+idsConstrDecl (RecordDecl _ c fs) =
+ DataCons ConsDeclare False (qualify c) : concatMap idsFieldDecl fs
idsNewConstrDecl :: NewConstrDecl -> [Code]
idsNewConstrDecl (NewConstrDecl _ c ty) =
diff --git a/src/Imports.hs b/src/Imports.hs
--- a/src/Imports.hs
+++ b/src/Imports.hs
@@ -28,8 +28,8 @@
import Curry.Syntax
import Base.CurryKinds (toKind')
-import Base.CurryTypes ( toQualType, toQualTypes, toQualPredSet, toQualPredType
- , toConstrType, toMethodType )
+import Base.CurryTypes ( toQualType, toQualTypes, toQualPredType, toConstrType
+ , toMethodType )
import Base.Kinds
import Base.Messages
@@ -164,10 +164,11 @@
bindClass :: ModuleIdent -> IDecl -> ClassEnv -> ClassEnv
bindClass m (HidingClassDecl p cx cls k tv) =
bindClass m (IClassDecl p cx cls k tv [] [])
-bindClass m (IClassDecl _ cx cls _ _ ds _) =
+bindClass m (IClassDecl _ cx cls _ _ ds ids) =
bindClassInfo (qualQualify m cls) (sclss, ms)
where sclss = map (\(Constraint _ scls _) -> qualQualify m scls) cx
- ms = map (\d -> (imethod d, isJust $ imethodArity d)) ds
+ ms = map (\d -> (imethod d, isJust $ imethodArity d)) $ filter isVis ds
+ isVis (IMethodDecl _ idt _ _ ) = idt `notElem` ids
bindClass _ _ = id
importInstances :: ModuleIdent -> [IDecl] -> InstEnv -> InstEnv
@@ -201,33 +202,28 @@
types m (IDataDecl _ tc k tvs cs _) =
[typeCon DataType m tc k tvs (map mkData cs)]
where
- mkData (ConstrDecl _ evs cx c tys) =
- DataConstr c (length evs) (toQualPredSet m tvs' cx)
- (toQualTypes m tvs' tys)
- where tvs' = tvs ++ evs
- mkData (ConOpDecl _ evs cx ty1 c ty2) =
- DataConstr c (length evs) (toQualPredSet m tvs' cx)
- (toQualTypes m tvs' [ty1, ty2])
- where tvs' = tvs ++ evs
- mkData (RecordDecl _ evs cx c fs) =
- RecordConstr c (length evs) (toQualPredSet m tvs' cx) labels
- (toQualTypes m tvs' tys)
- where tvs' = tvs ++ evs
- (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
+ mkData (ConstrDecl _ c tys) =
+ DataConstr c (toQualTypes m tvs tys)
+ mkData (ConOpDecl _ ty1 c ty2) =
+ DataConstr c (toQualTypes m tvs [ty1, ty2])
+ mkData (RecordDecl _ c fs) =
+ RecordConstr c labels (toQualTypes m tvs tys)
+ where (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
types m (INewtypeDecl _ tc k tvs nc _) =
[typeCon RenamingType m tc k tvs (mkData nc)]
where
mkData (NewConstrDecl _ c ty) =
- DataConstr c 0 emptyPredSet [toQualType m tvs ty]
+ DataConstr c [toQualType m tvs ty]
mkData (NewRecordDecl _ c (l, ty)) =
- RecordConstr c 0 emptyPredSet [l] [toQualType m tvs ty]
+ RecordConstr c [l] [toQualType m tvs ty]
types m (ITypeDecl _ tc k tvs ty) =
[typeCon aliasType m tc k tvs (toQualType m tvs ty)]
where
aliasType tc' k' = AliasType tc' k' (length tvs)
-types m (IClassDecl _ _ qcls k tv ds _) =
- [typeCls m qcls k (map mkMethod ds)]
+types m (IClassDecl _ _ qcls k tv ds ids) =
+ [typeCls m qcls k (map mkMethod $ filter isVis ds)]
where
+ isVis (IMethodDecl _ f _ _ ) = f `notElem` ids
mkMethod (IMethodDecl _ f a qty) = ClassMethod f a $
qualifyPredType m $ normalize 1 $ toMethodType qcls tv qty
types _ _ = []
@@ -251,7 +247,7 @@
map (recLabel m tc' tvs ty') (nubBy sameLabel clabels)
where tc' = qualQualify m tc
ty' = constrType tc' tvs
- labels = [ (l, lty) | RecordDecl _ _ _ _ fs <- cs
+ labels = [ (l, lty) | RecordDecl _ _ fs <- cs
, FieldDecl _ ls lty <- fs, l <- ls, l `notElem` hs
]
clabels = [(l, constr l, ty) | (l, ty) <- labels]
@@ -278,17 +274,17 @@
values _ _ = []
dataConstr :: ModuleIdent -> QualIdent -> [Ident] -> ConstrDecl -> ValueInfo
-dataConstr m tc tvs (ConstrDecl _ evs cx c tys) =
+dataConstr m tc tvs (ConstrDecl _ c tys) =
DataConstructor (qualifyLike tc c) a labels $
- constrType' m tc tvs evs cx tys
+ constrType' m tc tvs tys
where a = length tys
labels = replicate a anonId
-dataConstr m tc tvs (ConOpDecl _ evs cx ty1 op ty2) =
+dataConstr m tc tvs (ConOpDecl _ ty1 op ty2) =
DataConstructor (qualifyLike tc op) 2 [anonId, anonId] $
- constrType' m tc tvs evs cx [ty1, ty2]
-dataConstr m tc tvs (RecordDecl _ evs cx c fs) =
+ constrType' m tc tvs [ty1, ty2]
+dataConstr m tc tvs (RecordDecl _ c fs) =
DataConstructor (qualifyLike tc c) a labels $
- constrType' m tc tvs evs cx tys
+ constrType' m tc tvs tys
where fields = [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
(labels, tys) = unzip fields
a = length labels
@@ -296,10 +292,10 @@
newConstr :: ModuleIdent -> QualIdent -> [Ident] -> NewConstrDecl -> ValueInfo
newConstr m tc tvs (NewConstrDecl _ c ty1) =
NewtypeConstructor (qualifyLike tc c) anonId $
- constrType' m tc tvs [] [] [ty1]
+ constrType' m tc tvs [ty1]
newConstr m tc tvs (NewRecordDecl _ c (l, ty1)) =
NewtypeConstructor (qualifyLike tc c) l $
- constrType' m tc tvs [] [] [ty1]
+ constrType' m tc tvs [ty1]
recLabel :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr
-> (Ident, [Ident], TypeExpr) -> ValueInfo
@@ -308,11 +304,9 @@
qcs = map (qualifyLike tc) cs
tySc = polyType (toQualType m tvs (ArrowType NoSpanInfo ty0 lty))
-constrType' :: ModuleIdent -> QualIdent -> [Ident] -> [Ident] -> Context
- -> [TypeExpr] -> ExistTypeScheme
-constrType' m tc tvs evs cx tys = ForAllExist (length tvs) (length evs) pty
- where tvs' = tvs ++ evs
- pty = qualifyPredType m $ toConstrType tc tvs' cx tys
+constrType' :: ModuleIdent -> QualIdent -> [Ident] -> [TypeExpr] -> TypeScheme
+constrType' m tc tvs tys = ForAll (length tvs) pty
+ where pty = qualifyPredType m $ toConstrType tc tvs tys
constrType :: QualIdent -> [Ident] -> TypeExpr
constrType tc tvs = foldl (ApplyType NoSpanInfo) (ConstructorType NoSpanInfo tc)
diff --git a/src/Transformations/CaseCompletion.hs b/src/Transformations/CaseCompletion.hs
--- a/src/Transformations/CaseCompletion.hs
+++ b/src/Transformations/CaseCompletion.hs
@@ -391,9 +391,9 @@
CS.INewtypeDecl _ _ _ _ nc _ -> isNewConstrDecl qid nc
_ -> False
- declaresConstr (CS.ConstrDecl _ _ _ cid _) qid = unqualify qid == cid
- declaresConstr (CS.ConOpDecl _ _ _ _ oid _) qid = unqualify qid == oid
- declaresConstr (CS.RecordDecl _ _ _ cid _) qid = unqualify qid == cid
+ declaresConstr (CS.ConstrDecl _ cid _) qid = unqualify qid == cid
+ declaresConstr (CS.ConOpDecl _ _ oid _) qid = unqualify qid == oid
+ declaresConstr (CS.RecordDecl _ cid _) qid = unqualify qid == cid
isNewConstrDecl qid (CS.NewConstrDecl _ cid _) = unqualify qid == cid
isNewConstrDecl qid (CS.NewRecordDecl _ cid _) = unqualify qid == cid
@@ -401,11 +401,11 @@
extractConstrDecls (CS.IDataDecl _ _ _ vs cs' _) = zip (repeat vs) cs'
extractConstrDecls _ = []
- constrInfo vs (CS.ConstrDecl _ _ _ cid tys) =
+ constrInfo vs (CS.ConstrDecl _ cid tys) =
(qualifyWith mid cid, map (transType' vs) tys)
- constrInfo vs (CS.ConOpDecl _ _ _ ty1 oid ty2) =
+ constrInfo vs (CS.ConOpDecl _ ty1 oid ty2) =
(qualifyWith mid oid, map (transType' vs) [ty1, ty2])
- constrInfo vs (CS.RecordDecl _ _ _ cid fs) =
+ constrInfo vs (CS.RecordDecl _ cid fs) =
( qualifyWith mid cid
, [transType' vs ty | CS.FieldDecl _ ls ty <- fs, _ <- ls]
)
diff --git a/src/Transformations/CurryToIL.hs b/src/Transformations/CurryToIL.hs
--- a/src/Transformations/CurryToIL.hs
+++ b/src/Transformations/CurryToIL.hs
@@ -127,8 +127,8 @@
constrType c = do
vEnv <- getValueEnv
case qualLookupValue c vEnv of
- [DataConstructor _ _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
- [NewtypeConstructor _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
+ [DataConstructor _ _ _ (ForAll _ (PredType _ ty))] -> return ty
+ [NewtypeConstructor _ _ (ForAll _ (PredType _ ty))] -> return ty
_ -> internalError $ "CurryToIL.constrType: " ++ show c
-- -----------------------------------------------------------------------------
@@ -160,9 +160,9 @@
ty' <- arrowArgs <$> constrType c'
return $ IL.ConstrDecl c' (map transType ty')
where
- constr (ConstrDecl _ _ _ c _) = c
- constr (ConOpDecl _ _ _ _ op _) = op
- constr (RecordDecl _ _ _ c _) = c
+ constr (ConstrDecl _ c _) = c
+ constr (ConOpDecl _ _ op _) = op
+ constr (RecordDecl _ c _) = c
trExternalData :: Ident -> [Ident] -> TransM IL.Decl
trExternalData tc tvs = flip IL.ExternalDataDecl (length tvs) <$> trQualify tc
@@ -186,8 +186,6 @@
transType' (TypeApply ty1 ty2) = transType' ty1 . (transType ty2 :)
transType' (TypeVariable tv) = foldl applyType' (IL.TypeVariable tv)
transType' (TypeConstrained tys _) = transType' (head tys)
-transType' (TypeSkolem k) =
- foldl applyType' (IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) [])
transType' (TypeArrow ty1 ty2) =
foldl applyType' (IL.TypeArrow (transType ty1) (transType ty2))
transType' (TypeForall tvs ty) =
diff --git a/src/Transformations/Derive.hs b/src/Transformations/Derive.hs
--- a/src/Transformations/Derive.hs
+++ b/src/Transformations/Derive.hs
@@ -274,8 +274,8 @@
deriveBoundedMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveBoundedMethods ty cis ps = sequence
- [ deriveMaxOrMinBound qMaxBoundId ty (head cis) ps
- , deriveMaxOrMinBound qMinBoundId ty (last cis) ps
+ [ deriveMaxOrMinBound qMinBoundId ty (head cis) ps
+ , deriveMaxOrMinBound qMaxBoundId ty (last cis) ps
]
deriveMaxOrMinBound :: QualIdent -> Type -> ConstrInfo -> PredSet
@@ -506,9 +506,9 @@
_ -> internalError $ "Derive.constructors: " ++ show tc
mkConstrInfo :: ModuleIdent -> Int -> DataConstr -> ConstrInfo
-mkConstrInfo m i (DataConstr c _ _ tys) =
+mkConstrInfo m i (DataConstr c tys) =
(i, qualifyWith m c, Nothing, tys)
-mkConstrInfo m i (RecordConstr c _ _ ls tys) =
+mkConstrInfo m i (RecordConstr c ls tys) =
(i, qualifyWith m c, Just ls, tys)
showsConstr :: Ident -> ShowS
diff --git a/src/Transformations/Desugar.hs b/src/Transformations/Desugar.hs
--- a/src/Transformations/Desugar.hs
+++ b/src/Transformations/Desugar.hs
@@ -222,9 +222,9 @@
-- Remove any labels from a data constructor declaration
unlabelConstr :: ConstrDecl -> ConstrDecl
-unlabelConstr (RecordDecl p evs cx c fs) = ConstrDecl p evs cx c tys
+unlabelConstr (RecordDecl p c fs) = ConstrDecl p c tys
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
-unlabelConstr c = c
+unlabelConstr c = c
-- Remove any labels from a newtype constructor declaration
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
@@ -677,7 +677,7 @@
where ty = typeOf e
pty = predType ty
tc = rootOfType (arrowBase ty)
- updateAlt (RecordConstr c _ _ ls _)
+ updateAlt (RecordConstr c ls _)
| all (`elem` qls2) (map fieldLabel fs)= do
let qc = qualifyLike tc c
vEnv <- getValueEnv
@@ -1042,7 +1042,7 @@
-- Auxiliary definitions
-- ---------------------------------------------------------------------------
-conType :: QualIdent -> ValueEnv -> ([Ident], ExistTypeScheme)
+conType :: QualIdent -> ValueEnv -> ([Ident], TypeScheme)
conType c vEnv = case qualLookupValue c vEnv of
[DataConstructor _ _ ls ty] -> (ls , ty)
[NewtypeConstructor _ l ty] -> ([l], ty)
@@ -1071,8 +1071,8 @@
-- variables are allowed for records), the compiler can reuse the same
-- monomorphic type variables for every instantiated type.
-instType :: ExistTypeScheme -> Type
-instType (ForAllExist _ _ pty) = inst $ unpredType pty
+instType :: TypeScheme -> Type
+instType (ForAll _ pty) = inst $ unpredType pty
where inst (TypeConstructor tc) = TypeConstructor tc
inst (TypeApply ty1 ty2) = TypeApply (inst ty1) (inst ty2)
inst (TypeVariable tv) = TypeVariable (-1 - tv)
@@ -1094,5 +1094,5 @@
argumentTypes :: Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes ty c vEnv =
(map (qualifyLike c) ls, map (subst (matchType ty0 ty idSubst)) tys)
- where (ls, ForAllExist _ _ (PredType _ ty')) = conType c vEnv
+ where (ls, ForAll _ (PredType _ ty')) = conType c vEnv
(tys, ty0) = arrowUnapply ty'
diff --git a/src/Transformations/Dictionary.hs b/src/Transformations/Dictionary.hs
--- a/src/Transformations/Dictionary.hs
+++ b/src/Transformations/Dictionary.hs
@@ -373,14 +373,10 @@
createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
createClassDictConstrDecl cls tv ds = do
- clsEnv <- getClassEnv
- let sclss = superClasses cls clsEnv
- cx = [Constraint NoSpanInfo scls (VariableType NoSpanInfo tv)
- | scls <- sclss]
- tvs = tv : filter (unRenameIdent tv /=) identSupply
+ let tvs = tv : filter (unRenameIdent tv /=) identSupply
mtys = map (fromType tvs . generalizeMethodType . transformMethodPredType)
[toMethodType cls tv qty | TypeSig _ fs qty <- ds, _ <- fs]
- return $ ConstrDecl NoSpanInfo [] cx (dictConstrId cls) mtys
+ return $ ConstrDecl NoSpanInfo (dictConstrId cls) mtys
classDictConstrPredType :: ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType vEnv clsEnv cls = PredType ps $ foldr TypeArrow ty mtys
@@ -561,7 +557,7 @@
bindDictType m clsEnv (TypeClass cls k ms) = bindEntity m tc ti
where ti = DataType tc (KindArrow k KindStar) [c]
tc = qDictTypeId cls
- c = DataConstr (dictConstrId cls) 0 ps tys
+ c = DataConstr (dictConstrId cls) (map dictType (Set.toAscList ps) ++ tys)
sclss = superClasses cls clsEnv
ps = Set.fromList [Pred scls (TypeVariable 0) | scls <- sclss]
tys = map (generalizeMethodType . transformMethodPredType . methodType) ms
@@ -591,7 +587,7 @@
dc = DataConstructor c a (replicate a anonId) tySc
a = Set.size ps + arrowArity ty
pty@(PredType ps ty) = classDictConstrPredType vEnv clsEnv cls
- tySc = ForAllExist 1 0 pty
+ tySc = ForAll 1 pty
bindDefaultMethods :: ModuleIdent -> QualIdent -> [(Ident, Int)] -> ValueEnv
-> ValueEnv
@@ -675,10 +671,9 @@
internalError "Dictionary.dictTransTypeInfo: type variable"
dictTransDataConstr :: DataConstr -> DataConstr
-dictTransDataConstr (DataConstr c n ps tys) =
- DataConstr c n emptyPredSet $ map dictType (Set.toAscList ps) ++ tys
-dictTransDataConstr (RecordConstr c n ps _ tys) =
- dictTransDataConstr $ DataConstr c n ps tys
+dictTransDataConstr (DataConstr c tys) = DataConstr c tys
+dictTransDataConstr (RecordConstr c _ tys) =
+ dictTransDataConstr $ DataConstr c tys
-- For the same reason as in 'bindClassEntities' it is safe to use 'fromMaybe 0'
-- in 'dictTransClassMethod'. Note that type classes are removed anyway in the
@@ -693,13 +688,13 @@
dictTransValues = fmap dictTransValueInfo
dictTransValueInfo :: ValueInfo -> ValueInfo
-dictTransValueInfo (DataConstructor c a ls (ForAllExist n n' pty)) =
- DataConstructor c a' ls' $ ForAllExist n n' $ predType ty
+dictTransValueInfo (DataConstructor c a ls (ForAll n pty)) =
+ DataConstructor c a' ls' $ ForAll n $ predType ty
where a' = arrowArity ty
ls' = replicate (a' - a) anonId ++ ls
ty = transformPredType pty
-dictTransValueInfo (NewtypeConstructor c l (ForAllExist n n' pty)) =
- NewtypeConstructor c l (ForAllExist n n' (predType (unpredType pty)))
+dictTransValueInfo (NewtypeConstructor c l (ForAll n pty)) =
+ NewtypeConstructor c l (ForAll n (predType (unpredType pty)))
dictTransValueInfo (Value f cm a (ForAll n pty)) =
Value f False a' $ ForAll n $ predType ty
where a' = a + if cm then 1 else arrowArity ty - arrowArity (unpredType pty)
@@ -798,12 +793,11 @@
internalError $ "Dictionary.dictTrans: " ++ show d
dictTransConstrDecl :: [Ident] -> ConstrDecl -> DataConstr -> ConstrDecl
-dictTransConstrDecl tvs (ConstrDecl p evs _ c tes) dc =
- ConstrDecl p evs [] c $ map (fromType $ tvs ++ evs ++ bvs) tys
- where DataConstr _ _ _ tys = dictTransDataConstr dc
- bvs = nub $ bv tes
-dictTransConstrDecl tvs (ConOpDecl p evs cx ty1 op ty2) dc =
- dictTransConstrDecl tvs (ConstrDecl p evs cx op [ty1, ty2]) dc
+dictTransConstrDecl tvs (ConstrDecl p c tes) dc =
+ ConstrDecl p c $ map (fromType $ tvs ++ bvs) (constrTypes dc)
+ where bvs = nub $ bv tes
+dictTransConstrDecl tvs (ConOpDecl p ty1 op ty2) dc =
+ dictTransConstrDecl tvs (ConstrDecl p op [ty1, ty2]) dc
dictTransConstrDecl _ d _ = internalError $ "Dictionary.dictTrans: " ++ show d
instance DictTrans Equation where
@@ -1160,18 +1154,8 @@
ms = classMethods qcls clsEnv
dictTransIConstrDecl :: ModuleIdent -> [Ident] -> ConstrDecl -> ConstrDecl
-dictTransIConstrDecl m tvs (ConstrDecl p evs cx c tys) =
- ConstrDecl p evs [] c $ transformIContext m (tvs ++ evs) cx ++ tys
-dictTransIConstrDecl m tvs (ConOpDecl p evs cx ty1 op ty2) =
- dictTransIConstrDecl m tvs (ConstrDecl p evs cx op [ty1, ty2])
-dictTransIConstrDecl m tvs (RecordDecl p evs cx c fs) =
- RecordDecl p evs [] c $
- map toFieldDecl (transformIContext m (tvs ++ evs) cx) ++ fs
- where toFieldDecl = FieldDecl NoSpanInfo [anonId]
-
-transformIContext :: ModuleIdent -> [Ident] -> Context -> [TypeExpr]
-transformIContext m tvs cx =
- map (fromQualType m tvs . dictType) (Set.toAscList $ toQualPredSet m tvs cx)
+dictTransIConstrDecl _ _ (ConOpDecl p ty1 op ty2) = ConstrDecl p op [ty1, ty2]
+dictTransIConstrDecl _ _ cd = cd
iFunctionDeclFromValue :: ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue m vEnv f = case qualLookupValue f vEnv of
@@ -1183,10 +1167,9 @@
iConstrDeclFromDataConstructor :: ModuleIdent -> ValueEnv -> QualIdent
-> ConstrDecl
iConstrDeclFromDataConstructor m vEnv c = case qualLookupValue c vEnv of
- [DataConstructor _ _ _ (ForAllExist n n' pty)] ->
- ConstrDecl NoSpanInfo evs [] (unqualify c) tys
- where evs = take n' $ drop n identSupply
- tys = map (fromQualType m identSupply) $ arrowArgs $ unpredType pty
+ [DataConstructor _ _ _ (ForAll _ pty)] ->
+ ConstrDecl NoSpanInfo (unqualify c) tys
+ where tys = map (fromQualType m identSupply) $ arrowArgs $ unpredType pty
_ -> internalError $ "Dictionary.iConstrDeclFromDataConstructor: " ++ show c
-- -----------------------------------------------------------------------------
@@ -1322,8 +1305,8 @@
conType :: QualIdent -> ValueEnv -> TypeScheme
conType c vEnv = case qualLookupValue c vEnv of
- [DataConstructor _ _ _ (ForAllExist n _ pty)] -> ForAll n pty
- [NewtypeConstructor _ _ (ForAllExist n _ pty)] -> ForAll n pty
+ [DataConstructor _ _ _ (ForAll n pty)] -> ForAll n pty
+ [NewtypeConstructor _ _ (ForAll n pty)] -> ForAll n pty
_ -> internalError $ "Dictionary.conType: " ++ show c
funType :: QualIdent -> ValueEnv -> TypeScheme
@@ -1334,8 +1317,8 @@
opType :: QualIdent -> ValueEnv -> TypeScheme
opType op vEnv = case qualLookupValue op vEnv of
- [DataConstructor _ _ _ (ForAllExist n _ pty)] -> ForAll n pty
- [NewtypeConstructor _ _ (ForAllExist n _ pty)] -> ForAll n pty
+ [DataConstructor _ _ _ (ForAll n pty)] -> ForAll n pty
+ [NewtypeConstructor _ _ (ForAll n pty)] -> ForAll n pty
[Value _ _ _ tySc] -> tySc
[Label _ _ tySc] -> tySc
_ -> internalError $ "Dictionary.opType " ++ show op
diff --git a/src/Transformations/Qual.hs b/src/Transformations/Qual.hs
--- a/src/Transformations/Qual.hs
+++ b/src/Transformations/Qual.hs
@@ -86,12 +86,12 @@
qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds
qConstrDecl :: Qual ConstrDecl
-qConstrDecl (ConstrDecl p vs cx n tys) =
- flip (ConstrDecl p vs) n <$> qContext cx <*> mapM qTypeExpr tys
-qConstrDecl (ConOpDecl p vs cx ty1 op ty2) =
- ConOpDecl p vs <$> qContext cx <*> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2
-qConstrDecl (RecordDecl p vs cx c fs) =
- flip (RecordDecl p vs) c <$> qContext cx <*> mapM qFieldDecl fs
+qConstrDecl (ConstrDecl p n tys) =
+ ConstrDecl p n <$> mapM qTypeExpr tys
+qConstrDecl (ConOpDecl p ty1 op ty2) =
+ ConOpDecl p <$> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2
+qConstrDecl (RecordDecl p c fs) =
+ RecordDecl p c <$> mapM qFieldDecl fs
qNewConstrDecl :: Qual NewConstrDecl
qNewConstrDecl (NewConstrDecl p n ty)
diff --git a/test/TestFrontend.hs b/test/TestFrontend.hs
--- a/test/TestFrontend.hs
+++ b/test/TestFrontend.hs
@@ -243,6 +243,13 @@
)
, ("TypeError1", ["Type error in explicitly typed expression"])
, ("TypeError2", ["Missing instance for Prelude.Num Prelude.Bool"])
+ , ("TypeSigTooGeneral",
+ [ "Type signature too general"
+ , "Function: h"
+ , "Type signature too general"
+ , "Function: g'"
+ ]
+ )
]
--------------------------------------------------------------------------------