curry-frontend 1.0.3 → 1.0.4

raw patch · 35 files changed

+385/−573 lines, 35 filesdep +bytestringdep +file-embeddep +template-haskelldep ~curry-basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, file-embed, template-haskell

Dependency ranges changed: curry-base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• curry-frontend.cabal +15/−7
• data/currysource.css +37/−27
• src/Base/CurryTypes.hs +4/−17
• src/Base/PrettyKinds.hs +1/−1
• src/Base/PrettyTypes.hs +5/−7
• src/Base/TypeExpansion.hs +3/−4
• src/Base/TypeSubst.hs +0/−6
• src/Base/Types.hs +23/−61
• src/Base/Typing.hs +0/−2
• src/Checks/DeriveCheck.hs +5/−15
• src/Checks/ExportCheck.hs +3/−3
• src/Checks/InstanceCheck.hs +11/−11
• src/Checks/InterfaceCheck.hs +14/−14
• src/Checks/InterfaceSyntaxCheck.hs +8/−20
• src/Checks/KindCheck.hs +21/−29
• src/Checks/SyntaxCheck.hs +4/−4
• src/Checks/TypeCheck.hs +45/−105
• src/Checks/TypeSyntaxCheck.hs +15/−31
• src/Checks/WarnCheck.hs +11/−26
• src/CompilerOpts.hs +0/−2
• src/Env/TypeConstructor.hs +2/−2
• src/Env/Value.hs +7/−7
• src/Exports.hs +18/−24
• src/Generators/GenAbstractCurry.hs +9/−8
• src/Html/CurryHtml.hs +24/−24
• src/Html/SyntaxColoring.hs +5/−8
• src/Imports.hs +29/−35
• src/Transformations/CaseCompletion.hs +6/−6
• src/Transformations/CurryToIL.hs +5/−7
• src/Transformations/Derive.hs +4/−4
• src/Transformations/Desugar.hs +7/−7
• src/Transformations/Dictionary.hs +25/−42
• src/Transformations/Qual.hs +6/−6
• test/TestFrontend.hs +7/−0

@@ -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).-

@@ -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

@@ -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    }

@@ -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)

@@ -10,7 +10,7 @@     TODO -}-+{-# OPTIONS_GHC -Wno-orphans #-} module Base.PrettyKinds where  import Curry.Base.Pretty

@@ -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

@@ -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

@@ -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)) 

@@ -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

@@ -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) =

@@ -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

@@ -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

@@ -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         =

@@ -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

@@ -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) =

@@ -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) =

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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"

@@ -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"

@@ -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

@@ -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

@@ -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)

@@ -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   [ "<!DOCTYPE html>"-  , "<html>", "<head>"-  , "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"+  , "<html lang=\"en\">"+  , "<head>"+  , "<meta charset=\"utf-8\" />"+  , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\" />"   , "<title>" ++ titleHtml ++ "</title>"-  , "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ cssFile ++ "\"/>"+  , "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\" />"   , "</head>"   , "<body>"   , "<table><tbody><tr>"-  , "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"-  , "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"+  , "<td class=\"line-numbers\"><pre>" ++ lineHtml ++ "</pre></td>"+  , "<td class=\"source-code\"><pre>" ++ codeHtml ++ "</pre></td>"   , "</tr></tbody></table>"   , "</body>"   , "</html>"

@@ -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) =

@@ -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)

@@ -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]     )

@@ -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) =

@@ -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

@@ -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'

@@ -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

@@ -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)

@@ -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'"+      ]+    )   ]  --------------------------------------------------------------------------------