Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • testsuite/tests/ghc-api/T25121_status.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +{-# LANGUAGE RequiredTypeArguments #-}
    3 
    +{-# LANGUAGE TypeAbstractions #-}
    4 
    +{-# LANGUAGE ExplicitNamespaces #-}
    5 
    +{-# LANGUAGE UndecidableInstances #-}
    6 
    +
    7 
    +module Main where
    8 
    +
    9 
    +import Type.Reflection
    10 
    +import GHC.Hs
    11 
    +
    12 
    +main :: IO ()
    13 
    +main = do
    14 
    +  checkAllExtFields
    15 
    +  checkAllDirectFields
    16 
    +
    17 
    +checkAllExtFields :: IO ()
    18 
    +checkAllExtFields = do
    19 
    +  -- No corresponding HsExpr: HsListTy HsTupleTy HsSumTy HsIParamTy HsDocTy
    20 
    +
    21 
    +  putStrLn "Extension fields @GhcPs\n-----------------------"
    22 
    +  checkExtField "Var"      (HsVar @GhcPs) (HsTyVar @GhcPs)
    23 
    +  checkExtField "LitE"     (HsLit @GhcPs) (HsTyLit @GhcPs)
    24 
    +  checkExtField "Par"      (HsPar @GhcPs) (HsParTy @GhcPs)
    25 
    +  checkExtField "App"      (HsApp @GhcPs) (HsAppTy @GhcPs)
    26 
    +  checkExtField "AppTypeE" (HsAppType @GhcPs) (HsAppKindTy @GhcPs)
    27 
    +  checkExtField "OpApp"    (OpApp @GhcPs) (HsOpTy @GhcPs)
    28 
    +  checkExtField "ForAll"   (HsForAll @GhcPs) (HsForAllTy @GhcPs)
    29 
    +  checkExtField "Qual"     (HsQual @GhcPs) (HsQualTy @GhcPs)
    30 
    +  checkExtField "Star"     (HsStar @GhcPs) (HsStarTy @GhcPs)
    31 
    +  checkExtField "FunArr"   (HsFunArr @GhcPs) (HsFunTy @GhcPs)
    32 
    +  checkExtField "ExprWithTySig" (ExprWithTySig @GhcPs) (HsKindSig @GhcPs)
    33 
    +  checkExtField "UntypedSplice" (HsUntypedSplice @GhcPs) (HsSpliceTy @GhcPs)
    34 
    +  checkExtField "ExplicitList"  (ExplicitList @GhcPs) (HsExplicitListTy @GhcPs)
    35 
    +  checkExtField "ExplicitTuple" (ExplicitTuple @GhcPs) (HsExplicitTupleTy @GhcPs)
    36 
    +  checkExtField "Hole"     (HsHole @GhcPs) (HsWildCardTy @GhcPs)
    37 
    +
    38 
    +  putStrLn "\nExtension fields @GhcRn\n-----------------------"
    39 
    +  checkExtField "Var"      (HsVar @GhcRn) (HsTyVar @GhcRn)
    40 
    +  checkExtField "LitE"     (HsLit @GhcRn) (HsTyLit @GhcRn)
    41 
    +  checkExtField "Par"      (HsPar @GhcRn) (HsParTy @GhcRn)
    42 
    +  checkExtField "App"      (HsApp @GhcRn) (HsAppTy @GhcRn)
    43 
    +  checkExtField "AppTypeE" (HsAppType @GhcRn) (HsAppKindTy @GhcRn)
    44 
    +  checkExtField "OpApp"    (OpApp @GhcRn) (HsOpTy @GhcRn)
    45 
    +  checkExtField "ForAll"   (HsForAll @GhcRn) (HsForAllTy @GhcRn)
    46 
    +  checkExtField "Qual"     (HsQual @GhcRn) (HsQualTy @GhcRn)
    47 
    +  checkExtField "Star"     (HsStar @GhcRn) (HsStarTy @GhcRn)
    48 
    +  checkExtField "FunArr"   (HsFunArr @GhcRn) (HsFunTy @GhcRn)
    49 
    +  checkExtField "ExprWithTySig" (ExprWithTySig @GhcRn) (HsKindSig @GhcRn)
    50 
    +  checkExtField "UntypedSplice" (HsUntypedSplice @GhcRn) (HsSpliceTy @GhcRn)
    51 
    +  checkExtField "ExplicitList"  (ExplicitList @GhcRn) (HsExplicitListTy @GhcRn)
    52 
    +  checkExtField "ExplicitTuple" (ExplicitTuple @GhcRn) (HsExplicitTupleTy @GhcRn)
    53 
    +  checkExtField "Hole"     (HsHole @GhcRn) (HsWildCardTy @GhcRn)
    54 
    +
    55 
    +  putStrLn "\nExtension fields @GhcTc\n-----------------------"
    56 
    +  checkExtField "Var"      (HsVar @GhcTc) (HsTyVar @GhcTc)
    57 
    +  checkExtField "LitE"     (HsLit @GhcTc) (HsTyLit @GhcTc)
    58 
    +  checkExtField "Par"      (HsPar @GhcTc) (HsParTy @GhcTc)
    59 
    +  checkExtField "App"      (HsApp @GhcTc) (HsAppTy @GhcTc)
    60 
    +  checkExtField "AppTypeE" (HsAppType @GhcTc) (HsAppKindTy @GhcTc)
    61 
    +  checkExtField "OpApp"    (OpApp @GhcTc) (HsOpTy @GhcTc)
    62 
    +  checkExtField "ForAll"   (HsForAll @GhcTc) (HsForAllTy @GhcTc)
    63 
    +  checkExtField "Qual"     (HsQual @GhcTc) (HsQualTy @GhcTc)
    64 
    +  checkExtField "Star"     (HsStar @GhcTc) (HsStarTy @GhcTc)
    65 
    +  checkExtField "FunArr"   (HsFunArr @GhcTc) (HsFunTy @GhcTc)
    66 
    +  checkExtField "ExprWithTySig" (ExprWithTySig @GhcTc) (HsKindSig @GhcTc)
    67 
    +  checkExtField "UntypedSplice" (HsUntypedSplice @GhcTc) (HsSpliceTy @GhcTc)
    68 
    +  checkExtField "ExplicitList"  (ExplicitList @GhcTc) (HsExplicitListTy @GhcTc)
    69 
    +  checkExtField "ExplicitTuple" (ExplicitTuple @GhcTc) (HsExplicitTupleTy @GhcTc)
    70 
    +  checkExtField "Hole"     (HsHole @GhcTc) (HsWildCardTy @GhcTc)
    71 
    +
    72 
    +checkAllDirectFields :: IO ()
    73 
    +checkAllDirectFields = do
    74 
    +  -- No corresponding HsExpr: HsListTy HsTupleTy HsSumTy HsIParamTy HsDocTy
    75 
    +  putStrLn "\nDirect fields\n-------------"
    76 
    +  checkDirectFields "Var"      (HsVar @GhcPs) (HsTyVar @GhcPs)
    77 
    +  checkDirectFields "LitE"     (HsLit @GhcPs) (HsTyLit @GhcPs)
    78 
    +  checkDirectFields "Par"      (HsPar @GhcPs) (HsParTy @GhcPs)
    79 
    +  checkDirectFields "App"      (HsApp @GhcPs) (HsAppTy @GhcPs)
    80 
    +  checkDirectFields "AppTypeE" (HsAppType @GhcPs) (HsAppKindTy @GhcPs)
    81 
    +  checkDirectFields "OpApp"    (OpApp @GhcPs) (HsOpTy @GhcPs)
    82 
    +  checkDirectFields "ForAll"   (HsForAll @GhcPs) (HsForAllTy @GhcPs)
    83 
    +  checkDirectFields "Qual"     (HsQual @GhcPs) (HsQualTy @GhcPs)
    84 
    +  checkDirectFields "Star"     (HsStar @GhcPs) (HsStarTy @GhcPs)
    85 
    +  checkDirectFields "FunArr"   (HsFunArr @GhcPs) (HsFunTy @GhcPs)
    86 
    +  checkDirectFields "ExprWithTySig" (ExprWithTySig @GhcPs) (HsKindSig @GhcPs)
    87 
    +  checkDirectFields "UntypedSplice" (HsUntypedSplice @GhcPs) (HsSpliceTy @GhcPs)
    88 
    +  checkDirectFields "ExplicitList"  (ExplicitList @GhcPs) (HsExplicitListTy @GhcPs)
    89 
    +  checkDirectFields "ExplicitTuple" (ExplicitTuple @GhcPs) (HsExplicitTupleTy @GhcPs)
    90 
    +  checkDirectFields "Hole"     (HsHole @GhcPs) (HsWildCardTy @GhcPs)
    91 
    +
    92 
    +data P   -- placeholder for the pass
    93 
    +
    94 
    +type Replace :: k -> k
    95 
    +type family Replace t where
    96 
    +  Replace (GhcPass _) = P
    97 
    +  Replace HsType = HsExpr
    98 
    +  Replace (f a) = Replace f (Replace a)
    99 
    +  Replace t = t
    100 
    +
    101 
    +checkDirectFields :: forall r1 r2. String ->
    102 
    +  forall x1 x2. forall (con1 :: x1 -> r1) (con2 :: x2 -> r2) ->
    103 
    +  (Typeable (Replace r1), Typeable (Replace r2)) => IO ()
    104 
    +checkDirectFields @r1 @r2 ctx _ _ =
    105 
    +  let aRep = typeRep @(Replace r1)
    106 
    +      bRep = typeRep @(Replace r2)
    107 
    +  in case eqTypeRep aRep bRep of
    108 
    +       Nothing -> do
    109 
    +         putStrLn $ "T(" ++ ctx ++ ") mismatch"
    110 
    +         putStrLn $ "  >>> " ++ show aRep
    111 
    +         putStrLn $ "  <<< " ++ show bRep
    112 
    +       Just HRefl -> do
    113 
    +         putStrLn $ "T(" ++ ctx ++ ") match = " ++ show aRep
    114 
    +
    115 
    +checkExtField :: forall x1 x2. String ->
    116 
    +  forall r1 r2. forall (con1 :: x1 -> r1) (con2 :: x2 -> r2) ->
    117 
    +  (Typeable x1, Typeable x2) => IO ()
    118 
    +checkExtField @x1 @x2 ctx _ _ =
    119 
    +  let aRep = typeRep @x1
    120 
    +      bRep = typeRep @x2
    121 
    +  in case eqTypeRep aRep bRep of
    122 
    +       Nothing    -> do
    123 
    +         putStrLn $ "X(" ++ ctx ++ ") mismatch"
    124 
    +         putStrLn $ "  >>> " ++ show aRep
    125 
    +         putStrLn $ "  <<< " ++ show bRep
    126 
    +       Just HRefl -> do
    127 
    +         putStrLn $ "X(" ++ ctx ++ ") match = " ++ show aRep

  • testsuite/tests/ghc-api/T25121_status.stdout
    1 
    +Extension fields @GhcPs
    2 
    +-----------------------
    3 
    +X(Var) mismatch
    4 
    +  >>> NoExtField
    5 
    +  <<< EpToken "'"
    6 
    +X(LitE) match = NoExtField
    7 
    +X(Par) match = ((EpToken "("),(EpToken ")"))
    8 
    +X(App) match = NoExtField
    9 
    +X(AppTypeE) match = EpToken "@"
    10 
    +X(OpApp) match = NoExtField
    11 
    +X(ForAll) match = NoExtField
    12 
    +X(Qual) match = NoExtField
    13 
    +X(Star) match = EpUniToken "*" "\9733"
    14 
    +X(FunArr) match = NoExtField
    15 
    +X(ExprWithTySig) match = EpUniToken "::" "\8759"
    16 
    +X(UntypedSplice) match = NoExtField
    17 
    +X(ExplicitList) mismatch
    18 
    +  >>> AnnList ()
    19 
    +  <<< ((EpToken "'"),(EpToken "["),(EpToken "]"))
    20 
    +X(ExplicitTuple) mismatch
    21 
    +  >>> ((EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]),(EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]))
    22 
    +  <<< ((EpToken "'"),(EpToken "("),(EpToken ")"))
    23 
    +X(Hole) mismatch
    24 
    +  >>> HoleKind
    25 
    +  <<< EpToken "_"
    26 
    +
    27 
    +Extension fields @GhcRn
    28 
    +-----------------------
    29 
    +X(Var) mismatch
    30 
    +  >>> NoExtField
    31 
    +  <<< EpToken "'"
    32 
    +X(LitE) match = NoExtField
    33 
    +X(Par) mismatch
    34 
    +  >>> NoExtField
    35 
    +  <<< ((EpToken "("),(EpToken ")"))
    36 
    +X(App) match = NoExtField
    37 
    +X(AppTypeE) match = NoExtField
    38 
    +X(OpApp) mismatch
    39 
    +  >>> Fixity
    40 
    +  <<< NoExtField
    41 
    +X(ForAll) match = NoExtField
    42 
    +X(Qual) match = NoExtField
    43 
    +X(Star) match = EpUniToken "*" "\9733"
    44 
    +X(FunArr) match = NoExtField
    45 
    +X(ExprWithTySig) mismatch
    46 
    +  >>> NoExtField
    47 
    +  <<< EpUniToken "::" "\8759"
    48 
    +X(UntypedSplice) mismatch
    49 
    +  >>> HsUntypedSpliceResult (HsExpr (GhcPass 'Renamed))
    50 
    +  <<< HsUntypedSpliceResult (GenLocated (EpAnn AnnListItem) (HsType (GhcPass 'Renamed)))
    51 
    +X(ExplicitList) match = NoExtField
    52 
    +X(ExplicitTuple) match = NoExtField
    53 
    +X(Hole) mismatch
    54 
    +  >>> HoleKind
    55 
    +  <<< NoExtField
    56 
    +
    57 
    +Extension fields @GhcTc
    58 
    +-----------------------
    59 
    +X(Var) mismatch
    60 
    +  >>> NoExtField
    61 
    +  <<< EpToken "'"
    62 
    +X(LitE) match = NoExtField
    63 
    +X(Par) mismatch
    64 
    +  >>> NoExtField
    65 
    +  <<< ((EpToken "("),(EpToken ")"))
    66 
    +X(App) match = NoExtField
    67 
    +X(AppTypeE) mismatch
    68 
    +  >>> Type
    69 
    +  <<< NoExtField
    70 
    +X(OpApp) mismatch
    71 
    +  >>> DataConCantHappen
    72 
    +  <<< NoExtField
    73 
    +X(ForAll) mismatch
    74 
    +  >>> DataConCantHappen
    75 
    +  <<< NoExtField
    76 
    +X(Qual) mismatch
    77 
    +  >>> DataConCantHappen
    78 
    +  <<< NoExtField
    79 
    +X(Star) mismatch
    80 
    +  >>> DataConCantHappen
    81 
    +  <<< EpUniToken "*" "\9733"
    82 
    +X(FunArr) mismatch
    83 
    +  >>> DataConCantHappen
    84 
    +  <<< NoExtField
    85 
    +X(ExprWithTySig) mismatch
    86 
    +  >>> NoExtField
    87 
    +  <<< EpUniToken "::" "\8759"
    88 
    +X(UntypedSplice) mismatch
    89 
    +  >>> DataConCantHappen
    90 
    +  <<< Type
    91 
    +X(ExplicitList) match = Type
    92 
    +X(ExplicitTuple) mismatch
    93 
    +  >>> NoExtField
    94 
    +  <<< [Type]
    95 
    +X(Hole) mismatch
    96 
    +  >>> (HoleKind,HoleExprRef)
    97 
    +  <<< NoExtField
    98 
    +
    99 
    +Direct fields
    100 
    +-------------
    101 
    +T(Var) mismatch
    102 
    +  >>> GenLocated (EpAnn NameAnn) RdrName -> HsExpr P
    103 
    +  <<< PromotionFlag -> GenLocated (EpAnn NameAnn) RdrName -> HsExpr P
    104 
    +T(LitE) match = HsLit P -> HsExpr P
    105 
    +T(Par) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    106 
    +T(App) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    107 
    +T(AppTypeE) mismatch
    108 
    +  >>> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsWildCardBndrs P (GenLocated (EpAnn AnnListItem) (HsExpr P)) -> HsExpr P
    109 
    +  <<< GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    110 
    +T(OpApp) match = GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    111 
    +T(ForAll) match = HsForAllTelescope P -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    112 
    +T(Qual) match = GenLocated (EpAnn AnnContext) [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    113 
    +T(Star) match = HsExpr P
    114 
    +T(FunArr) match = HsMultAnnOf (GenLocated (EpAnn AnnListItem) (HsExpr P)) P -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    115 
    +T(ExprWithTySig) mismatch
    116 
    +  >>> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsWildCardBndrs P (GenLocated (EpAnn AnnListItem) (HsSigType P)) -> HsExpr P
    117 
    +  <<< GenLocated (EpAnn AnnListItem) (HsExpr P) -> GenLocated (EpAnn AnnListItem) (HsExpr P) -> HsExpr P
    118 
    +T(UntypedSplice) match = HsUntypedSplice P -> HsExpr P
    119 
    +T(ExplicitList) mismatch
    120 
    +  >>> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P
    121 
    +  <<< PromotionFlag -> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P
    122 
    +T(ExplicitTuple) mismatch
    123 
    +  >>> [HsTupArg P] -> Boxity -> HsExpr P
    124 
    +  <<< PromotionFlag -> [GenLocated (EpAnn AnnListItem) (HsExpr P)] -> HsExpr P
    125 
    +T(Hole) match = HsExpr P

  • testsuite/tests/ghc-api/all.T
    ... ... @@ -79,3 +79,5 @@ test('T26910', [ extra_run_opts(f'"{config.libdir}"')
    79 79 
                    , when(arch('wasm32') or arch('javascript'), skip)
    80 80 
                    ], compile_and_run, ['-package ghc -package template-haskell'])
    81 81 
     test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
    82 
    +
    83 
    +test('T25121_status', normal, compile_and_run, ['-package ghc'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help