{-# LANGUAGE TemplateHaskell #-}
module Inferno.Utils.QQ.Common where
import Data.Text (Text)
import qualified Data.Text as Text
import Inferno.Parse.Error (prettyError)
import Language.Haskell.TH.Syntax
( Exp (AppE, VarE),
Lift (lift),
Loc (loc_filename, loc_start),
Q,
location,
)
import Text.Megaparsec (ParseError, ShowErrorComponent, SourcePos (..), mkPos, unPos)
location' :: Q SourcePos
location' :: Q SourcePos
location' = Loc -> SourcePos
aux forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
where
aux :: Loc -> SourcePos
aux :: Loc -> SourcePos
aux Loc
loc = let (Int
l, Int
c) = (Loc -> (Int, Int)
loc_start Loc
loc) in String -> Pos -> Pos -> SourcePos
SourcePos (Loc -> String
loc_filename Loc
loc) (Int -> Pos
mkPos Int
l) (Int -> Pos
mkPos Int
c)
liftText :: Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Text.pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (Text -> String
Text.unpack Text
txt)
mkParseErrorStr :: ShowErrorComponent e => (ParseError Text e, SourcePos) -> String
mkParseErrorStr :: forall e.
ShowErrorComponent e =>
(ParseError Text e, SourcePos) -> String
mkParseErrorStr (ParseError Text e
err, SourcePos {String
Pos
sourceColumn :: SourcePos -> Pos
sourceLine :: SourcePos -> Pos
sourceName :: SourcePos -> String
sourceColumn :: Pos
sourceLine :: Pos
sourceName :: String
..}) =
String
"Error at line "
forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
sourceLine)
forall a. Semigroup a => a -> a -> a
<> String
" column "
forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
sourceColumn)
forall a. Semigroup a => a -> a -> a
<> String
"\n "
forall a. Semigroup a => a -> a -> a
<> (Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"\n" Text
"\n " forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. ShowErrorComponent e => ParseError Text e -> String
prettyError ParseError Text e
err)