Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
Checking mergeability… Don't worry, you can still create the pull request.
  • 2 commits
  • 12 files changed
  • 0 commit comments
  • 1 contributor
View
2  EHC/src/ehc/EH.cag
@@ -149,7 +149,7 @@ mkIf'' (bn:tn:fn:_) r c t e i failS
| n == tn -> t
| n == fn -> e
_ -> mkCase' r
- ( rngLift r Expr_TypeAs (rngLift r TyExpr_Con bn) c )
+ ( rngLift r Expr_TypeAs False (rngLift r TyExpr_Con bn) c )
%%[[8
i failS False
%%]]
View
3  EHC/src/ehc/EH/AbsSyn.cag
@@ -339,7 +339,8 @@ DATA Expr
body : Expr
| AppTop expr : Expr
| Parens expr : Expr
- | TypeAs tyExpr : TyExpr
+ | TypeAs isScoped : {Bool} -- ^ Are the type vars in 'tyExpr' to be lexically scoped? Used for: f a :: t = e, rewritten to \a -> (e :: t)
+ tyExpr : TyExpr
expr : Expr
| Ann ann : ExprAnn
expr : Expr
View
1  EHC/src/ehc/EH/InferExpr.cag
@@ -481,6 +481,7 @@ SEM Expr
. gTyTvS = @tyTyUpdFreeTvarS `Set.union` @valTyUpdFreeTvarS
%%]]
. tyVarWildS = Map.keysSet @tyExpr.tyVarWildMp
+ `Set.union` (if @isScoped then varFreeSet @tyExpr.ty else Set.empty)
. ty_q_ := tyQuantifyOuter (const kiStar {- TBD -}) (`Set.member` (@tyVarWildS `Set.union` @gTyTvS)) @tyTy
. fo_ := fitsIn @knTyFIOpts @fe @lUniq @lhs.tyVarMp @ty_q_ @lhs.knTy
. ty_q_2_VarMp = foVarMp @fo_ `varUpd` @lhs.tyVarMp
View
2  EHC/src/ehc/EH/Parser.chs
@@ -340,7 +340,7 @@ pExprBase = mkEH Expr_IConst <$> pInt
-- pExpr
%%[1.pExpr
-pExpr = pE <??> (mkEH Expr_TypeAs <$ pKey "::" <*> pTyExpr)
+pExpr = pE <??> (mkEH Expr_TypeAs False <$ pKey "::" <*> pTyExpr)
where pE = pExprPrefix <*> pE
<|> pExprApp
%%]
View
2  EHC/src/ehc/EH/Pretty.cag
@@ -63,7 +63,7 @@ SEM Expr
%%]]
| App loc . pp = @func.pp >#< @arg.pp
| Parens loc . pp = ppParens @expr.pp
- | TypeAs loc . pp = ppParens @expr.pp >#< "::" >#< @tyExpr.pp
+ | TypeAs loc . pp = ppParens @expr.pp >#< "::" >|< (if @isScoped then "sc" else "") >#< @tyExpr.pp
| Ann loc . pp = {- @ann.pp >#< -} @expr.pp
%%]
View
2  EHC/src/ehc/EH/PrettyAST.cag
@@ -129,7 +129,7 @@ SEM Expr
. sinfo_8 = []
. info_9 = []
. info_4_2 = []
- | TypeAs lhs . ppAST = ppNestInfo @lhs.opts ["Expr","TypeAs"] [] [@expr.ppAST,@tyExpr.ppAST] (@info_3 ++ @info_4)
+ | TypeAs lhs . ppAST = ppNestInfo @lhs.opts ["Expr","TypeAs"] [pp @isScoped] [@expr.ppAST,@tyExpr.ppAST] (@info_3 ++ @info_4)
loc . info_3 = []
loc . info_4 = []
View
6 EHC/src/ehc/HS/ToEH.cag
@@ -742,7 +742,7 @@ SEM Expression
| Tuple
loc . eh = ehExpConApp @range (hsnProd (length @expressions.eh)) @expressions.eh
| Typed
- loc . eh = rngLift @range EH.Expr_TypeAs @type.eh @expression.eh
+ loc . eh = rngLift @range EH.Expr_TypeAs False @type.eh @expression.eh
| Negate
loc . eh = ehExpVarApp @range @refname [@expression.eh]
| Annotate
@@ -1127,7 +1127,7 @@ SEM FunctionBinding
%%[2 hs
-- | enforce monomorphism
ehMkEnforceMono :: Range -> Bool -> EH.Expr -> EH.Expr
-ehMkEnforceMono r True e = rngLift r EH.Expr_TypeAs (rngLift r EH.TyExpr_Mono) e
+ehMkEnforceMono r True e = rngLift r EH.Expr_TypeAs False (rngLift r EH.TyExpr_Mono) e
ehMkEnforceMono _ _ e = e
%%]
@@ -1166,7 +1166,7 @@ ATTR LeftHandSide [ | | ehTyMk: {EH.Expr -> EH.Expr} ]
SEM LeftHandSide
| Typed
- lhs . ehTyMk = rngLift @range EH.Expr_TypeAs @type.eh
+ lhs . ehTyMk = rngLift @range EH.Expr_TypeAs True @type.eh
| * - Typed
lhs . ehTyMk = id
%%]
View
94 EHC/test/regress/99/LexScopedTyVar1.hs
@@ -1,93 +1,25 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{- ----------------------------------------------------------------------------------------
- what : lexically scoped tyvar for instance
- expected: ok, see comment for the complex Sup inst for depth 2
+ what : lexically scoped tyvar of function result
+ expected: ok
---------------------------------------------------------------------------------------- -}
module LexScopedTyVar1 where
-import Data.Maybe
-import Data.Dynamic
+import Unsafe.Coerce
-{-
-class Sub a b where
- upcast :: a -> b
--}
+class GetObjectRef a where
+ getObjectRef :: a -> b
-class Sup a b where
- downcast :: a -> Maybe b
-{-
-class Narrow a b where
- narrow :: a -> b
--}
+cast :: forall a b. GetObjectRef b => a -> Maybe b
+cast a :: Maybe b = -- the type of 'b' should be propagated
+ if instanceOf a (getObjectRef (undefined :: b))
+ then Just (unsafeCoerce a)
+ else Nothing
-class Widen a b where
- widen :: a -> Maybe b
-
--- depth 1
-
-{-
-instance Sub (a ()) (a ()) where
- upcast = id
--}
-
-instance Sup (a ()) (a ()) where
- downcast = Just
-
--- depth 2
-
-{-
-instance Sub (a (b ())) (a (b ())) where
- upcast = id
--}
-
-instance Sup (a (b ())) (a (b ())) where
- downcast = Just
-
-{-
-instance (Sub (a ()) x, Narrow (a (b ())) (a ())) => Sub (a (b ())) x where
- upcast = upcast . (narrow :: a (b ()) -> a () )
--}
-
--- here ref to scoped tyvar would go wrong because type of 'a' and 'b' would not be propagated correctly
-instance (Sup (a (b ())) (a (b c)), Widen (a ()) (a (b ()))) => Sup (a ()) (a (b c)) where
- downcast o = case widen o :: Maybe (a (b ())) of
- Just r -> downcast r
- Nothing -> Nothing
-
-{-
--- depth 3
-
-instance Sub (a (b (c ()))) (a (b (c ()))) where
- upcast = id
-
-instance Sup (a (b (c ()))) (a (b (c ()))) where
- downcast = Just
-
-instance (Sub (a (b ())) x, Narrow (a (b (c ()))) (a (b ()))) => Sub (a (b (c ()))) x where
- upcast = upcast . (narrow :: a (b (c ())) -> a (b ()))
-
-instance (Sup (a (b (c ()))) (a (b (c d))), Widen (a (b ())) (a (b (c ())))) => Sup (a (b ())) (a (b (c d))) where
- downcast o = case widen o :: Maybe (a (b (c ()))) of
- Just r -> downcast r
- Nothing -> Nothing
-
--- depth 4
-instance Sub (a (b (c (d ())))) (a (b (c (d ())))) where
- upcast = id
-
-instance Sup (a (b (c (d ())))) (a (b (c (d ())))) where
- downcast = Just
-
-instance (Sub (a (b (c ()))) x, Narrow (a (b (c (d ())))) (a (b (c ())))) => Sub (a (b (c (d ())))) x where
- upcast = upcast . (narrow :: a (b (c (d ()))) -> a (b (c ())))
-
-instance (Sup (a (b (c (d ())))) (a (b (c (d e)))), Widen (a (b (c ()))) (a (b (c (d ()))))) => Sup (a (b (c ()))) (a (b (c (d e)))) where
- downcast o = case widen o :: Maybe (a (b (c (d ())))) of
- Just r -> downcast r
- Nothing -> Nothing
--}
+instanceOf :: a -> b -> Bool
+instanceOf = undefined
main = return ()
View
93 EHC/test/regress/99/LexScopedTyVar2.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, OverlappingInstances #-}
+
+{- ----------------------------------------------------------------------------------------
+ what : lexically scoped tyvar for instance
+ expected: ok, see comment for the complex Sup inst for depth 2
+---------------------------------------------------------------------------------------- -}
+
+module LexScopedTyVar2 where
+
+import Data.Maybe
+import Data.Dynamic
+
+{-
+class Sub a b where
+ upcast :: a -> b
+-}
+
+class Sup a b where
+ downcast :: a -> Maybe b
+
+{-
+class Narrow a b where
+ narrow :: a -> b
+-}
+
+class Widen a b where
+ widen :: a -> Maybe b
+
+-- depth 1
+
+{-
+instance Sub (a ()) (a ()) where
+ upcast = id
+-}
+
+instance Sup (a ()) (a ()) where
+ downcast = Just
+
+-- depth 2
+
+{-
+instance Sub (a (b ())) (a (b ())) where
+ upcast = id
+-}
+
+instance Sup (a (b ())) (a (b ())) where
+ downcast = Just
+
+{-
+instance (Sub (a ()) x, Narrow (a (b ())) (a ())) => Sub (a (b ())) x where
+ upcast = upcast . (narrow :: a (b ()) -> a () )
+-}
+
+-- here ref to scoped tyvar would go wrong because type of 'a' and 'b' would not be propagated correctly
+instance (Sup (a (b ())) (a (b c)), Widen (a ()) (a (b ()))) => Sup (a ()) (a (b c)) where
+ downcast o = case widen o :: Maybe (a (b ())) of
+ Just r -> downcast r
+ Nothing -> Nothing
+
+{-
+-- depth 3
+
+instance Sub (a (b (c ()))) (a (b (c ()))) where
+ upcast = id
+
+instance Sup (a (b (c ()))) (a (b (c ()))) where
+ downcast = Just
+
+instance (Sub (a (b ())) x, Narrow (a (b (c ()))) (a (b ()))) => Sub (a (b (c ()))) x where
+ upcast = upcast . (narrow :: a (b (c ())) -> a (b ()))
+
+instance (Sup (a (b (c ()))) (a (b (c d))), Widen (a (b ())) (a (b (c ())))) => Sup (a (b ())) (a (b (c d))) where
+ downcast o = case widen o :: Maybe (a (b (c ()))) of
+ Just r -> downcast r
+ Nothing -> Nothing
+
+-- depth 4
+instance Sub (a (b (c (d ())))) (a (b (c (d ())))) where
+ upcast = id
+
+instance Sup (a (b (c (d ())))) (a (b (c (d ())))) where
+ downcast = Just
+
+instance (Sub (a (b (c ()))) x, Narrow (a (b (c (d ())))) (a (b (c ())))) => Sub (a (b (c (d ())))) x where
+ upcast = upcast . (narrow :: a (b (c (d ()))) -> a (b (c ())))
+
+instance (Sup (a (b (c (d ())))) (a (b (c (d e)))), Widen (a (b (c ()))) (a (b (c (d ()))))) => Sup (a (b (c ()))) (a (b (c (d e)))) where
+ downcast o = case widen o :: Maybe (a (b (c (d ())))) of
+ Just r -> downcast r
+ Nothing -> Nothing
+-}
+
+main = return ()
View
22 EHC/test/regress/99/NameAmbigPatternCon.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE NoGenericDeriving #-}
+
+{- ----------------------------------------------------------------------------------------
+ what : test for bug which did not detect ambiguous name references
+ expected: error messages about 4 available occurrences
+---------------------------------------------------------------------------------------- -}
+
+module NameAmbigPatternCon where
+
+import NameAmbigPatternConImpMod1
+import NameAmbigPatternConImpMod2
+
+-- intentional duplicate def
+-- data Maybe a = Nothing | Just a
+data Maybe a = Nothing | Just a
+
+-- should give error
+f (Just a) = id a
+
+id x = x
+
+main = return ()
View
20 EHC/test/regress/99/NameAmbigPatternConImpMod1.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE NoGenericDeriving #-}
+
+{- ----------------------------------------------------------------------------------------
+ what : NameAmbigPatternCon
+ expected: not to be tested on its own
+ constraints: exclude-if-js
+ constraints: exclude-if-bc
+---------------------------------------------------------------------------------------- -}
+
+module NameAmbigPatternConImpMod1 where
+
+import Prelude hiding (Maybe(..), id)
+
+-- intentional duplicate def
+data Maybe a = Nothing | Just a
+
+-- should give error
+f (Just a) = id a
+
+id x = x
View
20 EHC/test/regress/99/NameAmbigPatternConImpMod2.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE NoGenericDeriving #-}
+
+{- ----------------------------------------------------------------------------------------
+ what : NameAmbigPatternCon
+ expected: not to be tested on its own
+ constraints: exclude-if-js
+ constraints: exclude-if-bc
+---------------------------------------------------------------------------------------- -}
+
+module NameAmbigPatternConImpMod2 where
+
+import Prelude hiding (Maybe(..), id)
+
+-- intentional duplicate def
+data Maybe a = Nothing | Just a
+
+-- should give error
+f (Just a) = id a
+
+id x = x

No commit comments for this range

Something went wrong with that request. Please try again.