yaml 0.8.6.2 → 0.8.7
raw patch · 4 files changed
+272/−1 lines, 4 filesdep ~conduit
Dependency ranges changed: conduit
Files
- Data/Yaml/Aeson.hs +7/−0
- Data/Yaml/Builder.hs +72/−0
- Data/Yaml/Parser.hs +189/−0
- yaml.cabal +4/−1
+ Data/Yaml/Aeson.hs view
@@ -0,0 +1,7 @@+-- | Just a re-export of @Data.Yaml@. In the future, this will be the canonical+-- name for that module\'s contents.+module Data.Yaml.Aeson+ ( module Data.Yaml+ ) where++import Data.Yaml
+ Data/Yaml/Builder.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+-- | NOTE: This module is a highly experimental preview release. It may change+-- drastically, or be entirely removed, in a future release.+module Data.Yaml.Builder+ ( YamlBuilder (..)+ , ToYaml (..)+ , mapping+ , array+ , string+ , toByteString+ , writeYamlFile+ , (.=)+ ) where++import Data.Conduit+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Text.Libyaml+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Conduit.List as CL+import System.IO.Unsafe (unsafePerformIO)+import Control.Arrow (second)+import qualified Data.ByteString.Char8 as S8++(.=) :: ToYaml a => Text -> a -> (Text, YamlBuilder)+k .= v = (k, toYaml v)++newtype YamlBuilder = YamlBuilder { unYamlBuilder :: [Event] -> [Event] }++class ToYaml a where+ toYaml :: a -> YamlBuilder+instance ToYaml YamlBuilder where+ toYaml = id+instance ToYaml a => ToYaml [(Text, a)] where+ toYaml = mapping . map (second toYaml)+instance ToYaml a => ToYaml [a] where+ toYaml = array . map toYaml+instance ToYaml Text where+ toYaml = string+instance ToYaml Int where+ toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) IntTag PlainNoTag Nothing:)++mapping :: [(Text, YamlBuilder)] -> YamlBuilder+mapping pairs = YamlBuilder $ \rest ->+ EventMappingStart Nothing : foldr addPair (EventMappingEnd : rest) pairs+ where+ addPair (key, YamlBuilder value) after+ = EventScalar (encodeUtf8 key) StrTag PlainNoTag Nothing+ : value after++array :: [YamlBuilder] -> YamlBuilder+array bs =+ YamlBuilder $ (EventSequenceStart Nothing:) . flip (foldr go) bs . (EventSequenceEnd:)+ where+ go (YamlBuilder b) rest = b rest++string :: Text -> YamlBuilder+string t = YamlBuilder (EventScalar (encodeUtf8 t) StrTag PlainNoTag Nothing:)++toEvents :: YamlBuilder -> [Event]+toEvents (YamlBuilder front) =+ EventStreamStart : EventDocumentStart : front [EventDocumentEnd, EventStreamEnd]++toSource :: (Monad m, ToYaml a) => a -> Source m Event+toSource = mapM_ yield . toEvents . toYaml++toByteString :: ToYaml a => a -> ByteString+toByteString yb = unsafePerformIO $ runResourceT $ toSource yb $$ encode++writeYamlFile :: ToYaml a => FilePath -> a -> IO ()+writeYamlFile fp yb = runResourceT $ toSource yb $$ encodeFile fp
+ Data/Yaml/Parser.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+-- | NOTE: This module is a highly experimental preview release. It may change+-- drastically, or be entirely removed, in a future release.+module Data.Yaml.Parser where++import Text.Libyaml+import Control.Applicative ((<$>), Applicative (..), Alternative (..))+import Data.Monoid (Monoid (..))+import Control.Monad (MonadPlus (..), liftM, ap)+import Control.Monad.Trans.Writer.Strict (tell, WriterT)+import Control.Monad.Trans.Class (lift)+import qualified Data.Map as Map+import Data.Conduit+import Data.Conduit.Lift (runWriterSC)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.ByteString (ByteString)+import Control.Exception (Exception)+import Data.Typeable (Typeable)+import Data.Text.Read (signed, decimal)++newtype YamlParser a = YamlParser+ { unYamlParser :: AnchorMap -> Either Text a+ }+instance Functor YamlParser where+ fmap = liftM+instance Applicative YamlParser where+ pure = return+ (<*>) = ap+instance Alternative YamlParser where+ empty = fail "empty"+ (<|>) = mplus+instance Monoid (YamlParser a) where+ mempty = fail "mempty"+ mappend = mplus+instance Monad YamlParser where+ return = YamlParser . const . Right+ YamlParser f >>= g = YamlParser $ \am ->+ case f am of+ Left t -> Left t+ Right x -> unYamlParser (g x) am+ fail = YamlParser . const . Left . pack+instance MonadPlus YamlParser where+ mzero = fail "mzero"+ mplus a b = YamlParser $ \am ->+ case unYamlParser a am of+ Left _ -> unYamlParser b am+ x -> x++lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)+lookupAnchor name = YamlParser $ Right . Map.lookup name++withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a+withAnchor name expected f = do+ mv <- lookupAnchor name+ case mv of+ Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name+ Just v -> f v++withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a+withMapping _ f (Mapping m _) = f m+withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f+withMapping expected _ v = typeMismatch expected v++withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a+withSequence _ f (Sequence s _) = f s+withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f+withSequence expected _ v = typeMismatch expected v++withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a+withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s+withText expected f (Alias an) = withAnchor an expected $ withText expected f+withText expected _ v = typeMismatch expected v++typeMismatch :: Text -> YamlValue -> YamlParser a+typeMismatch expected v =+ fail $ concat+ [ "Expected "+ , unpack expected+ , ", but got: "+ , t+ ]+ where+ t = case v of+ Mapping _ _ -> "mapping"+ Sequence _ _ -> "sequence"+ Scalar _ _ _ _ -> "scalar"+ Alias _ -> "alias"++class FromYaml a where+ fromYaml :: YamlValue -> YamlParser a+instance FromYaml YamlValue where+ fromYaml = return+instance FromYaml a => FromYaml [a] where+ fromYaml = withSequence "[a]" (mapM fromYaml)+instance FromYaml Text where+ fromYaml = withText "Text" return+instance FromYaml Int where+ fromYaml =+ withText "Int" go+ where+ go t =+ case signed decimal t of+ Right (i, "") -> return i+ _ -> fail $ "Invalid Int: " ++ unpack t++data YamlValue+ = Mapping [(Text, YamlValue)] Anchor+ | Sequence [YamlValue] Anchor+ | Scalar ByteString Tag Style Anchor+ | Alias AnchorName+ deriving Show++type AnchorMap = Map.Map AnchorName YamlValue+data RawDoc = RawDoc YamlValue AnchorMap+ deriving Show++parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a+parseRawDoc (RawDoc val am) =+ case unYamlParser (fromYaml val) am of+ Left t -> monadThrow $ FromYamlException t+ Right x -> return x++(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a+o .: k =+ case lookup k o of+ Nothing -> fail $ "Key not found: " ++ unpack k+ Just v -> fromYaml v++data YamlParseException+ = UnexpectedEndOfEvents+ | UnexpectedEvent Event+ | FromYamlException Text+ deriving (Show, Typeable)+instance Exception YamlParseException++sinkValue :: MonadThrow m => Consumer Event (WriterT AnchorMap m) YamlValue+sinkValue =+ start+ where+ start = await >>= maybe (monadThrow UnexpectedEndOfEvents) go++ tell' Nothing val = return val+ tell' (Just name) val = do+ lift $ tell $ Map.singleton name val+ return val++ go EventStreamStart = start+ go EventDocumentStart = start+ go (EventAlias a) = return $ Alias a+ go (EventScalar a b c d) = tell' d $ Scalar a b c d+ go (EventSequenceStart mname) = do+ vals <- goS id+ let val = Sequence vals mname+ tell' mname val+ go (EventMappingStart mname) = do+ pairs <- goM id+ let val = Mapping pairs mname+ tell' mname val++ go e = monadThrow $ UnexpectedEvent e++ goS front = do+ me <- await+ case me of+ Nothing -> monadThrow UnexpectedEndOfEvents+ Just EventSequenceEnd -> return $ front []+ Just e -> do+ val <- go e+ goS (front . (val:))++ goM front = do+ mk <- await+ case mk of+ Nothing -> monadThrow UnexpectedEndOfEvents+ Just EventMappingEnd -> return $ front []+ Just (EventScalar a b c d) -> do+ _ <- tell' d $ Scalar a b c d+ let k = decodeUtf8 a+ v <- start+ goM (front . ((k, v):))+ Just e -> monadThrow $ UnexpectedEvent e++sinkRawDoc :: MonadThrow m => Consumer Event m RawDoc+sinkRawDoc = uncurry RawDoc <$> runWriterSC sinkValue++readYamlFile :: FromYaml a => FilePath -> IO a+readYamlFile fp = runResourceT (decodeFile fp $$ sinkRawDoc) >>= parseRawDoc
yaml.cabal view
@@ -1,5 +1,5 @@ name: yaml-version: 0.8.6.2+version: 0.8.7 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov @@ -52,6 +52,9 @@ , scientific exposed-modules: Text.Libyaml Data.Yaml+ Data.Yaml.Aeson+ Data.Yaml.Builder+ Data.Yaml.Parser ghc-options: -Wall c-sources: c/helper.c include-dirs: c