Commit e7f7ec6e authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Use Pretty class from Curry.Base.Pretty

parent 0097441d
......@@ -19,9 +19,9 @@ module Base.CurryKinds
( toKind, toKind', fromKind, fromKind', ppKind
) where
import Curry.Base.Pretty (Doc)
import Curry.Syntax.Pretty (ppKindExpr)
import Curry.Syntax.Type (KindExpr (..))
import Curry.Base.Pretty (Doc)
import Curry.Syntax.Pretty (pPrintPrec)
import Curry.Syntax.Type (KindExpr (..))
import Base.Kinds
......@@ -42,4 +42,4 @@ fromKind' k n | k == simpleKind n = Nothing
| otherwise = Just (fromKind k)
ppKind :: Kind -> Doc
ppKind = ppKindExpr 0 . fromKind
ppKind = pPrintPrec 0 . fromKind
......@@ -41,7 +41,7 @@ import Curry.Base.Ident
import Curry.Base.Pretty (Doc, list, parens)
import Curry.Base.SpanInfo
import qualified Curry.Syntax as CS
import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr)
import Curry.Syntax.Pretty (pPrint, pPrintPrec)
import Base.Expr
import Base.Messages (internalError)
......@@ -215,13 +215,13 @@ fromQualPredType m tvs = fromPredType tvs . unqualifyType m
-- The following functions implement pretty-printing for types.
ppType :: ModuleIdent -> Type -> Doc
ppType m = ppTypeExpr 0 . fromQualType m identSupply
ppType m = pPrintPrec 0 . fromQualType m identSupply
ppPred :: ModuleIdent -> Pred -> Doc
ppPred m = ppConstraint . fromQualPred m identSupply
ppPred m = pPrint . fromQualPred m identSupply
ppPredSet :: ModuleIdent -> PredSet -> Doc
ppPredSet m = parens . list . map (ppPred m) . Set.toList
ppPredType :: ModuleIdent -> Type -> Doc
ppPredType m = ppTypeExpr 0 . fromQualPredType m identSupply
ppPredType m = pPrintPrec 0 . fromQualPredType m identSupply
......@@ -10,29 +10,25 @@
TODO
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Base.PrettyTypes where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (Set, toAscList)
import Curry.Base.Ident (identSupply)
import Curry.Base.Ident (identSupply)
import Curry.Base.Pretty
import Curry.Syntax.Pretty
import Curry.Syntax.Pretty ()
import Base.CurryTypes
import Base.Types
instance Pretty Type where
pPrint = ppTypeExpr 0 . fromType identSupply
pPrint = pPrintPrec 0 . fromType identSupply
instance Pretty Pred where
pPrint = ppConstraint . fromPred identSupply
pPrint = pPrint . fromPred identSupply
instance Pretty a => Pretty (Set.Set a) where
pPrint = parens . list . map pPrint . Set.toAscList
......
......@@ -14,9 +14,6 @@ variables. An error is generated if one is found. It also ensures that
default-declarations contain no universally quantified type variables or
predicates.
-}
{-# LANGUAGE CPP #-}
module Checks.ImpredCheck (impredCheck) where
import Control.Monad.Extra (allM, unlessM)
......@@ -26,7 +23,7 @@ import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax
import Curry.Syntax.Pretty (ppTypeExpr)
import Curry.Syntax.Pretty ()
import Base.CurryTypes
import Base.Messages (Message, posMessage)
......@@ -157,12 +154,12 @@ checkSimpleType (ForallType _ _ _) = return False
errIllegalPolymorphicType :: Position -> TypeExpr -> Message
errIllegalPolymorphicType p ty = posMessage p $ vcat
[ text "Illegal polymorphic type" <+> ppTypeExpr 0 ty
[ text "Illegal polymorphic type" <+> pPrintPrec 0 ty
, text "Impredicative polymorphism isn't yet supported."
]
errIllegalDefaultType :: Position -> TypeExpr -> Message
errIllegalDefaultType p ty = posMessage p $ vcat
[ text "Illegal polymorphic type:" <+> ppTypeExpr 0 ty
[ text "Illegal polymorphic type:" <+> pPrintPrec 0 ty
, text "When checking the types in a default declaration."
]
......@@ -340,7 +340,7 @@ 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."
]
......
......@@ -442,7 +442,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
......@@ -464,30 +464,30 @@ kcDecl tcEnv (InstanceDecl p cx qcls inst ds) = do
mapM_ (kcDecl tcEnv') ds
where
what = "instance declaration"
doc = ppDecl (InstanceDecl p cx qcls inst [])
doc = pPrint (InstanceDecl p cx qcls inst [])
kcConstrDecl :: TCEnv -> ConstrDecl -> KCM ()
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)
......@@ -576,7 +576,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 -> TypeExpr -> KCM ()
kcTypeSig tcEnv p (ContextType _ cx ty) = do
......@@ -585,13 +585,13 @@ kcTypeSig tcEnv p (ContextType _ 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
kcTypeSig tcEnv p ty = do
tcEnv' <- foldM bindFreshKind tcEnv free
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
......@@ -601,7 +601,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
......@@ -615,9 +615,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,7 @@ import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (ppPattern)
import Curry.Syntax.Pretty (pPrintPrec)
import Base.Expr
import Base.Messages (Message, internalError, posMessage)
......@@ -1279,12 +1279,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
......
......@@ -565,7 +565,7 @@ tcPDecl ps (i, FunctionDecl p _ f eqs) = do
tcPDecl ps (i, d@(PatternDecl p t rhs)) = do
(ps', ty, t') <- tcPattern p t
(ps'', rhs') <- tcRhs (Check ty) rhs >>-
unifyDecl p "pattern declaration" (ppDecl d) (ps `Set.union` ps') ty
unifyDecl p "pattern declaration" (pPrint d) (ps `Set.union` ps') ty
return (ps'', (ty, (i, PatternDecl p t' rhs')))
tcPDecl _ _ = internalError "TypeCheck.tcPDecl"
......@@ -582,7 +582,7 @@ tcFunctionPDecl i ps tySc p f eqs = do
tcEquation :: Type -> PredSet -> Equation a -> TCM (PredSet, Equation Type)
tcEquation ty ps eqn@(Equation p lhs rhs) =
tcEqn ty p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty
tcEqn ty p lhs rhs >>- unifyDecl p "equation" (pPrint eqn) ps ty
tcEqn :: Type -> SpanInfo -> Lhs a -> Rhs a
-> TCM (PredSet, Type, Equation Type)
......@@ -595,7 +595,7 @@ tcEqn tySc p lhs rhs = do
(ps, tys, lhs') <- tcLhs p lhs
(ps', ty, rhs') <- tcRhs (Check resTy') rhs
return (ps, tys, lhs', ps', ty, rhs')
ps'' <- reducePredSet p "equation" (ppEquation (Equation p lhs' rhs'))
ps'' <- reducePredSet p "equation" (pPrint (Equation p lhs' rhs'))
(ps `Set.union` ps')
return (ps'', foldr TypeArrow ty tys, Equation p lhs' rhs')
......@@ -1105,7 +1105,7 @@ tcPattern p t@(ConstructorPattern spi _ c ts) = do
m <- getModuleIdent
vEnv <- getValueEnv
(ps, (tys, ty')) <- liftM (fmap arrowUnapply) (inst (constrType m c vEnv))
(ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t))
(ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (pPrintPrec 0 t))
ps (zip tys ts)
return (ps', ty', ConstructorPattern spi ty' c ts')
tcPattern p (InfixPattern spi a t1 op t2) = do
......@@ -1120,21 +1120,21 @@ tcPattern _ t@(RecordPattern spi _ c fs) = do
vEnv <- getValueEnv
(ps, ty) <- liftM (fmap arrowBase) (inst (constrType m c vEnv))
(ps', fs') <- mapAccumM (tcField tcPattern "pattern"
(\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs
(\t' -> pPrintPrec 0 t $-$ text "Term:" <+> pPrintPrec 0 t') ty) ps fs
return (ps', ty, RecordPattern spi ty c fs')
tcPattern p (TuplePattern spi ts) = do
(pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts
return (Set.unions pss, tupleType tys, TuplePattern spi ts')
tcPattern p t@(ListPattern spi _ ts) = do
ty <- freshTypeVar
(ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty)
(ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (pPrintPrec 0 t)) ty)
emptyPredSet ts
return (ps, listType ty, ListPattern spi (listType ty) ts')
tcPattern p t@(AsPattern spi v t') = do
vEnv <- getValueEnv
let ty = rawPredType (varType v vEnv)
(ps, t'') <- tcPattern p t' >>-
unify p "pattern" (ppPattern 0 t) emptyPredSet ty
unify p "pattern" (pPrintPrec 0 t) emptyPredSet ty
return (ps, ty, AsPattern spi v t'')
tcPattern p (LazyPattern spi t) = do
(ps, ty, t') <- tcPattern p t
......@@ -1143,7 +1143,7 @@ tcPattern p t@(FunctionPattern spi _ f ts) = do
m <- getModuleIdent
vEnv <- getValueEnv
(ps, ty) <- inst (funType m f vEnv)
tcFuncPattern p spi (ppPattern 0 t) f id ps ty ts
tcFuncPattern p spi (pPrintPrec 0 t) f id ps ty ts
tcPattern p (InfixFuncPattern spi a t1 op t2) = do
(ps, ty, t') <- tcPattern p (FunctionPattern spi a op [t1, t2])
let FunctionPattern _ a' op' [t1', t2'] = t'
......@@ -1157,7 +1157,7 @@ tcFuncPattern _ spi _ f ts ps ty [] =
return (ps, ty, FunctionPattern spi ty f (ts []))
tcFuncPattern p spi doc f ts ps ty (t':ts') = do
(alpha, beta) <-
tcArrow p "functional pattern" (doc $-$ text "Term:" <+> ppPattern 0 t) ty
tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty
(ps', t'') <- tcPatternArg p "functional pattern" doc ps alpha t'
tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts'
where t = FunctionPattern spi ty f (ts [])
......@@ -1166,7 +1166,7 @@ tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type
-> Pattern a -> TCM (PredSet, Pattern Type)
tcPatternArg p what doc ps ty t =
tcPattern p t >>-
unify p what (doc $-$ text "Term:" <+> ppPattern 0 t) ps ty
unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 t) ps ty
tcRhs :: CheckMode -> Rhs a -> TCM (PredSet, Type, Rhs Type)
tcRhs cm (SimpleRhs p e ds) = do
......@@ -1174,7 +1174,7 @@ tcRhs cm (SimpleRhs p e ds) = do
(ps, ds') <- tcDecls ds
(ps', ty, e') <- tcExpr cm p e
return (ps, ds', ps', ty, e')
ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')
ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps')
return (ps'', ty, SimpleRhs p e' ds')
tcRhs cm (GuardedRhs spi es ds) = withLocalValueEnv $ do
(ps, ds') <- tcDecls ds
......@@ -1184,8 +1184,8 @@ tcRhs cm (GuardedRhs spi es ds) = withLocalValueEnv $ do
tcCondExpr :: CheckMode -> Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr Type)
tcCondExpr cm ty ps (CondExpr p g e) = do
(ps', g') <- tcExpr Infer p g >>- unify p "guard" (ppExpr 0 g) ps boolType
(ps'', e') <- tcExpr cm p e >>- unify p "guarded expression" (ppExpr 0 e) ps' ty
(ps', g') <- tcExpr Infer p g >>- unify p "guard" (pPrintPrec 0 g) ps boolType
(ps'', e') <- tcExpr cm p e >>- unify p "guarded expression" (pPrintPrec 0 e) ps' ty
return (ps'', CondExpr p g' e')
tcExpr :: HasPosition p => CheckMode -> p -> Expression a
......@@ -1211,7 +1211,7 @@ tcExpr _ p (Typed spi e qty) = do
pty <- expandTypeExpr qty
(ps, ty) <- inst (polyType pty)
(ps', e') <- tcExpr (Check ty) p e >>-
unifyDecl p "explicitly typed expression" (ppExpr 0 e) emptyPredSet ty
unifyDecl p "explicitly typed expression" (pPrintPrec 0 e) emptyPredSet ty
fvs <- computeFvEnv
theta <- getTypeSubst
let (gps, lps) = splitPredSet fvs ps'
......@@ -1219,7 +1219,7 @@ tcExpr _ p (Typed spi e qty) = do
unlessM (checkTypeSig pty tySc) $ do
m <- getModuleIdent
report $
errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) qty
errTypeSigTooGeneral p m (text "Expression:" <+> pPrintPrec 0 e) qty
(rawPredType tySc)
return (ps `Set.union` gps, ty, Typed spi e' qty)
tcExpr _ _ e@(Record spi _ c fs) = do
......@@ -1227,12 +1227,12 @@ tcExpr _ _ e@(Record spi _ c fs) = do
vEnv <- getValueEnv
(ps, ty) <- liftM (fmap arrowBase) (inst (constrType m c vEnv))
(ps', fs') <- mapAccumM (tcField (tcExpr Infer) "construction"
(\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs
(\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs
return (ps', ty, Record spi ty c fs')
tcExpr _ p e@(RecordUpdate spi e1 fs) = do
(ps, ty, e1') <- tcExpr Infer p e1
(ps', fs') <- mapAccumM (tcField (tcExpr Infer) "update"
(\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs
(\e' -> pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e') ty) ps fs
return (ps', ty, RecordUpdate spi e1' fs')
tcExpr _ p (Tuple spi es) = do
(pss, tys, es') <- liftM unzip3 $ mapM (tcExpr Infer p) es
......@@ -1240,61 +1240,61 @@ tcExpr _ p (Tuple spi es) = do
tcExpr _ p e@(List spi _ es) = do
ty <- freshTypeVar
(ps, es') <-
mapAccumM (flip (tcArg Infer p "expression" (ppExpr 0 e)) ty) emptyPredSet es
mapAccumM (flip (tcArg Infer p "expression" (pPrintPrec 0 e)) ty) emptyPredSet es
return (ps, listType ty, List spi (listType ty) es')
tcExpr _ p (ListCompr spi e qs) = do
(ps, qs', ps', ty, e') <- withLocalValueEnv $ do
(ps, qs') <- mapAccumM (tcQual p) emptyPredSet qs
(ps', ty, e') <- tcExpr Infer p e
return (ps, qs', ps', ty, e')
ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')
ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps')
return (ps'', listType ty, ListCompr spi e' qs')
tcExpr _ p e@(EnumFrom spi e1) = do
(ps, ty) <- freshEnumType
(ps', e1') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps ty e1
(ps', e1') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps ty e1
return (ps', listType ty, EnumFrom spi e1')
tcExpr _ p e@(EnumFromThen spi e1 e2) = do
(ps, ty) <- freshEnumType
(ps', e1') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps' ty e2
(ps', e1') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2
return (ps'', listType ty, EnumFromThen spi e1' e2')
tcExpr _ p e@(EnumFromTo spi e1 e2) = do
(ps, ty) <- freshEnumType
(ps', e1') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps' ty e2
(ps', e1') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2
return (ps'', listType ty, EnumFromTo spi e1' e2')
tcExpr _ p e@(EnumFromThenTo spi e1 e2 e3) = do
(ps, ty) <- freshEnumType
(ps', e1') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps' ty e2
(ps''', e3') <- tcArg Infer p "arithmetic sequence" (ppExpr 0 e) ps'' ty e3
(ps', e1') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps ty e1
(ps'', e2') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps' ty e2
(ps''', e3') <- tcArg Infer p "arithmetic sequence" (pPrintPrec 0 e) ps'' ty e3
return (ps''', listType ty, EnumFromThenTo spi e1' e2' e3')
tcExpr _ p e@(UnaryMinus spi e1) = do
(ps, ty) <- freshNumType
(ps', e1') <- tcArg Infer p "unary negation" (ppExpr 0 e) ps ty e1
(ps', e1') <- tcArg Infer p "unary negation" (pPrintPrec 0 e) ps ty e1
return (ps', ty, UnaryMinus spi e1')
tcExpr _ p e@(Apply spi e1 e2) = do
(ps, y, e1') <- tcExpr Infer p e1
(alpha, beta) <- tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) y
(ps', e2') <- tcArg (Check alpha) p "application" (ppExpr 0 e) ps alpha e2
(alpha, beta) <- tcArrow p "application" (pPrintPrec 0 e $-$ text "Term:" <+> pPrintPrec 0 e1) y
(ps', e2') <- tcArg (Check alpha) p "application" (pPrintPrec 0 e) ps alpha e2
return (ps', beta, Apply spi e1' e2')
tcExpr _ p e@(InfixApply spi e1 op e2) = do
(ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-
tcBinary p "infix application" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)
(ps', e1') <- tcArg (Check alpha) p "infix application" (ppExpr 0 e) ps alpha e1
(ps'', e2') <- tcArg (Check beta) p "infix application" (ppExpr 0 e) ps' beta e2
tcBinary p "infix application" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)
(ps', e1') <- tcArg (Check alpha) p "infix application" (pPrintPrec 0 e) ps alpha e1
(ps'', e2') <- tcArg (Check beta) p "infix application" (pPrintPrec 0 e) ps' beta e2
return (ps'', gamma, InfixApply spi e1' op' e2')
tcExpr _ p e@(LeftSection spi e1 op) = do
(ps, (alpha, beta), op') <- tcInfixOp op >>=-
tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)
tcArrow p "left section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)
(aps, _) <- inst alpha
(ps', e1') <- tcArg Infer p "left section" (ppExpr 0 e) (ps `Set.union` aps) alpha e1
(ps', e1') <- tcArg Infer p "left section" (pPrintPrec 0 e) (ps `Set.union` aps) alpha e1
return (ps', beta, LeftSection spi e1' op')
tcExpr _ p e@(RightSection spi op e1) = do
(ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=-
tcBinary p "right section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)
tcBinary p "right section" (pPrintPrec 0 e $-$ text "Operator:" <+> pPrint op)
(bps, _) <- inst beta
(ps', e1') <- tcArg Infer p "right section" (ppExpr 0 e) (ps `Set.union` bps) beta e1
(ps', e1') <- tcArg Infer p "right section" (pPrintPrec 0 e) (ps `Set.union` bps) beta e1
return (ps', TypeArrow alpha gamma, RightSection spi op' e1')
tcExpr cm p (Lambda spi ts e) = do
(pss, tys, ts', ps, ty, e') <- withLocalValueEnv $ do
......@@ -1305,27 +1305,27 @@ tcExpr cm p (Lambda spi ts e) = do
(pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts
(ps, ty, e') <- tcExpr Infer p e
return (pss, tys, ts', ps, ty, e')
ps' <- reducePredSet p "expression" (ppExpr 0 e') (Set.unions $ ps : pss)
ps' <- reducePredSet p "expression" (pPrintPrec 0 e') (Set.unions $ ps : pss)
return (ps', foldr TypeArrow ty tys, Lambda spi ts' e')
tcExpr cm p (Let spi ds e) = do
(ps, ds', ps', ty, e') <- withLocalValueEnv $ do
(ps, ds') <- tcDecls ds
(ps', ty, e') <- tcExpr cm p e
return (ps, ds', ps', ty, e')
ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')
ps'' <- reducePredSet p "expression" (pPrintPrec 0 e') (ps `Set.union` ps')
return (ps'', ty, Let spi ds' e')
tcExpr _ p (Do spi sts e) = do
(sts', ty, ps', e') <- withLocalValueEnv $ do
((ps, mTy), sts') <-
mapAccumM (uncurry (tcStmt p)) (emptyPredSet, Nothing) sts
ty <- liftM (maybe id TypeApply mTy) freshTypeVar
(ps', e') <- tcExpr Infer p e >>- unify p "statement" (ppExpr 0 e) ps ty
(ps', e') <- tcExpr Infer p e >>- unify p "statement" (pPrintPrec 0 e) ps ty
return (sts', ty, ps', e')
return (ps', ty, Do spi sts' e')
tcExpr cm p e@(IfThenElse spi e1 e2 e3) = do
(ps, e1') <- tcArg Infer p "expression" (ppExpr 0 e) emptyPredSet boolType e1
(ps, e1') <- tcArg Infer p "expression" (pPrintPrec 0 e) emptyPredSet boolType e1
(ps', ty, e2') <- tcExpr cm p e2
(ps'', e3') <- tcArg cm p "expression" (ppExpr 0 e) (ps `Set.union` ps') ty e3
(ps'', e3') <- tcArg cm p "expression" (pPrintPrec 0 e) (ps `Set.union` ps') ty e3
return (ps'', ty, IfThenElse spi e1' e2' e3')
tcExpr cm p (Case spi ct e as) = do
(ps, tyLhs, e') <- tcExpr Infer p e
......@@ -1336,13 +1336,13 @@ tcExpr cm p (Case spi ct e as) = do
tcArg :: HasPosition p => CheckMode -> p -> String -> Doc -> PredSet -> Type
-> Expression a -> TCM (PredSet, Expression Type)
tcArg cm p what doc ps ty e =
tcExpr cm p e >>- unify p what (doc $-$ text "Term:" <+> ppExpr 0 e) ps ty
tcExpr cm p e >>- unify p what (doc $-$ text "Term:" <+> pPrintPrec 0 e) ps ty
tcAlt :: CheckMode -> Type -> Type -> PredSet -> Alt a
-> TCM (PredSet, Alt Type)
tcAlt cm tyLhs tyRhs ps a@(Alt p t rhs) =
tcAltern cm tyLhs p t rhs >>-
unify p "case alternative" (ppAlt a) ps tyRhs
unify p "case alternative" (pPrint a) ps tyRhs
tcAltern :: CheckMode -> Type -> SpanInfo -> Pattern a
-> Rhs a -> TCM (PredSet, Type, Alt Type)
......@@ -1350,26 +1350,26 @@ tcAltern cm tyLhs p t rhs = do
(ps, t', ps', ty', rhs') <- withLocalValueEnv $ do
bindPatternVars (Check tyLhs) t
(ps, t') <-
tcPatternArg p "case pattern" (ppAlt (Alt p t rhs)) emptyPredSet tyLhs t
tcPatternArg p "case pattern" (pPrint (Alt p t rhs)) emptyPredSet tyLhs t
(ps', ty', rhs') <- tcRhs cm rhs
return (ps, t', ps', ty', rhs')
ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs'))
ps'' <- reducePredSet p "alternative" (pPrint (Alt p t' rhs'))
(ps `Set.union` ps')
return (ps'', ty', Alt p t' rhs')
tcQual :: HasPosition p => p -> PredSet -> Statement a
-> TCM (PredSet, Statement Type)
tcQual p ps (StmtExpr spi e) = do
(ps', e') <- tcExpr Infer p e >>- unify p "guard" (ppExpr 0 e) ps boolType
(ps', e') <- tcExpr Infer p e >>- unify p "guard" (pPrintPrec 0 e) ps boolType
return (ps', StmtExpr spi e')
tcQual _ ps (StmtDecl spi ds) = do
(ps', ds') <- tcDecls ds
return (ps `Set.union` ps', StmtDecl spi ds')
tcQual p ps q@(StmtBind spi t e) = do
alpha <- freshTypeVar
(ps', e') <- tcArg Infer p "generator" (ppStmt q) ps (listType alpha) e
(ps', e') <- tcArg Infer p "generator" (pPrint q) ps (listType alpha) e
bindPatternVars Infer t
(ps'', t') <- tcPatternArg p "generator" (ppStmt q) ps' alpha t
(ps'', t') <- tcPatternArg p "generator" (pPrint q) ps' alpha t
return (ps'', StmtBind spi t' e')
tcStmt :: HasPosition p => p -> PredSet -> Maybe Type -> Statement a
......@@ -1378,7 +1378,7 @@ tcStmt p ps mTy (StmtExpr spi e) = do
(ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy
alpha <- freshTypeVar
(ps'', e') <- tcExpr Infer p e >>-
unify p "statement" (ppExpr 0 e) (ps `Set.union` ps') (applyType ty [alpha])
unify p "statement" (pPrintPrec 0 e) (ps `Set.union` ps') (applyType ty [alpha])
return ((ps'', Just ty), StmtExpr spi e')
tcStmt _ ps mTy (StmtDecl spi ds) = do
(ps', ds') <- tcDecls ds
......@@ -1389,9 +1389,9 @@ tcStmt p ps mTy st@(StmtBind spi t e) = do
(ps', ty) <- maybe freshMType (return . (,) emptyPredSet) mTy
alpha <- freshTypeVar
(ps'', e') <-
tcArg Infer p "statement" (ppStmt st) (ps `Set.union` ps') (applyType ty [alpha]) e
tcArg Infer p "statement" (pPrint st) (ps `Set.union` ps') (applyType ty [alpha]) e
bindPatternVars Infer t
(ps''', t') <- tcPatternArg p "statement" (ppStmt st) ps'' alpha t
(ps''', t') <- tcPatternArg p "statement" (pPrint st) ps'' alpha t
return ((ps''', Just ty), StmtBind spi t' e')
checkFailableBind :: Pattern a -> TCM Bool
......@@ -1903,7 +1903,7 @@ errTypeSigTooGeneral :: HasPosition a => a -> ModuleIdent -> Doc -> TypeExpr
errTypeSigTooGeneral p m what tySc ty = posMessage p $ vcat
[ text "Type signature too general", what
, text "Inferred type:" <+> ppType m ty
, text "Type signature:" <+> ppTypeExpr 0 tySc ]
, text "Type signature:" <+> pPrintPrec 0 tySc ]
errMethodTypeTooSpecific :: HasPosition a => a -> ModuleIdent -> Doc -> Type
-> Type -> Message
......
......@@ -705,14 +705,14 @@ errUnboundVariable tv = posMessage tv $ hsep $ map text
errIllegalConstraint :: Constraint -> Message
errIllegalConstraint c@(Constraint _ cls _) = posMessage cls $ vcat
[ text "Illegal class constraint" <+> ppConstraint c
[ text "Illegal class constraint" <+> pPrint c
, text "Constraints must be of the form C u or C (u t1 ... tn),"
, text "where C is a type class, u is a type variable and t1, ..., tn are types."
]
errIllegalSimpleConstraint :: Constraint -> Message
errIllegalSimpleConstraint c@(Constraint _ cls _) = posMessage cls $ 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."
]
......
......@@ -41,7 +41,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, pPrintPrec, ppIdent)
import Base.CurryTypes (ppPredType, toPredSet, fromPred)
import Base.Messages (Message, posMessage, internalError)
......@@ -466,7 +466,7 @@ checkOrphanInstance p cx cls ty = warnFor WarnOrphanInstances $ do
let ocls = getOrigName m cls tcEnv
otc = getOrigName m tc tcEnv
unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $
warnOrphanInstance (spanInfo2Pos p) $ ppDecl $ InstanceDecl p cx cls ty []
warnOrphanInstance (spanInfo2Pos p) $ pPrint $ InstanceDecl p cx cls ty []