Skip to content

Commit a61980a

Browse files
guibouguibou
committed
WIP: correct error reporting
1 parent b59df66 commit a61980a

2 files changed

Lines changed: 144 additions & 90 deletions

File tree

‎src/PyF/Internal/QQ.hs‎

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -292,24 +292,27 @@ reportErrorAt loc msg = unsafeRunTcM $ addErrAt loc msg'
292292
#endif
293293

294294
reportParserErrorAt :: ParseError -> Q ()
295-
reportParserErrorAt err = reportErrorAt span msg
295+
reportParserErrorAt err = reportErrorAt (RealSrcSpan span mempty) msg
296296
where
297-
msg = intercalate "\n" $ formatErrorMessages err
297+
(loc, msg) = parseErrorToLocAndMessage err
298+
span = mkRealSrcSpan loc loc'
298299

299-
span :: SrcSpan
300-
span = mkSrcSpan loc loc'
300+
loc' = srcLocFromParserError (incSourceColumn (errorPos err) 1)
301301

302+
parseErrorToLocAndMessage :: ParseError -> (RealSrcLoc, [Char])
303+
parseErrorToLocAndMessage err = (loc, msg)
304+
where
305+
msg = intercalate "\n" $ formatErrorMessages err
302306
loc = srcLocFromParserError (errorPos err)
303-
loc' = srcLocFromParserError (incSourceColumn (errorPos err) 1)
304307

305-
srcLocFromParserError :: SourcePos -> SrcLoc
308+
srcLocFromParserError :: SourcePos -> RealSrcLoc
306309
srcLocFromParserError sourceLoc = srcLoc
307310
where
308311
line = sourceLine sourceLoc
309312
column = sourceColumn sourceLoc
310313
name = sourceName sourceLoc
311314

312-
srcLoc = mkSrcLoc (fromString name) line column
315+
srcLoc = mkRealSrcLoc (fromString name) line column
313316

314317
formatErrorMessages :: ParseError -> [String]
315318
formatErrorMessages err

‎src/PyF/Plugin.hs‎

