Skip to content
Browse files

fix of propagation of scoped type variable on result of function

  • Loading branch information...
1 parent 9fce526 commit 3bee6e389e7f4716035b64bab38d7db33c45796b @atzedijkstra atzedijkstra committed Sep 6, 2012
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 ()

0 comments on commit 3bee6e3

Please sign in to comment.
Something went wrong with that request. Please try again.