Commit a54fc8ec authored by Fredrik Wieczerkowski's avatar Fredrik Wieczerkowski

Re-add support for 'Data' and fix remaining errors

parent b0bacc0b
......@@ -43,6 +43,7 @@ checkDerivable m tcEnv cs cls
| ocls == qEnumId && not (isEnum cs) = [errNotEnum cls]
| ocls == qBoundedId && not (isBounded cs) = [errNotBounded cls]
| ocls `notElem` derivableClasses = [errNotDerivable ocls]
| ocls == qDataId = [errNoDataDerive ocls]
| otherwise = []
where ocls = getOrigName m cls tcEnv
......@@ -53,7 +54,7 @@ derivableClasses = [qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId]
-- where all data constructors are constants.
isEnum :: [ConstrDecl] -> Bool
isEnum cs = all ((0 ==) . constrArity) cs
isEnum = all ((0 ==) . constrArity)
-- Instances of 'Bounded' can be derived only for enumerations and for single
-- constructor types.
......@@ -88,6 +89,12 @@ errNotDerivable :: QualIdent -> Message
errNotDerivable cls = posMessage cls $ hsep $ map text
["Instances of type class", escQualName cls, "cannot be derived"]
errNoDataDerive :: QualIdent -> Message
errNoDataDerive qcls = posMessage qcls $ hsep $ map text
[ "Instances of type class"
, escQualName qcls
, "are automatically derived if possible"]
errNotEnum :: HasPosition a => a -> Message
errNotEnum p = posMessage p $
text "Instances for Enum can be derived only for enumeration types"
......
This diff is collapsed.
......@@ -334,14 +334,14 @@ errNoElement what for tc x = posMessage tc $ hsep $ map text
errIllegalSimpleConstraint :: Constraint -> Message
errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat
[ text "Illegal class constraint" <+> ppConstraint c
[ text "Illegal class constraint" <+> pPrint c
, text "Constraints in class and instance declarations must be of"
, text "the form C u, where C is a type class and u is a type variable."
]
errIllegalInstanceType :: Position -> InstanceType -> Message
errIllegalInstanceType p inst = posMessage p $ vcat
[ text "Illegal instance type" <+> ppInstanceType inst
[ text "Illegal instance type" <+> pPrint inst
, text "The instance type must be of the form (T u_1 ... u_n),"
, text "where T is not a type synonym and u_1, ..., u_n are"
, text "mutually distinct, non-anonymous type variables."
......
......@@ -341,7 +341,7 @@ bindKind m tcEnv' _ tcEnv (TypeDecl _ tc tvs ty) =
bindTypeConstructor aliasType tc tvs Nothing ty' tcEnv
where
aliasType tc' k = AliasType tc' k $ length tvs
ty' = expandMonoType m tcEnv' clsEnv tvs ty
ty' = expandMonoType m tcEnv' tvs ty
bindKind m tcEnv' clsEnv tcEnv (ClassDecl _ _ _ cls tv ds) =
bindTypeClass cls (concatMap mkMethods ds) tcEnv
where
......@@ -444,7 +444,7 @@ kcDecl tcEnv (NewtypeDecl _ tc tvs nc _) = do
kcNewConstrDecl tcEnv' nc
kcDecl tcEnv t@(TypeDecl p tc tvs ty) = do
(k, tcEnv') <- bindTypeVars tc tvs tcEnv
kcType tcEnv' p "type declaration" (ppDecl t) k ty
kcType tcEnv' p "type declaration" (pPrint t) k ty
kcDecl tcEnv (TypeSig p _ qty) = kcTypeSig tcEnv p qty
kcDecl tcEnv (FunctionDecl _ _ _ eqs) = mapM_ (kcEquation tcEnv) eqs
kcDecl _ (ExternalDecl _ _) = ok
......@@ -473,23 +473,23 @@ kcConstrDecl tcEnv d@(ConstrDecl p _ tys) = do
mapM_ (kcValueType tcEnv p what doc) tys
where
what = "data constructor declaration"
doc = ppConstr d
doc = pPrint d
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
doc = pPrint d
kcConstrDecl tcEnv (RecordDecl _ _ fs) = do
mapM_ (kcFieldDecl tcEnv) fs
kcFieldDecl :: TCEnv -> FieldDecl -> KCM ()
kcFieldDecl tcEnv d@(FieldDecl p _ ty) =
kcValueType tcEnv p "field declaration" (ppFieldDecl d) ty
kcValueType tcEnv p "field declaration" (pPrint d) ty
kcNewConstrDecl :: TCEnv -> NewConstrDecl -> KCM ()
kcNewConstrDecl tcEnv d@(NewConstrDecl p _ ty) =
kcValueType tcEnv p "newtype constructor declaration" (ppNewConstr d) ty
kcValueType tcEnv p "newtype constructor declaration" (pPrint d) ty
kcNewConstrDecl tcEnv (NewRecordDecl p _ (l, ty)) =
kcFieldDecl tcEnv (FieldDecl p [l] ty)
......@@ -578,7 +578,7 @@ kcConstraint tcEnv p sc@(Constraint _ qcls ty) = do
m <- getModuleIdent
kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty
where
doc = ppConstraint sc
doc = pPrint sc
kcTypeSig :: HasPosition p => TCEnv -> p -> QualTypeExpr -> KCM ()
kcTypeSig tcEnv p (QualTypeExpr _ cx ty) = do
......@@ -587,7 +587,7 @@ kcTypeSig tcEnv p (QualTypeExpr _ cx ty) = do
kcValueType tcEnv' p "type signature" doc ty
where
free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty
doc = ppTypeExpr 0 ty
doc = pPrintPrec 0 ty
kcValueType :: HasPosition p => TCEnv -> p -> String -> Doc -> TypeExpr -> KCM ()
kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar
......@@ -597,7 +597,7 @@ kcType tcEnv p what doc k ty = do
k' <- kcTypeExpr tcEnv p "type expression" doc' 0 ty
unify p what (doc $-$ text "Type:" <+> doc') k k'
where
doc' = ppTypeExpr 0 ty
doc' = pPrintPrec 0 ty
kcTypeExpr :: HasPosition p => TCEnv -> p -> String -> Doc -> Int -> TypeExpr -> KCM Kind
kcTypeExpr tcEnv p _ _ n (ConstructorType _ tc) = do
......@@ -611,9 +611,9 @@ kcTypeExpr tcEnv p _ _ n (ConstructorType _ tc) = do
_ -> return $ tcKind m tc tcEnv
kcTypeExpr tcEnv p what doc n (ApplyType _ ty1 ty2) = do
(alpha, beta) <- kcTypeExpr tcEnv p what doc (n + 1) ty1 >>=
kcArrow p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty1)
kcArrow p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty1)
kcTypeExpr tcEnv p what doc 0 ty2 >>=
unify p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty2) alpha
unify p what (doc $-$ text "Type:" <+> pPrintPrec 0 ty2) alpha
return beta
kcTypeExpr tcEnv _ _ _ _ (VariableType _ tv) = return (varKind tv tcEnv)
kcTypeExpr tcEnv p what doc _ (TupleType _ tys) = do
......
......@@ -51,7 +51,6 @@ import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (pPrintPrec)
import Base.Expr
import Base.Messages (Message, internalError, posMessage)
......@@ -369,7 +368,7 @@ bindRecordLabels cs =
bindRecordLabel :: (Ident, [Ident]) -> SCM ()
bindRecordLabel (l, cs) = do
m <- getModuleIdent
new <- (null . lookupVar l) <$> getRenameEnv
new <- null . lookupVar l <$> getRenameEnv
unless new $ report $ errDuplicateDefinition l
modifyRenameEnv $ bindGlobal False m l $
RecordLabel (qualifyWith m l) (map (qualifyWith m) cs)
......@@ -384,7 +383,7 @@ bindFuncDecl tcc m (FunctionDecl _ _ f (eq:_)) env
= let arty = length $ snd $ getFlatLhs eq
in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env
bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ _ ty)) env
= foldr bindTS env $ map (qualifyWith m) fs
= foldr (bindTS . qualifyWith m) env fs
where
bindTS qf env'
| null $ qualLookupVar qf env'
......@@ -414,8 +413,7 @@ bindVarDecl (FunctionDecl _ _ f eqs) env
| otherwise = let arty = length $ snd $ getFlatLhs $ head eqs
in bindLocal (unRenameIdent f) (LocalVar f arty) env
bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t)
bindVarDecl (FreeDecl _ vs) env =
foldr bindVar env (map varIdent vs)
bindVarDecl (FreeDecl _ vs) env = foldr (bindVar . varIdent) env vs
bindVarDecl _ env = env
bindVar :: Ident -> RenameEnv -> RenameEnv
......@@ -476,7 +474,7 @@ checkFuncPatDeps = do
fps <- getFuncPats
deps <- getGlobalDeps
let levels = scc (:[])
(\k -> Set.toList (Map.findWithDefault (Set.empty) k deps))
(\k -> Set.toList (Map.findWithDefault Set.empty k deps))
(Map.keys deps)
levelMap = Map.fromList [ (f, l) | (fs, l) <- zip levels [1 ..], f <- fs ]
level f = Map.findWithDefault (0 :: Int) f levelMap
......@@ -782,7 +780,7 @@ checkPattern _ (LiteralPattern spi a l) =
checkPattern _ (NegativePattern spi a l) =
return $ NegativePattern spi a l
checkPattern p (VariablePattern spi a v)
| isAnonId v = (VariablePattern spi a . renameIdent v) <$> newId
| isAnonId v = VariablePattern spi a . renameIdent v <$> newId
| otherwise = checkConstructorPattern p spi (qualify v) []
checkPattern p (ConstructorPattern spi _ c ts) =
checkConstructorPattern p spi c ts
......@@ -802,9 +800,9 @@ checkPattern p (LazyPattern spi t) = do
t' <- checkPattern p t
banFPTerm "lazy pattern" p t'
return (LazyPattern spi t')
checkPattern _ (FunctionPattern _ _ _ _) = internalError $
checkPattern _ (FunctionPattern _ _ _ _) = internalError
"SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError $
checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError
"SyntaxCheck.checkPattern: infix function pattern not defined"
checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()]
......@@ -971,7 +969,7 @@ checkVariable spi a v
-- anonymous free variable
| isAnonId (unqualify v) = do
checkAnonFreeVarsExtension $ getPosition v
(\n -> Variable spi a $ updQualIdent id (flip renameIdent n) v) <$> newId
(\n -> Variable spi a $ updQualIdent id (`renameIdent` n) v) <$> newId
-- return $ Variable v
-- normal variable
| otherwise = do
......@@ -1172,7 +1170,7 @@ recLabels _ = []
-- it is necessary to sort the list of declarations.
sortFuncDecls :: [Decl a] -> [Decl a]
sortFuncDecls decls = sortFD Set.empty [] decls
sortFuncDecls = sortFD Set.empty []
where
sortFD _ res [] = reverse res
sortFD env res (decl : decls') = case decl of
......@@ -1283,12 +1281,12 @@ opAnnotation (InfixConstr a _) = a
errUnsupportedFPTerm :: String -> Position -> Pattern a -> Message
errUnsupportedFPTerm s p pat = posMessage p $ text s
<+> text "patterns are not supported inside a functional pattern."
$+$ ppPattern 0 pat
$+$ pPrintPrec 0 pat
errUnsupportedFuncPattern :: String -> Position -> Pattern a -> Message
errUnsupportedFuncPattern s p pat = posMessage p $
text "Functional patterns are not supported inside a" <+> text s <> dot
$+$ ppPattern 0 pat
$+$ pPrintPrec 0 pat
errFuncPatNotGlobal :: QualIdent -> Message
errFuncPatNotGlobal f = posMessage f $ hsep $ map text
......
This diff is collapsed.
......@@ -208,12 +208,12 @@ instance Rename (Decl a) where
rename decl = return decl
instance Rename ConstrDecl where
rename (ConstrDecl p c tys) = withLocalEnv $ do
ConstrDecl p <$> pure c <*> rename tys
rename (ConOpDecl p ty1 op ty2) = withLocalEnv $ do
rename (ConstrDecl p c tys) = withLocalEnv $
ConstrDecl p c <$> rename tys
rename (ConOpDecl p ty1 op ty2) = withLocalEnv $
ConOpDecl p <$> rename ty1 <*> pure op <*> rename ty2
rename (RecordDecl p c fs) = withLocalEnv $ do
RecordDecl p <$> pure c <*> rename fs
rename (RecordDecl p c fs) = withLocalEnv $
RecordDecl p c <$> rename fs
instance Rename FieldDecl where
rename (FieldDecl p ls ty) = FieldDecl p ls <$> rename ty
......@@ -312,9 +312,7 @@ bindVars :: [Ident] -> TSCM ()
bindVars = mapM_ bindVar
lookupVar :: Ident -> TSCM (Maybe Ident)
lookupVar tv = do
env <- getRenameEnv
return $ Map.lookup tv env
lookupVar tv = Map.lookup tv <$> getRenameEnv
-- When type declarations are checked, the compiler will allow anonymous
-- type variables on the left hand side of the declaration, but not on
......@@ -332,19 +330,19 @@ checkDecl :: Decl a -> TSCM (Decl a)
checkDecl (DataDecl p tc tvs cs clss) = do
checkTypeLhs tvs
cs' <- mapM (checkConstrDecl tvs) cs
mapM_ checkClass clss
mapM_ (checkClass False) clss
return $ DataDecl p tc tvs cs' clss
checkDecl (NewtypeDecl p tc tvs nc clss) = do
checkTypeLhs tvs
nc' <- checkNewConstrDecl tvs nc
mapM_ checkClass clss
mapM_ (checkClass False) clss
return $ NewtypeDecl p tc tvs nc' clss
checkDecl (TypeDecl p tc tvs ty) = do
checkTypeLhs tvs
ty' <- checkClosedType tvs ty
return $ TypeDecl p tc tvs ty'
checkDecl (TypeSig p vs ty) =
TypeSig p vs <$> checkClosedTypeSig [] ty
checkDecl (TypeSig p vs qty) =
TypeSig p vs <$> checkQualType qty
checkDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$>
mapM checkEquation eqs
checkDecl (PatternDecl p t rhs) = PatternDecl p t <$> checkRhs rhs
......@@ -428,7 +426,7 @@ checkTypeVars :: String -> [Ident] -> TSCM ()
checkTypeVars _ [] = ok
checkTypeVars what (tv : tvs) = do
unless (isAnonId tv) $ do
isTypeConstrOrClass <- (not . null . lookupTypeKind tv) <$> getTypeEnv
isTypeConstrOrClass <- not . null . lookupTypeKind tv <$> getTypeEnv
when isTypeConstrOrClass $ report $ errNoVariable tv what
when (tv `elem` tvs) $ report $ errNonLinear tv what
checkTypeVars what tvs
......@@ -526,7 +524,7 @@ checkContext = mapM checkConstraint
checkConstraint :: Constraint -> TSCM Constraint
checkConstraint c@(Constraint spi qcls ty) = do
checkClass qcls
checkClass False qcls
ty' <- checkType ty
unless (isVariableType $ rootType ty') $ report $ errIllegalConstraint c
return $ Constraint spi qcls ty'
......@@ -534,16 +532,22 @@ checkConstraint c@(Constraint spi qcls ty) = do
rootType (ApplyType _ ty' _) = ty'
rootType ty' = ty'
checkClass :: QualIdent -> TSCM ()
checkClass qcls = do
checkClass :: Bool -> QualIdent -> TSCM ()
checkClass isInstDecl qcls = do
m <- getModuleIdent
tEnv <- getTypeEnv
case qualLookupTypeKind qcls tEnv of
[] -> report $ errUndefinedClass qcls
[Class _ _] -> ok
[Class c _]
| c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $
errIllegalDataInstance qcls
| otherwise -> ok
[_] -> report $ errUndefinedClass qcls
tks -> case qualLookupTypeKind (qualQualify m qcls) tEnv of
[Class _ _] -> ok
[Class c _]
| c == qDataId -> when (isInstDecl && m /= preludeMIdent) $ report $
errIllegalDataInstance qcls
| otherwise -> ok
[_] -> report $ errUndefinedClass qcls
_ -> report $ errAmbiguousIdent qcls $ map origName tks
......@@ -667,8 +671,8 @@ errNonLinear tv what = posMessage tv $ hsep $ map text
[ "Type variable", idName tv, "occurs more than once in", what ]
errNoVariable :: Ident -> String -> Message
errNoVariable tv what = posMessage tv $ hsep $ map text $
[ "Type constructor or type class identifier", idName tv, "used in", what ]
errNoVariable tv what = posMessage tv $ hsep $ map text
["Type constructor or type class identifier", idName tv, "used in", what]
errUnboundVariable :: Ident -> Message
errUnboundVariable tv = posMessage tv $ hsep $ map text
......@@ -695,3 +699,10 @@ errIllegalInstanceType p inst = posMessage p $ vcat
, text "where T is not a type synonym and u_1, ..., u_n are"
, text "mutually distinct, non-anonymous type variables."
]
errIllegalDataInstance :: QualIdent -> Message
errIllegalDataInstance qcls = posMessage qcls $ vcat
[ text "Illegal instance of" <+> ppQIdent qcls
, text "Instances of this class cannot be defined."
, text "Instead, they are automatically derived if possible."
]
......@@ -43,7 +43,7 @@ import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Utils (typeVariables)
import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent, ppConstraint)
import Curry.Syntax.Pretty (pPrint)
import Base.CurryTypes (ppTypeScheme, fromPred, toPredSet)
import Base.Messages (Message, posMessage, internalError)
......@@ -70,7 +70,6 @@ import CompilerOpts
-- - overlapping case alternatives
-- - non-adjacent function rules
-- - wrong case mode
-- - redundant context
warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv
-> Module a -> [Message]
warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
......@@ -81,7 +80,6 @@ warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
checkMissingTypeSignatures ds
checkModuleAlias is
checkCaseMode ds
checkRedContext ds
where Module _ _ _ mid es is ds = fmap (const ()) mdl
type ScopeEnv = NestEnv IdInfo
......@@ -949,9 +947,9 @@ warnMissingPattern p loc pats = posMessage p
ppExPat (ps, cs)
| null cs = ppPats
| otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs)
where ppPats = hsep (map (ppPattern 2) ps)
ppCons (i, lits) = ppIdent i <+> text "`notElem`"
<+> ppExpr 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits))
where ppPats = hsep (map (pPrintPrec 2) ps)
ppCons (i, lits) = pPrint i <+> text "`notElem`"
<+> pPrintPrec 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits))
-- |Warning message for unreachable patterns.
-- To shorten the output only the first 'maxPattern' are printed,
......@@ -1473,147 +1471,6 @@ isDataDeclName CaseModeGoedel (x:_) | isAlpha x = isUpper x
isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x
isDataDeclName _ _ = True
-- ---------------------------------------------------------------------------
-- Warn for redundant context
-- ---------------------------------------------------------------------------
--traverse the AST for QualTypeExpr/Context and check for redundancy
checkRedContext :: [Decl a] -> WCM ()
checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl
getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet
getRedPredSet m cenv tcEnv ps =
Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup
where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps
qualifyAndAddPred p@(Pred qid ty) (ps', pm') =
let qp = Pred (getOrigName m qid tcEnv) ty
in (Set.insert qp ps', Map.insert qp p pm')
getPredFromContext :: Context -> ([Ident], PredSet)
getPredFromContext cx =
let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx
in (vs, toPredSet vs cx)
checkRedContext' :: (Pred -> Message) -> PredSet -> WCM ()
checkRedContext' f ps = do
m <- gets moduleId
cenv <- gets classEnv
tcEnv <- gets tyConsEnv
mapM_ (report . f) (getRedPredSet m cenv tcEnv ps)
checkRedContextDecl :: Decl a -> WCM ()
checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) =
checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs
checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs
checkRedContextDecl (ClassDecl _ _ cx i _ ds) = do
checkRedContext'
(warnRedContext (text ("class declaration " ++ escName i)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (InstanceDecl _ _ cx qid _ ds) = do
checkRedContext'
(warnRedContext (text ("instance declaration " ++ escQualName qid)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (DataDecl _ _ _ cs _) = mapM_ checkRedContextConstrDecl cs
checkRedContextDecl _ = return ()
checkRedContextConstrDecl :: ConstrDecl -> WCM ()
checkRedContextConstrDecl (ConstrDecl _ _ cx idt _ ) =
checkRedContext'
(warnRedContext (text ("constructor declaration " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextConstrDecl (ConOpDecl _ _ cx _ idt _) =
checkRedContext'
(warnRedContext (text ("constructor operator " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextConstrDecl (RecordDecl _ _ cx idt _ ) =
checkRedContext'
(warnRedContext (text ("record declaration " ++ escName idt)) vs)
ps
where (vs, ps) = getPredFromContext cx
checkRedContextEq :: Equation a -> WCM ()
checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs
checkRedContextRhs :: Rhs a -> WCM ()
checkRedContextRhs (SimpleRhs _ _ e ds) = do
checkRedContextExpr e
mapM_ checkRedContextDecl ds
checkRedContextRhs (GuardedRhs _ _ cs ds) = do
mapM_ checkRedContextCond cs
mapM_ checkRedContextDecl ds
checkRedContextCond :: CondExpr a -> WCM ()
checkRedContextCond (CondExpr _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr :: Expression a -> WCM ()
checkRedContextExpr (Paren _ e) = checkRedContextExpr e
checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do
checkRedContextExpr e
checkRedContext' (warnRedContext (text "type signature") vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (RecordUpdate _ e fs) = do
checkRedContextExpr e
mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (Tuple _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (ListCompr _ e sts) = do
checkRedContextExpr e
mapM_ checkRedContextStmt sts
checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e
checkRedContextExpr (EnumFromThen _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromTo _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e
checkRedContextExpr (Apply _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (InfixApply _ e1 _ e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (LeftSection _ e _) = checkRedContextExpr e
checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e
checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e
checkRedContextExpr (Let _ _ ds e) = do
mapM_ checkRedContextDecl ds
checkRedContextExpr e
checkRedContextExpr (IfThenElse _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (Case _ _ _ e as) = do
checkRedContextExpr e
mapM_ checkRedContextAlt as
checkRedContextExpr _ = return ()
checkRedContextStmt :: Statement a -> WCM ()
checkRedContextStmt (StmtExpr _ e) = checkRedContextExpr e
checkRedContextStmt (StmtDecl _ _ ds) = mapM_ checkRedContextDecl ds
checkRedContextStmt (StmtBind _ _ e) = checkRedContextExpr e
checkRedContextAlt :: Alt a -> WCM ()
checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs
checkRedContextFieldExpr :: Field (Expression a) -> WCM ()
checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e
-- ---------------------------------------------------------------------------
-- Warnings messages
-- ---------------------------------------------------------------------------
......@@ -1627,7 +1484,7 @@ warnRedFuncString is = text "type signature for function" <>
warnRedContext :: Doc -> [Ident] -> Pred -> Message
warnRedContext d vs p@(Pred qid _) = posMessage qid $
text "Redundant context in" <+> d <> colon <+>
quotes (ppConstraint $ fromPred vs p) -- idents use ` ' as quotes not ' '
quotes (pPrint $ fromPred vs p) -- idents use ` ' as quotes not ' '
-- seperate a list by ', '
csep :: [Doc] -> Doc
......
......@@ -266,9 +266,9 @@ values m (IFunctionDecl _ f Nothing a qty) =
[Value (qualQualify m f) Nothing a (typeScheme (toQualPredType m [] qty))]
values m (IFunctionDecl _ f (Just tv) _ qty) =
let mcls = case qty of
ContextType _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $
find (\(Constraint _ _ ty) -> isVar ty) ctx
_ -> Nothing
QualTypeExpr _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $
find (\(Constraint _ _ ty) -> isVar ty) ctx
_ -> Nothing
in [Value (qualQualify m f) mcls 0 (typeScheme (toQualPredType m [tv] qty))]
where
isVar (VariableType _ i) = i == tv
......
......@@ -96,7 +96,7 @@ compileModule opts m fn = do
writeAST opts (fst mdl, fmap (const ()) (snd mdl))
writeShortAST opts (fst qmdl, fmap (const ()) (snd qmdl))
mdl' <- expandExports opts mdl
qmdl' <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'
qmdl' <- dumpWith opts CS.showModule pPrint DumpQualified $ qual mdl'
writeAbstractCurry opts qmdl'
-- generate interface file
let intf = uncurry exportInterface qmdl'
......@@ -251,7 +251,7 @@ checkModule opts mdl = do
where
dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a)
-> m (CompEnv (CS.Module a))
dumpCS = dumpWith opts CS.showModule CS.ppModule
dumpCS = dumpWith opts CS.showModule pPrint
-- ---------------------------------------------------------------------------
-- Translating a module
......@@ -275,7 +275,7 @@ transModule opts mdl = do
remNT = optDesugarNewtypes optOpts
dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a)
-> CYIO (CompEnv (CS.Module a))
dumpCS = dumpWith opts CS.showModule CS.ppModule
dumpCS = dumpWith opts CS.showModule pPrint
dumpIL = dumpWith opts IL.showModule IL.ppModule
-- ---------------------------------------------------------------------------
......@@ -332,7 +332,7 @@ writeInterface opts env intf@(CS.Interface m _ _)
interfaceFile = interfName (filePath env)
outputInterface = liftIO $ writeModule
(addCurrySubdirModule (optUseSubdir opts) m interfaceFile)
(show $ CS.ppInterface intf)
(show $ pPrint intf)
matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface ifn i = do
......@@ -344,11 +344,11 @@ matchInterface ifn i = do
writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO ()
writeFlat opts env mdl il = do
(_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg)
(_, tfc) <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg)
when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tafcyProg
when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tfc
when fcyTarget $ do
(_, fc) <- dumpWith opts show FC.ppProg DumpFlatCurry (env, fcyProg)
(_, fc) <- dumpWith opts show pPrint DumpFlatCurry (env, fcyProg)
liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc
writeFlatIntf opts env fcyProg
where
......
......@@ -16,6 +16,7 @@ module Transformations.Derive (derive) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (replicateM)
import qualified Control.Monad.State as S (State, evalState, gets, modify)
import Data.List (intercalate, intersperse)
import Data.Maybe (fromJust, isJust)
......@@ -50,9 +51,8 @@ type DVM = S.State DVState
derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType
-> Module PredType
derive tcEnv vEnv inEnv pEnv (Module spi li ps m es is ds) =
Module spi li ps m es is $
ds ++ concat (S.evalState (mapM deriveInstances tds) initState)
derive tcEnv vEnv inEnv pEnv (Module spi li ps m es is ds) = Module spi li ps m es is $
ds ++ concat (S.evalState (deriveAllInstances tds) initState)
where tds = filter isTypeDecl ds
initState = DVState m tcEnv vEnv inEnv pEnv 1
......@@ -81,6 +81,35 @@ getNextId = do
type ConstrInfo = (Int, QualIdent, Maybe [Ident], [Type])
deriveAllInstances :: [Decl PredType] -> DVM [[Decl PredType]]
deriveAllInstances ds = do
derived <- mapM deriveInstances ds
inst <- getInstEnv
mid <- getModuleIdent
let dds = filter (hasDataInstance inst mid) ds
datains <- mapM deriveDataInstance dds
return (datains:derived)
-- If we ever entered a data instance for this datatype into the instance
-- environment, we can safely derive a data instance
hasDataInstance :: InstEnv -> ModuleIdent -> Decl PredType -> Bool
hasDataInstance inst mid (DataDecl _ tc _ _ _) =
maybe False (\(mid', _, _) -> mid == mid') $
lookupInstInfo (qDataId, qualifyWith mid tc) inst
hasDataInstance inst mid (NewtypeDecl _ tc _ _ _) =
maybe False (\(mid', _, _) -> mid == mid') $
lookupInstInfo (qDataId, qualifyWith mid tc) inst
hasDataInstance _ _ _ =
False
deriveDataInstance :: Decl PredType -> DVM (Decl PredType)
deriveDataInstance (DataDecl p tc tvs _ _) =
head <$> deriveInstances (DataDecl p tc tvs [] [qDataId])
deriveDataInstance (NewtypeDecl p tc tvs _ _) =
deriveDataInstance $ DataDecl p tc tvs [] []
deriveDataInstance _ =
internalError "Derive.deriveDataInstance: No DataDel"