Skip to content
Snippets Groups Projects
Commit e6ca1009 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari
Browse files

Changes from #14579

We now have a top-level `tyConAppNeedsKindSig` function, which means
that we can delete lots of code in `Convert`.

(cherry picked from commit cfd682c5)
parent 2a5fc0ad
No related branches found
No related tags found
5 merge requests!38Make --no-tmp-comp-dir the default,!37Adapt to latest xhtml version, various optimizations,!31Support HsToken in DataDecl and ClassDecl,!12Drop orphan instance when defined upstream.,!10Haddock interfaces produced from `.hi` files
...@@ -28,7 +28,6 @@ import ConLike ...@@ -28,7 +28,6 @@ import ConLike
import Data.Either (lefts, rights) import Data.Either (lefts, rights)
import DataCon import DataCon
import FamInstEnv import FamInstEnv
import FV
import HsSyn import HsSyn
import Name import Name
import NameSet ( emptyNameSet ) import NameSet ( emptyNameSet )
...@@ -45,8 +44,7 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName ...@@ -45,8 +44,7 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
, liftedRepDataConKey ) , liftedRepDataConKey )
import Unique ( getUnique ) import Unique ( getUnique )
import Util ( chkAppend, compareLength, dropList, filterByList, filterOut import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList )
, splitAtList )
import Var import Var
import VarSet import VarSet
...@@ -547,7 +545,7 @@ synifyType _ vs (TyConApp tc tys) ...@@ -547,7 +545,7 @@ synifyType _ vs (TyConApp tc tys)
= noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer. -- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc | Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys , tyConArity tc == tys_len
= noLoc $ HsTupleTy noExt = noLoc $ HsTupleTy noExt
(case sort of (case sort of
BoxedTuple -> HsBoxedTuple BoxedTuple -> HsBoxedTuple
...@@ -604,32 +602,17 @@ synifyType _ vs (TyConApp tc tys) ...@@ -604,32 +602,17 @@ synifyType _ vs (TyConApp tc tys)
(map (synifyType WithinType vs) $ (map (synifyType WithinType vs) $
filterOut isCoercionTy ty_args) filterOut isCoercionTy ty_args)
vis_tys = filterOutInvisibleTypes tc tys tys_len = length tys
binders = tyConBinders tc vis_tys = filterOutInvisibleTypes tc tys
res_kind = tyConResKind tc
maybe_sig :: LHsType GhcRn -> LHsType GhcRn maybe_sig :: LHsType GhcRn -> LHsType GhcRn
maybe_sig ty' maybe_sig ty'
| needs_kind_sig | tyConAppNeedsKindSig False tc tys_len
= let full_kind = typeKind (mkTyConApp tc tys) = let full_kind = typeKind (mkTyConApp tc tys)
full_kind' = synifyType WithinType vs full_kind full_kind' = synifyType WithinType vs full_kind
in noLoc $ HsKindSig noExt ty' full_kind' in noLoc $ HsKindSig noExt ty' full_kind'
| otherwise = ty' | otherwise = ty'
needs_kind_sig :: Bool
needs_kind_sig
| GT <- compareLength tys binders
= False
| otherwise
= let (dropped_binders, remaining_binders)
= splitAtList tys binders
result_kind = mkTyConKind remaining_binders res_kind
result_vars = tyCoVarsOfType result_kind
dropped_vars = fvVarSet $
mapUnionFV injectiveVarsOfBinder dropped_binders
in not (subVarSet result_vars dropped_vars)
synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1
synifyType _ vs (AppTy t1 t2) = let synifyType _ vs (AppTy t1 t2) = let
s1 = synifyType WithinType vs t1 s1 = synifyType WithinType vs t1
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment