git.iko.soy/typeable/yaml
on de41665 help sign in
typeable/yaml/Data/Yaml/Internal.hs
293 lines 11 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE OverloadedStrings #-}
5module Data.Yaml.Internal
6 (
7 ParseException(..)
8 , prettyPrintParseException
9 , parse
10 , decodeHelper
11 , decodeHelper_
12 , specialStrings
13 , isNumeric
14 ) where
16#if !MIN_VERSION_base(4,8,0)
17import Control.Applicative ((<$>), Applicative(..))
18#endif
19import Control.Exception
20import Control.Exception.Enclosed
21import Control.Monad (liftM, ap, unless)
22import Control.Monad.IO.Class (MonadIO, liftIO)
23import Control.Monad.Trans.Class (MonadTrans, lift)
24import Control.Monad.Trans.Resource (ResourceT, runResourceT)
25import Control.Monad.Trans.State
26import Data.Aeson
27import Data.Aeson.Types hiding (parse)
28import qualified Data.Attoparsec.Text as Atto
29import Data.ByteString (ByteString)
30import Data.Char (toUpper)
31import qualified Data.Conduit as C
32import qualified Data.Conduit.List as CL
33import qualified Data.HashMap.Strict as M
34import qualified Data.HashSet as HashSet
35import qualified Data.Map as Map
36import Data.Scientific (Scientific)
37import Data.Text (Text, pack)
38import qualified Data.Text as T
39import Data.Text.Encoding (decodeUtf8With)
40import Data.Text.Encoding.Error (lenientDecode)
41import Data.Typeable
42import qualified Data.Vector as V
44import qualified Text.Libyaml as Y
45import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
47data ParseException = NonScalarKey
48 | UnknownAlias { _anchorName :: Y.AnchorName }
49 | UnexpectedEvent { _received :: Maybe Event
50 , _expected :: Maybe Event
51 }
52 | InvalidYaml (Maybe YamlException)
53 | AesonException String
54 | OtherParseException SomeException
55 | NonStringKeyAlias Y.AnchorName Value
56 | CyclicIncludes
57 deriving (Show, Typeable)
59instance Exception ParseException where
60#if MIN_VERSION_base(4, 8, 0)
61 displayException = prettyPrintParseException
62#endif
64-- | Alternative to 'show' to display a 'ParseException' on the screen.
65-- Instead of displaying the data constructors applied to their arguments,
66-- a more textual output is returned. For example, instead of printing:
67--
68-- > InvalidYaml (Just (YamlParseException {yamlProblem = "did not find expected ',' or '}'", yamlContext = "while parsing a flow mapping", yamlProblemMark = YamlMark {yamlIndex = 42, yamlLine = 2, yamlColumn = 12}})))
69--
70-- It looks more pleasant to print:
71--
72-- > YAML parse exception at line 2, column 12,
73-- > while parsing a flow mapping:
74-- > did not find expected ',' or '}'
75--
76-- Since 0.8.11
77prettyPrintParseException :: ParseException -> String
78prettyPrintParseException pe = case pe of
79 NonScalarKey -> "Non scalar key"
80 UnknownAlias anchor -> "Unknown alias `" ++ anchor ++ "`"
81 UnexpectedEvent { _expected = mbExpected, _received = mbUnexpected } -> unlines
82 [ "Unexpected event: expected"
83 , " " ++ show mbExpected
84 , "but received"
85 , " " ++ show mbUnexpected
86 ]
87 InvalidYaml mbYamlError -> case mbYamlError of
88 Nothing -> "Unspecified YAML error"
89 Just yamlError -> case yamlError of
90 YamlException s -> "YAML exception:\n" ++ s
91 YamlParseException problem context mark -> concat
92 [ "YAML parse exception at line " ++ show (yamlLine mark) ++
93 ", column " ++ show (yamlColumn mark)
94 , case context of
95 "" -> ":\n"
96 -- The context seems to include a leading "while" or similar.
97 _ -> ",\n" ++ context ++ ":\n"
98 , problem
99 ]
100 AesonException s -> "Aeson exception:\n" ++ s
101 OtherParseException exc -> "Generic parse exception:\n" ++ show exc
102 NonStringKeyAlias anchor value -> unlines
103 [ "Non-string key alias:"
104 , " Anchor name: " ++ anchor
105 , " Value: " ++ show value
106 ]
107 CyclicIncludes -> "Cyclic includes"
109newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
110instance Monad m => Functor (PErrorT m) where
111 fmap = liftM
112instance Monad m => Applicative (PErrorT m) where
113 pure = PErrorT . return . Right
114 (<*>) = ap
115instance Monad m => Monad (PErrorT m) where
116 return = pure
117 (PErrorT m) >>= f = PErrorT $ do
118 e <- m
119 case e of
120 Left e' -> return $ Left e'
121 Right a -> runPErrorT $ f a
122instance MonadTrans PErrorT where
123 lift = PErrorT . liftM Right
124instance MonadIO m => MonadIO (PErrorT m) where
125 liftIO = lift . liftIO
127type Parse = StateT (Map.Map String Value) (ResourceT IO)
129requireEvent :: Event -> C.Sink Event Parse ()
130requireEvent e = do
131 f <- CL.head
132 unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e
134parse :: C.Sink Event Parse Value
135parse = do
136 streamStart <- CL.head
137 case streamStart of
138 Nothing ->
139 -- empty string input
140 return Null
141 Just EventStreamStart -> do
142 documentStart <- CL.head
143 case documentStart of
144 Just EventStreamEnd ->
145 -- empty file input, comment only string/file input
146 return Null
147 Just EventDocumentStart -> do
148 res <- parseO
149 requireEvent EventDocumentEnd
150 requireEvent EventStreamEnd
151 return res
152 _ -> liftIO $ throwIO $ UnexpectedEvent documentStart Nothing
153 _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing
155parseScalar :: ByteString -> Anchor -> Style -> Tag
156 -> C.Sink Event Parse Text
157parseScalar v a style tag = do
158 let res = decodeUtf8With lenientDecode v
159 case a of
160 Nothing -> return res
161 Just an -> do
162 lift $ modify (Map.insert an $ textToValue style tag res)
163 return res
165textToValue :: Style -> Tag -> Text -> Value
166textToValue SingleQuoted _ t = String t
167textToValue DoubleQuoted _ t = String t
168textToValue _ StrTag t = String t
169textToValue Folded _ t = String t
170textToValue _ _ t
171 | t `elem` ["null", "Null", "NULL", "~", ""] = Null
172 | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True
173 | any (t `isLike`) ["n", "no", "off", "false"] = Bool False
174 | Right x <- textToScientific t = Number x
175 | otherwise = String t
176 where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]
177 where titleCased = toUpper (T.head ref) `T.cons` T.tail ref
179textToScientific :: Text -> Either String Scientific
180textToScientific = Atto.parseOnly (Atto.scientific <* Atto.endOfInput)
182parseO :: C.Sink Event Parse Value
183parseO = do
184 me <- CL.head
185 case me of
186 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag
187 Just (EventSequenceStart a) -> parseS a id
188 Just (EventMappingStart a) -> parseM a M.empty
189 Just (EventAlias an) -> do
190 m <- lift get
191 case Map.lookup an m of
192 Nothing -> liftIO $ throwIO $ UnknownAlias an
193 Just v -> return v
194 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
196parseS :: Y.Anchor
197 -> ([Value] -> [Value])
198 -> C.Sink Event Parse Value
199parseS a front = do
200 me <- CL.peek
201 case me of
202 Just EventSequenceEnd -> do
203 CL.drop 1
204 let res = Array $ V.fromList $ front []
205 case a of
206 Nothing -> return res
207 Just an -> do
208 lift $ modify $ Map.insert an res
209 return res
210 _ -> do
211 o <- parseO
212 parseS a $ front . (:) o
214parseM :: Y.Anchor
215 -> M.HashMap Text Value
216 -> C.Sink Event Parse Value
217parseM a front = do
218 me <- CL.peek
219 case me of
220 Just EventMappingEnd -> do
221 CL.drop 1
222 let res = Object front
223 case a of
224 Nothing -> return res
225 Just an -> do
226 lift $ modify $ Map.insert an res
227 return res
228 _ -> do
229 CL.drop 1
230 s <- case me of
231 Just (EventScalar v tag style a') -> parseScalar v a' style tag
232 Just (EventAlias an) -> do
233 m <- lift get
234 case Map.lookup an m of
235 Nothing -> liftIO $ throwIO $ UnknownAlias an
236 Just (String t) -> return t
237 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
238 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
239 o <- parseO
241 let al = M.insert s o front
242 al' = if s == pack "<<"
243 then case o of
244 Object l -> M.union front l
245 Array l -> M.union front $ foldl merge' M.empty $ V.toList l
246 _ -> al
247 else al
248 parseM a al'
249 where merge' al (Object om) = M.union al om
250 merge' al _ = al
252decodeHelper :: FromJSON a
253 => C.Source Parse Y.Event
254 -> IO (Either ParseException (Either String a))
255decodeHelper src = do
256 x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse
257 case x of
258 Left e
259 | Just pe <- fromException e -> return $ Left pe
260 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
261 | otherwise -> throwIO e
262 Right y -> return $ Right $ parseEither parseJSON y
264decodeHelper_ :: FromJSON a
265 => C.Source Parse Event
266 -> IO (Either ParseException a)
267decodeHelper_ src = do
268 x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse
269 return $ case x of
270 Left e
271 | Just pe <- fromException e -> Left pe
272 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)
273 | otherwise -> Left $ OtherParseException e
274 Right y -> either
275 (Left . AesonException)
276 Right
277 (parseEither parseJSON y)
279-- | Strings which must be escaped so as not to be treated as non-string scalars.
280specialStrings :: HashSet.HashSet Text
281specialStrings = HashSet.fromList $ T.words
282 "y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~"
284isNumeric :: Text -> Bool
285isNumeric =
286 T.all isNumeric'
287 where
288 isNumeric' c = ('0' <= c && c <= '9')
289 || c == 'e'
290 || c == 'E'
291 || c == '.'
292 || c == '-'
293 || c == '+'