Make frontend compile again

src/Base/Expr.hs

@@ -94,6 +94,8 @@ instance QualExpr Expression where
   qfv _ (Constructor           _) = []
   qfv m (Paren                 e) = qfv m e
   qfv m (Typed               e _) = qfv m e
+  qfv m (Record             _ fs) = qfv m fs
+  qfv m (RecordUpdate       e fs) = qfv m e ++ qfv m fs
   qfv m (Tuple              _ es) = qfv m es
   qfv m (List               _ es) = qfv m es
   qfv m (ListCompr        _ e qs) = foldr (qfvStmt m) (qfv m e) qs
@@ -111,8 +113,6 @@ instance QualExpr Expression where
   qfv m (Do                sts e) = foldr (qfvStmt m) (qfv m e) sts
   qfv m (IfThenElse   _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
   qfv m (Case         _ _ e alts) = qfv m e ++ qfv m alts
-  qfv m (RecordConstr       _ fs) = qfv m fs
-  qfv m (RecordUpdate       e fs) = qfv m e ++ qfv m fs
 
 qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
 qfvStmt m st fvs = qfv m st ++ filterBv st fvs
@@ -147,13 +147,13 @@ instance QuantExpr Pattern where
   bv (ConstructorPattern  _ ts) = bv ts
   bv (InfixPattern     t1 _ t2) = bv t1 ++ bv t2
   bv (ParenPattern           t) = bv t
+  bv (RecordPattern       _ fs) = bv fs
   bv (TuplePattern        _ ts) = bv ts
   bv (ListPattern         _ ts) = bv ts
   bv (AsPattern            v t) = v : bv t
   bv (LazyPattern          _ t) = bv t
   bv (FunctionPattern     _ ts) = nub $ bv ts
   bv (InfixFuncPattern t1 _ t2) = nub $ bv t1 ++ bv t2
-  bv (RecordPattern       _ fs) = bv fs
 
 instance QualExpr Pattern where
   qfv _ (LiteralPattern          _) = []
@@ -162,6 +162,7 @@ instance QualExpr Pattern where
   qfv m (ConstructorPattern   _ ts) = qfv m ts
   qfv m (InfixPattern      t1 _ t2) = qfv m [t1, t2]
   qfv m (ParenPattern            t) = qfv m t
+  qfv m (RecordPattern        _ fs) = qfv m fs
   qfv m (TuplePattern         _ ts) = qfv m ts
   qfv m (ListPattern          _ ts) = qfv m ts
   qfv m (AsPattern            _ ts) = qfv m ts
@@ -170,7 +171,6 @@ instance QualExpr Pattern where
     = maybe [] return (localIdent m f) ++ qfv m ts
   qfv m (InfixFuncPattern t1 op t2)
     = maybe [] return (localIdent m op) ++ qfv m [t1, t2]
-  qfv m (RecordPattern        _ fs) = qfv m fs
 
 instance Expr TypeExpr where
   fv (ConstructorType _ tys) = fv tys

src/Base/TopEnv.hs

@@ -163,5 +163,5 @@ allLocalBindings :: TopEnv a -> [(QualIdent, a)]
 allLocalBindings (TopEnv env) = [ (x, y) | (x, ys)    <- Map.toList env
                                          , (Local, y) <- ys ]
 
-allEntities :: TopEnv a -> [(QualIdent, a)]
-allEntities env = [ (x, y) | (x, ys) <- Map.toList env, (_, y) <- ys]
+allEntities :: TopEnv a -> [a]
+allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys]

src/Base/TypeSubst.hs

@@ -54,10 +54,10 @@ instance SubstType ExistTypeScheme where
     ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
 
 instance SubstType ValueInfo where
