Skip to content

GitLab

Commit 69d91016 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Make frontend compile again

parent 78887d02
Hide whitespace changes
Inline Side-by-side
Showing with 297 additions and 293 deletions
src/Base/Expr.hs
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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
View file @ 69d91016
......@@ -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