57 lines
1.5 KiB
Haskell
57 lines
1.5 KiB
Haskell
{-# LANGUAGE RequiredTypeArguments #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ApplicativeDo #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE TemplateHaskellQuotes #-}
|
|
module Gyehoek.QBE
|
|
( module QBE
|
|
, render
|
|
, fn
|
|
)
|
|
where
|
|
|
|
import Gyehoek.QBE.Parse
|
|
import Language.QBE as QBE
|
|
import Data.String (IsString(fromString))
|
|
import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
|
|
import Data.Text (Text)
|
|
import Data.Data
|
|
import Prettyprinter.Render.Text (renderStrict)
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
import Language.Haskell.TH qualified as TH
|
|
import Language.Haskell.TH.Quote
|
|
import Data.Kind (Type)
|
|
|
|
|
|
render :: Pretty a => a -> Text
|
|
render = renderStrict . layoutPretty defaultLayoutOptions . pretty
|
|
|
|
|
|
|
|
parseQuoteExp
|
|
:: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp
|
|
parseQuoteExp p s =
|
|
case parse (space *> p <* space <* eof) "qq" (fromString s) of
|
|
Left es -> fail . foldMap f . bundleErrors $ es
|
|
where f e = parseErrorPretty e ++ "\n\n"
|
|
Right x -> dataToExpQ (\_ -> Nothing) x
|
|
|
|
-- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp
|
|
-- quoteExp t s = case parse (parser @t) "qq" (fromString s) of
|
|
-- Left es -> _
|
|
-- Right x -> dataToExpQ (\_ -> Nothing) x
|
|
|
|
makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter
|
|
makeQQ t = QuasiQuoter
|
|
{ quoteExp = parseQuoteExp (parser @t)
|
|
, quotePat = _
|
|
, quoteType = undefined
|
|
, quoteDec = undefined
|
|
}
|
|
|
|
fn :: QuasiQuoter
|
|
fn = makeQQ (type FuncDef)
|