Commit bea7dd01 authored by Finn Teegen's avatar Finn Teegen
Browse files

Adapt deriving clauses

parent 21143542
......@@ -114,8 +114,8 @@ ok = return ()
-- and free type constructor and type class identifiers of the declarations.
bt :: Decl a -> [Ident]
bt (DataDecl _ tc _ _) = [tc]
bt (NewtypeDecl _ tc _ _) = [tc]
bt (DataDecl _ tc _ _ _) = [tc]
bt (NewtypeDecl _ tc _ _ _) = [tc]
bt (TypeDecl _ tc _ _) = [tc]
bt (ClassDecl _ _ cls _ _) = [cls]
bt _ = []
......@@ -134,8 +134,8 @@ instance HasType a => HasType (Maybe a) where
instance HasType (Decl a) where
fts _ (InfixDecl _ _ _ _) = id
fts m (DataDecl _ _ _ cs) = fts m cs
fts m (NewtypeDecl _ _ _ nc) = fts m nc
fts m (DataDecl _ _ _ cs clss) = fts m cs . fts m clss
fts m (NewtypeDecl _ _ _ nc clss) = fts m nc . fts m clss
fts m (TypeDecl _ _ _ ty) = fts m ty
fts m (TypeSig _ _ ty) = fts m ty
fts m (FunctionDecl _ _ _ eqs) = fts m eqs
......@@ -233,10 +233,10 @@ instance HasType QualIdent where
-- newtypes, which is checked in the function 'checkNonRecursiveTypes' below.
ft' :: ModuleIdent -> Decl a -> [Ident]
ft' _ (DataDecl _ _ _ _) = []
ft' m (NewtypeDecl _ _ _ nc) = fts m nc []
ft' m (TypeDecl _ _ _ ty) = fts m ty []
ft' _ _ = []
ft' _ (DataDecl _ _ _ _ _) = []
ft' m (NewtypeDecl _ _ _ nc _) = fts m nc []
ft' m (TypeDecl _ _ _ ty) = fts m ty []
ft' _ _ = []
checkNonRecursiveTypes :: [Decl a] -> KCM ()
checkNonRecursiveTypes ds = do
......@@ -246,7 +246,7 @@ checkNonRecursiveTypes ds = do
checkTypeAndNewtypeDecls :: [Decl a] -> KCM ()
checkTypeAndNewtypeDecls [] =
internalError "Checks.KindCheck.checkTypeAndNewtypeDecls: empty list"
checkTypeAndNewtypeDecls [DataDecl _ _ _ _] = ok
checkTypeAndNewtypeDecls [DataDecl _ _ _ _ _] = ok
checkTypeAndNewtypeDecls [d] | isTypeOrNewtypeDecl d = do
m <- getModuleIdent
let tc = typeConstructor d
......@@ -302,7 +302,7 @@ checkClassDecl _ =
-- from the 'MonadFix' type class.
bindKind :: ModuleIdent -> TCEnv -> ClassEnv -> TCEnv -> Decl a -> KCM TCEnv
bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs) = do
bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs _) = do
bindTypeConstructor DataType tc tvs (Just KindStar) (map mkData cs) tcEnv
where
mkData (ConstrDecl _ evs cx c tys) = mkData' evs cx c tys
......@@ -321,7 +321,7 @@ bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs) = do
tvs' = tvs ++ evs
PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys
tys' = arrowArgs ty
bindKind m tcEnv' _ tcEnv (NewtypeDecl _ tc tvs nc) =
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']
......@@ -424,10 +424,10 @@ kcDeclGroup tcEnv clsEnv ds = do
kcDecl :: TCEnv -> Decl a -> KCM ()
kcDecl _ (InfixDecl _ _ _ _) = ok
kcDecl tcEnv (DataDecl _ tc tvs cs) = do
kcDecl tcEnv (DataDecl _ tc tvs cs _) = do
(_, tcEnv') <- bindTypeVars tc tvs tcEnv
mapM_ (kcConstrDecl tcEnv') cs
kcDecl tcEnv (NewtypeDecl _ tc tvs nc) = do
kcDecl tcEnv (NewtypeDecl _ tc tvs nc _) = do
(_, tcEnv') <- bindTypeVars tc tvs tcEnv
kcNewConstrDecl tcEnv' nc
kcDecl tcEnv t@(TypeDecl p tc tvs ty) = do
......@@ -683,16 +683,16 @@ freshKindVar = fresh KindVariable
-- ---------------------------------------------------------------------------
typeConstructor :: Decl a -> Ident
typeConstructor (DataDecl _ tc _ _) = tc
typeConstructor (NewtypeDecl _ tc _ _) = tc
typeConstructor (TypeDecl _ tc _ _) = tc
typeConstructor _ =
typeConstructor (DataDecl _ tc _ _ _) = tc
typeConstructor (NewtypeDecl _ tc _ _ _) = tc
typeConstructor (TypeDecl _ tc _ _ ) = tc
typeConstructor _ =
internalError "Checks.KindCheck.typeConstructor: no type declaration"
isTypeOrNewtypeDecl :: Decl a -> Bool
isTypeOrNewtypeDecl (NewtypeDecl _ _ _ _) = True
isTypeOrNewtypeDecl (TypeDecl _ _ _ _) = True
isTypeOrNewtypeDecl _ = False
isTypeOrNewtypeDecl (NewtypeDecl _ _ _ _ _) = True
isTypeOrNewtypeDecl (TypeDecl _ _ _ _) = True
isTypeOrNewtypeDecl _ = False
-- ---------------------------------------------------------------------------
-- Error messages
......
......@@ -108,9 +108,9 @@ bindPrec m (InfixDecl _ fix mprec ops) pEnv
bindPrec _ _ pEnv = pEnv
boundValues :: Decl a -> [Ident]
boundValues (DataDecl _ _ _ cs) = [ v | c <- cs
boundValues (DataDecl _ _ _ cs _) = [ v | c <- cs
, v <- constrId c : recordLabels c]
boundValues (NewtypeDecl _ _ _ nc) = nconstrId nc : nrecordLabels nc
boundValues (NewtypeDecl _ _ _ nc _) = nconstrId nc : nrecordLabels nc
boundValues (TypeSig _ fs _) = fs
boundValues (FunctionDecl _ _ f _) = [f]
boundValues (ForeignDecl _ _ _ _ f _) = [f]
......
......@@ -318,9 +318,10 @@ bindLocal = bindNestEnv
-- |Bind type constructor information and record label information
bindTypeDecl :: Decl a -> SCM ()
bindTypeDecl (DataDecl _ _ _ cs) = mapM_ bindConstr cs >> bindRecordLabels cs
bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
bindTypeDecl _ = ok
bindTypeDecl (DataDecl _ _ _ cs _) =
mapM_ bindConstr cs >> bindRecordLabels cs
bindTypeDecl (NewtypeDecl _ _ _ nc _) = bindNewConstr nc
bindTypeDecl _ = ok
bindConstr :: ConstrDecl -> SCM ()
bindConstr (ConstrDecl _ _ _ c tys) = do
......@@ -658,8 +659,8 @@ checkDecls bindDecl ds = do
-- -- ---------------------------------------------------------------------------
checkDeclRhs :: [Ident] -> Decl () -> SCM (Decl ())
checkDeclRhs _ (DataDecl p tc tvs cs) =
DataDecl p tc tvs <$> mapM checkDeclLabels cs
checkDeclRhs _ (DataDecl p tc tvs cs clss) =
flip (DataDecl p tc tvs) clss <$> mapM checkDeclLabels cs
checkDeclRhs bvs (TypeSig p vs ty) =
(\vs' -> TypeSig p vs' ty) <$> mapM (checkLocalVar bvs) vs
checkDeclRhs _ (FunctionDecl a p f eqs) =
......@@ -1102,9 +1103,9 @@ checkField check (Field p l x) = Field p l <$> check x
-- ---------------------------------------------------------------------------
constrs :: Decl a -> [Ident]
constrs (DataDecl _ _ _ cs) = map constrId cs
constrs (NewtypeDecl _ _ _ nc) = [nconstrId nc]
constrs _ = []
constrs (DataDecl _ _ _ cs _) = map constrId cs
constrs (NewtypeDecl _ _ _ nc _) = [nconstrId nc]
constrs _ = []
vars :: Decl a -> [Ident]
vars (TypeSig _ fs _) = fs
......@@ -1116,8 +1117,8 @@ vars (FreeDecl _ vs) = bv vs
vars _ = []
recLabels :: Decl a -> [Ident]
recLabels (DataDecl _ _ _ cs) = concatMap recordLabels cs
recLabels (NewtypeDecl _ _ _ nc) = nrecordLabels nc
recLabels (DataDecl _ _ _ cs _) = concatMap recordLabels cs
recLabels (NewtypeDecl _ _ _ nc _) = nrecordLabels nc
recLabels _ = []
-- Since the compiler expects all rules of the same function to be together,
......
......@@ -286,12 +286,12 @@ constrType' tc n =
-- the field label.
checkFieldLabel :: Decl a -> TCM ()
checkFieldLabel (DataDecl _ _ tvs cs) = do
checkFieldLabel (DataDecl _ _ tvs cs _) = do
ls' <- mapM (tcFieldLabel tvs) labels
mapM_ tcFieldLabels (groupLabels ls')
where labels = [(l, p, ty) | RecordDecl _ _ _ _ fs <- cs,
FieldDecl p ls ty <- fs, l <- ls]
checkFieldLabel (NewtypeDecl _ _ tvs (NewRecordDecl p _ (l, ty))) = do
checkFieldLabel (NewtypeDecl _ _ tvs (NewRecordDecl p _ (l, ty)) _) = do
_ <- tcFieldLabel tvs (l, p, ty)
ok
checkFieldLabel _ = ok
......@@ -808,8 +808,10 @@ bindArity v n = bindTopEnv v (Value (qualify v) False n undefined)
-- signature.
tcTopPDecl :: PDecl a -> TCM (PDecl PredType)
tcTopPDecl (i, DataDecl p tc tvs cs) = return (i, DataDecl p tc tvs cs)
tcTopPDecl (i, NewtypeDecl p tc tvs nc) = return (i, NewtypeDecl p tc tvs nc)
tcTopPDecl (i, DataDecl p tc tvs cs clss) =
return (i, DataDecl p tc tvs cs clss)
tcTopPDecl (i, NewtypeDecl p tc tvs nc clss) =
return (i, NewtypeDecl p tc tvs nc clss)
tcTopPDecl (i, TypeDecl p tc tvs ty) = return (i, TypeDecl p tc tvs ty)
tcTopPDecl (i, DefaultDecl p tys) = return (i, DefaultDecl p tys)
tcTopPDecl (i, ClassDecl p cx cls tv ds) = withLocalSigEnv $ do
......
......@@ -127,11 +127,11 @@ ok :: TSCM ()
ok = return ()
bindType :: ModuleIdent -> Decl a -> TypeEnv -> TypeEnv
bindType m (DataDecl _ tc _ cs) = bindTypeKind m tc (Data qtc ids)
bindType m (DataDecl _ tc _ cs _) = bindTypeKind m tc (Data qtc ids)
where
qtc = qualifyWith m tc
ids = map constrId cs ++ nub (concatMap recordLabels cs)
bindType m (NewtypeDecl _ tc _ nc) = bindTypeKind m tc (Data qtc ids)
bindType m (NewtypeDecl _ tc _ nc _) = bindTypeKind m tc (Data qtc ids)
where
qtc = qualifyWith m tc
ids = nconstrId nc : nrecordLabels nc
......@@ -173,12 +173,12 @@ instance Rename a => Rename [a] where
instance Rename (Decl a) where
rename (InfixDecl p fix pr ops) = return $ InfixDecl p fix pr ops
rename (DataDecl p tc tvs cs) = withLocalEnv $ do
rename (DataDecl p tc tvs cs clss) = withLocalEnv $ do
bindVars tvs
DataDecl p tc <$> rename tvs <*> rename cs
rename (NewtypeDecl p tc tvs nc) = withLocalEnv $ do
DataDecl p tc <$> rename tvs <*> rename cs <*> pure clss
rename (NewtypeDecl p tc tvs nc clss) = withLocalEnv $ do
bindVars tvs
NewtypeDecl p tc <$> rename tvs <*> rename nc
NewtypeDecl p tc <$> rename tvs <*> rename nc <*> pure clss
rename (TypeDecl p tc tvs ty) = withLocalEnv $ do
bindVars tvs
TypeDecl p tc <$> rename tvs <*> rename ty
......@@ -310,17 +310,19 @@ checkModule (Module ps m es is ds) = do
return (Module ps m es is ds'', exts)
checkDecl :: Decl a -> TSCM (Decl a)
checkDecl (DataDecl p tc tvs cs) = do
checkDecl (DataDecl p tc tvs cs clss) = do
checkTypeLhs tvs
cs' <- mapM (checkConstrDecl tvs) cs
return $ DataDecl p tc tvs cs'
checkDecl (NewtypeDecl p tc tvs nc) = do
cs' <- mapM (checkConstrDecl tvs) cs
mapM_ checkClass clss
return $ DataDecl p tc tvs cs' clss
checkDecl (NewtypeDecl p tc tvs nc clss) = do
checkTypeLhs tvs
nc' <- checkNewConstrDecl tvs nc
return $ NewtypeDecl p tc tvs nc'
nc' <- checkNewConstrDecl tvs nc
mapM_ checkClass clss
return $ NewtypeDecl p tc tvs nc' clss
checkDecl (TypeDecl p tc tvs ty) = do
checkTypeLhs tvs
ty' <- checkClosedType tvs ty
ty' <- checkClosedType tvs ty
return $ TypeDecl p tc tvs ty'
checkDecl (TypeSig p vs qty) =
TypeSig p vs <$> checkQualType qty
......@@ -583,8 +585,8 @@ checkUsedExtension pos msg ext = do
-- ---------------------------------------------------------------------------
getIdent :: Decl a -> Ident
getIdent (DataDecl _ tc _ _) = tc
getIdent (NewtypeDecl _ tc _ _) = tc
getIdent (DataDecl _ tc _ _ _) = tc
getIdent (NewtypeDecl _ tc _ _ _) = tc
getIdent (TypeDecl _ tc _ _) = tc
getIdent (ClassDecl _ _ cls _ _) = cls
getIdent _ =
......
......@@ -234,7 +234,7 @@ warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text
<+> parens (text "first occurrence at" <+> text (showLine pos))
checkDecl :: Decl () -> WCM ()
checkDecl (DataDecl _ _ vs cs) = inNestedScope $ do
checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do
mapM_ insertTypeVar vs
mapM_ checkConstrDecl cs
reportUnusedTypeVars vs
......@@ -895,7 +895,7 @@ reportUnusedTypeVars vs = warnFor WarnUnusedBindings $ do
-- sides.
insertDecl :: Decl a -> WCM ()
insertDecl (DataDecl _ d _ cs) = do
insertDecl (DataDecl _ d _ cs _) = do
insertTypeConsId d
mapM_ insertConstrDecl cs
insertDecl (TypeDecl _ t _ ty) = do
......
......@@ -137,15 +137,19 @@ trInstanceMethodType ity (QualTypeExpr cx ty) =
toPredType (take 1 identSupply) $ QualTypeExpr (drop 1 cx) ty
trTypeDecl :: Decl a -> GAC [CTypeDecl]
trTypeDecl (DataDecl _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs'])
trTypeDecl (DataDecl _ t vs cs clss) =
(\t' v vs' cs' clss' -> [CType t' v vs' cs' clss'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> mapM trConsDecl cs
<*> mapM trQual clss
trTypeDecl (TypeDecl _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> trTypeExpr ty
trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' nc' -> [CNewType t' v vs' nc'])
trTypeDecl (NewtypeDecl _ t vs nc clss) =
(\t' v vs' nc' clss' -> [CNewType t' v vs' nc' clss'])
<$> trGlobalIdent t <*> getTypeVisibility t
<*> mapM genTVarIndex vs <*> trNewConsDecl nc
<*> mapM trQual clss
trTypeDecl _ = return []
trConsDecl :: ConstrDecl -> GAC CConsDecl
......
......@@ -247,8 +247,8 @@ pragmaCategories = [PragmaLanguage, PragmaOptions, PragmaEnd]
declPos :: Decl a -> Position
declPos (InfixDecl p _ _ _ ) = p
declPos (DataDecl p _ _ _ ) = p
declPos (NewtypeDecl p _ _ _ ) = p
declPos (DataDecl p _ _ _ _ ) = p
declPos (NewtypeDecl p _ _ _ _ ) = p
declPos (TypeDecl p _ _ _ ) = p
declPos (TypeSig p _ _ ) = p
declPos (FunctionDecl p _ _ _ ) = p
......@@ -316,31 +316,33 @@ idsImport mid (ImportTypeAll t) =
-- Declarations
idsDecl :: Decl a -> [Code]
idsDecl (InfixDecl _ _ _ ops) =
idsDecl (InfixDecl _ _ _ ops) =
map (Function FuncInfix False . qualify) ops
idsDecl (DataDecl _ d vs cds) =
idsDecl (DataDecl _ d vs cds clss) =
TypeCons TypeDeclare False (qualify d) :
map (Identifier IdDeclare False . qualify) vs ++ concatMap idsConstrDecl cds
idsDecl (NewtypeDecl _ t vs nc) =
TypeCons TypeDeclare False (qualify t)
: map (Identifier IdDeclare False . qualify) vs ++ idsNewConstrDecl nc
idsDecl (TypeDecl _ t vs ty) =
map (Identifier IdDeclare False . qualify) vs ++
concatMap idsConstrDecl cds ++ map (TypeCons TypeRefer False) clss
idsDecl (NewtypeDecl _ t vs nc clss) =
TypeCons TypeDeclare False (qualify t) :
map (Identifier IdDeclare False . qualify) vs ++ idsNewConstrDecl nc ++
map (TypeCons TypeRefer False) clss
idsDecl (TypeDecl _ t vs ty) =
TypeCons TypeDeclare False (qualify t) :
map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty
idsDecl (TypeSig _ fs qty) =
idsDecl (TypeSig _ fs qty) =
map (Function FuncTypeSig False . qualify) fs ++ idsQualTypeExpr qty
idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs
idsDecl (ForeignDecl _ _ _ _ _ _) = []
idsDecl (ExternalDecl _ fs) =
idsDecl (FunctionDecl _ _ _ eqs) = concatMap idsEquation eqs
idsDecl (ForeignDecl _ _ _ _ _ _) = []
idsDecl (ExternalDecl _ fs) =
map (Function FuncDeclare False . qualify . varIdent) fs
idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs
idsDecl (FreeDecl _ vs) =
idsDecl (PatternDecl _ p rhs) = idsPat p ++ idsRhs rhs
idsDecl (FreeDecl _ vs) =
map (Identifier IdDeclare False . qualify . varIdent) vs
idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys
idsDecl (ClassDecl _ cx c v ds) =
idsDecl (DefaultDecl _ tys) = concatMap idsTypeExpr tys
idsDecl (ClassDecl _ cx c v ds) =
idsContext cx ++ TypeCons TypeDeclare False (qualify c) :
Identifier IdDeclare False (qualify v) : concatMap idsClassDecl ds
idsDecl (InstanceDecl _ cx c ty ds) = idsContext cx ++
idsDecl (InstanceDecl _ cx c ty ds) = idsContext cx ++
TypeCons TypeRefer False c : idsTypeExpr ty ++ concatMap idsInstanceDecl ds
idsConstrDecl :: ConstrDecl -> [Code]
......
......@@ -67,6 +67,7 @@ showToken (Token KW_case _) = "KW_case"
showToken (Token KW_class _) = "KW_class"
showToken (Token KW_data _) = "KW_data"
showToken (Token KW_default _) = "KW_default"
showToken (Token KW_deriving _) = "KW_deriving"
showToken (Token KW_do _) = "KW_do"
showToken (Token KW_else _) = "KW_else"
showToken (Token KW_external _) = "KW_external"
......
......@@ -142,8 +142,8 @@ constrType c = do
-- alias types.
trDecl :: Decl Type -> TransM [IL.Decl]
trDecl (DataDecl _ tc tvs cs) = (:[]) <$> trData tc tvs cs
trDecl (NewtypeDecl _ tc tvs nc) = (:[]) <$> trNewtype tc tvs nc
trDecl (DataDecl _ tc tvs cs _) = (:[]) <$> trData tc tvs cs
trDecl (NewtypeDecl _ tc tvs nc _) = (:[]) <$> trNewtype tc tvs nc
trDecl (ForeignDecl _ cc ie ty f _) = (:[]) <$> trForeign f cc ie ty
trDecl (FunctionDecl p ty f eqs) = (:[]) <$> trFunction p f ty eqs
trDecl _ = return []
......
......@@ -193,16 +193,16 @@ dsClassAndInstanceDecl d = return d
-- Generate selector functions for record labels and replace record
-- constructor declarations by ordinary constructor declarations.
dsRecordDecl :: Decl PredType -> DsM [Decl PredType]
dsRecordDecl (DataDecl p tc tvs cs) = do
dsRecordDecl (DataDecl p tc tvs cs clss) = do
m <- getModuleIdent
let qcs = map (qualifyWith m . constrId) cs
selFuns <- mapM (genSelFun p qcs) (nub $ concatMap recordLabels cs)
return $ DataDecl p tc tvs (map unlabelConstr cs) : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc) = do
return $ DataDecl p tc tvs (map unlabelConstr cs) clss : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc clss) = do
m <- getModuleIdent
let qc = qualifyWith m (nconstrId nc)
selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)
return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) : selFun
return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) clss : selFun
dsRecordDecl d = return [d]
-- Generate a selector function for a single record label
......
......@@ -357,7 +357,7 @@ methodMap ds = [(unRenameIdent f, d) | d@(FunctionDecl _ _ f _) <- ds]
createClassDictDecl :: QualIdent -> Ident -> [Decl a] -> DTM (Decl a)
createClassDictDecl cls tv ds = do
c <- createClassDictConstrDecl cls tv ds
return $ DataDecl NoPos (dictTypeId cls) [tv] [c]
return $ DataDecl NoPos (dictTypeId cls) [tv] [c] []
createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
createClassDictConstrDecl cls tv ds = do
......@@ -749,12 +749,13 @@ instance DictTrans Module where
instance DictTrans Decl where
dictTrans (InfixDecl p fix prec ops) = return $ InfixDecl p fix prec ops
dictTrans (DataDecl p tc tvs cs) = do
dictTrans (DataDecl p tc tvs cs _) = do
m <- getModuleIdent
tcEnv <- getTyConsEnv
let DataType _ _ cs' = head $ qualLookupTypeInfo (qualifyWith m tc) tcEnv
return $ DataDecl p tc tvs $ zipWith (dictTransConstrDecl tvs) cs cs'
dictTrans (NewtypeDecl p tc tvs nc) = return $ NewtypeDecl p tc tvs nc
return $ DataDecl p tc tvs (zipWith (dictTransConstrDecl tvs) cs cs') []
dictTrans (NewtypeDecl p tc tvs nc _) =
return $ NewtypeDecl p tc tvs nc []
dictTrans (TypeDecl p tc tvs ty) = return $ TypeDecl p tc tvs ty
dictTrans (FunctionDecl p pty f eqs) =
FunctionDecl p (transformPredType pty) f <$> mapM dictTrans eqs
......
......@@ -68,8 +68,10 @@ qExport m@(ExportModule _) = return m
qDecl :: Qual (Decl a)
qDecl i@(InfixDecl _ _ _ _) = return i
qDecl (DataDecl p n vs cs) = DataDecl p n vs <$> mapM qConstrDecl cs
qDecl (NewtypeDecl p n vs nc) = NewtypeDecl p n vs <$> qNewConstrDecl nc
qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$>
mapM qConstrDecl cs <*> mapM qClass clss
qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$>
qNewConstrDecl nc <*> mapM qClass clss
qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty
qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty
qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment