Commit 50d25c6d authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Merge remote-tracking branch 'origin/higher-rank-polymorphism' into version3

parents aed95970 6aff14f7
......@@ -23,7 +23,6 @@ import Data.List (nub)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (Set, map)
import Base.Messages (internalError)
import Base.Subst
import Base.TopEnv
import Base.Types
......@@ -135,4 +134,4 @@ normalize n ty = expandAliasType [TypeVariable (occur tv) | tv <- [0..]] ty
instanceType :: ExpandAliasType a => Type -> a -> a
instanceType ty = expandAliasType (ty : map TypeVariable [n..])
where
n = maximum (-1 : typeVars ty) + 1
n = maximum (1 : typeVars ty)
......@@ -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
......@@ -39,10 +39,9 @@ module Base.Types
, ClassMethod (..)
, methodName, methodArity, methodType
-- * Representation of quantification
, monoType, polyType, typeScheme, rawType, rawPredType
, 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
......@@ -54,6 +53,8 @@ import Curry.Base.Ident
import Base.Messages (internalError)
import Env.Class (ClassEnv, allSuperClasses)
import Data.List (nub)
-- -----------------------------------------------------------------------------
-- Types
-- -----------------------------------------------------------------------------
......@@ -316,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
......@@ -395,11 +391,7 @@ monoType = TypeForall []
-- universally quantified type variables in the type are assigned indices
-- starting with 0 and does not renumber the variables.
polyType :: Type -> Type
polyType = typeScheme
-- | Translates a type into a type scheme.
typeScheme :: Type -> Type
typeScheme ty = TypeForall (typeVars ty) ty
polyType ty = TypeForall (filter (>= 0) (nub $ typeVars ty)) ty
-- | Strips the quantifier and predicate set from a type scheme.
rawType :: Type -> Type
......@@ -427,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 []
......@@ -447,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]
......
......@@ -404,7 +404,7 @@ bindClassMethods' m tcEnv vEnv
bindClassMethod :: ModuleIdent -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod m (ClassMethod f _ ty) =
bindGlobalInfo (\qc tySc -> Value qc True 0 tySc) m f (typeScheme ty)
bindGlobalInfo (\qc tySc -> Value qc True 0 tySc) m f (polyType ty)
-- -----------------------------------------------------------------------------
-- Default Types
......@@ -416,7 +416,7 @@ bindClassMethod m (ClassMethod f _ ty) =
setDefaults :: Decl a -> TCM ()
setDefaults (DefaultDecl _ tys) = mapM toDefaultType tys >>= setDefaultTypes
where
toDefaultType ty = snd <$> (inst =<< typeScheme <$> expandTypeExpr ty)
toDefaultType ty = snd <$> (inst =<< polyType <$> expandTypeExpr ty)
setDefaults _ = ok
-- -----------------------------------------------------------------------------
......@@ -539,7 +539,7 @@ tcDeclVars (FunctionDecl _ _ f eqs) = do
case lookupTypeSig f sigs of
Just ty -> do
ty' <- expandTypeExpr ty
return [(f, n, typeScheme ty')]
return [(f, n, polyType ty')]
Nothing -> do
tys <- replicateM (n + 1) freshTypeVar
return [(f, n, monoType $ foldr1 TypeArrow tys)]
......@@ -553,7 +553,7 @@ tcDeclVar poly v = do
sigs <- getSigEnv
case lookupTypeSig v sigs of
Just ty | poly || null (fv ty) -> do ty' <- expandTypeExpr ty
return (v, 0, typeScheme ty')
return (v, 0, polyType ty')
| otherwise -> do report $ errPolymorphicVar v
lambdaVar v
Nothing -> lambdaVar v
......@@ -706,15 +706,12 @@ fixType _ _ = internalError "TypeCheck.fixType"
declVars :: Decl Type -> [(Ident, Int, Type)]
declVars (FunctionDecl _ ty f eqs)
= [(f, eqnArity $ head eqs, typeSchemeFixed ty)]
= [(f, eqnArity $ head eqs, polyType ty)]
declVars (PatternDecl _ t _) = case t of
VariablePattern _ ty v -> [(v, 0, typeSchemeFixed ty)]
VariablePattern _ ty v -> [(v, 0, polyType ty)]
_ -> []
declVars _ = internalError "TypeCheck.declVars"
typeSchemeFixed :: Type -> Type
typeSchemeFixed ty = TypeForall (filter (>= 0) (typeVars ty)) ty
-- The function 'tcCheckPDecl' checks the type of an explicitly typed function
-- or variable declaration. After inferring a type for the declaration, the
-- inferred type is compared with the type signature. Since the inferred type of
......@@ -991,7 +988,7 @@ toClassMethodTypeExpr qcls clsvar ty
tcInstanceMethodPDecl :: QualIdent -> Type -> PDecl a -> TCM (PDecl Type)
tcInstanceMethodPDecl qcls pty pd@(_, FunctionDecl _ _ f _) = do
methTy <- instMethodType (qualifyLike qcls) pty f
(tySc, pd') <- tcMethodPDecl (typeScheme methTy) pd
(tySc, pd') <- tcMethodPDecl (polyType methTy) pd
checkInstMethodType (normalize 0 methTy) tySc pd'
tcInstanceMethodPDecl _ _ _ = internalError "TypeCheck.tcInstanceMethodPDecl"
......@@ -1041,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:
......@@ -1212,7 +1209,7 @@ tcExpr cm p (Paren spi e) = do
return (ps, ty, Paren spi e')
tcExpr _ p (Typed spi e qty) = do
pty <- expandTypeExpr qty
(ps, ty) <- inst (typeScheme pty)
(ps, ty) <- inst (polyType pty)
(ps', e') <- tcExpr (Check ty) p e >>-
unifyDecl p "explicitly typed expression" (ppExpr 0 e) emptyPredSet ty
fvs <- computeFvEnv
......@@ -1509,42 +1506,41 @@ unify p what doc ps1 ty1 ps2 ty2 = do
m <- getModuleIdent
res <- unifyTypes m ty1' ty2'
case res of
Left reason -> report $ errTypeMismatch p what doc m ty1' ty2' reason
Right (_, sigma) -> modifyTypeSubst (compose sigma)
Left reason -> report $ errTypeMismatch p what doc m ty1' ty2' reason
Right sigma -> modifyTypeSubst (compose sigma)
reducePredSet p what doc (ps1 `Set.union` ps2)
unifyTypes :: ModuleIdent -> Type -> Type
-> TCM (Either Doc (PredSet, TypeSubst))
unifyTypes :: ModuleIdent -> Type -> Type -> TCM (Either Doc TypeSubst)
unifyTypes _ (TypeVariable tv1) ty@(TypeVariable tv2)
| tv1 == tv2 = return $ Right (emptyPredSet, idSubst)
| otherwise = return $ Right (emptyPredSet, singleSubst tv1 ty)
| tv1 == tv2 = return $ Right idSubst
| otherwise = return $ Right (singleSubst tv1 ty)
unifyTypes m (TypeVariable tv) ty
| tv `elem` typeVars ty = return $ Left (errRecursiveType m tv ty)
| hasHigherRankPoly ty = return $ Left (errImpredInst m tv ty)
| otherwise = return $ Right (emptyPredSet, singleSubst tv ty)
| otherwise = return $ Right (singleSubst tv ty)
unifyTypes m ty (TypeVariable tv)
| tv `elem` typeVars ty = return $ Left (errRecursiveType m tv ty)
| hasHigherRankPoly ty = return $ Left (errImpredInst m tv ty)
| otherwise = return $ Right (emptyPredSet, singleSubst tv ty)
| otherwise = return $ Right (singleSubst tv ty)
unifyTypes _ (TypeConstrained tys1 tv1) ty@(TypeConstrained tys2 tv2)
| tv1 == tv2 = return $ Right (emptyPredSet, idSubst)
| tys1 == tys2 = return $ Right (emptyPredSet, singleSubst tv1 ty)
| tv1 == tv2 = return $ Right idSubst
| tys1 == tys2 = return $ Right (singleSubst tv1 ty)
unifyTypes m (TypeConstrained tys tv) ty
= foldrM (\ty' s -> liftM (`choose` s) (unifyTypes m ty ty'))
(Left (errIncompatibleTypes m ty (head tys)))
tys
where
choose (Left _) theta' = theta'
choose (Right (ps, theta)) _ = Right (ps, bindSubst tv ty theta)
choose (Left _) theta' = theta'
choose (Right theta) _ = Right (bindSubst tv ty theta)
unifyTypes m ty (TypeConstrained tys tv)
= foldrM (\ty' s -> liftM (`choose` s) (unifyTypes m ty ty'))
(Left (errIncompatibleTypes m ty (head tys)))
tys
where
choose (Left _) theta' = theta'
choose (Right (ps, theta)) _ = Right (ps, bindSubst tv ty theta)
choose (Left _) theta' = theta'
choose (Right theta) _ = Right (bindSubst tv ty theta)
unifyTypes _ (TypeConstructor tc1) (TypeConstructor tc2)
| tc1 == tc2 = return $ Right (emptyPredSet, idSubst)
| tc1 == tc2 = return $ Right idSubst
unifyTypes m (TypeApply ty11 ty12) (TypeApply ty21 ty22)
= unifyTypeLists m [ty11, ty12] [ty21, ty22]
unifyTypes m ty@(TypeApply _ _) (TypeArrow ty21 ty22)
......@@ -1554,13 +1550,12 @@ unifyTypes m (TypeArrow ty11 ty12) ty@(TypeApply _ _)
unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22)
= unifyTypeLists m [ty11, ty12] [ty21, ty22]
unifyTypes m ty1@(TypeForall _ _) ty2@(TypeForall _ _)
= do (vs1, ps1, ty1') <- skolemise ty1
(vs2, ps2, ty2') <- skolemise ty2
= do (vs1, _, ty1') <- skolemise ty1
(vs2, _, ty2') <- skolemise ty2
res <- unifyTypes m ty1' ty2'
let ps = ps1 `Set.union` ps2
case res of
Left x -> return $ Left x
Right (ps', s) -> do
Left x -> return $ Left x
Right s -> do
let (_, tys) = unzip $ substToList $ restrictSubstTo (vs1 ++ vs2) s
case all isVarType tys of
True -> do
......@@ -1569,15 +1564,15 @@ unifyTypes m ty1@(TypeForall _ _) ty2@(TypeForall _ _)
$ restrictSubstTo vars s
let tys' = map (\(TypeVariable tv) -> tv) tys
case filter (`elem` tvs) (vs1 ++ vs2 ++ tys') of
[] -> return $ Right (ps `Set.union` ps', s)
[] -> return $ Right s
ev:_ -> return $ Left $ errEscapingTypeVariable m ev ty1 ty2
False -> return $ Left (errIncompatibleTypes m ty1 ty2)
unifyTypes m ty1@(TypeForall _ _) ty2
= do (vs, ps1, ty1') <- skolemise ty1
= do (vs, _, ty1') <- skolemise ty1
res <- unifyTypes m ty1' ty2
case res of
Left x -> return $ Left x
Right (ps, s) -> do
Left x -> return $ Left x
Right s -> do
let (_, tys) = unzip $ substToList $ restrictSubstTo vs s
case all isVarType tys of
True -> do
......@@ -1585,15 +1580,15 @@ unifyTypes m ty1@(TypeForall _ _) ty2
$ restrictSubstTo (typeVars ty1) s
let tys' = map (\(TypeVariable tv) -> tv) tys
case filter (`elem` tvs) (vs ++ tys') of
[] -> return $ Right (ps1 `Set.union` ps, s)
[] -> return $ Right s
ev:_ -> return $ Left $ errEscapingTypeVariable m ev ty1 ty2
False -> return $ Left (errIncompatibleTypes m ty1 ty2)
unifyTypes m ty1 ty2@(TypeForall _ _)
= do (vs, ps2, ty2') <- skolemise ty2
= do (vs, _, ty2') <- skolemise ty2
res <- unifyTypes m ty1 ty2'
case res of
Left x -> return $ Left x
Right (ps, s) -> do
Left x -> return $ Left x
Right s -> do
let (_, tys) = unzip $ substToList $ restrictSubstTo vs s
case all isVarType tys of
True -> do
......@@ -1601,24 +1596,22 @@ unifyTypes m ty1 ty2@(TypeForall _ _)
$ restrictSubstTo (typeVars ty2) s
let tys' = map (\(TypeVariable tv) -> tv) tys
case filter (`elem` tvs) (vs ++ tys') of
[] -> return $ Right (ps2 `Set.union` ps, s)
[] -> return $ Right s
ev:_ -> return $ Left $ errEscapingTypeVariable m ev ty1 ty2
False -> return $ Left (errIncompatibleTypes m ty1 ty2)
unifyTypes m ty1 ty2
= return $ Left (errIncompatibleTypes m ty1 ty2)
unifyTypeLists :: ModuleIdent -> [Type] -> [Type]
-> TCM (Either Doc (PredSet, TypeSubst))
unifyTypeLists _ [] _ = return $ Right (emptyPredSet, idSubst)
unifyTypeLists _ _ [] = return $ Right (emptyPredSet, idSubst)
unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> TCM (Either Doc TypeSubst)
unifyTypeLists _ [] _ = return $ Right idSubst
unifyTypeLists _ _ [] = return $ Right idSubst
unifyTypeLists m (ty1:tys1) (ty2:tys2) = eitherM (return . Left)
(uncurry unifyTypesTheta)
(unifyTypesTheta)
(unifyTypeLists m tys1 tys2)
where
unifyTypesTheta ps s
= eitherM (return . Left)
(\(ps', s') -> return $ Right (Set.union ps ps', compose s' s))
(unifyTypes m (subst s ty1) (subst s ty2))
unifyTypesTheta s = eitherM (return . Left)
(\s' -> return $ Right (compose s' s))
(unifyTypes m (subst s ty1) (subst s ty2))
-- After performing a unification, the resulting substitution is applied to the
-- current predicate set and the resulting predicate set is subject to a
......@@ -1965,11 +1958,6 @@ errEscapingTypeVariable m tv ty1 ty2 = sep
, text "because type variable" <+> ppType m (TypeVariable tv)
<+> text "would escape its scope" ]
errIncompatiblePredSets :: ModuleIdent -> PredSet -> PredSet -> Doc
errIncompatiblePredSets m ps1 ps2 = vcat
[ text "Could not deduce" <+> ppPredSet m ps1
, nest 2 $ text "from the context:" <+> ppPredSet m ps2 ]
errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type
-> Type -> Message
errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep
......
......@@ -427,7 +427,8 @@ checkConstrainedClsVar tv (ArrowType _ ty1 ty2)
checkConstrainedClsVar tv (ParenType _ ty) = checkConstrainedClsVar tv ty
checkConstrainedClsVar tv (ContextType _ cx ty)
= (||) <$> return (tv `elem` fv cx) <*> checkConstrainedClsVar tv ty
checkConstrainedClsVar tv (ForallType _ _ ty) = checkConstrainedClsVar tv ty
checkConstrainedClsVar tv (ForallType _ vs ty)
| not (tv `elem` vs) = checkConstrainedClsVar tv ty
checkConstrainedClsVar _ _ = return False
checkInstanceType :: SpanInfo -> InstanceType -> TSCM ()
......
......@@ -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,11 +197,11 @@ 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
bindLocalVar :: ValueType t => (Ident, Int, t) -> ValueEnv -> ValueEnv
bindLocalVar (v, a, ty) =
bindTopEnv v $ Value (qualify v) False a $ typeScheme $ fromValueType ty
bindTopEnv v $ Value (qualify v) False a $ polyType $ fromValueType ty
......@@ -263,9 +263,9 @@ values m (INewtypeDecl _ tc _ tvs nc hs) =
where tc' = qualQualify m tc
ty' = constrType tc' tvs
values m (IFunctionDecl _ f Nothing a qty) =
[Value (qualQualify m f) False a (typeScheme (toQualPredType m [] qty))]
[Value (qualQualify m f) False a (polyType (toQualPredType m [] qty))]
values m (IFunctionDecl _ f (Just tv) _ qty) =
[Value (qualQualify m f) True 0 (typeScheme (toQualPredType m [tv] qty))]
[Value (qualQualify m f) True 0 (polyType (toQualPredType m [tv] qty))]
values m (IClassDecl _ _ qcls _ tv ds hs) =
map (classMethod m qcls' tv) (filter ((`notElem` hs) . imethod) ds)
where qcls' = qualQualify m qcls
......@@ -316,7 +316,7 @@ constrType tc tvs = foldl (ApplyType NoSpanInfo) (ConstructorType NoSpanInfo tc)
classMethod :: ModuleIdent -> QualIdent -> Ident -> IMethodDecl -> ValueInfo
classMethod m qcls tv (IMethodDecl _ f _ qty) =
Value (qualifyLike qcls f) True 0 $
typeScheme $ qualifyType m $ toMethodType qcls tv qty
polyType $ qualifyType m $ toMethodType qcls tv qty
-- ---------------------------------------------------------------------------
......
......@@ -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
......
......@@ -843,7 +843,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'
checkFailableBind :: Pattern a -> DsM Bool
......@@ -970,13 +970,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
......@@ -1062,10 +1062,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') $
......@@ -634,7 +634,7 @@ bindInstMethod m cls ty m' ps is f vEnv = bindMethod m f' a pty vEnv
bindMethod :: ModuleIdent -> QualIdent -> Int -> Type -> ValueEnv
-> ValueEnv
bindMethod m f n pty = bindEntity m f $ Value f False n $ typeScheme pty
bindMethod m f n pty = bindEntity m f $ Value f False n $ polyType pty
-- The function 'bindEntity' introduces a binding for an entity into a top-level
-- environment. Depending on whether the entity is defined in the current module
......
......@@ -146,6 +146,7 @@ passInfos = map mkPassTest
, "AnonymVar"
, "CaseComplete"
, "ChurchEncoding"
, "ClassMethods"
, "DefaultPrecedence"
, "Dequeue"
, "ExplicitLayout"
......@@ -170,6 +171,8 @@ passInfos = map mkPassTest
, "Prelude"
, "Pretty"
, "RankNTypes"
, "RankNTypesFuncPats"
, "RankNTypesImport"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
......
class A a where
funA :: Integral b => a -> b
instance A Float where
funA _ = error "fail"
class B a where
funB :: (Integral b, Show c) => a -> b -> c -> a
instance B Float where
funB x _ _ = x
{-# LANGUAGE RankNTypes #-}
module RankNTypes where
type IdFunc = forall a. a -> a
id' :: IdFunc
......
{-# LANGUAGE FunctionalPatterns #-}
{-# LANGUAGE RankNTypes #-}
funH :: (forall c. Int -> c) -> a -> b -> Int
funH g (funF g x) (funF g y) = x + y
funF :: (a -> b) -> a -> b
funF g a = g a
funHTest :: Int
funHTest = funH id 4 4
import RankNTypes
funTest :: (Char, Bool)
funTest = fun id
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