@@ -1,10 +1,10 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TemplateHaskell #-}
43
54module Data.Yaml.TH
65 ( -- * Decoding
76 decodeFile
7+ , yamlQQ
88 -- * Re-exports from "Data.Yaml"
99 , Value (..)
1010 , Parser
@@ -19,9 +19,13 @@ module Data.Yaml.TH
1919 , FromJSON (..)
2020 ) where
2121
22−import Data.Yaml hiding (decodeFile)
23−import Language.Haskell.TH
24−import Language.Haskell.TH.Syntax
22+import Data.Text.Encoding
23+import qualified Data.Text as T
24+import Language.Haskell.TH
25+import Language.Haskell.TH.Syntax
26+import Language.Haskell.TH.Quote
27+
28+import Data.Yaml hiding (decodeFile)
2529
2630-- | Decode a @yaml@ file at compile time. Only available on GHC version @7.8.1@
2731-- or higher.
@@ -42,3 +46,20 @@ decodeFile path = do
4246 runIO (decodeFileEither path) >>= \case
4347 Left err -> fail (prettyPrintParseException err)
4448 Right x -> fmap TExp (lift (x :: a))
49+
50+decodeValue :: String -> Either String Value
51+decodeValue = decodeEither . encodeUtf8 . T.pack
52+
53+yamlExp :: String -> Q Exp
54+yamlExp input = case decodeValue input of
55+ Left err -> fail err
56+ Right a -> lift a
57+
58+yamlQQ :: QuasiQuoter
59+yamlQQ = QuasiQuoter {
60+ quoteExp = yamlExp
61+, quotePat = notDefined "quotePat"
62+, quoteType = notDefined "quoteType"
63+, quoteDec = notDefined "quoteDec"
64+} where
65+ notDefined name _ = fail (name ++ " is not defined for yamlQQ")