Revert everything since 'higher-rank-polymorphism' (!14)

CHANGELOG.md

 Change log for curry-frontend
 =============================
 
-Version 2.0.0
-=============
-
-  * Implemented the "MonadFail-Proposal" for curry
-    (see <https://wiki.haskell.org/MonadFail_Proposal>)
-  * Data class (see <https://arxiv.org/abs/1908.10607>)
-  * RankNTypes
-  * Fixed bug with partially imported Typeclasses
-  * Fixed bug with parsing of empty blocks
-  * Fixed bug with re-export of record labels
-
 Version 1.0.4
 =============
 
   * Fixed bug in type checking of instances
-  * Fixed bugs in deriving of `Bounded` instances.
 
 Version 1.0.3
 =============

data/currysource.css

-:root {
-  --link-bg-color: lightyellow;
-  --line-number-color: grey;
-  --pragma-color: green;
-  --comment-color: green;
-  --keyword-color: blue;
-  --symbol-color: red;
-  --type-color: orange;
-  --cons-color: magenta;
-  --label-color: darkgreen;
-  --func-color: purple;
-  --ident-color: black;
-  --module-color: brown;
-  --number-color: teal;
-  --string-color: maroon;
-  --char-color: maroon;
-  color-scheme: light dark;
-}
-
+/* Use always white background */
 body {
+  background : white;
+  color      : black;
   font-family: monospace;
-  text-size-adjust: none;
-  -moz-text-size-adjust: none;
-  -ms-text-size-adjust: none;
-  -webkit-text-size-adjust: none;
-}
-
-table {
-  border-collapse: collapse;
 }
 
-/* Hyperlinks */
-a:link,
-a:visited,
-a:active {
-  background: var(--link-bg-color);
+/* Show hyperlinks without text decoration, but in light yellow */
+a:visited, a:link, a:active {
   text-decoration: none;
+  background     : lightyellow;
 }
 
 /* Line numbers */
-.line-numbers {
-  border-right: 1px solid var(--line-number-color);
-  color: var(--line-number-color);
-  min-width: 5ch;
-  padding-right: 1em;
-  text-align: right;
+.linenumbers {
+  width        : 40px;
+  text-align   : right;
+  color        : grey;
+  padding-right: 10px;
+  border-right : 1px solid grey;
 }
 
 /* Source code */
-.source-code {
-  padding-left: 1em;
+.sourcecode  {
+  padding-left: 10px;
 }
 
 /* Code highlighting */
-.pragma  { color: var(--pragma-color)  }
-.comment { color: var(--comment-color) }
-.keyword { color: var(--keyword-color) }
-.symbol  { color: var(--symbol-color)  }
-.type    { color: var(--type-color)    }
-.cons    { color: var(--cons-color)    }
-.label   { color: var(--label-color)   }
-.func    { color: var(--func-color)    }
-.ident   { color: var(--ident-color)   }
-.module  { color: var(--module-color)  }
-.number  { color: var(--number-color)  }
-.string  { color: var(--string-color)  }
-.char    { color: var(--char-color)    }
-
-@supports not (color-scheme: light dark) {
-  @media (prefers-color-scheme: dark) {
-    html {
-      background: hsl(0, 0%, 12%);
-      color: white;
-    }
-  }
-}
-
-@media (prefers-color-scheme: dark) {
-  :root {
-    --link-bg-color: hsl(0, 0%, 17%);
-    --pragma-color: hsl(0, 0%, 60%);
-    --comment-color: hsl(0, 0%, 60%);
-    --keyword-color: hsl(300, 66%, 70%);
-    --symbol-color: hsl(0, 66%, 70%);
-    --type-color: hsl(60, 66%, 70%);
-    --cons-color: hsl(330, 66%, 70%);
-    --label-color: hsl(240, 66%, 70%);
-    --func-color: hsl(200, 66%, 70%);
-    --ident-color: hsl(0, 0%, 85%);
-    --module-color: hsl(20, 66%, 70%);
-    --number-color: hsl(180, 66%, 70%);
-    --string-color: hsl(120, 66%, 70%);
-    --char-color: hsl(120, 66%, 70%);
-  }
-}
+.pragma  { color : green     }
+.comment { color : green     }
+.keyword { color : blue      }
+.symbol  { color : red       }
+.type    { color : orange    }
+.cons    { color : magenta   }
+.label   { color : darkgreen }
+.func    { color : purple    }
+.ident   { color : black     }
+.module  { color : brown     }
+.number  { color : teal      }
+.string  { color : maroon    }
+.char    { color : maroon    }

src/Base/AnnotExpr.hs

@@ -33,11 +33,11 @@ class QualAnnotExpr e where
 -- variables cannot be computed independently for each declaration.
 
 instance QualAnnotExpr Decl where
-  qafv m (FunctionDecl    _ _ _ eqs) = concatMap (qafv m) eqs
-  qafv m (PatternDecl       _ _ rhs) = qafv m rhs
-  qafv m (ClassDecl    _ _ _ _ _ ds) = concatMap (qafv m) ds
-  qafv m (InstanceDecl _ _ _ _ _ ds) = concatMap (qafv m) ds
-  qafv _ _                           = []
+  qafv m (FunctionDecl  _ _ _ eqs) = concatMap (qafv m) eqs
+  qafv m (PatternDecl     _ _ rhs) = qafv m rhs
+  qafv m (ClassDecl    _ _ _ _ ds) = concatMap (qafv m) ds
+  qafv m (InstanceDecl _ _ _ _ ds) = concatMap (qafv m) ds
+  qafv _ _                         = []
 
 instance QualAnnotExpr Equation where
   qafv m (Equation _ lhs rhs) = filterBv lhs $ qafv m lhs ++ qafv m rhs
@@ -46,8 +46,8 @@ instance QualAnnotExpr Lhs where
   qafv m = concatMap (qafv m) . snd . flatLhs
 
 instance QualAnnotExpr Rhs where
-  qafv m (SimpleRhs _ _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds
-  qafv m (GuardedRhs _ _ es ds) =
+  qafv m (SimpleRhs _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds
+  qafv m (GuardedRhs _ es ds) =
     filterBv ds $ concatMap (qafv m) es ++ concatMap (qafv m) ds
 
 instance QualAnnotExpr CondExpr where
@@ -75,11 +75,11 @@ instance QualAnnotExpr Expression where
   qafv m (LeftSection        _ e op) = qafv m op ++ qafv m e
   qafv m (RightSection       _ op e) = qafv m op ++ qafv m e
   qafv m (Lambda             _ ts e) = filterBv ts $ qafv m e
-  qafv m (Let              _ _ ds e) =
+  qafv m (Let                _ ds e) =
     filterBv ds $ concatMap (qafv m) ds ++ qafv m e
-  qafv m (Do              _ _ sts e) = foldr (qafvStmt m) (qafv m e) sts
+  qafv m (Do                _ sts e) = foldr (qafvStmt m) (qafv m e) sts
   qafv m (IfThenElse     _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3
-  qafv m (Case         _ _ _ e alts) = qafv m e ++ concatMap (qafv m) alts
+  qafv m (Case           _ _ e alts) = qafv m e ++ concatMap (qafv m) alts
 
 qafvField :: QualAnnotExpr e => ModuleIdent -> Field (e Type) -> [(Type, Ident)]
 qafvField m (Field _ _ t) = qafv m t
@@ -88,9 +88,9 @@ qafvStmt :: ModuleIdent -> Statement Type -> [(Type, Ident)] -> [(Type, Ident)]
 qafvStmt m st fvs = qafv m st ++ filterBv st fvs
 
 instance QualAnnotExpr Statement where
-  qafv m (StmtExpr   _  e) = qafv m e
-  qafv m (StmtDecl _ _ ds) = filterBv ds $ concatMap (qafv m) ds
-  qafv m (StmtBind _ _  e) = qafv m e
+  qafv m (StmtExpr   _ e) = qafv m e
+  qafv m (StmtDecl  _ ds) = filterBv ds $ concatMap (qafv m) ds
+  qafv m (StmtBind _ _ e) = qafv m e
 
 instance QualAnnotExpr Alt where
   qafv m (Alt _ t rhs) = filterBv t $ qafv m rhs

src/Base/CurryKinds.hs

@@ -19,9 +19,9 @@ module Base.CurryKinds
   ( toKind, toKind', fromKind, fromKind', ppKind
   ) where
 
-import Curry.Base.Pretty   (Doc)
-import Curry.Syntax.Pretty (pPrintPrec)
-import Curry.Syntax.Type   (KindExpr (..))
+import Curry.Base.Pretty (Doc)
+import Curry.Syntax.Pretty (ppKindExpr)
+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 = pPrintPrec 0 . fromKind
+ppKind = ppKindExpr 0 . fromKind

src/Base/CurryTypes.hs

@@ -30,7 +30,7 @@ module Base.CurryTypes
   , fromType, fromQualType
   , fromPred, fromQualPred, fromPredSet, fromQualPredSet, fromPredType
   , fromQualPredType
-  , ppType, ppPred, ppPredSet, ppPredType
+  , ppType, ppPred, ppPredType, ppTypeScheme
   ) where
 
 import Data.List (nub)
@@ -38,10 +38,10 @@ import qualified Data.Map as Map (Map, fromList, lookup)
 import qualified Data.Set as Set
 
 import Curry.Base.Ident
-import Curry.Base.Pretty (Doc, list, parens)
+import Curry.Base.Pretty (Doc)
 import Curry.Base.SpanInfo
 import qualified Curry.Syntax as CS
-import Curry.Syntax.Pretty (pPrint, pPrintPrec)
+import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr, ppQualTypeExpr)
 
 import Base.Expr
 import Base.Messages (internalError)
@@ -76,11 +76,6 @@ toType' tvs (CS.ArrowType  _ ty1 ty2) tys
   | null tys = TypeArrow (toType' tvs ty1 []) (toType' tvs ty2 [])
   | otherwise = internalError "Base.CurryTypes.toType': arrow type application"
 toType' tvs (CS.ParenType       _ ty) tys = toType' tvs ty tys
-toType' tvs (CS.ContextType _ cx ty)  tys
-  | null cx   = toType' tvs ty tys
-  | otherwise = applyType (TypeContext (toPredSet' tvs cx)
-                                       (toType' tvs ty []))
-                          tys
 toType' tvs (CS.ForallType _ tvs' ty) tys
   | null tvs' = toType' tvs ty tys
   | otherwise = applyType (TypeForall (map (toVar tvs) tvs')
@@ -116,41 +111,47 @@ toPredSet' tvs = Set.fromList . map (toPred' tvs)
 toQualPredSet :: ModuleIdent -> [Ident] -> CS.Context -> PredSet
 toQualPredSet m tvs = qualifyPredSet m . toPredSet tvs
 
-toPredType :: [Ident] -> CS.TypeExpr -> Type
-toPredType tvs ty = toPredType' (enumTypeVars tvs ty) ty
+toPredType :: [Ident] -> CS.QualTypeExpr -> PredType
+toPredType tvs qty = toPredType' (enumTypeVars tvs qty) qty
 
-toPredType' :: Map.Map Ident Int -> CS.TypeExpr -> Type
-toPredType' tvs (CS.ContextType _ cx ty) =
-  TypeContext (toPredSet' tvs cx) (toType' tvs ty [])
-toPredType' tvs ty = TypeContext (toPredSet' tvs []) (toType' tvs ty [])
+toPredType' :: Map.Map Ident Int -> CS.QualTypeExpr -> PredType
+toPredType' tvs (CS.QualTypeExpr _ cx ty) =
+  PredType (toPredSet' tvs cx) (toType' tvs ty [])
 
-toQualPredType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type
-toQualPredType m tvs = qualifyType m . toPredType tvs
+toQualPredType :: ModuleIdent -> [Ident] -> CS.QualTypeExpr -> PredType
+toQualPredType m tvs = qualifyPredType m . toPredType tvs
 
 -- The function 'toConstrType' returns the type of a data or newtype
 -- constructor. Hereby, it restricts the context to those type variables
 -- which are free in the argument types.
 
-toConstrType :: QualIdent -> [Ident] -> [CS.TypeExpr] -> Type
-toConstrType tc tvs tys = toPredType tvs $
-  CS.ContextType NoSpanInfo [] ty'
-  where ty'  = foldr (CS.ArrowType NoSpanInfo) ty0 tys
+toConstrType :: QualIdent -> [Ident] -> CS.Context -> [CS.TypeExpr] -> PredType
+toConstrType tc tvs cx tys = toPredType tvs $
+  CS.QualTypeExpr NoSpanInfo cx' ty' 
+  where tvs' = nub (fv tys)
+        cx'  = restrictContext tvs' cx
+        ty'  = foldr (CS.ArrowType NoSpanInfo) ty0 tys
         ty0  = foldl (CS.ApplyType NoSpanInfo)
                      (CS.ConstructorType NoSpanInfo tc)
                      (map (CS.VariableType NoSpanInfo) tvs)
 
+restrictContext :: [Ident] -> CS.Context -> CS.Context
+restrictContext tvs cx =
+  [CS.Constraint spi cls ty
+    | CS.Constraint spi cls ty <- cx, classVar ty `elem` tvs]
+  where classVar (CS.VariableType _ tv) = tv
+        classVar (CS.ApplyType  _ ty _) = classVar ty
+        classVar _ = internalError "Base.CurryTypes.restrictContext.classVar"
+
 -- The function 'toMethodType' returns the type of a type class method.
 -- It adds the implicit type class constraint to the method's type signature
 -- and ensures that the class' type variable is always assigned index 0.
 
-toMethodType :: QualIdent -> Ident -> CS.TypeExpr -> Type
-toMethodType qcls clsvar (CS.ContextType spi cx ty) =
-  toPredType [clsvar] (CS.ContextType spi cx' ty)
+toMethodType :: QualIdent -> Ident -> CS.QualTypeExpr -> PredType
+toMethodType qcls clsvar (CS.QualTypeExpr spi cx ty) =
+  toPredType [clsvar] (CS.QualTypeExpr spi cx' ty)
   where cx' = CS.Constraint NoSpanInfo qcls
                 (CS.VariableType NoSpanInfo clsvar) : cx
-toMethodType qcls clsvar ty =
-  toPredType [clsvar] (CS.ContextType NoSpanInfo cx' ty)
-  where cx' = [CS.Constraint NoSpanInfo qcls (CS.VariableType NoSpanInfo clsvar)]
 
 fromType :: [Ident] -> Type -> CS.TypeExpr
 fromType tvs ty = fromType' tvs ty []
@@ -172,10 +173,9 @@ fromType' tvs (TypeArrow     ty1 ty2) tys =
   foldl (CS.ApplyType NoSpanInfo)
     (CS.ArrowType NoSpanInfo (fromType tvs ty1) (fromType tvs ty2)) tys
 fromType' tvs (TypeConstrained tys _) tys' = fromType' tvs (head tys) tys'
-fromType' tvs (TypeContext ps ty) tys
-  = foldl (CS.ApplyType NoSpanInfo)
-          (CS.ContextType NoSpanInfo (fromPredSet tvs ps) (fromType tvs ty))
-          tys
+fromType' _   (TypeSkolem          k) tys =
+  foldl (CS.ApplyType NoSpanInfo)
+    (CS.VariableType NoSpanInfo $ mkIdent $ "_?" ++ show k) tys
 fromType' tvs (TypeForall    tvs' ty) tys
   | null tvs' = fromType' tvs ty tys
   | otherwise = foldl (CS.ApplyType NoSpanInfo)
@@ -204,24 +204,23 @@ fromPredSet tvs = map (fromPred tvs) . Set.toAscList
 fromQualPredSet :: ModuleIdent -> [Ident] -> PredSet -> CS.Context
 fromQualPredSet m tvs = fromPredSet tvs . unqualifyPredSet m
 
-fromPredType :: [Ident] -> Type -> CS.TypeExpr
-fromPredType tvs (TypeContext ps ty) =
-  CS.ContextType NoSpanInfo (fromPredSet tvs ps) (fromType tvs ty)
-fromPredType tvs ty = fromType tvs ty
+fromPredType :: [Ident] -> PredType -> CS.QualTypeExpr
+fromPredType tvs (PredType ps ty) =
+  CS.QualTypeExpr NoSpanInfo (fromPredSet tvs ps) (fromType tvs ty)
 
-fromQualPredType :: ModuleIdent -> [Ident] -> Type -> CS.TypeExpr
-fromQualPredType m tvs = fromPredType tvs . unqualifyType m
+fromQualPredType :: ModuleIdent -> [Ident] -> PredType -> CS.QualTypeExpr
+fromQualPredType m tvs = fromPredType tvs . unqualifyPredType m
 
 -- The following functions implement pretty-printing for types.
 
 ppType :: ModuleIdent -> Type -> Doc
-ppType m = pPrintPrec 0 . fromQualType m identSupply
+ppType m = ppTypeExpr 0 . fromQualType m identSupply
 
 ppPred :: ModuleIdent -> Pred -> Doc
-ppPred m = pPrint . fromQualPred m identSupply
+ppPred m = ppConstraint . fromQualPred m identSupply
 
-ppPredSet :: ModuleIdent -> PredSet -> Doc
-ppPredSet m = parens . list . map (ppPred m) . Set.toList
+ppPredType :: ModuleIdent -> PredType -> Doc
+ppPredType m = ppQualTypeExpr . fromQualPredType m identSupply
 
-ppPredType :: ModuleIdent -> Type -> Doc
-ppPredType m = pPrintPrec 0 . fromQualPredType m identSupply
+ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc
+ppTypeScheme m (ForAll _ pty) = ppPredType m pty

src/Base/Expr.hs

@@ -58,20 +58,20 @@ instance QuantExpr e => QuantExpr [e] where
 -- variables cannot be computed independently for each declaration.
 
 instance QualExpr (Decl a) where
-  qfv m (FunctionDecl    _ _ _ eqs) = qfv m eqs
-  qfv m (PatternDecl       _ _ rhs) = qfv m rhs
-  qfv m (ClassDecl    _ _ _ _ _ ds) = qfv m ds
-  qfv m (InstanceDecl _ _ _ _ _ ds) = qfv m ds
-  qfv _ _                           = []
+  qfv m (FunctionDecl  _ _ _ eqs) = qfv m eqs
+  qfv m (PatternDecl     _ _ rhs) = qfv m rhs
+  qfv m (ClassDecl    _ _ _ _ ds) = qfv m ds
+  qfv m (InstanceDecl _ _ _ _ ds) = qfv m ds
+  qfv _ _                         = []
 
 instance QuantExpr (Decl a) where
-  bv (TypeSig         _ vs _) = vs
-  bv (FunctionDecl   _ _ f _) = [f]
-  bv (ExternalDecl      _ vs) = bv vs
-  bv (PatternDecl      _ t _) = bv t
-  bv (FreeDecl          _ vs) = bv vs
-  bv (ClassDecl _ _ _ _ _ ds) = concatMap methods ds
-  bv _                        = []
+  bv (TypeSig          _ vs _) = vs
+  bv (FunctionDecl    _ _ f _) = [f]
+  bv (ExternalDecl       _ vs) = bv vs
+  bv (PatternDecl       _ t _) = bv t
+  bv (FreeDecl           _ vs) = bv vs
+  bv (ClassDecl    _ _ _ _ ds) = concatMap methods ds
+  bv _                         = []
 
 instance QualExpr (Equation a) where
   qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs
@@ -83,8 +83,8 @@ instance QualExpr (Lhs a) where
   qfv m lhs = qfv m $ snd $ flatLhs lhs
 
 instance QualExpr (Rhs a) where
-  qfv m (SimpleRhs _ _ e ds) = filterBv ds $ qfv m e  ++ qfv m ds
-  qfv m (GuardedRhs _ _ es ds) = filterBv ds $ qfv m es ++ qfv m ds
+  qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e  ++ qfv m ds
+  qfv m (GuardedRhs _ es ds) = filterBv ds $ qfv m es ++ qfv m ds
 
 instance QualExpr (CondExpr a) where
   qfv m (CondExpr _ g e) = qfv m g ++ qfv m e
@@ -110,18 +110,18 @@ instance QualExpr (Expression a) where
   qfv m (LeftSection        _ e op) = qfv m op ++ qfv m e
   qfv m (RightSection       _ op e) = qfv m op ++ qfv m e
   qfv m (Lambda             _ ts e) = filterBv ts $ qfv m e
-  qfv m (Let              _ _ ds e) = filterBv ds $ qfv m ds ++ qfv m e
-  qfv m (Do              _ _ sts e) = foldr (qfvStmt m) (qfv m e) sts
+  qfv m (Let                _ ds e) = filterBv ds $ qfv m ds ++ qfv m e
+  qfv m (Do                _ sts e) = foldr (qfvStmt m) (qfv m e) sts
   qfv m (IfThenElse     _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
-  qfv m (Case         _ _ _ e alts) = qfv m e ++ qfv m alts
+  qfv m (Case           _ _ e alts) = qfv m e ++ qfv m alts
 
 qfvStmt :: ModuleIdent -> (Statement a) -> [Ident] -> [Ident]
 qfvStmt m st fvs = qfv m st ++ filterBv st fvs
 
 instance QualExpr (Statement a) where
-  qfv m (StmtExpr   _ e)  = qfv m e
-  qfv m (StmtDecl _ _ ds) = filterBv ds $ qfv m ds
-  qfv m (StmtBind _ _ e)  = qfv m e
+  qfv m (StmtExpr   _ e) = qfv m e
+  qfv m (StmtDecl  _ ds) = filterBv ds $ qfv m ds
+  qfv m (StmtBind _ _ e) = qfv m e
 
 instance QualExpr (Alt a) where
   qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs
@@ -136,9 +136,9 @@ instance QualExpr a => QualExpr (Field a) where
   qfv m (Field _ _ t) = qfv m t
 
 instance QuantExpr (Statement a) where
-  bv (StmtExpr   _ _)  = []
-  bv (StmtBind _ t _)  = bv t
-  bv (StmtDecl _ _ ds) = bv ds
+  bv (StmtExpr   _ _) = []
+  bv (StmtBind _ t _) = bv t
+  bv (StmtDecl  _ ds) = bv ds
 
 instance QualExpr (InfixOp a) where
   qfv m (InfixOp     a op) = qfv m $ Variable NoSpanInfo a op
@@ -182,6 +182,12 @@ instance Expr Constraint where
 instance QuantExpr Constraint where
   bv _ = []
 
+instance Expr QualTypeExpr where
+  fv (QualTypeExpr _ _ ty) = fv ty
+
+instance QuantExpr QualTypeExpr where
+  bv (QualTypeExpr _ _ ty) = bv ty
+
 instance Expr TypeExpr where
   fv (ConstructorType     _ _) = []
   fv (ApplyType     _ ty1 ty2) = fv ty1 ++ fv ty2
@@ -190,7 +196,6 @@ instance Expr TypeExpr where
   fv (ListType          _  ty) = fv ty
   fv (ArrowType     _ ty1 ty2) = fv ty1 ++ fv ty2
   fv (ParenType          _ ty) = fv ty
-  fv (ContextType      _ _ ty) = fv ty
   fv (ForallType      _ vs ty) = filter (`notElem` vs) $ fv ty
 
 instance QuantExpr TypeExpr where
@@ -201,7 +206,6 @@ instance QuantExpr TypeExpr where
   bv (ListType           _ ty) = bv ty
   bv (ArrowType     _ ty1 ty2) = bv ty1 ++ bv ty2
   bv (ParenType          _ ty) = bv ty
-  bv (ContextType      _ _ ty) = bv ty
   bv (ForallType     _ tvs ty) = tvs ++ bv ty
 
 filterBv :: QuantExpr e => e -> [Ident] -> [Ident]

src/Base/PrettyKinds.hs

@@ -10,7 +10,7 @@
 
    TODO
 -}
-{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Base.PrettyKinds where
 
 import Curry.Base.Pretty

src/Base/PrettyTypes.hs

@@ -10,33 +10,39 @@
 
    TODO
 -}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE CPP #-}
 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 = pPrintPrec 0 . fromType identSupply
+  pPrint = ppTypeExpr 0 . fromType identSupply
 
 instance Pretty Pred where
-  pPrint = pPrint . fromPred identSupply
+  pPrint = ppConstraint . fromPred identSupply
 
 instance Pretty a => Pretty (Set.Set a) where
   pPrint = parens . list . map pPrint . Set.toAscList
 
+instance Pretty PredType where
+  pPrint = ppQualTypeExpr . fromPredType identSupply
+
 instance Pretty DataConstr where
-  pPrint (DataConstr i tys)      = pPrint i <+> hsep (map pPrint tys)
-  pPrint (RecordConstr i ls tys) =     pPrint i
-                                   <+> braces (hsep (punctuate comma pLs))
+  pPrint (DataConstr i _ _ tys)      = pPrint i <+> hsep (map pPrint tys)
+  pPrint (RecordConstr i _ _ ls tys) =     pPrint i
+                                       <+> braces (hsep (punctuate comma pLs))
     where
       pLs = zipWith (\l ty -> pPrint l <+> colon <> colon <+> pPrint ty) ls tys
 
@@ -44,3 +50,9 @@ instance Pretty ClassMethod where
   pPrint (ClassMethod f mar pty) =     pPrint f
                                    <>  text "/" <> int (fromMaybe 0 mar)
                                    <+> colon <> colon <+> pPrint pty
+
+instance Pretty TypeScheme where
+  pPrint (ForAll _ ty) = pPrint ty
+
+instance Pretty ExistTypeScheme where
+  pPrint (ForAllExist _ _ ty) = pPrint ty

src/Base/Subst.hs

@@ -19,7 +19,7 @@
 
 module Base.Subst
   ( Subst (..), IntSubst (..), idSubst, singleSubst, bindSubst, unbindSubst
-  , substToList, compose, lookupSubst, substVar', isubstVar, restrictSubstTo
+  , substToList, compose, substVar', isubstVar, restrictSubstTo
   ) where
 
 import qualified Data.Map as Map
@@ -48,9 +48,6 @@ bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
 unbindSubst :: Ord v => v -> Subst v e -> Subst v e
 unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma
 
-lookupSubst :: Ord v => v -> Subst v e -> Maybe e
-lookupSubst v (Subst _ sigma) = Map.lookup v sigma
-
 -- For any substitution we have the following definitions:
 --     sigma(x)     = t_i   if x = x_i
 --                    x    otherwise

src/Base/TopEnv.hs

@@ -88,12 +88,12 @@ predefTopEnv k v (TopEnv env) = case Map.lookup k env of
 -- |Insert an 'Entity' as unqualified into a 'TopEnv'
 importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
              -> TopEnv a
-importTopEnv m x = addImport m (qualify x)
+importTopEnv m x y env = addImport m (qualify x) y env
 
 -- |Insert an 'Entity' as qualified into a 'TopEnv'
 qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
                  -> TopEnv a
-qualImportTopEnv m x = addImport m (qualifyWith m x)
+qualImportTopEnv m x y env = addImport m (qualifyWith m x) y env
 
 -- local helper
 addImport :: Entity a => ModuleIdent -> QualIdent -> a -> TopEnv a
@@ -109,7 +109,7 @@ addImport m k v (TopEnv env) = TopEnv $
     Nothing  -> imp : mergeImport y xs
 
 bindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
-bindTopEnv x = qualBindTopEnv (qualify x)
+bindTopEnv x y env = qualBindTopEnv (qualify x) y env
 
 qualBindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
 qualBindTopEnv x y (TopEnv env)
@@ -117,7 +117,7 @@ qualBindTopEnv x y (TopEnv env)
   where
   bindLocal y' ys
     | null [ y'' | (Local, y'') <- ys ] = (Local, y') : ys
-    | otherwise                         = ys
+    | otherwise = internalError $ "qualBindTopEnv " ++ show x