Skip to content

Commit e56163b

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

2 files changed

Lines changed: 117 additions & 84 deletions

File tree

‎src/PyF/Internal/QQ.hs‎

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -294,14 +294,17 @@ reportErrorAt loc msg = unsafeRunTcM $ addErrAt loc msg'
294294
reportParserErrorAt :: ParseError -> Q ()
295295
reportParserErrorAt err = reportErrorAt span msg
296296
where
297-
msg = intercalate "\n" $ formatErrorMessages err
298-
299-
span :: SrcSpan
297+
(loc, msg) = parseErrorToLocAndMessage err
300298
span = mkSrcSpan loc loc'
301299

302-
loc = srcLocFromParserError (errorPos err)
303300
loc' = srcLocFromParserError (incSourceColumn (errorPos err) 1)
304301

302+
parseErrorToLocAndMessage :: ParseError -> (SrcLoc, [Char])
303+
parseErrorToLocAndMessage err = (loc, msg)
304+
where
305+
msg = intercalate "\n" $ formatErrorMessages err
306+
loc = srcLocFromParserError (errorPos err)
307+
305308
srcLocFromParserError :: SourcePos -> SrcLoc
306309
srcLocFromParserError sourceLoc = srcLoc
307310
where

‎src/PyF/Plugin.hs‎

Lines changed: 110 additions & 80 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
@@ -24,9 +25,11 @@ 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)
@@ -79,37 +82,56 @@ replaceSplice e = do
7982

8083
applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs)
8184
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")
85+
let pyfItems = pyf loc s
86+
(join . fmap sequenceA -> itemsM) <- sequenceA (mapM toString <$> pyfItems)
87+
case itemsM of
88+
Left (theLoc, theMsg) -> do
89+
pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) noHsTok
90+
Right items -> do
91+
dynFlags <- getDynFlags
92+
let toOverloaded
93+
| xopt LangExt.OverloadedStrings dynFlags = app (var "fromString")
94+
| otherwise = id
95+
pure $
96+
toOverloaded $
97+
HsApp
98+
noExtField'
99+
( L
100+
noSrcSpanA
101+
( HsVar
102+
NoExtField
103+
( L noSrcSpanA $
104+
mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat")
105+
)
97106
)
98107
)
99-
)
100-
(L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items)
108+
(L noSrcSpanA $ ExplicitList emptyAnnList $ items)
101109

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
110+
appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs
111+
appTypeSymbol a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name)))))
108112

109-
pyf :: SrcAnn NoEpAnns -> String -> [Item]
113+
-- TODO: a lot of the Either could be "Validation" and generate MULTIPLES
114+
-- errors messages, but for now GHC is not able to handle multiples errors
115+
toString :: Item -> Hsc (Either (RealSrcLoc, String) (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs)))
116+
toString (Raw s) = pure $ pure $ L noSrcSpanA (HsLit noExtField' $ HsString NoSourceText (mkFastString s)) -- TODO: restore the correct location for the "raw" string
117+
toString (Replacement loc s formatMode) = do
118+
exprM <- toHsExpr loc s
119+
formatExprM <- padAndFormat (fromMaybe DefaultFormatMode formatMode)
120+
121+
-- We wrap the formatted expression using the location of the original expression
122+
-- Hence GHC will report type error at that location, if relevant
123+
pure $ do
124+
expr <- exprM
125+
formatExpr <- formatExprM
126+
let loc' = getLoc expr
127+
pure $ L loc' (formatExpr `app'` expr)
128+
129+
pyf :: SrcAnn NoEpAnns -> String -> Either (RealSrcLoc, String) [Item]
110130
pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of
111-
Right r -> r
112-
Left e -> error $ show e
131+
Right r -> Right r
132+
Left e -> Left (loc, msg)
133+
where
134+
(RealSrcLoc loc _, msg) = parseErrorToLocAndMessage e
113135
where
114136
filename = unpackFS $ srcLocFile start
115137
Config {..} = fmtConfig
@@ -148,86 +170,88 @@ ctor name =
148170
)
149171
)
150172

151-
padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (HsExpr GhcPs)
173+
padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (HsExpr GhcPs))
152174
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)))
175+
formatModeM <- evalSubExpression formatMode'
176+
pure $ do
177+
FormatMode padding tf grouping <- formatModeM
178+
pure $ case tf of
179+
-- Integrals
180+
BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
181+
CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing"
182+
DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3
183+
HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
184+
OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
185+
HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4
186+
-- Floating
187+
GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
188+
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
189+
ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
190+
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
191+
FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
192+
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
193+
PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec
194+
-- Default / String
195+
DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec
196+
StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString")
197+
198+
evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (FormatModeT (LocatedA (HsExpr GhcPs))))
175199
evalSubExpression (FormatMode padding tf grouping) = do
176200
padding' <- evalPadding padding
177201
tf' <- evalTf tf
178-
pure $ FormatMode padding' tf' grouping
202+
pure $ FormatMode <$> padding' <*> tf' <*> pure grouping
179203

180-
evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (LocatedA (HsExpr GhcPs)))
204+
evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (TypeFormatT (LocatedA (HsExpr GhcPs))))
181205
evalTf tf = case tf of
182206
-- 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
207+
BinaryF alt s -> pure $ pure $ BinaryF alt s
208+
CharacterF -> pure $ pure $ CharacterF
209+
DecimalF s -> pure $ pure $ DecimalF s
210+
HexF alt s -> pure $ pure $ HexF alt s
211+
OctalF alt s -> pure $ pure $ OctalF alt s
212+
HexCapsF alt s -> pure $ pure $ HexCapsF alt s
189213
-- Floating
190214
GeneralF prec alt s -> do
191215
prec' <- evalPrecision prec
192-
pure $ GeneralF prec' alt s
216+
pure $ GeneralF <$> prec' <*> pure alt <*> pure s
193217
GeneralCapsF prec alt s -> do
194218
prec' <- evalPrecision prec
195-
pure $ GeneralCapsF prec' alt s
219+
pure $ GeneralCapsF <$> prec' <*> pure alt <*> pure s
196220
ExponentialF prec alt s -> do
197221
prec' <- evalPrecision prec
198-
pure $ ExponentialF prec' alt s
222+
pure $ ExponentialF <$> prec' <*> pure alt <*> pure s
199223
ExponentialCapsF prec alt s -> do
200224
prec' <- evalPrecision prec
201-
pure $ ExponentialCapsF prec' alt s
225+
pure $ ExponentialCapsF <$> prec' <*> pure alt <*> pure s
202226
FixedF prec alt s -> do
203227
prec' <- evalPrecision prec
204-
pure $ FixedF prec' alt s
228+
pure $ FixedF <$> prec' <*> pure alt <*> pure s
205229
FixedCapsF prec alt s -> do
206230
prec' <- evalPrecision prec
207-
pure $ FixedCapsF prec' alt s
231+
pure $ FixedCapsF <$> prec' <*> pure alt <*> pure s
208232
PercentF prec alt s -> do
209233
prec' <- evalPrecision prec
210-
pure $ PercentF prec' alt s
234+
pure $ PercentF <$> prec' <*> pure alt <*> pure s
211235
-- Default / String
212236
DefaultF prec s -> do
213237
prec' <- evalPrecision prec
214-
pure $ DefaultF prec' s
238+
pure $ DefaultF <$> prec' <*> pure s
215239
StringF prec -> do
216240
prec' <- evalPrecision prec
217-
pure $ StringF prec'
241+
pure $ StringF <$> prec'
218242

219-
evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (LocatedA (HsExpr GhcPs)))
220-
evalPrecision (PrecisionDefault) = pure PrecisionDefault
221-
evalPrecision (Precision e) = Precision <$> exprToInt e
243+
evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PrecisionT (LocatedA (HsExpr GhcPs))))
244+
evalPrecision (PrecisionDefault) = pure $ pure PrecisionDefault
245+
evalPrecision (Precision e) = fmap Precision <$> exprToInt e
222246

223-
evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (LocatedA (HsExpr GhcPs)))
247+
evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PaddingT (LocatedA (HsExpr GhcPs))))
224248
evalPadding p = case p of
225-
PaddingDefault -> pure PaddingDefault
249+
PaddingDefault -> pure $ pure PaddingDefault
226250
Padding i v -> do
227251
i' <- exprToInt i
228-
pure $ Padding i' v
252+
pure $ Padding <$> i' <*> pure v
229253

230-
mkPaddingToPaddingK :: PaddingT _ -> HsExpr GhcPs
254+
mkPaddingToPaddingK :: PaddingT (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs
231255
mkPaddingToPaddingK p = case p of
232256
PaddingDefault -> ctor "PaddingDefaultK"
233257
Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app'` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char)))
@@ -313,19 +337,25 @@ mkPrecision Nothing PrecisionDefault = ctor "Nothing"
313337
mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v))
314338
mkPrecision _ (Precision p) = liftHsExpr (Just p)
315339

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

320-
toHsExpr :: SourcePos -> String -> Hsc (LocatedA (HsExpr GhcPs))
344+
toHsExpr :: SourcePos -> String -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs)))
321345
toHsExpr sourcePos s = do
322346
dynFlags <- getDynFlags
323347
-- TODO
324348
let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos)
325349

326350
case ParseExp.parseExpression srcLoc s dynFlags of
327-
Right res -> pure res
328-
Left e -> error $ show e
351+
Right res -> pure $ Right res
352+
Left e -> pure $ Left e
353+
354+
class ForceError (m :: Symbol) where
355+
forceError :: Proxy m -> t
356+
357+
instance (TypeError (Text m)) => ForceError m where
358+
forceError = undefined
329359

330360
#if MIN_VERSION_ghc(9,10,0)
331361
noExtField' :: NoExtField

0 commit comments

Comments
 (0)