Lines changed: 134 additions & 83 deletions
Original file line numberDiff line numberDiff line change
@@ -6,10 +6,11 @@
66
{-# LANGUAGE PatternSynonyms #-}
77
{-# LANGUAGE PolyKinds #-}
88
{-# LANGUAGE RecordWildCards #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
910
{-# LANGUAGE TypeFamilies #-}
1011
{-# LANGUAGE ViewPatterns #-}
1112

12-
module PyF.Plugin (plugin) where
13+
module PyF.Plugin (plugin, forceError) where
1314

1415
import Data.Data
1516
import qualified GHC.LanguageExtensions as LangExt
@@ -18,15 +19,17 @@ import qualified GHC.LanguageExtensions as LangExt
1819

1920
#if MIN_VERSION_ghc(9,0,0)
2021
import GHC.Hs
21-
import GHC.Plugins
22+
import GHC.Plugins hiding (msg)
2223
#else
2324
import GHC
2425
import GhcPlugins
2526
#endif
2627

28+
import Control.Monad (join)
2729
import Control.Monad.Reader (runReader)
2830
import Data.Generics
2931
import Data.Maybe (fromMaybe)
32+
import GHC.TypeLits
3033
import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence
3134
import GHC.Types.SourceText (SourceText (..), mkIntegralLit)
3235
import PyF (defaultFloatPrecision, fmtConfig, trimIndent)
@@ -44,7 +47,7 @@ import PyF.Internal.PythonSyntax
4447
parseGenericFormatString,
4548
pattern DefaultFormatMode,
4649
)
47-
import PyF.Internal.QQ (Config (..))
50+
import PyF.Internal.QQ (Config (..), parseErrorToLocAndMessage)
4851
import Text.Parsec (runParserT)
4952
import Text.Parsec.Pos
5053
import Text.Parsec.Prim (setPosition)
@@ -77,46 +80,87 @@ replaceSplice e = do
7780
_ -> do
7881
pure e
7982

83+
{-
84+
- This is not used, the idea was to report the error during the plugin, but it
85+
- actually fails the compilation completly.
86+
reportError theLoc theMsg = do
87+
Hsc $ \env messages -> do
88+
pure
89+
( (),
90+
addMessage
91+
( MsgEnvelope
92+
{ errMsgSpan = RealSrcSpan (realSrcLocSpan theLoc) mempty,
93+
-- TODO: maybe alwaysqualify can be refined
94+
errMsgContext = alwaysQualify,
95+
errMsgDiagnostic = GhcUnknownMessage (UnknownDiagnostic (mkPlainError noHints (text theMsg))),
96+
errMsgSeverity = SevWarning
97+
}
98+
)
99+
messages
100+
)
101+
-}
102+
80103
applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs)
81104
applyPyf loc s = do
82-
items <- mapM toString $ pyf loc s
83-
dynFlags <- getDynFlags
84-
let toOverloaded
85-
| xopt LangExt.OverloadedStrings dynFlags = app (var "fromString")
86-
| otherwise = id
87-
pure $
88-
toOverloaded $
89-
HsApp
90-
noExtField'
91-
( L
92-
noSrcSpanA
93-
( HsVar
94-
NoExtField
95-
( L noSrcSpanA $
96-
mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat")
105+
let pyfItems = pyf loc s
106+
(join . fmap sequenceA -> itemsM) <- sequenceA (mapM toString <$> pyfItems)
107+
case itemsM of
108+
Left (theLoc, theMsg) -> do
109+
pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) noHsTok
110+
Right items -> do
111+
dynFlags <- getDynFlags
112+
let toOverloaded
113+
| xopt LangExt.OverloadedStrings dynFlags = app (var "fromString")
114+
| otherwise = id
115+
pure $
116+
toOverloaded $
117+
HsApp
118+
noExtField'
119+
( L
120+
noSrcSpanA
121+
( HsVar
122+
NoExtField
123+
( L noSrcSpanA $
124+
mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat")
125+
)
97126
)
98127
)
99-
)
100-
(L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items)
128+
(L noSrcSpanA $ ExplicitList emptyAnnList $ items)
101129

102-
toString :: Item -> Hsc (HsExpr GhcPs)
103-
toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s)
104-
toString (Replacement loc s formatMode) = do
105-
expr <- toHsExpr loc s
106-
formatExpr <- padAndFormat (fromMaybe DefaultFormatMode formatMode)
107-
pure $ formatExpr `app'` expr
130+
appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs
131+
appTypeSymbol a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name)))))
108132