-  subst _     dc@(DataConstructor  _ _ _) = dc
-  subst _     nc@(NewtypeConstructor _ _) = nc
-  subst theta (Value              v a ty) = Value v a (subst theta ty)
-  subst theta (Label              l r ty) = Label l r (subst theta ty)
+  subst _     dc@(DataConstructor  _ _ _ _) = dc
+  subst _     nc@(NewtypeConstructor _ _ _) = nc
+  subst theta (Value                v a ty) = Value v a (subst theta ty)
+  subst theta (Label                l r ty) = Label l r (subst theta ty)
 
 instance SubstType a => SubstType (TopEnv a) where
   subst = fmap . subst

src/Base/Types.hs

@@ -21,7 +21,8 @@ module Base.Types
     Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply
   , typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType
     -- * Representation of Data Constructors
-  , DataConstr (..), constrIdent, tupleData
+  , DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes
+  , tupleData
     -- * Representation of Quantification
   , TypeScheme (..), ExistTypeScheme (..), monoType, polyType
     -- * Predefined types
@@ -180,7 +181,7 @@ unqualifyType _ skol@(TypeSkolem      _) = skol
 
 -- The type 'DataConstr' is used to represent value or record constructors
 -- introduced by data or newtype declarations.
-data DataConstr = DataConstr Ident Int [Type]
+data DataConstr = DataConstr   Ident Int [Type]
                 | RecordConstr Ident Int [Ident] [Type]
     deriving (Eq, Show)
 
@@ -188,6 +189,18 @@ constrIdent :: DataConstr -> Ident
 constrIdent (DataConstr     c _ _) = c
 constrIdent (RecordConstr c _ _ _) = c
 
+constrTypes :: DataConstr -> [Type]
+constrTypes (DataConstr     _ _ ty) = ty
+constrTypes (RecordConstr _ _ _ ty) = ty
+
+recLabels :: DataConstr -> [Ident]
+recLabels (DataConstr      _ _ _) = []
+recLabels (RecordConstr _ _ ls _) = ls
+
+recLabelTypes :: DataConstr -> [Type]
+recLabelTypes (DataConstr       _ _ _) = []
+recLabelTypes (RecordConstr _ _ _ tys) = tys
+
 -- We support two kinds of quantifications of types here, universally
 -- quantified type schemes (forall alpha . tau(alpha)) and universally
 -- and existentially quantified type schemes

src/Base/Typing.hs

@@ -11,7 +11,7 @@
 
 -}
 
-module Base.Typing (Typeable (..), argumentTypes) where
+module Base.Typing (Typeable (..)) where
 
 import Control.Monad
 import qualified Control.Monad.State as S (State, evalState, gets, modify)
@@ -25,9 +25,7 @@ import Base.Types
 import Base.TypeSubst
 import Base.Utils (foldr2)
 
-import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
-import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue
-                 , conType)
+import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
 
 -- During the transformation of Curry source code into the intermediate
 -- language, the compiler has to recompute the types of expressions. This
@@ -92,16 +90,12 @@ import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue
 
 data TcState = TcState
   { valueEnv  :: ValueEnv
-  , tyConsEnv :: TCEnv
   , typeSubst :: TypeSubst
   , nextId    :: Int
   }
 
 type TCM = S.State TcState
 
-getTyConsEnv :: TCM TCEnv
-getTyConsEnv = S.gets tyConsEnv
-
 getValueEnv :: TCM ValueEnv
 getValueEnv = S.gets valueEnv
 
@@ -117,12 +111,12 @@ getNextId = do
   S.modify $ \ s -> s { nextId = succ nid }
   return nid
 
-run :: TCM a -> ValueEnv -> TCEnv -> a
-run m tyEnv tcEnv = S.evalState m initState
-  where initState = TcState tyEnv tcEnv idSubst 0
+run :: TCM a -> ValueEnv -> a
+run m tyEnv = S.evalState m initState
+  where initState = TcState tyEnv idSubst 0
 
 class Typeable a where
-  typeOf :: ValueEnv -> TCEnv -> a -> Type
+  typeOf :: ValueEnv -> a -> Type
 
 instance Typeable Ident where
   typeOf = computeType identType
