1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE OverloadedStrings #-} 4-- | NOTE: This module is a highly experimental preview release. It may change 5-- drastically, or be entirely removed, in a future release. 6module Data.Yaml.Parser where 7 8import Control.Applicative 9import Control.Exception (Exception) 10import Control.Monad (MonadPlus (..), liftM, ap) 11import Control.Monad.Trans.Class (lift) 12import Control.Monad.Trans.Resource (MonadThrow, throwM) 13import Control.Monad.Trans.Writer.Strict (tell, WriterT) 14import Data.ByteString (ByteString) 15import Data.Conduit 16import Data.Conduit.Lift (runWriterC) 17import qualified Data.Map as Map 18#if !MIN_VERSION_base(4,8,0) 19import Data.Monoid (Monoid (..)) 20#endif 21#if !MIN_VERSION_base(4,11,0) 22import Data.Semigroup (Semigroup(..)) 23#endif 24import Data.Text (Text, pack, unpack) 25import Data.Text.Encoding (decodeUtf8) 26import Data.Text.Read (signed, decimal) 27import Data.Typeable (Typeable) 28 29import Text.Libyaml 30 31newtype YamlParser a = YamlParser 32 { unYamlParser :: AnchorMap -> Either Text a 33 } 34instance Functor YamlParser where 35 fmap = liftM 36instance Applicative YamlParser where 37 pure = YamlParser . const . Right 38 (<*>) = ap 39instance Alternative YamlParser where 40 empty = fail "empty" 41 (<|>) = mplus 42instance Semigroup (YamlParser a) where 43 (<>) = mplus 44instance Monoid (YamlParser a) where 45 mempty = fail "mempty" 46#if !MIN_VERSION_base(4,11,0) 47 mappend = (<>) 48#endif 49instance Monad YamlParser where 50 return = pure 51 YamlParser f >>= g = YamlParser $ \am -> 52 case f am of 53 Left t -> Left t 54 Right x -> unYamlParser (g x) am 55#if MIN_VERSION_base(4,13,0) 56instance MonadFail YamlParser where 57#endif 58 fail = YamlParser . const . Left . pack 59instance MonadPlus YamlParser where 60 mzero = fail "mzero" 61 mplus a b = YamlParser $ \am -> 62 case unYamlParser a am of 63 Left _ -> unYamlParser b am 64 x -> x 65 66lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue) 67lookupAnchor name = YamlParser $ Right . Map.lookup name 68 69withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a 70withAnchor name expected f = do 71 mv <- lookupAnchor name 72 case mv of 73 Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name 74 Just v -> f v 75 76withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a 77withMapping _ f (Mapping m _) = f m 78withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f 79withMapping expected _ v = typeMismatch expected v 80 81withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a 82withSequence _ f (Sequence s _) = f s 83withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f 84withSequence expected _ v = typeMismatch expected v 85 86withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a 87withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s 88withText expected f (Alias an) = withAnchor an expected $ withText expected f 89withText expected _ v = typeMismatch expected v 90 91typeMismatch :: Text -> YamlValue -> YamlParser a 92typeMismatch expected v = 93 fail $ concat 94 [ "Expected " 95 , unpack expected 96 , ", but got: " 97 , t 98 ] 99 where 100 t = case v of 101 Mapping _ _ -> "mapping" 102 Sequence _ _ -> "sequence" 103 Scalar _ _ _ _ -> "scalar" 104 Alias _ -> "alias" 105 106class FromYaml a where 107 fromYaml :: YamlValue -> YamlParser a 108instance FromYaml YamlValue where 109 fromYaml = return 110instance FromYaml a => FromYaml [a] where 111 fromYaml = withSequence "[a]" (mapM fromYaml) 112instance FromYaml Text where 113 fromYaml = withText "Text" return 114instance FromYaml Int where 115 fromYaml = 116 withText "Int" go 117 where 118 go t = 119 case signed decimal t of 120 Right (i, "") -> return i 121 _ -> fail $ "Invalid Int: " ++ unpack t 122 123data YamlValue 124 = Mapping [(Text, YamlValue)] Anchor 125 | Sequence [YamlValue] Anchor 126 | Scalar ByteString Tag Style Anchor 127 | Alias AnchorName 128 deriving Show 129 130type AnchorMap = Map.Map AnchorName YamlValue 131data RawDoc = RawDoc YamlValue AnchorMap 132 deriving Show 133 134parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a 135parseRawDoc (RawDoc val am) = 136 case unYamlParser (fromYaml val) am of 137 Left t -> throwM $ FromYamlException t 138 Right x -> return x 139 140(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a 141o .: k = 142 case lookup k o of 143 Nothing -> fail $ "Key not found: " ++ unpack k 144 Just v -> fromYaml v 145 146data YamlParseException 147 = UnexpectedEndOfEvents 148 | UnexpectedEvent Event 149 | FromYamlException Text 150 deriving (Show, Typeable) 151instance Exception YamlParseException 152 153sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue 154sinkValue = 155 start 156 where 157 start = await >>= maybe (throwM UnexpectedEndOfEvents) go 158 159 tell' Nothing val = return val 160 tell' (Just name) val = do 161 lift $ tell $ Map.singleton name val 162 return val 163 164 go EventStreamStart = start 165 go EventDocumentStart = start 166 go (EventAlias a) = return $ Alias a 167 go (EventScalar a b c d) = tell' d $ Scalar a b c d 168 go (EventSequenceStart _tag _style mname) = do 169 vals <- goS id 170 let val = Sequence vals mname 171 tell' mname val 172 go (EventMappingStart _tag _style mname) = do 173 pairs <- goM id 174 let val = Mapping pairs mname 175 tell' mname val 176 177 go e = throwM $ UnexpectedEvent e 178 179 goS front = do 180 me <- await 181 case me of 182 Nothing -> throwM UnexpectedEndOfEvents 183 Just EventSequenceEnd -> return $ front [] 184 Just e -> do 185 val <- go e 186 goS (front . (val:)) 187 188 goM front = do 189 mk <- await 190 case mk of 191 Nothing -> throwM UnexpectedEndOfEvents 192 Just EventMappingEnd -> return $ front [] 193 Just (EventScalar a b c d) -> do 194 _ <- tell' d $ Scalar a b c d 195 let k = decodeUtf8 a 196 v <- start 197 goM (front . ((k, v):)) 198 Just e -> throwM $ UnexpectedEvent e 199 200sinkRawDoc :: MonadThrow m => ConduitM Event o m RawDoc 201sinkRawDoc = uncurry RawDoc <$> runWriterC sinkValue 202 203readYamlFile :: FromYaml a => FilePath -> IO a 204readYamlFile fp = runConduitRes (decodeFile fp .| sinkRawDoc) >>= parseRawDoc 205