Brandon Chinn pushed to branch wip/T26503 at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • compiler/GHC/Hs/Lit.hs
    ... ... @@ -35,6 +35,7 @@ import GHC.Hs.Extension
    35 35 
     import Language.Haskell.Syntax.Expr ( HsExpr )
    36 36 
     import Language.Haskell.Syntax.Extension
    37 37 
     import Language.Haskell.Syntax.Lit
    38 
    +import Language.Haskell.Syntax.Module.Name (moduleNameString)
    38 39
    39 40 
     {-
    40 41 
     ************************************************************************
    ... ... @@ -211,14 +212,18 @@ Equivalently it's True if
    211 212 
     instance IsPass p => Outputable (HsLit (GhcPass p)) where
    212 213 
         ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)
    213 214 
         ppr (HsCharPrim st c)   = pprWithSourceText st (pprPrimChar c)
    214 
    -    ppr (HsString StringMeta{..} s)
    215 
    -      -- multiline strings
    216 
    -      | strMetaMultiline =
    215 
    +    ppr (HsString StringMeta{..} s) =
    216 
    +      handleQualified $ if strMetaMultiline then renderMultiline else renderNormal
    217 
    +      where
    218 
    +        handleQualified =
    219 
    +          case strMetaQualified of
    220 
    +            Nothing -> id
    221 
    +            Just modName -> (text (moduleNameString modName ++ ".") <>)
    222 
    +        renderMultiline =
    217 223 
               case strMetaSrc of
    218 224 
                 NoSourceText -> pprHsString s
    219 
    -            SourceText src -> vcat $ map text $ split '\n' (unpackFS src)
    220 
    -      -- normal strings
    221 
    -      | otherwise = pprWithSourceText strMetaSrc (pprHsString s)
    225 
    +            SourceText src -> vcat . map text . split '\n' . unpackFS $ src
    226 
    +        renderNormal = pprWithSourceText strMetaSrc (pprHsString s)
    222 227 
         ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
    223 228 
         ppr (HsInt _ i)
    224 229 
           = pprWithSourceText (il_text i) (integer (il_value i))

  • compiler/GHC/HsToCore/Pmc/Desugar.hs
    ... ... @@ -39,6 +39,7 @@ import GHC.Core.TyCo.Compare( eqType )
    39 39 
     import GHC.Core.Type
    40 40 
     import GHC.Data.Maybe
    41 41 
     import GHC.Types.SourceText (FractionalLit(..))
    42 
    +import GHC.Types.StringMeta (StringMeta(..))
    42 43 
     import Control.Monad (zipWithM, replicateM)
    43 44 
     import Data.List (elemIndex)
    44 45 
     import Data.List.NonEmpty ( NonEmpty(..) )
    ... ... @@ -137,6 +138,11 @@ desugarPat x pat = case pat of
    137 138 
               , is_to_list (unLoc lrhs)
    138 139 
               -> desugarLPat x pat
    139 140
    141 
    +        -- Desugar qualified string literals the same as RebindableSyntax
    142 
    +        LitPat _ (HsString StringMeta{strMetaQualified = Just _} s)
    143 
    +          | ViewPat ty _ _ <- expansion
    144 
    +          -> mkPmLitGrds x $ PmLit ty (PmLitOverString s)
    145 
    +
    140 146 
             _ -> desugarPat x expansion
    141 147
    142 148 
         -- See Note [Desugar CoPats]

  • compiler/GHC/Rename/Expr.hs
    ... ... @@ -359,7 +359,8 @@ rnExpr (HsLit x lit) | Just (meta, s) <- stringLike lit
    359 359 
               | StringMeta{strMetaQualified = Just modName} <- meta -> do
    360 360 
                   (qualifiedFromString, fvs) <- first genHsVar <$> lookupNameWithQualifier fromStringName modName
    361 361 
                   let hsLit = HsLit x (convertLit lit)
    362 
    -              return (HsApp noExtField (noLocA qualifiedFromString) (noLocA hsLit), fvs)
    362 
    +              let expr = HsApp noExtField (noLocA qualifiedFromString) (noLocA hsLit)
    363 
    +              return (mkExpandedExpr hsLit expr, fvs)
    363 364 
               | opt_OverloadedStrings ->
    364 365 
                   rnExpr (HsOverLit x (mkHsIsString (strMetaSrc meta) s))
    365 366 
               | otherwise -> do {

  • compiler/GHC/Rename/Pat.hs
    ... ... @@ -567,13 +567,14 @@ rnPatAndThen mk (LitPat x lit)
    567 567 
                   -- M."asdf" => ((M.fromString "asdf" ==) -> True)
    568 568 
                   eqExpr <- liftCpsFV $ lookupSyntaxExpr eqName
    569 569 
                   fromStringExpr <- fmap genHsVar $ liftCpsFV $ lookupNameWithQualifier fromStringName modName
    570 
    -              let lit = noLocA $ HsLit noExtField (mkHsStringFS s)
    571 
    -              let trueExpr = noLocA $
    570 
    +              let litExpr = noLocA $ HsLit noExtField (convertLit lit)
    571 
    +                  truePat = noLocA $
    572 572 
                         ConPat
    573 573 
                           noExtField
    574 574 
                           (noLocA $ noUserRdr trueDataConName)
    575 575 
                           (PrefixCon [])
    576 
    -              return $ ViewPat Nothing (genLHsApp eqExpr (genLHsApp fromStringExpr lit)) trueExpr
    576 
    +              return . mkExpandedPat (LitPat x (convertLit lit)) $
    577 
    +                ViewPat Nothing (genLHsApp eqExpr (genLHsApp fromStringExpr litExpr)) truePat
    577 578 
               | opt_OverloadedStrings ->
    578 579 
                   rnPatAndThen mk
    579 580 
                     (mkNPat (noLocA (mkHsIsString (strMetaSrc meta) s))

  • testsuite/tests/qualified-strings/should_fail/Example/Length.hs
    1 
    +module Example.Length where
    2 
    +
    3 
    +fromString :: String -> Int
    4 
    +fromString = length

  • testsuite/tests/qualified-strings/should_fail/all.T
    1 1 
     setTestOpts(only_ways(['normal']));
    2 2
    3 
    +qextra_files = extra_files(['Example'])
    4 
    +
    3 5 
     test('qstrings_multiline_no_ext', normal, compile_fail, [''])
    6 
    +test('qstrings_bad_expr', [qextra_files], multimod_compile_fail, ['qstrings_bad_expr', ''])
    7 
    +test('qstrings_bad_pat', [qextra_files], multimod_compile_fail, ['qstrings_bad_pat', ''])
    8 
    +test('qstrings_redundant_pattern', [qextra_files], multimod_compile_fail, ['qstrings_redundant_pattern', ''])

  • testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.hs
    1 
    +{-# LANGUAGE QualifiedStrings #-}
    2 
    +
    3 
    +import qualified Example.Length as Length
    4 
    +
    5 
    +main :: IO ()
    6 
    +main = putStrLn Length."this fails after being converted into an Int"

  • testsuite/tests/qualified-strings/should_fail/qstrings_bad_expr.stderr
    1 
    +[1 of 3] Compiling Example.Length   ( Example/Length.hs, Example/Length.o )
    2 
    +[2 of 3] Compiling Main             ( qstrings_bad_expr.hs, qstrings_bad_expr.o )
    3 
    +qstrings_bad_expr.hs:6:17: error: [GHC-83865]
    4 
    +    • Couldn't match type ‘Int’ with ‘[Char]’
    5 
    +      Expected: String
    6 
    +        Actual: Int
    7 
    +    • In the first argument of ‘putStrLn’, namely
    8 
    +        ‘Length."this fails after being converted into an Int"’
    9 
    +      In the expression:
    10 
    +        putStrLn
    11 
    +          Length."this fails after being converted into an Int"
    12 
    +      In an equation for ‘main’:
    13 
    +          main
    14 
    +            = putStrLn
    15 
    +                Length."this fails after being converted into an Int"

  • testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.hs
    1 
    +{-# LANGUAGE QualifiedStrings #-}
    2 
    +
    3 
    +import qualified Example.Length as Length
    4 
    +
    5 
    +main :: IO ()
    6 
    +main =
    7 
    +  case "" of
    8 
    +    Length."this fails after being converted into an Int" -> pure ()
    9 
    +    _ -> pure ()

  • testsuite/tests/qualified-strings/should_fail/qstrings_bad_pat.stderr
    1 
    +[1 of 3] Compiling Example.Length   ( Example/Length.hs, Example/Length.o )
    2 
    +[2 of 3] Compiling Main             ( qstrings_bad_pat.hs, qstrings_bad_pat.o )
    3 
    +qstrings_bad_pat.hs:8:5: error: [GHC-83865]
    4 
    +    • Couldn't match type ‘[Char]’ with ‘Int’
    5 
    +      Expected: String
    6 
    +        Actual: Int
    7 
    +    • In the pattern:
    8 
    +        Length."this fails after being converted into an Int"
    9 
    +      In a case alternative:
    10 
    +          Length."this fails after being converted into an Int"
    11 
    +            -> pure ()
    12 
    +      In the expression:
    13 
    +        case "" of
    14 
    +          Length."this fails after being converted into an Int" -> pure ()
    15 
    +          _ -> pure ()

  • testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.hs
    1 
    +{-# LANGUAGE QualifiedStrings #-}
    2 
    +{-# OPTIONS_GHC -Wall -Werror #-}
    3 
    +
    4 
    +import qualified Example.Length as Length
    5 
    +
    6 
    +main :: IO ()
    7 
    +main = print $ foo Length."abc"
    8 
    +
    9 
    +foo :: Int -> ()
    10 
    +foo Length."abc" = ()
    11 
    +foo other =
    12 
    +  case other of
    13 
    +    Length."abc" -> ()
    14 
    +    Length."def" -> ()
    15 
    +    _ -> ()

  • testsuite/tests/qualified-strings/should_fail/qstrings_redundant_pattern.stderr
    1 
    +[1 of 3] Compiling Example.Length   ( Example/Length.hs, Example/Length.o )
    2 
    +[2 of 3] Compiling Main             ( qstrings_redundant_pattern.hs, qstrings_redundant_pattern.o )
    3 
    +qstrings_redundant_pattern.hs:13:5: error: [GHC-53633] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns]
    4 
    +    Pattern match is redundant
    5 
    +    In a case alternative: Length."abc" -> ...
    6 
    +

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