@@ -136,8 +130,8 @@ instance Typeable Expression where
 instance Typeable Rhs where
   typeOf = computeType rhsType
 
-computeType :: (a -> TCM Type) -> ValueEnv -> TCEnv -> a -> Type
-computeType f tyEnv tcEnv x = normalize (run doComputeType tyEnv tcEnv)
+computeType :: (a -> TCM Type) -> ValueEnv -> a -> Type
+computeType f tyEnv x = normalize (run doComputeType tyEnv)
   where
     doComputeType = do
       ty    <- f x
@@ -276,7 +270,7 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
 fieldType :: (a -> TCM Type) -> Type -> Field a -> TCM Type
 fieldType tcheck ty (Field _ l x) = do
   tyEnv <- getValueEnv
-  TypeArrow ty1 ty2 <- instType (labelType l tyEnv)
+  TypeArrow ty1 ty2 <- instUniv (labelType l tyEnv)
   unify ty ty1
   lty <- tcheck x
   unify ty2 lty
@@ -294,11 +288,6 @@ instType n ty = do
   tys <- replicateM n freshTypeVar
   return (expandAliasType tys ty)
 
-instType' :: Int -> Type -> TCM (Type,[Type])
-instType' n ty = do
-  tys <- replicateM n freshTypeVar
-  return (expandAliasType tys ty, tys)
-
 instUniv :: TypeScheme -> TCM Type
 instUniv (ForAll n ty) = instType n ty
 
@@ -357,24 +346,6 @@ unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
 unifyTypes ty1 ty2 _ = internalError $
   "Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")"
 
--- The function argumentTypes returns the labels and the argument types
--- of a data constructor instantiated at a particular type. This
--- function is useful for desugaring record patterns and expressions,
--- where the compiler must compute the types of the omitted arguments.
--- Since the type annotation of record patterns and expressions applies
--- to the pattern or expression as a whole, the instance type is
--- unified with the constructor's result type and the resulting
--- substitution is applied to all argument types. Note that this is
--- sound because record fields cannot have existentially quantified
--- types and therefore all type variables appearing in their
--- types occur in the constructor's result type as well.
-
-argumentTypes :: TCEnv -> Type -> QualIdent -> ValueEnv -> ([Ident],[Type])
-argumentTypes tcEnv ty c tyEnv =
-  (ls, map (subst (unifyTypes rty ty idSubst)) tys)
-  where (ls, ForAllExist _ _ ty') = conType c tyEnv
-        (tys, rty) = arrowUnapply ty'
-        
 -- The functions 'constrType', 'varType', and 'funType' are used for computing
 -- the type of constructors, pattern variables, and variables.
 
@@ -396,7 +367,7 @@ funType f tyEnv = case qualLookupValue f tyEnv of
   [Value _ _ sigma] -> sigma
   _ -> internalError $ "Base.Typing.funType: " ++ show f
 
-labelType :: Ident -> ValueEnv -> TypeScheme
-labelType l tyEnv = case lookupValue l tyEnv of
+labelType :: QualIdent -> ValueEnv -> TypeScheme
+labelType l tyEnv = case qualLookupValue l tyEnv of
   [Label _ _ sigma] -> sigma
   _ -> internalError $ "Base.Typing.labelType: " ++ show l

src/Checks.hs

@@ -57,8 +57,7 @@ syntaxCheck :: Monad m => Check m Module
 syntaxCheck opts (env, mdl)
   | null msgs = ok (env { extensions = exts }, mdl')
   | otherwise = failMessages msgs
-  where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env)
-                                                   (tyConsEnv env) mdl
+  where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env) mdl
 
 -- |Check the precedences of infix operators.
 --

src/Checks/ExportCheck.hs

