Commit 5889b76e authored by Michael Hanus's avatar Michael Hanus
Browse files

Fix printing of types, default `MonadFail`

parent 8907e037
......@@ -1127,16 +1127,16 @@ defaultQualTypeExpr (CQualType (CContext ctxt) cty) =
where
defaultData qty@(CQualType (CContext dctxt) dcty) = case dctxt of
[] -> qty
(qtcons, CTVar tv) : cs | qtcons == ("Prelude","Data")
(qtcons, CTVar tv) : cs | qtcons == pre "Data"
-> defaultData (CQualType (CContext cs)
(substTypeVar tv (CTCons ("Prelude","Bool")) dcty))
(substTypeVar tv (CTCons (pre "Bool")) dcty))
_ -> qty
defaultMonad qty@(CQualType (CContext dctxt) dcty) = case dctxt of
[] -> qty
(qtcons, CTVar tv) : cs | qtcons == ("Prelude","Monad")
(qtcons, CTVar tv) : cs | qtcons `elem` map pre ["Monad","MonadFail"]
-> defaultMonad (CQualType (CContext cs)
(substTypeVar tv (CTCons ("Prelude","IO")) dcty))
(substTypeVar tv (CTCons (pre "IO")) dcty))
_ -> qty
defaultTExp :: [CConstraint] -> CQualTypeExpr -> CQualTypeExpr
......@@ -1150,7 +1150,7 @@ defaultQualTypeExpr (CQualType (CContext ctxt) cty) =
in defaultTExp
(removeConstraints tv defptype cs)
(CQualType (CContext (removeConstraints tv defptype cs2))
(substTypeVar tv (CTCons ("Prelude", defptype)) ty))
(substTypeVar tv (CTCons (pre defptype)) ty))
else defaultTExp cs (CQualType (CContext (cs2 ++ [c])) ty)
_ -> defaultTExp cs (CQualType (CContext (cs2 ++ [c])) ty)
......
......@@ -40,7 +40,7 @@ showContext True _ = ""
--- Shows an AbstractCurry constraint in standard Curry syntax.
showConstraint :: CConstraint -> String
showConstraint ((_, name), ty) =
showIdentifier name ++ " " ++ showMonoTypeExpr False ty
showIdentifier name ++ " " ++ showMonoTypeExpr' False 2 ty
--- Shows an AbstractCurry type expression in standard Curry syntax.
--- If the first argument is True, all occurrences of type variables
......@@ -56,8 +56,8 @@ showMonoTypeExpr' mono p (CFuncType domain range) = parens (p > 0) $
showMonoTypeExpr' _ _ (CTCons (_,name)) = name
showMonoTypeExpr' mono p texp@(CTApply tcon targ) = maybe
(parens (p > 1) $ showMonoTypeExpr' mono 2 tcon ++ " " ++
showMonoTypeExpr' mono 2 targ)
(\(mod,name) -> showTypeCons mono mod name (argsOfApply texp))
showMonoTypeExpr' mono 2 targ)
(\ (mod,name) -> showTypeCons mono mod name (argsOfApply texp))
(funOfApply texp)
where
funOfApply te = case te of CTApply (CTCons qn) _ -> Just qn
......
Supports Markdown
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