Skip to content
Browse files

fix for issue #18, faulty defaulting inside instance decl

  • Loading branch information...
1 parent b30abe9 commit aade7de19cb0595bdc1a52f096584044a432b2dc @atzedijkstra atzedijkstra committed
Showing with 79 additions and 16 deletions.
  1. +48 −15 EHC/src/ehc/EH/Infer.cag
  2. +1 −1 EHC/src/ehc/EH/ResolvePredCHR.cag
  3. +30 −0 EHC/test/regress/99/Defaulting1.hs
View
63 EHC/src/ehc/EH/Infer.cag
@@ -109,25 +109,17 @@ SEM Expr
decls . patTyVarMp := @exTyVarMp1b
%%[(9 hmtyinfer) hs
--- | split a list of predicates into non-ambiguous & ambiguous, using quantifications results tqoGam,
--- which (a.o.) administers which predicates could be merged for quantification, those not are then ambiguous
-doPredAmbigSplit :: (x -> PredOcc) -> TQOGam -> [x] -> ([x],[x])
-doPredAmbigSplit get tqoGam prOccL
- = partition (\o -> poPoi (get o) `Set.member` assumedByQuant) prOccL
- where assumedByQuant = Set.unions $ map tmpoInsPrIdSet $ gamElts tqoGam
+-- | Construct a function which does quantification given some fixed environmental info
+mkDoValGamQuantify
+ :: TyKiGam -> VarMp -> TyVarIdS -> ValGam
+ -> (Bool -> VarMp -> [PredOcc] -> (ValGam, VarMp, (VarMp, TQOGam)))
+mkDoValGamQuantify valQuTyKiGam quTvKiVarMp noLetQuantTyVarIdS valGam_l_
+ = \doQuant tyVarMp prOccL -> valGamQuantifyWithVarMp doQuant valQuTyKiGam quTvKiVarMp tyVarMp noLetQuantTyVarIdS prOccL valGam_l_
%%]
%%[(9 hmtyinfer)
SEM Expr
- | Let loc . doValGamQuantify = \doQuant tyVarMp prOccL -> valGamQuantifyWithVarMp doQuant @valQuTyKiGam @quTvKiVarMp tyVarMp @noLetQuantTyVarIdS prOccL @valGam_l_
- . doPredAmbigSplitForSimplify
- = \chrPrOccL
- -> let us = mkNewLevUIDL (length chrPrOccL) uidStart
- -- couple with arbitrary id's to make quantify & split work
- prOccL = zipWith (\u (o,_) -> cpo2PredOcc (mkPrId u) o) us chrPrOccL
- (_,_, (_,tqoGam)) = @doValGamQuantify False @tyVarMpDeclsL01 prOccL
- (namb,amb) = doPredAmbigSplit fst tqoGam $ zip prOccL chrPrOccL
- in (map snd amb, map snd namb)
+ | Let loc . doValGamQuantify = mkDoValGamQuantify @valQuTyKiGam @quTvKiVarMp @noLetQuantTyVarIdS @valGam_l_
. (quValGam_qu_,quTyVarMp, (cycTyVarMp_l,tqoGam))
:= @doValGamQuantify True @tyVarMpDeclsQuant @toQuantOverPrOccL
. tmpoTyVarMp = foldr (\tmpo c -> tmpoImplsVarMp tmpo `varUpd` c) emptyVarMp (gamElts @tqoGam)
@@ -148,6 +140,47 @@ SEM Expr
`varUpd` @lhs.tyVarMp
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% Split for ambiguity check, required for defaulting
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%[(9 hmtyinfer) hs
+-- | split a list of predicates into non-ambiguous & ambiguous, using quantifications results tqoGam,
+-- which (a.o.) administers which predicates could be merged for quantification, those not are then ambiguous
+doPredAmbigSplit :: (x -> PredOcc) -> TQOGam -> [x] -> ([x],[x])
+doPredAmbigSplit get tqoGam prOccL
+ = partition (\o -> poPoi (get o) `Set.member` assumedByQuant) prOccL
+ where assumedByQuant = Set.unions $ map tmpoInsPrIdSet $ gamElts tqoGam
+
+-- | Split predicates according to whether the predicate combining part of quantification can be done
+mkDoPredAmbigSplitForSimplify :: (Bool -> vm -> [PredOcc] -> (dum1,dum2,(dum3,TQOGam))) -> vm -> [(CHRPredOcc, x)] -> ([(CHRPredOcc, x)],[(CHRPredOcc, x)])
+mkDoPredAmbigSplitForSimplify doValGamQuantify tyVarMpDeclsL01
+ = \chrPrOccL
+ -> let us = mkNewLevUIDL (length chrPrOccL) uidStart
+ -- couple with arbitrary id's to make quantify & split work
+ prOccL = zipWith (\u (o,_) -> cpo2PredOcc (mkPrId u) o) us chrPrOccL
+ (_,_, (_,tqoGam)) = doValGamQuantify False tyVarMpDeclsL01 prOccL
+ (namb,amb) = doPredAmbigSplit fst tqoGam $ zip prOccL chrPrOccL
+ in (map snd amb, map snd namb)
+%%]
+
+%%[(9 hmtyinfer)
+SEM Expr
+ | Let loc . doPredAmbigSplitForSimplify
+ = mkDoPredAmbigSplitForSimplify @doValGamQuantify @tyVarMpDeclsL01
+%%]
+
+%%[(9 hmtyinfer)
+SEM Decl
+ | Instance loc . doPredAmbigSplitForSimplify
+ = mkDoPredAmbigSplitForSimplify
+ (mkDoValGamQuantify
+ @lhs.finTyKiGam @lhs.tvKiVarMp
+ (setSubst @tyVarMpDeclsL0 @decls.noLetQuantTyVarIdS)
+ (gamTop @decls.patValGam))
+ @tyVarMpDeclsL01
+%%]
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Restriction of @decls.tyVarMp to meta level 0
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
2 EHC/src/ehc/EH/ResolvePredCHR.cag
@@ -510,7 +510,7 @@ SEM Decl
%%]]
)
= ehcOptTrace @lhs.opts "Decl.Instance.simplify1" $
- simplify [SimplifyHow_Canonicalize] (@chrProveFIIn {fiUniq = @lUniq7}) @lhs.chrStore @lhs.clDfGam (heurScopedEHC @chrProveFIIn) ((,) []) Map.empty @toProveDeclsCnstrMp emptySimplifyResult
+ simplify [SimplifyHow_Canonicalize] (@chrProveFIIn {fiUniq = @lUniq7}) @lhs.chrStore @lhs.clDfGam (heurScopedEHC @chrProveFIIn) @doPredAmbigSplitForSimplify Map.empty @toProveDeclsCnstrMp emptySimplifyResult
. (chrSolveDeclsState,chrSolveDeclsRedGraph,chrSolveDeclsDoneConstraints,chrSolveDeclsTrace,_,_,_)
= debugInfo @chrDeclsSimplifyResult
View
30 EHC/test/regress/99/Defaulting1.hs
@@ -0,0 +1,30 @@
+{- ----------------------------------------------------------------------------------------
+ what : correct defaulting to Integer in instance decl, due to bug not doing so
+ expected: ok
+---------------------------------------------------------------------------------------- -}
+
+module Defaulting1 where
+
+f :: Num a => a -> ()
+f _ = ()
+
+class C a where
+ it :: a
+
+
+-- fix of previous bug:
+-- Here I get a type error:
+-- Test.hs:14-15:
+-- Predicates remain unproven:
+-- preds: UHC.Base.Num v_3_190_2
+-- at :
+-- trace: (UHC.Base.Num v_3_190_2,<4,0>,Test.hs:15:8): FAIL
+-- (UHC.Base.Num v_3_190_2,<4,0>,Test.hs:15:8): FAIL
+instance C () where
+ it = f 0
+
+-- This one compiles fine.
+it' :: ()
+it' = f 0
+
+main = print (it :: ())

0 comments on commit aade7de

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