@@ -5,7 +5,7 @@ import           Control.Monad              (unless)
 import qualified Control.Monad.State as S   (State, runState, gets, modify)
 import           Data.List                  (nub, union)
 import qualified Data.Map            as Map
-import           Data.Maybe                 (catMaybes, fromMaybe)
+import           Data.Maybe                 (fromMaybe)
 import qualified Data.Set            as Set
 
 import Curry.Base.Ident
@@ -136,7 +136,7 @@ expandTypeWith tc xs = do
   case qualLookupTC tc tcEnv of
     [] -> report (errUndefinedType tc) >> return []
     [t@(DataType _ _ cs)]    -> do
-      mapM_ (checkElement (concatMap visibleElems (catMaybes cs))) xs'
+      mapM_ (checkElement (concatMap visibleElems cs)) xs'
       return [ExportTypeWith (origName t) xs']
     [t@(RenamingType _ _ c)] -> do
       mapM_ (checkElement (visibleElems c)) xs'
@@ -250,21 +250,25 @@ exportType t = ExportTypeWith tc xs
 -- in the interface, we convert an individual export of a label @l@ into
 -- the form @T(l)@ whenever its type @T@ occurs in the export list as well.
 
-canonExports ::  [Export] -> [Export]
-canonExports es = map (canonExport (canonLabels tcEnv es)) es
+canonExports :: TCEnv -> [Export] -> [Export]
+canonExports tcEnv es = map (canonExport (canonLabels tcEnv es)) es
 
 canonExport :: Map.Map QualIdent Export -> Export -> Export
 canonExport ls (Export x)             = fromMaybe (Export x) (Map.lookup x ls)
 canonExport _  (ExportTypeWith tc xs) = ExportTypeWith tc xs
+canonExport _  e                      = internalError $
+  "Checks.ExportCheck.canonExport: " ++ show e
 
 canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export
 canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv)
-  where tcs = [tc | ExportTypeWith tc _ <- es]
-        bindLabels t ls
-          | tc `elem` tcs = foldr (bindLabel tc) ls (elements t)
-          | otherwise     = ls
-        where tc = origName t
-        bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x])
+  where
+    tcs = [tc | ExportTypeWith tc _ <- es]
+    bindLabels t ls
+      | tc' `elem` tcs = foldr (bindLabel tc') ls (elements t)
+      | otherwise     = ls
+        where
+          tc'            = origName t
+          bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x])
 
 -- The expanded list of exported entities may contain duplicates. These
 -- are removed by the function joinExports. In particular, this
@@ -299,7 +303,7 @@ joinFun export                _ = internalError $
 -- constrs (AliasType _ _ _)  = []
 
 elements :: TypeInfo -> [Ident]
-elements (DataType    _ _ cs) = concatMap visibleElems $ catMaybes cs
+elements (DataType    _ _ cs) = concatMap visibleElems cs
 elements (RenamingType _ _ c) = visibleElems c
 elements (AliasType    _ _ _) = []
 
@@ -320,9 +324,9 @@ errUndefinedType :: QualIdent -> Message
 errUndefinedType tc = posMessage tc $ hsep $ map text
   ["Type", qualName tc, "in export list is not defined"]
   
-errUndefinedElement :: Ident -> Ident -> Message
+errUndefinedElement :: QualIdent -> Ident -> Message
 errUndefinedElement tc c = posMessage c $ hsep $ map text
-  [ idName c, "is not a constructor or label of type ", idName tc ]
+  [ idName c, "is not a constructor or label of type ", qualName tc ]
 
 errModuleNotImported :: ModuleIdent -> Message
 errModuleNotImported m = posMessage m $ hsep $ map text

src/Checks/InterfaceCheck.hs

@@ -49,7 +49,7 @@ module Checks.InterfaceCheck (interfaceCheck) where
 
 import           Control.Monad            (unless)
 import qualified Control.Monad.State as S
-import           Data.Maybe               (catMaybes, fromMaybe)
+import           Data.Maybe               (fromMaybe)
 
 import Curry.Base.Ident
 import Curry.Base.Position
