- (s1,t1) `eq` (s2,t2) = s1 `coreEqType` s2 && t1 `coreEqType` t2
-
- (result,_,_) = go co
- -- optimized, changed?, identity?
- go :: Coercion -> ( Coercion, Bool, Bool )
- -- traverse coercion term bottom up and return
- --
- -- 1) equivalent coercion, in optimized form
- --
- -- 2) whether the output coercion differs from
- -- the input coercion
- --
- -- 3) whether the coercion is an identity coercion
- --
- -- Performs the following optimizations:
- --
- -- sym id >-> id
- -- trans id co >-> co
- -- trans co id >-> co
- --
- go ty@(TyVarTy a) | isCoVar a = let (ty1,ty2) = coercionKind ty
- in (ty, False, ty1 `coreEqType` ty2)
- | otherwise = (ty, False, True)
- go ty@(AppTy ty1 ty2)
- = let (ty1', chan1, id1) = go ty1
- (ty2', chan2, id2) = go ty2
- in if chan1 || chan2
- then (AppTy ty1' ty2', True, id1 && id2)
- else (ty , False, id1 && id2)
- go ty@(TyConApp tc args)
- | tc == symCoercionTyCon, [ty1] <- args
- = case go ty1 of
- (ty1', _ , True) -> (ty1', True, True)
- (ty1', True, _ ) -> (TyConApp tc [ty1'], True, False)
- (_ , _ , _ ) -> (ty, False, False)
- | tc == transCoercionTyCon, [ty1,ty2] <- args
- = let (ty1', chan1, id1) = go ty1
- (ty2', chan2, id2) = go ty2
- in if id1
- then (ty2', True, id2)
- else if id2
- then (ty1', True, False)
- else if chan1 || chan2
- then (TyConApp tc [ty1',ty2'], True , False)
- else (ty , False, False)
- | otherwise
- = let (args', chans, ids) = mapAndUnzip3 go args
- in if or chans
- then (TyConApp tc args', True , and ids)
- else (ty , False, and ids)
- go ty@(FunTy ty1 ty2)
- = let (ty1',chan1,id1) = go ty1
- (ty2',chan2,id2) = go ty2
- in if chan1 || chan2
- then (FunTy ty1' ty2', True , id1 && id2)
- else (ty , False, id1 && id2)
- go ty@(ForAllTy tv ty1)
- = let (ty1', chan1, id1) = go ty1
- in if chan1
- then (ForAllTy tv ty1', True , id1)
- else (ty , False, id1)
- go ty@(PredTy (EqPred ty1 ty2))
- = let (ty1', chan1, id1) = go ty1
- (ty2', chan2, id2) = go ty2
- in if chan1 || chan2
- then (PredTy (EqPred ty1' ty2'), True , id1 && id2)
- else (ty , False, id1 && id2)
- go ty@(PredTy (ClassP cl args))
- = let (args', chans, ids) = mapAndUnzip3 go args
- in if or chans
- then (PredTy (ClassP cl args'), True , and ids)
- else (ty , False, and ids)
- go ty@(PredTy (IParam name ty1))
- = let (ty1', chan1, id1) = go ty1
- in if chan1
- then (PredTy (IParam name ty1'), True , id1)
- else (ty , False, id1)
--}
-\end{code}
+ (ty1,ty2) = coVarKind tv
+
+opt_co' sym (ForAllTy tv cor)
+ | isCoVar tv = mkCoPredTy (opt_co sym co1) (opt_co sym co2) (opt_co sym cor)
+ | otherwise = ForAllTy tv (opt_co sym cor)
+ where
+ (co1,co2) = coVarKind tv
+
+opt_co' sym (TyConApp tc cos)
+ | isCoercionTyCon tc
+ = foldl mkAppTy opt_co_tc
+ (map (opt_co sym) (drop arity cos))
+ | otherwise
+ = TyConApp tc (map (opt_co sym) cos)
+ where
+ arity = tyConArity tc
+ opt_co_tc :: NormalCo
+ opt_co_tc = opt_co_tc_app sym tc (take arity cos)
+
+--------
+opt_co_tc_app :: Bool -> TyCon -> [Type] -> NormalCo
+-- Used for CoercionTyCons only
+opt_co_tc_app sym tc cos
+ | tc `hasKey` symCoercionTyConKey
+ = opt_co (not sym) co1
+
+ | tc `hasKey` transCoercionTyConKey
+ = if sym then opt_trans opt_co2 opt_co1
+ else opt_trans opt_co1 opt_co2
+
+ | tc `hasKey` leftCoercionTyConKey
+ , Just (co1, _) <- splitAppTy_maybe opt_co1
+ = co1
+
+ | tc `hasKey` rightCoercionTyConKey
+ , Just (_, co2) <- splitAppTy_maybe opt_co1
+ = co2
+
+ | tc `hasKey` csel1CoercionTyConKey
+ , Just (s1,_,_) <- splitCoPredTy_maybe opt_co1
+ = s1
+
+ | tc `hasKey` csel2CoercionTyConKey
+ , Just (_,s2,_) <- splitCoPredTy_maybe opt_co1
+ = s2
+
+ | tc `hasKey` cselRCoercionTyConKey
+ , Just (_,_,r) <- splitCoPredTy_maybe opt_co1
+ = r
+
+ | tc `hasKey` instCoercionTyConKey
+ , Just (tv, co'') <- splitForAllTy_maybe opt_co1
+ , let ty = co2
+ = substTyWith [tv] [ty] co''
+
+ | otherwise -- Do not push sym inside top-level axioms
+ -- e.g. if g is a top-level axiom
+ -- g a : F a ~ a
+ -- Then (sym (g ty)) /= g (sym ty) !!
+ = if sym then mkSymCoercion the_co
+ else the_co
+ where
+ the_co = TyConApp tc cos
+ (co1 : cos1) = cos
+ (co2 : _) = cos1
+ opt_co1 = opt_co sym co1
+ opt_co2 = opt_co sym co2
+
+-------------
+opt_trans :: NormalCo -> NormalCo -> NormalCo
+opt_trans co1 co2
+ | isIdNormCo co1 = co2
+ | otherwise = opt_trans1 co1 co2
+
+opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
+-- First arg is not the identity
+opt_trans1 co1 co2
+ | isIdNormCo co2 = co1
+ | otherwise = opt_trans2 co1 co2
+
+opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
+-- Neither arg is the identity
+opt_trans2 (TyConApp tc [co1a,co1b]) co2
+ | tc `hasKey` transCoercionTyConKey
+ = opt_trans1 co1a (opt_trans2 co1b co2)
+
+opt_trans2 co1 co2
+ | Just co <- opt_trans_rule co1 co2
+ = co
+
+opt_trans2 co1 (TyConApp tc [co2a,co2b])
+ | tc `hasKey` transCoercionTyConKey
+ , Just co1_2a <- opt_trans_rule co1 co2a
+ = if isIdNormCo co1_2a
+ then co2b
+ else opt_trans2 co1_2a co2b
+
+opt_trans2 co1 co2
+ = mkTransCoercion co1 co2
+
+------
+opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+opt_trans_rule (TyConApp tc [co1]) co2
+ | tc `hasKey` symCoercionTyConKey
+ , co1 `coreEqType` co2
+ , (_,ty2) <- coercionKind co2
+ = Just ty2
+
+opt_trans_rule co1 (TyConApp tc [co2])
+ | tc `hasKey` symCoercionTyConKey
+ , co1 `coreEqType` co2
+ , (ty1,_) <- coercionKind co1
+ = Just ty1
+
+opt_trans_rule (TyConApp tc1 [co1,ty1]) (TyConApp tc2 [co2,ty2])
+ | tc1 `hasKey` instCoercionTyConKey
+ , tc1 == tc2
+ , ty1 `coreEqType` ty2
+ = Just (mkInstCoercion (opt_trans2 co1 co2) ty1)
+
+opt_trans_rule (TyConApp tc1 cos1) (TyConApp tc2 cos2)
+ | not (isCoercionTyCon tc1) ||
+ getUnique tc1 `elem` [ leftCoercionTyConKey, rightCoercionTyConKey
+ , csel1CoercionTyConKey, csel2CoercionTyConKey
+ , cselRCoercionTyConKey ] --Yuk!
+ , tc1 == tc2 -- Works for left,right, and csel* family
+ -- BUT NOT equality axioms
+ -- E.g. (g Int) `trans` (g Bool)
+ -- /= g (Int . Bool)
+ = Just (TyConApp tc1 (zipWith opt_trans cos1 cos2))
+
+opt_trans_rule co1 co2
+ | Just (co1a, co1b) <- splitAppTy_maybe co1
+ , Just (co2a, co2b) <- splitAppTy_maybe co2
+ = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
+
+ | Just (s1,t1,r1) <- splitCoPredTy_maybe co1
+ , Just (s2,t2,r2) <- splitCoPredTy_maybe co1
+ = Just (mkCoPredTy (opt_trans s1 s2)
+ (opt_trans t1 t2)
+ (opt_trans r1 r2))
+
+ | Just (tv1,r1) <- splitForAllTy_maybe co1
+ , Just (tv2,r2) <- splitForAllTy_maybe co2
+ , not (isCoVar tv1) -- Both have same kind
+ , let r2' = substTyWith [tv2] [TyVarTy tv1] r2
+ = Just (ForAllTy tv1 (opt_trans2 r1 r2'))
+
+opt_trans_rule _ _ = Nothing
+
+
+-------------
+isIdNormCo :: NormalCo -> Bool
+-- Cheap identity test: look for coercions with no coercion variables at all
+-- So it'll return False for (sym g `trans` g)
+isIdNormCo ty = go ty
+ where
+ go (TyVarTy tv) = not (isCoVar tv)
+ go (AppTy t1 t2) = go t1 && go t2
+ go (FunTy t1 t2) = go t1 && go t2
+ go (ForAllTy tv ty) = go (tyVarKind tv) && go ty
+ go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys
+ go (PredTy (IParam _ ty)) = go ty
+ go (PredTy (ClassP _ tys)) = all go tys
+ go (PredTy (EqPred t1 t2)) = go t1 && go t2
+\end{code}