62 lines
1.7 KiB
Haskell
62 lines
1.7 KiB
Haskell
{-# LANGUAGE RequiredTypeArguments #-}
|
||
{-# LANGUAGE TypeFamilies #-}
|
||
{-# LANGUAGE BlockArguments #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE ApplicativeDo #-}
|
||
{-# LANGUAGE PartialTypeSignatures #-}
|
||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||
module Gyehoek.QBE
|
||
( module QBE
|
||
, render
|
||
, fn
|
||
, writeTo
|
||
)
|
||
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)
|
||
import qualified Data.Text.IO as TIO
|
||
|
||
|
||
writeTo :: FilePath -> Text -> IO ()
|
||
writeTo = TIO.writeFile
|
||
|
||
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)
|