@@ -156,7 +156,7 @@ checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do
 checkConstrImport tc tvs (RecordDecl p evs c fs) = do
   m <- getModuleIdent
   let qc = qualifyLike tc c
-      (ls, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
+      (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels]
       checkConstr (DataConstructor c' _ ls' (ForAllExist uqvs eqvs ty')) =
         qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' &&
         toQualTypes m tvs tys == arrowArgs ty'

src/Checks/InterfaceSyntaxCheck.hs

@@ -25,8 +25,6 @@ module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where
 import           Control.Monad            (liftM, liftM2)
 import qualified Control.Monad.State as S
 import           Data.List                (nub, partition)
-import           Data.Maybe               (catMaybes)
-import qualified Data.Traversable    as T (mapM)
 
 import Base.Expr
 import Base.Messages (Message, posMessage, internalError)
@@ -63,16 +61,13 @@ intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s')
 -- The latter must not occur in type expressions in interfaces.
 
 bindType :: IDecl -> TypeEnv -> TypeEnv
-bindType (IInfixDecl       _ _ _ _) = id
-bindType (HidingDataDecl    _ tc _) = qualBindTopEnv tc (Data tc [])
-bindType (IDataDecl      _ tc _ cs) = qualBindTopEnv tc
-                                      (Data tc (map constr (catMaybes cs)))
-  where constr (ConstrDecl    _ _ c _) = c
-        constr (ConOpDecl  _ _ _ op _) = op
-bindType (INewtypeDecl   _ tc _ nc) = qualBindTopEnv tc (Data tc [nconstr nc])
-  where nconstr (NewConstrDecl _ _ c _) = c
-bindType (ITypeDecl       _ tc _ _) = qualBindTopEnv tc (Alias tc)
-bindType (IFunctionDecl    _ _ _ _) = id
+bindType (IInfixDecl         _ _ _ _) = id
+bindType (HidingDataDecl      _ tc _) = qualBindTopEnv tc (Data tc [])
+bindType (IDataDecl      _ tc _ cs _) = qualBindTopEnv tc
+                                      (Data tc (map constrId cs))
+bindType (INewtypeDecl   _ tc _ nc _) = qualBindTopEnv tc (Data tc [nconstrId nc])
+bindType (ITypeDecl         _ tc _ _) = qualBindTopEnv tc (Alias tc)
+bindType (IFunctionDecl      _ _ _ _) = id
 
 -- The checks applied to the interface are similar to those performed
 -- during syntax checking of type expressions.
@@ -82,18 +77,30 @@ checkIDecl (IInfixDecl  p fix pr op) = return (IInfixDecl p fix pr op)
 checkIDecl (HidingDataDecl p tc tvs) = do
   checkTypeLhs tvs
   return (HidingDataDecl p tc tvs)
-checkIDecl (IDataDecl p tc tvs cs) = do
+checkIDecl (IDataDecl p tc tvs cs hs) = do
   checkTypeLhs tvs
-  liftM (IDataDecl p tc tvs) (mapM (T.mapM (checkConstrDecl tvs)) cs)
-checkIDecl (INewtypeDecl p tc tvs nc) = do
+  checkHidden tc (cons ++ labels) hs
+  cs' <- mapM (checkConstrDecl tvs) cs
+  return $ IDataDecl p tc tvs cs' hs
+  where cons   = map constrId cs
+        labels = nub $ concatMap recordLabels cs
+checkIDecl (INewtypeDecl p tc tvs nc hs) = do
   checkTypeLhs tvs
-  liftM (INewtypeDecl p tc tvs) (checkNewConstrDecl tvs nc)
+  checkHidden tc (con : labels) hs
+  nc' <- checkNewConstrDecl tvs nc
+  return $ INewtypeDecl p tc tvs nc' hs
+  where con    = nconstrId nc
+        labels = nrecordLabels nc
 checkIDecl (ITypeDecl p tc tvs ty) = do
   checkTypeLhs tvs
   liftM (ITypeDecl p tc tvs) (checkClosedType tvs ty)
 checkIDecl (IFunctionDecl p f n ty) =
   liftM (IFunctionDecl p f n) (checkType ty)
 
+checkHidden :: QualIdent -> [Ident] -> [Ident] -> ISC ()
+checkHidden tc csls hs =
+  mapM_ (report . errNoElement tc) $ nub $ filter (`notElem` csls) hs
+
 checkTypeLhs :: [Ident] -> ISC ()
 checkTypeLhs tvs = do
   tyEnv <- getTypeEnv
@@ -120,7 +127,7 @@ checkConstrDecl tvs (RecordDecl p evs c fs) = do
 
 checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl
 checkFieldDecl tvs (FieldDecl p ls ty) =
-  liftM (FieldDecl p ls ty) (checkClosedType tvs ty)
+  liftM (FieldDecl p ls) (checkClosedType tvs ty)
 
 checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl
 checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
@@ -187,3 +194,9 @@ errUnboundVariable tv = posMessage tv $
 errBadTypeSynonym :: QualIdent -> Message
 errBadTypeSynonym tc = posMessage tc $ text "Synonym type"
                     <+> text (qualName tc) <+> text "in interface"
+
+errNoElement :: QualIdent -> Ident -> Message
+errNoElement tc x = posMessage tc $ hsep $ map text
+  [ "Hidden constructor or label ", escName x
+  , " is not defined for type ", qualName tc
+  ]
\ No newline at end of file

src/Checks/KindCheck.hs

@@ -54,7 +54,7 @@ import Env.TypeConstructor (TCEnv, tcArity)
 kindCheck :: TCEnv -> Module -> (Module, [Message])
 kindCheck tcEnv mdl@(Module _ m _ _ ds) =
   case findMultiples $ map typeConstr tds of
-    []  -> runKCM (mapM checkModule mdl) state
+    []  -> runKCM (checkModule mdl) state
     tss -> (mdl, map errMultipleDeclaration tss)
   where tds   = filter isTypeDecl ds
         kEnv  = foldr (bindKind m) (fmap tcArity tcEnv) tds
@@ -104,7 +104,7 @@ qualLookupKind :: QualIdent -> KindEnv -> [Int]
 qualLookupKind = qualLookupTopEnv
 
 checkModule :: Module -> KCM Module
-checkModule (Module ps m es is ds) = Module ps m es is `liftM` mapM checkDecl ds
+checkModule (Module ps m es is ds) = Module ps m es is <$> mapM checkDecl ds
 
 -- When type declarations are checked, the compiler will allow anonymous
 -- type variables on the left hand side of the declaration, but not on
@@ -156,7 +156,7 @@ checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
   evs' <- checkTypeLhs evs
   ty'  <- checkClosedType (evs' ++ tvs) ty
   return $ NewConstrDecl p evs' c ty'
-checkNewConstrDecl tvs (NewRecordDecl p evs c (l, ty))
+checkNewConstrDecl tvs (NewRecordDecl p evs c (l, ty)) = do
   evs' <- checkTypeLhs evs
   ty'  <- checkClosedType (evs' ++ tvs) ty
   return $ NewRecordDecl p evs' c (l, ty')

