Commit 23e86daf authored by Jan-Hendrik Matthes's avatar Jan-Hendrik Matthes 😄

Remove some more empty predicate sets

parent b22b7df4
......@@ -31,7 +31,7 @@ module Base.Types
, PredSet
, emptyPredSet, partitionPredSet, minPredSet, maxPredSet, qualifyPredSet
, unqualifyPredSet
, predType, unpredType
, unpredType
-- * Representation of data constructors
, DataConstr (..)
, constrIdent, constrTypes, recLabels, recLabelTypes, tupleData
......@@ -41,8 +41,7 @@ module Base.Types
-- * Representation of quantification
, monoType, polyType, rawType, rawPredType
-- * Predefined types
, arrowType, unitType, predUnitType, boolType, predBoolType, charType
, intType, predIntType, floatType, predFloatType, stringType, predStringType
, arrowType, unitType, boolType, charType, intType, floatType, stringType
, listType, consType, ioType, tupleType
, numTypes, fractionalTypes, predefTypes
) where
......@@ -318,11 +317,6 @@ unqualifyPredSet m = Set.map (unqualifyPred m)
-- Predicated types
-- -----------------------------------------------------------------------------
-- | Transforms a type into a predicated type with an empty predicate set.
predType :: Type -> Type
predType ty@(TypeContext _ _) = ty
predType ty = TypeContext emptyPredSet ty
-- | Removes the predicate set from a predicated type.
unpredType :: Type -> Type
unpredType (TypeContext _ ty) = ty
......@@ -425,18 +419,10 @@ arrowType ty1 ty2 = primType qArrowId [ty1, ty2]
unitType :: Type
unitType = primType qUnitId []
-- | Returns the predicated unit type.
predUnitType :: Type
predUnitType = predType unitType
-- | Returns the bool type.
boolType :: Type
boolType = primType qBoolId []
-- | Returns the predicated bool type.
predBoolType :: Type
predBoolType = predType boolType
-- | Returns the char type.
charType :: Type
charType = primType qCharId []
......@@ -445,26 +431,14 @@ charType = primType qCharId []
intType :: Type
intType = primType qIntId []
-- | Returns the predicated integer type.
predIntType :: Type
predIntType = predType intType
-- | Returns the float type.
floatType :: Type
floatType = primType qFloatId []
-- | Returns the predicated float type.
predFloatType :: Type
predFloatType = predType floatType
-- | Returns the string type.
stringType :: Type
stringType = listType charType
-- | Returns the predicated string type.
predStringType :: Type
predStringType = predType stringType
-- | Returns a list type with the given argument type.
listType :: Type -> Type
listType ty = primType qListId [ty]
......
......@@ -1038,7 +1038,7 @@ instMethodType qual (TypeContext ps ty) f = do
let TypeForall _ (TypeContext ps' _) = tySc
TypeContext ps'' ty'' = instanceType ty (TypeContext (Set.deleteMin ps') (rawType tySc))
return $ TypeContext (ps `Set.union` ps'') ty''
instMethodType qual ty f = instMethodType qual (predType ty) f
instMethodType qual ty f = instMethodType qual (TypeContext emptyPredSet ty) f
-- External functions:
......
......@@ -165,9 +165,8 @@ tupleDCs :: [ValueInfo]
tupleDCs = map dataInfo tupleData
where dataInfo (DataConstr _ tys) =
let n = length tys
TypeContext ps ty = predType $ foldr TypeArrow (tupleType tys) tys
in DataConstructor (qTupleId n) n (replicate n anonId) $
TypeForall [0..n-1] (TypeContext ps ty)
in DataConstructor (qTupleId n) n (replicate n anonId) $
TypeForall [0..n-1] (foldr TypeArrow (tupleType tys) tys)
dataInfo (RecordConstr _ _ _) =
internalError $ "Env.Value.tupleDCs: " ++ show tupleDCs
......@@ -198,7 +197,7 @@ class ValueType t where
instance ValueType Type where
toValueType = id
fromValueType ty@(TypeContext _ _) = ty
fromValueType ty = predType ty
fromValueType ty = ty
bindLocalVars :: ValueType t => [(Ident, Int, t)] -> ValueEnv -> ValueEnv
bindLocalVars = flip $ foldr bindLocalVar
......
......@@ -325,9 +325,9 @@ readsPrecReadParenCondExpr :: ConstrInfo -> Expression Type -> Precedence
readsPrecReadParenCondExpr (_, c, _, tys) d p
| null tys = prelFalse
| isQInfixOp c && length tys == 2 =
prelLt (Literal NoSpanInfo predIntType $ Int p) d
prelLt (Literal NoSpanInfo intType $ Int p) d
| otherwise =
prelLt (Literal NoSpanInfo predIntType $ Int 10) d
prelLt (Literal NoSpanInfo intType $ Int 10) d
deriveReadsPrecLambdaExpr :: Type -> ConstrInfo -> Precedence
-> DVM (Expression Type)
......@@ -403,7 +403,7 @@ deriveReadsPrecLexStmt :: String -> (Type, Ident)
deriveReadsPrecLexStmt str r = do
s <- freshArgument $ stringType
let pat = TuplePattern NoSpanInfo
[ LiteralPattern NoSpanInfo predStringType $ String str
[ LiteralPattern NoSpanInfo stringType $ String str
, uncurry (VariablePattern NoSpanInfo) s
]
stmt = StmtBind NoSpanInfo pat $ preludeLex $ uncurry mkVar r
......@@ -458,7 +458,7 @@ showsPrecNullaryConstrExpr c = preludeShowString $ showsConstr c ""
showsPrecShowParenExpr :: Expression Type -> Precedence
-> Expression Type -> Expression Type
showsPrecShowParenExpr d p =
prelShowParen $ prelLt (Literal NoSpanInfo predIntType $ Int p) d
prelShowParen $ prelLt (Literal NoSpanInfo intType $ Int p) d
showsPrecRecordConstrExpr :: Ident -> [Ident] -> [Expression Type]
-> Expression Type
......@@ -549,10 +549,10 @@ instMethodType vEnv ps cls ty f = TypeContext (ps `Set.union` ps'') ty''
-- -----------------------------------------------------------------------------
prelTrue :: Expression Type
prelTrue = Constructor NoSpanInfo predBoolType qTrueId
prelTrue = Constructor NoSpanInfo boolType qTrueId
prelFalse :: Expression Type
prelFalse = Constructor NoSpanInfo predBoolType qFalseId
prelFalse = Constructor NoSpanInfo boolType qFalseId
prelAppend :: Expression Type -> Expression Type -> Expression Type
prelAppend e1 e2 = foldl1 (Apply NoSpanInfo)
......@@ -634,7 +634,7 @@ preludeReadsPrec :: Type -> Integer -> Expression Type
-> Expression Type
preludeReadsPrec ty p e = flip (Apply NoSpanInfo) e $
Apply NoSpanInfo (Variable NoSpanInfo pty qReadsPrecId) $
Literal NoSpanInfo predIntType $ Int p
Literal NoSpanInfo intType $ Int p
where pty = foldr1 TypeArrow [ intType, stringType
, listType $ tupleType [ ty
, stringType
......@@ -644,14 +644,14 @@ preludeReadsPrec ty p e = flip (Apply NoSpanInfo) e $
preludeShowsPrec :: Integer -> Expression Type -> Expression Type
preludeShowsPrec p e = flip (Apply NoSpanInfo) e $
Apply NoSpanInfo (Variable NoSpanInfo pty qShowsPrecId) $
Literal NoSpanInfo predIntType $ Int p
Literal NoSpanInfo intType $ Int p
where pty = foldr1 TypeArrow [ intType, typeOf e
, stringType, stringType
]
preludeShowString :: String -> Expression Type
preludeShowString s = Apply NoSpanInfo (Variable NoSpanInfo pty qShowStringId) $
Literal NoSpanInfo predStringType $ String s
Literal NoSpanInfo stringType $ String s
where pty = foldr1 TypeArrow $ replicate 3 stringType
preludeFailed :: Type -> Expression Type
......
......@@ -840,7 +840,7 @@ dsStmt (StmtBind _ t e1) e' = do
return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func]
where failedPatternMatch ty =
apply (prelFail ty)
[Literal NoSpanInfo predStringType $ String "Pattern match failed!"]
[Literal NoSpanInfo stringType $ String "Pattern match failed!"]
dsStmt (StmtDecl _ ds) e' = return $ Let NoSpanInfo ds e'
-- -----------------------------------------------------------------------------
......@@ -932,13 +932,13 @@ dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty)
| ty == intType = Literal NoSpanInfo pty $ Int i
| ty == floatType = Literal NoSpanInfo pty $ Float $ fromInteger i
| otherwise = Apply NoSpanInfo (prelFromInt $ unpredType pty) $
Literal NoSpanInfo predIntType $ Int i
Literal NoSpanInfo intType $ Int i
dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty)
where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
fixLiteral ty
| ty == floatType = Literal NoSpanInfo pty f
| otherwise = Apply NoSpanInfo (prelFromFloat $ unpredType pty) $
Literal NoSpanInfo predFloatType f
Literal NoSpanInfo floatType f
dsLiteral pty (String cs) =
Left $ List NoSpanInfo pty $ map (Literal NoSpanInfo pty' . Char) cs
where pty' = elemType $ unpredType pty
......@@ -1024,10 +1024,10 @@ e1 &> e2 = apply (preludeFun [boolType, typeOf e2] (typeOf e2) "cond") [e1, e2]
e1 & e2 = apply (preludeFun [boolType, boolType] boolType "&") [e1, e2]
truePat :: Pattern Type
truePat = ConstructorPattern NoSpanInfo predBoolType qTrueId []
truePat = ConstructorPattern NoSpanInfo boolType qTrueId []
falsePat :: Pattern Type
falsePat = ConstructorPattern NoSpanInfo predBoolType qFalseId []
falsePat = ConstructorPattern NoSpanInfo boolType qFalseId []
-- ---------------------------------------------------------------------------
-- Auxiliary definitions
......
......@@ -269,7 +269,7 @@ augmentLhs mm lhs@(FunLhs spi f ts) = do
augEnv <- getAugEnv
if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f)
then return $ FunLhs spi f
$ ConstructorPattern NoSpanInfo predUnitType qUnitId [] : ts
$ ConstructorPattern NoSpanInfo unitType qUnitId [] : ts
else return lhs
augmentLhs _ lhs =
internalError $ "Dictionary.augmentLhs" ++ show lhs
......@@ -285,7 +285,7 @@ instance Augment Expression where
augEnv <- getAugEnv
return $ if isAugmented augEnv v'
then apply (Variable NoSpanInfo (augmentType pty) v')
[Constructor NoSpanInfo predUnitType qUnitId]
[Constructor NoSpanInfo unitType qUnitId]
else v
augment c@(Constructor _ _ _) = return c
augment (Typed spi e qty) = flip (Typed spi) qty <$> augment e
......@@ -414,7 +414,7 @@ defaultClassMethodDecl cls f = do
augEnv <- getAugEnv
let augmented = isAugmented augEnv (qualifyLike cls f)
pats = if augmented
then [ConstructorPattern NoSpanInfo predUnitType qUnitId []]
then [ConstructorPattern NoSpanInfo unitType qUnitId []]
else []
ty' = if augmented then arrowBase ty else ty
return $ funDecl NoSpanInfo pty f pats $ preludeError (instType ty') $
......
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