109-
pyf :: SrcAnn NoEpAnns -> String -> [Item]
133+
-- TODO: a lot of the Either could be "Validation" and generate MULTIPLES
134+
-- errors messages, but for now GHC is not able to handle multiples errors
135+
toString :: Item -> Hsc (Either (RealSrcLoc, String) (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))
136+
toString (Raw s) = pure $ pure $ L noSrcSpanA (HsLit noExtField' $ HsString NoSourceText (mkFastString s)) -- TODO: restore the correct location for the "raw" string
137+
toString (Replacement loc s formatMode) = do
138+
exprM <- toHsExpr loc s
139+
formatExprM <- padAndFormat (fromMaybe DefaultFormatMode formatMode)
140+
141+
-- We wrap the formatted expression using the location of the original expression
142+
-- Hence GHC will report type error at that location, if relevant
143+
pure $ do
144+
expr <- exprM
145+
formatExpr <- formatExprM
146+
let loc' = getLoc expr
147+
pure $ L loc' (formatExpr `app'` expr)
148+
149+
pyf :: SrcAnn NoEpAnns -> String -> Either (RealSrcLoc, String) [Item]
110150
pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of
111-
Right r -> r
112-
Left e -> error $ show e
151+
Right r -> Right r
152+
Left e -> Left (loc, msg)
153+
where
154+
(loc, msg) = parseErrorToLocAndMessage e
113155
where
114156
filename = unpackFS $ srcLocFile start
115157
Config {..} = fmtConfig
116158
context = ParsingContext {..}
117159

118160
initPos = setSourceColumn (setSourceLine (initialPos filename) (srcLocLine start)) (srcLocCol start)
119-
RealSrcLoc start _ = srcSpanStart srcSpan
161+
start = case srcSpanStart srcSpan of
162+
RealSrcLoc startLoc _ -> startLoc
163+
_ -> error "Plugin API does not know it's RealSrcLoc"
120164

121165
appType :: HsExpr GhcPs -> String -> HsExpr GhcPs
122166
appType a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name))))))
@@ -148,86 +192,88 @@ ctor name =
148192
)
149193
)
150194

151-
padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (HsExpr GhcPs)
195+
padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (HsExpr GhcPs))
152196
padAndFormat formatMode' = do
153-
(FormatMode padding tf grouping) <- evalSubExpression formatMode'
154-
pure $ case tf of
155-
-- Integrals
156-
BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
157-
CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing"
158-
DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3
159-
HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
160-
OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
161-
HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
162-
-- Floating
163-
GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
164-
GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
165-
ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
166-
ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
167-
FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
168-
FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
169-
PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
170-
-- Default / String
171-
DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec
172-
StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString")
173-
174-
evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (FormatModeT (LocatedA (HsExpr GhcPs)))
197+
formatModeM <- evalSubExpression formatMode'
198+
pure $ do
199+
FormatMode padding tf grouping <- formatModeM
200+
pure $ case tf of
201+
-- Integrals
202+
BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
203+
CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing"
204+
DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3
205+
HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
206+
OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
207+
HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
208+
-- Floating
209+
GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
210+
GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
211+
ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
212+
ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
213+
FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
214+
FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
215+
PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
216+
-- Default / String
217+
DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec
218+
StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString")
219+
220+
evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (FormatModeT (LocatedA (HsExpr GhcPs))))
175221
evalSubExpression (FormatMode padding tf grouping) = do
176222
padding' <- evalPadding padding
177223
tf' <- evalTf tf
178-
pure $ FormatMode padding' tf' grouping
224+
pure $ FormatMode <$> padding' <*> tf' <*> pure grouping
179225

180-
evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (LocatedA (HsExpr GhcPs)))
226+
evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (TypeFormatT (LocatedA (HsExpr GhcPs))))
181227
evalTf tf = case tf of
182228
-- Integrals
183-
BinaryF alt s -> pure $ BinaryF alt s
184-
CharacterF -> pure $ CharacterF
185-
DecimalF s -> pure $ DecimalF s
186-
HexF alt s -> pure $ HexF alt s
187-
OctalF alt s -> pure $ OctalF alt s
188-
HexCapsF alt s -> pure $ HexCapsF alt s
229+
BinaryF alt s -> pure $ pure $ BinaryF alt s
230+
CharacterF -> pure $ pure $ CharacterF
231+
DecimalF s -> pure $ pure $ DecimalF s
232+
HexF alt s -> pure $ pure $ HexF alt s
233+
OctalF alt s -> pure $ pure $ OctalF alt s
234+
HexCapsF alt s -> pure $ pure $ HexCapsF alt s
189235
-- Floating
190236
GeneralF prec alt s -> do
191237
prec' <- evalPrecision prec
192-
pure $ GeneralF prec' alt s
238+
pure $ GeneralF <$> prec' <*> pure alt <*> pure s
193239
GeneralCapsF prec alt s -> do
194240
prec' <- evalPrecision prec
195-
pure $ GeneralCapsF prec' alt s
241+
pure $ GeneralCapsF <$> prec' <*> pure alt <*> pure s
196242
ExponentialF prec alt s -> do
197243
prec' <- evalPrecision prec
198-
pure $ ExponentialF prec' alt s
244+
pure $ ExponentialF <$> prec' <*> pure alt <*> pure s
199245
ExponentialCapsF prec alt s -> do
200246
prec' <- evalPrecision prec
201-
pure $ ExponentialCapsF prec' alt s
247+
pure $ ExponentialCapsF <$> prec' <*> pure alt <*> pure s
202248
FixedF prec alt s -> do
203249
prec' <- evalPrecision prec
204-
pure $ FixedF prec' alt s
250+
pure $ FixedF <$> prec' <*> pure alt <*> pure s
205251
FixedCapsF prec alt s -> do
206252
prec' <- evalPrecision prec
207-
pure $ FixedCapsF prec' alt s
253+
pure $ FixedCapsF <$> prec' <*> pure alt <*> pure s
208254
PercentF prec alt s -> do
209255
prec' <- evalPrecision prec
210-
pure $ PercentF prec' alt s
256+
pure $ PercentF <$> prec' <*> pure alt <*> pure s
211257
-- Default / String
212258
DefaultF prec s -> do
213259
prec' <- evalPrecision prec
214-
pure $ DefaultF prec' s
260+
pure $ DefaultF <$> prec' <*> pure s
215261
StringF prec -> do
216262
prec' <- evalPrecision prec
217-
pure $ StringF prec'
263+
pure $ StringF <$> prec'
218264

219-
evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (LocatedA (HsExpr GhcPs)))
220-
evalPrecision (PrecisionDefault) = pure PrecisionDefault
221-
evalPrecision (Precision e) = Precision <$> exprToInt e
265+
evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PrecisionT (LocatedA (HsExpr GhcPs))))
266+
evalPrecision (PrecisionDefault) = pure $ pure PrecisionDefault
267+
evalPrecision (Precision e) = fmap Precision <$> exprToInt e
222268

223-
evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (LocatedA (HsExpr GhcPs)))
269+
evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PaddingT (LocatedA (HsExpr GhcPs))))
224270
evalPadding p = case p of
225-
PaddingDefault -> pure PaddingDefault
271+
PaddingDefault -> pure $ pure PaddingDefault
226272
Padding i v -> do
227273
i' <- exprToInt i
228-
pure $ Padding i' v
274+
pure $ Padding <$> i' <*> pure v
229275

230-
mkPaddingToPaddingK :: PaddingT _ -> HsExpr GhcPs
276+
mkPaddingToPaddingK :: PaddingT (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs
231277
mkPaddingToPaddingK p = case p of
232278
PaddingDefault -> ctor "PaddingDefaultK"
233279
Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app'` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char)))
@@ -313,19 +359,24 @@ mkPrecision Nothing PrecisionDefault = ctor "Nothing"
313359
mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v))
314360
mkPrecision _ (Precision p) = liftHsExpr (Just p)
315361

316-
exprToInt :: ExprOrValue Int -> Hsc (LocatedA (HsExpr GhcPs))
317-
exprToInt (Value i) = pure $ noLocA $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i)
362+
exprToInt :: ExprOrValue Int -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs)))
363+
exprToInt (Value i) = pure $ pure $ noLocA $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i)
318364
exprToInt (HaskellExpr loc s) = toHsExpr loc s
319365

320-
toHsExpr :: SourcePos -> String -> Hsc (LocatedA (HsExpr GhcPs))
366+
toHsExpr :: SourcePos -> String -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs)))
321367
toHsExpr sourcePos s = do
322368
dynFlags <- getDynFlags
323-
-- TODO
324369
let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos)
325370

326371
case ParseExp.parseExpression srcLoc s dynFlags of
327-
Right res -> pure res
328-
Left e -> error $ show e
372+
Right res -> pure $ Right res
373+
Left e -> pure $ Left e
374+
375+
class ForceError (m :: Symbol) where
376+
forceError :: Proxy m -> t
377+
378+
instance (TypeError (Text m)) => ForceError m where
379+
forceError = undefined
329380

330381
#if MIN_VERSION_ghc(9,10,0)
331382
noExtField' :: NoExtField

0 commit comments

Comments
 (0)