src/Checks/PrecCheck.hs

@@ -33,7 +33,7 @@ import Curry.Syntax
 
 import Base.Expr
 import Base.Messages (Message, posMessage)
-import Base.Utils (constrId, findDouble)
+import Base.Utils (findDouble)
 
 import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
   , mkPrec, qualLookupP)

src/Checks/SyntaxCheck.hs

@@ -26,11 +26,10 @@
 module Checks.SyntaxCheck (syntaxCheck) where
 
 import Control.Applicative                ((<$>), (<*>))
-import Control.Monad                      ( forM_, unless, when)
+import Control.Monad                      (unless, when)
 import qualified Control.Monad.State as S (State, runState, gets, modify)
-import Data.List                          ((\\), insertBy, intersect, nub, partition)
-import Data.Maybe                         ( fromJust, isJust, isNothing
-                                          , maybeToList)
+import Data.List                          (insertBy, intersect, nub, partition)
+import Data.Maybe                         (isJust, isNothing)
 import qualified Data.Set as Set          (empty, insert, member)
 
 import Curry.Base.Ident
@@ -42,10 +41,8 @@ import Curry.Syntax.Pretty (ppPattern)
 import Base.Expr
 import Base.Messages (Message, posMessage, internalError)
 import Base.NestEnv
-import Base.Types
 import Base.Utils    ((++!), findDouble, findMultiples)
 
