Commit 49bd521d authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Add support for 'Data' typeclass

parent a15821f2
......@@ -298,7 +298,7 @@ minPredSet clsEnv ps =
[Pred cls' ty | cls' <- tail (allSuperClasses cls clsEnv)]
maxPredSet :: ClassEnv -> PredSet -> PredSet
maxPredSet clsEnv ps = Set.concatMap implied ps
maxPredSet clsEnv = Set.concatMap implied
where implied (Pred cls ty) = Set.fromList
[Pred cls' ty | cls' <- allSuperClasses cls clsEnv]
......
......@@ -44,6 +44,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
......@@ -54,7 +55,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.
......@@ -98,6 +99,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"
......
......@@ -19,9 +19,10 @@
-}
module Checks.InstanceCheck (instanceCheck) where
import Control.Monad.Extra (concatMapM, whileM)
import Control.Monad.Extra (concatMapM, whileM, when)
import qualified Control.Monad.State as S (State, execState, gets, modify)
import Data.List (nub, partition, sortBy)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import qualified Data.Set.Extra as Set
......@@ -52,7 +53,7 @@ instanceCheck m tcEnv clsEnv inEnv ds =
iss -> (inEnv, map (errMultipleInstances tcEnv) iss)
where
local = map (flip InstSource m) $ concatMap (genInstIdents m tcEnv) ds
imported = map (uncurry InstSource) $ map (fmap fst3) $ Map.toList inEnv
imported = map (uncurry InstSource . fmap fst3) $ Map.toList inEnv
state = INCState m inEnv []
-- In order to provide better error messages, we use the following data type
......@@ -95,6 +96,8 @@ ok = return ()
checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM ()
checkDecls tcEnv clsEnv ds = do
mapM_ (bindInstance tcEnv clsEnv) ids
mapM (declDeriveDataInfo tcEnv clsEnv) (filter isDataDecl tds) >>=
mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos
mapM (declDeriveInfo tcEnv clsEnv) (filter hasDerivedInstances tds) >>=
mapM_ (bindDerivedInstances clsEnv) . groupDeriveInfos
mapM_ (checkInstance tcEnv clsEnv) ids
......@@ -102,6 +105,9 @@ checkDecls tcEnv clsEnv ds = do
where (tds, ods) = partition isTypeDecl ds
ids = filter isInstanceDecl ods
dds = filter isDefaultDecl ods
isDataDecl (DataDecl _ _ _ _ _) = True
isDataDecl (NewtypeDecl _ _ _ _ _) = True
isDataDecl _ = False
-- First, the compiler adds all explicit instance declarations to the
-- instance environment.
......@@ -137,6 +143,7 @@ hasDerivedInstances _ = False
-- instances are added to the instance environment after their super classes.
data DeriveInfo = DeriveInfo Position QualIdent PredType [Type] [QualIdent]
deriving Show
declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo
declDeriveInfo tcEnv clsEnv (DataDecl p tc tvs cs clss) =
......@@ -151,8 +158,21 @@ declDeriveInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc clss) =
declDeriveInfo _ _ _ =
internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration"
declDeriveDataInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo
declDeriveDataInfo tcEnv clsEnv (DataDecl p tc tvs cs _) =
mkDeriveDataInfo tcEnv clsEnv p tc tvs (concat cxs) (concat tyss)
where (cxs, tyss) = unzip (map constrDeclTypes cs)
constrDeclTypes (ConstrDecl _ _ cx _ tys) = (cx, tys)
constrDeclTypes (ConOpDecl _ _ cx ty1 _ ty2) = (cx, [ty1, ty2])
constrDeclTypes (RecordDecl _ _ cx _ fs) = (cx, tys)
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
declDeriveDataInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc _) =
mkDeriveDataInfo tcEnv clsEnv p tc tvs [] [nconstrType nc]
declDeriveDataInfo _ _ _ = internalError
"InstanceCheck.declDeriveDataInfo: no data or newtype declaration"
mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> Context
-> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo
-> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo
mkDeriveInfo tcEnv clsEnv spi tc tvs cx tys clss = do
m <- getModuleIdent
let otc = qualifyWith m tc
......@@ -162,34 +182,59 @@ mkDeriveInfo tcEnv clsEnv spi tc tvs cx tys clss = do
return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss
where p = spanInfo2Pos spi
mkDeriveDataInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> Context
-> [TypeExpr] -> INCM DeriveInfo
mkDeriveDataInfo tcEnv clsEnv spi tc tvs cx tys = do
m <- getModuleIdent
let otc = qualifyWith m tc
PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs cx tys
(tys', ty') = arrowUnapply ty
return $ DeriveInfo p otc (PredType ps ty') tys' [qDataId]
where p = spanInfo2Pos spi
sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent]
sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss
where (_, d1) `compareDepth` (_, d2) = d1 `compare` d2
adjoinDepth cls = (cls, length $ allSuperClasses cls clsEnv)
groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]]
groupDeriveInfos ds = scc bound free ds
groupDeriveInfos = scc bound free
where bound (DeriveInfo _ tc _ _ _) = [tc]
free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys
bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()
bindDerivedInstances clsEnv dis = do
mapM_ (enterInitialPredSet clsEnv) dis
whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets
-- If any registration of initial pred sets failed, return immediately, as
-- there are no other (Data-)Instances that might succeed.
bs <- mapM (enterInitialPredSet clsEnv) dis
when (any or bs) $
whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()
enterInitialPredSet clsEnv (DeriveInfo p tc pty _ clss) =
mapM_ (bindDerivedInstance clsEnv p tc pty []) clss
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM [Bool]
enterInitialPredSet clsEnv (DeriveInfo p tc pty tys clss) =
mapM (bindDerivedInstance clsEnv p tc pty tys) clss
-- Note: The methods and arities entered into the instance environment have
-- to match methods and arities of the later generated instance declarations.
bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM ()
-> QualIdent -> INCM Bool
bindDerivedInstance clsEnv p tc pty tys cls = do
m <- getModuleIdent
(i, ps) <- inferPredSet clsEnv p tc pty tys cls
modifyInstEnv $ bindInstInfo i (m, ps, impls)
-- immediately return if asked to derive Data for functional Datatype
if any isFunType tys && cls == qDataId
then return False
else do
-- bindDerivedInstances normally infers the PredSet with empty `tys`
-- in order to always bind the instance in a first step.
-- For DataDeriving, this leads to problems.
let tys' = if cls == qDataId then tys else []
mps <- inferPredSet clsEnv p tc pty tys' cls
case mps of
Just (i, ps) -> modifyInstEnv (bindInstInfo i (m, ps, impls)) >>
return True
-- encountered unsatisfied DataClass constraint -> dont derive it here
Nothing -> return False
where impls | cls == qEqId = [(eqOpId, 2)]
| cls == qOrdId = [(leqOpId, 2)]
| cls == qEnumId = [ (succId, 1), (predId, 1), (toEnumId, 1)
......@@ -199,15 +244,16 @@ bindDerivedInstance clsEnv p tc pty tys cls = do
| cls == qBoundedId = [(maxBoundId, 0), (minBoundId, 0)]
| cls == qReadId = [(readsPrecId, 2)]
| cls == qShowId = [(showsPrecId, 2)]
| cls == qDataId = [(dataEqId, 2), (aValueId, 0)]
| otherwise =
internalError "InstanceCheck.bindDerivedInstance.impls"
inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)]
inferPredSets clsEnv (DeriveInfo p tc pty tys clss) =
mapM (inferPredSet clsEnv p tc pty tys) clss
catMaybes <$> mapM (inferPredSet clsEnv p tc pty tys) clss
inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM (InstIdent, PredSet)
-> QualIdent -> INCM (Maybe (InstIdent, PredSet))
inferPredSet clsEnv p tc (PredType ps inst) tys cls = do
m <- getModuleIdent
let doc = ppPred m $ Pred cls inst
......@@ -215,12 +261,20 @@ inferPredSet clsEnv p tc (PredType ps inst) tys cls = do
ps' = Set.fromList [Pred cls ty | ty <- tys]
ps'' = Set.fromList [Pred scls inst | scls <- sclss]
ps''' = ps `Set.union` ps' `Set.union` ps''
ps'''' <- reducePredSet p "derived instance" doc clsEnv ps'''
mapM_ (reportUndecidable p "derived instance" doc) $ Set.toList ps''''
return ((cls, tc), ps'''')
(ps4, novarps) <-
reducePredSet (cls == qDataId) p "derived instance" doc clsEnv ps'''
let ps5 = filter noPolyPred $ Set.toList ps4
if any (isDataPred m) (Set.toList novarps ++ ps5) && cls == qDataId
then return Nothing
else mapM_ (reportUndecidable p "derived instance" doc) ps5
>> return (Just ((cls, tc), ps4))
where
noPolyPred (Pred _ (TypeVariable _)) = False
noPolyPred (Pred _ _ ) = True
isDataPred _ (Pred qid _) = qid == qDataId
updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool
updatePredSets = (=<<) (return . or) . mapM (uncurry updatePredSet)
updatePredSets = fmap or . mapM (uncurry updatePredSet)
updatePredSet :: InstIdent -> PredSet -> INCM Bool
updatePredSet i ps = do
......@@ -259,9 +313,9 @@ checkInstance tcEnv clsEnv (InstanceDecl spi cx cls inst _) = do
ps' = Set.fromList [ Pred scls ty | scls <- superClasses ocls clsEnv ]
doc = ppPred m $ Pred cls ty
what = "instance declaration"
ps'' <- reducePredSet p what doc clsEnv ps'
(ps'', _) <- reducePredSet False p what doc clsEnv ps'
Set.mapM_ (report . errMissingInstance m p what doc) $
ps'' `Set.difference` (maxPredSet clsEnv ps)
ps'' `Set.difference` maxPredSet clsEnv ps
where p = spanInfo2Pos spi
checkInstance _ _ _ = ok
......@@ -280,7 +334,8 @@ checkDefaultType p tcEnv clsEnv ty = do
m <- getModuleIdent
let PredType _ ty' = expandPolyType m tcEnv clsEnv $
QualTypeExpr NoSpanInfo [] ty
ps <- reducePredSet p what empty clsEnv (Set.singleton $ Pred qNumId ty')
(ps, _) <- reducePredSet False p what empty clsEnv
(Set.singleton $ Pred qNumId ty')
Set.mapM_ (report . errMissingInstance m p what empty) ps
where what = "default declaration"
......@@ -290,16 +345,20 @@ checkDefaultType p tcEnv clsEnv ty = do
-- a type variable. An error is reported if the predicate set cannot
-- be transformed into this form. In addition, we remove all predicates
-- that are implied by others within the same set.
-- When the flag is set, all missing Data preds are ignored
reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet
-> INCM PredSet
reducePredSet p what doc clsEnv ps = do
reducePredSet :: Bool -> Position -> String -> Doc -> ClassEnv -> PredSet
-> INCM (PredSet, PredSet)
reducePredSet b p what doc clsEnv ps = do
m <- getModuleIdent
inEnv <- getInstEnv
let (ps1, ps2) = partitionPredSet $ minPredSet clsEnv $ reducePreds inEnv ps
Set.mapM_ (report . errMissingInstance m p what doc) ps2
return ps1
ps2' = if b then Set.filter (isNotDataPred m) ps2 else ps2
Set.mapM_ (reportMissing m) ps2' >> return (ps1, ps2)
where
isNotDataPred _ (Pred qid _) = qid /= qDataId
reportMissing m pr@(Pred _ _) =
report $ errMissingInstance m p what doc pr
reducePreds inEnv = Set.concatMap $ reducePred inEnv
reducePred inEnv predicate = maybe (Set.singleton predicate)
(reducePreds inEnv)
......@@ -344,6 +403,15 @@ unqualInstIdent tcEnv (qcls, tc) = (unqual qcls, unqual tc)
where
unqual = head . flip reverseLookupByOrigName tcEnv
isFunType :: Type -> Bool
isFunType (TypeArrow _ _) = True
isFunType (TypeApply t1 t2) = isFunType t1 || isFunType t2
isFunType (TypeForall _ ty) = isFunType ty
isFunType (TypeConstructor _) = False
isFunType (TypeVariable _) = False
isFunType (TypeSkolem _) = False
isFunType (TypeConstrained tys _) = any isFunType tys
-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------
......
......@@ -450,8 +450,16 @@ tcPDeclGroup ps [(i, ExternalDecl p fs)] = do
tcPDeclGroup ps [(i, FreeDecl p fvs)] = do
vs <- mapM (tcDeclVar False) (bv fvs)
m <- getModuleIdent
modifyValueEnv $ flip (bindVars m) vs
return (ps, [(i, FreeDecl p (map (\(v, _, ForAll _ pty) -> Var pty v) vs))])
(vs', ps') <- unzip <$> mapM addDataPred vs
modifyValueEnv $ flip (bindVars m) vs'
let d = FreeDecl p (map (\(v, _, ForAll _ pty) -> Var pty v) vs')
return (ps `Set.union` Set.unions ps', [(i, d)])
where
addDataPred :: (Ident, Int, TypeScheme) -> TCM ((Ident, Int, TypeScheme), PredSet)
addDataPred (idt, n, ForAll vars (PredType ps1 ty1)) = do
(ps2, ty2) <- freshDataType
ps' <- unify idt "free variable" (ppIdent idt) ps1 ty1 ps2 ty2
return ((idt, n, ForAll vars (PredType ps' ty1)), ps')
tcPDeclGroup ps pds = do
vEnv <- getValueEnv
vss <- mapM (tcDeclVars . snd) pds
......@@ -1590,6 +1598,9 @@ freshFractionalType = freshPredType [qFractionalId]
freshMonadType :: TCM (PredSet, Type)
freshMonadType = freshPredType [qMonadId]
freshDataType :: TCM (PredSet, Type)
freshDataType = freshPredType [qDataId]
freshConstrained :: [Type] -> TCM Type
freshConstrained = freshVar . TypeConstrained
......
......@@ -324,12 +324,12 @@ 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
......@@ -350,7 +350,7 @@ checkDecl (ClassDecl p cx cls clsvar ds) = do
mapM_ (checkClassMethod clsvar) ds'
return $ ClassDecl p cx' cls clsvar ds'
checkDecl (InstanceDecl p cx qcls inst ds) = do
checkClass qcls
checkClass True qcls
QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst
checkSimpleContext cx'
checkInstanceType p inst'
......@@ -529,7 +529,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'
......@@ -537,16 +537,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
......@@ -698,3 +704,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."
]
......@@ -51,7 +51,7 @@ type DVM = S.State DVState
derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType
-> Module PredType
derive tcEnv vEnv inEnv pEnv (Module spi ps m es is ds) = Module spi ps m es is $
ds ++ concat (S.evalState (mapM deriveInstances tds) initState)
ds ++ concat (S.evalState (deriveAllInstances tds) initState)
where tds = filter isTypeDecl ds
initState = DVState m tcEnv vEnv inEnv pEnv 1
......@@ -80,6 +80,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"
-- An instance declaration is created for each type class of a deriving clause.
-- Newtype declaration are simply treated as data declarations.
......@@ -118,6 +147,7 @@ deriveMethods cls
| cls == qBoundedId = deriveBoundedMethods
| cls == qReadId = deriveReadMethods
| cls == qShowId = deriveShowMethods
| cls == qDataId = deriveDataMethods
| otherwise = internalError $ "Derive.deriveMethods: " ++ show cls
-- Binary Operators:
......@@ -160,6 +190,40 @@ eqOpExpr i1 es1 i2 es2
else foldl1 prelAnd $ zipWith prelEq es1 es2
| otherwise = prelFalse
-- Data:
deriveDataMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
deriveDataMethods ty cis ps = sequence
[ deriveBinOp qDataId dataEqId dataEqOpExpr ty cis ps
, deriveAValue ty cis ps]
dataEqOpExpr :: BinOpExpr
dataEqOpExpr i1 es1 i2 es2
| i1 == i2 = if null es1 then prelTrue
else foldl1 prelAnd $ zipWith prelDataEq es1 es2
| otherwise = prelFalse
deriveAValue :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveAValue ty cis ps = do
pty <- getInstMethodType ps qDataId ty aValueId
return $ FunctionDecl NoSpanInfo pty aValueId $
if null cis
then [mkEquation NoSpanInfo aValueId [] $
preludeFailed $ instType ty]
else map (deriveAValueEquation ty) cis
deriveAValueEquation :: Type -> ConstrInfo -> Equation PredType
deriveAValueEquation ty (arity, cns, _, tys)
| arity >= 0 = mkEquation NoSpanInfo aValueId [] $
foldl (Apply NoSpanInfo)
(Constructor NoSpanInfo constrType cns)
(map mkAValue tys')
| otherwise = internalError "Derive.aValueEquation: negative arity"
where
constrType = predType $ foldr TypeArrow (instType ty) tys'
mkAValue argty = Variable NoSpanInfo (predType argty) qAValueId
tys' = map instType tys
-- Ordering:
deriveOrdMethods :: Type -> [ConstrInfo] -> PredSet -> DVM [Decl PredType]
......@@ -262,7 +326,7 @@ deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do
enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent
-> QualIdent -> Expression PredType
enumFromThenExpr v1 v2 c1 c2 =
prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) $ boundedExpr
prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) boundedExpr
where boundedExpr = IfThenElse NoSpanInfo
(prelLeq
(prelFromEnum $ uncurry mkVar v1)
......@@ -299,7 +363,7 @@ deriveReadMethods ty cis ps = sequence [deriveReadsPrec ty cis ps]
deriveReadsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveReadsPrec ty cis ps = do
pty <- getInstMethodType ps qReadId ty $ readsPrecId
pty <- getInstMethodType ps qReadId ty readsPrecId
d <- freshArgument intType
r <- freshArgument stringType
let pats = map (uncurry (VariablePattern NoSpanInfo)) [d, r]
......@@ -310,7 +374,7 @@ deriveReadsPrecExpr :: Type -> [ConstrInfo] -> Expression PredType
-> Expression PredType -> DVM (Expression PredType)
deriveReadsPrecExpr ty cis d r = do
es <- mapM (deriveReadsPrecReadParenExpr ty d) cis
return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) $ es
return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) es
deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo
-> DVM (Expression PredType)
......@@ -334,7 +398,7 @@ deriveReadsPrecLambdaExpr :: Type -> ConstrInfo -> Precedence
deriveReadsPrecLambdaExpr ty (_, c, ls, tys) p = do
r <- freshArgument stringType
(stmts, vs, s) <- deriveReadsPrecStmts (unqualify c) (p + 1) r ls tys
let pty = predType $ foldr TypeArrow (instType ty) $ map instType tys
let pty = predType $ foldr (TypeArrow . instType) (instType ty) tys
e = Tuple NoSpanInfo
[ apply (Constructor NoSpanInfo pty c) $ map (uncurry mkVar) vs
, uncurry mkVar s
......@@ -401,7 +465,7 @@ deriveReadsPrecConstrStmts c r tys = do
deriveReadsPrecLexStmt :: String -> (PredType, Ident)
-> DVM ((PredType, Ident), Statement PredType)
deriveReadsPrecLexStmt str r = do
s <- freshArgument $ stringType
s <- freshArgument stringType
let pat = TuplePattern NoSpanInfo
[ LiteralPattern NoSpanInfo predStringType $ String str
, uncurry (VariablePattern NoSpanInfo) s
......@@ -427,7 +491,7 @@ deriveShowMethods ty cis ps = sequence [deriveShowsPrec ty cis ps]
deriveShowsPrec :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType)
deriveShowsPrec ty cis ps = do
pty <- getInstMethodType ps qShowId ty $ showsPrecId
pty <- getInstMethodType ps qShowId ty showsPrecId
eqs <- mapM (deriveShowsPrecEquation ty) cis
return $ FunctionDecl NoSpanInfo pty showsPrecId eqs
......@@ -492,7 +556,7 @@ freshArgument = freshVar "_#arg"
freshVar :: String -> Type -> DVM (PredType, Ident)
freshVar name ty =
((,) (predType ty)) . mkIdent . (name ++) . show <$> getNextId
(,) (predType ty) . mkIdent . (name ++) . show <$> getNextId
-- -----------------------------------------------------------------------------
-- Auxiliary functions
......@@ -541,7 +605,7 @@ instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType vEnv ps cls ty f = PredType (ps `Set.union` ps'') ty''
where PredType ps' ty' = case qualLookupValue (qualifyLike cls f) vEnv of
[Value _ _ _ (ForAll _ pty)] -> pty
_ -> internalError $ "Derive.instMethodType"
_ -> internalError "Derive.instMethodType"
PredType ps'' ty'' = instanceType ty $ PredType (Set.deleteMin ps') ty'
-- -----------------------------------------------------------------------------
......@@ -577,6 +641,12 @@ prelEq e1 e2 = foldl1 (Apply NoSpanInfo)
where ty = typeOf e1
pty = predType $ foldr1 TypeArrow [ty, ty, boolType]
prelDataEq :: Expression PredType -> Expression PredType -> Expression PredType
prelDataEq e1 e2 = foldl1 (Apply NoSpanInfo)
[Variable NoSpanInfo pty qDataEqId, e1, e2]
where ty = typeOf e1
pty = predType $ foldr1 TypeArrow [ty, ty, boolType]
prelLeq :: Expression PredType -> Expression PredType -> Expression PredType
prelLeq e1 e2 = foldl1 (Apply NoSpanInfo)
[Variable NoSpanInfo pty qLeqOpId, e1, e2]
......@@ -626,7 +696,7 @@ prelShowParen e1 e2 = apply (Variable NoSpanInfo pty qShowParenId) [e1, e2]
]
preludeLex :: Expression PredType -> Expression PredType
preludeLex e = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) e
preludeLex = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId)
where pty = predType $ TypeArrow stringType $
listType $ tupleType [stringType, stringType]
......
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