-import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
 import Env.Value           (ValueEnv, ValueInfo (..))
 
 import CompilerOpts
@@ -59,15 +56,15 @@ import CompilerOpts
 -- generated. Finally, all declarations are checked within the resulting
 -- environment. In addition, this process will also rename the local variables.
 
-syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module
+syntaxCheck :: Options -> ValueEnv -> Module
             -> ((Module, [KnownExtension]), [Message])
-syntaxCheck opts tyEnv tcEnv mdl@(Module _ m _ _ ds) =
-  case findMultiples $ concatMap constrId tds of
+syntaxCheck opts tyEnv mdl@(Module _ m _ _ ds) =
+  case findMultiples $ concatMap constrs tds of
     []  -> runSC (checkModule mdl) state
     css -> ((mdl, exts), map errMultipleDataConstructor css)
   where
     tds   = filter isTypeDecl ds
-    rEnv  = globalEnv $ fmap (renameInfo tcEnv) tyEnv
+    rEnv  = globalEnv $ fmap renameInfo tyEnv
     state = initState exts m rEnv
     exts  = optExtensions opts
 
@@ -206,10 +203,10 @@ ppRenameInfo (LocalVar     n _) = text (escName      n)
 -- Furthermore, it is not allowed to declare a label more than once.
 
 renameInfo :: ValueInfo -> RenameInfo
-renameInfo (DataConstructor    qid a  _) = Constr      qid a
-renameInfo (NewtypeConstructor qid    _) = Constr      qid 1
-renameInfo (Value              qid a  _) = GlobalVar   qid a
-renameInfo (Label              qid cs _) = RecordLabel qid cs
+renameInfo (DataConstructor    qid a  _ _) = Constr      qid a
+renameInfo (NewtypeConstructor qid    _ _) = Constr      qid 1
+renameInfo (Value              qid a    _) = GlobalVar   qid a
+renameInfo (Label              qid cs   _) = RecordLabel qid cs
 
 bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv
 bindGlobal m c r = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r
@@ -221,7 +218,7 @@ bindLocal = bindNestEnv
 
 -- |Bind type constructor information and record label information
 bindTypeDecl :: Decl -> SCM ()
-bindTypeDecl (DataDecl    _ _ _ cs) = mapM_ bindConstr cs >> bindLabels cs
+bindTypeDecl (DataDecl    _ _ _ cs) = mapM_ bindConstr cs >> bindRecordLabels cs
 bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
 bindTypeDecl _                      = return ()
 
@@ -234,7 +231,6 @@ bindConstr (ConOpDecl _ _ _ op _) = do
   modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2)
 bindConstr (RecordDecl _ _ c fs)  = do
   m <- getModuleIdent
-  mapM_ bindRecordLabel labels
   modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) (length labels))
     where labels = [l | FieldDecl _ ls _ <- fs, l <- ls]
 
@@ -251,10 +247,10 @@ bindRecordLabels :: [ConstrDecl] -> SCM ()
 bindRecordLabels cs =
   mapM_ bindRecordLabel [(l, constr l) | l <- nub (concatMap recordLabels cs)]
   where constr l = [constrId c | c <- cs, l `elem` recordLabels c]
-  
+
 bindRecordLabel :: (Ident, [Ident]) -> SCM ()
 bindRecordLabel (l, cs) = do
-  m <- getModuleIdent
+  m   <- getModuleIdent
   new <- (null . lookupVar l) <$> getRenameEnv
   unless new $ report $ errDuplicateDefinition l
   modifyRenameEnv $ bindGlobal m l $
@@ -331,7 +327,7 @@ checkModule (Module ps m es is ds) = do
   ds' <- (tds ++) <$> checkTopDecls vds
   exts <- getExtensions
   return (Module ps m es is ds', exts)
-  where (tds, vds) = partition isTypeDecl decls
+  where (tds, vds) = partition isTypeDecl ds
 
 checkPragma :: ModulePragma -> SCM ()
 checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
@@ -505,8 +501,9 @@ checkDeclRhs _   d                      = return d
 
 -- jrt: added for Haskell's record syntax
 checkDeclLabels :: ConstrDecl -> SCM ConstrDecl
-checkDeclLabels rd@(RecordDecl p evs c fs) = do
-  onJust (report . errDuplicateLabel "declaration") (findDouble labels)
+checkDeclLabels rd@(RecordDecl _ _ _ fs) = do
+  onJust (report . errDuplicateLabel "declaration")
+         (findDouble $ map qualify labels)
   return rd
   where
     onJust = maybe (return ())
@@ -550,6 +547,8 @@ checkParenPattern o (InfixPattern     t1 op t2) =
   ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
 checkParenPattern _ (ParenPattern            t) =
   checkParenPattern Nothing t
+checkParenPattern _ (RecordPattern        _ fs) =
+  concatMap (\(Field _ _ t) -> checkParenPattern Nothing t) fs
 checkParenPattern _ (TuplePattern         _ ts) =
   concatMap (checkParenPattern Nothing) ts
 checkParenPattern _ (ListPattern          _ ts) =
@@ -563,8 +562,6 @@ checkParenPattern _ (FunctionPattern      _ ts) =
 checkParenPattern o (InfixFuncPattern t1 op t2) =
   maybe [] (\c -> [(c, op)]) o
   ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
-checkParenPattern _ (RecordPattern        _ fs) =
-  concatMap (\(Field _ _ t) -> checkParenPattern Nothing t) fs
 
 checkPattern :: Position -> Pattern -> SCM Pattern
 checkPattern _ (LiteralPattern        l) =
@@ -580,6 +577,8 @@ checkPattern p (InfixPattern   t1 op t2) =
   checkInfixPattern p t1 op t2
 checkPattern p (ParenPattern          t) =
   ParenPattern <$> checkPattern p t
+checkPattern p (RecordPattern      c fs) =
+  checkRecordPattern p c fs
 checkPattern p (TuplePattern     pos ts) =
   TuplePattern pos <$> mapM (checkPattern p) ts
 checkPattern p (ListPattern      pos ts) =
@@ -588,8 +587,6 @@ checkPattern p (AsPattern           v t) = do
   AsPattern <$> checkVar "@ pattern" v <*> checkPattern p t
 checkPattern p (LazyPattern       pos t) =
   LazyPattern pos <$> checkPattern p t
-checkPattern p (RecordPattern      c fs) =
-  checkRecordPattern p c fs
 checkPattern _ (FunctionPattern     _ _) = internalError $
   "SyntaxCheck.checkPattern: function pattern not defined"
 checkPattern _ (InfixFuncPattern  _ _ _) = internalError $
@@ -669,7 +666,7 @@ checkRecordPattern p c fs = do
   case qualLookupVar c env of
     [Constr c' _] -> processRecPat (Just c') fs
     rs            -> case qualLookupVar (qualQualify m c) env of