module Data.EDN.Types.Class (
ToEDN, FromEDN, toEDN, fromEDN, fromEDNv, (.:), (.:?)
) where
import Control.Applicative (pure, (<$>))
import Control.Monad (liftM, liftM2)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Vector as V
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Parser as P
import qualified Data.EDN.Types as E
class ToEDN a where
toEDN :: a -> E.TaggedValue
toEDN = E.notag . toEDNv
toEDNv :: a -> E.Value
toEDNv = E.stripTag . toEDN
class FromEDN a where
parseEDN :: E.TaggedValue -> P.Parser a
parseEDN = parseEDNv . E.stripTag
parseEDNv :: E.Value -> P.Parser a
parseEDNv = parseEDN . E.notag
instance (ToEDN a) => ToEDN (Maybe a) where
toEDN (Just a) = toEDN a
toEDN Nothing = E.nil
instance (FromEDN a) => (FromEDN (Maybe a)) where
parseEDNv E.Nil = pure Nothing
parseEDNv a = Just <$> parseEDNv a
instance (ToEDN a, ToEDN b) => ToEDN (Either a b) where
toEDN (Left a) = E.tag "either" "left" $ toEDNv a
toEDN (Right b) = E.tag "either" "right" $ toEDNv b
instance (FromEDN a, FromEDN b) => FromEDN (Either a b) where
parseEDN (E.Tagged v "either" "left") = Left <$> parseEDNv v
parseEDN (E.Tagged v "either" "right") = Right <$> parseEDNv v
parseEDN (E.Tagged _ _ _) = fail "incorrect tag"
parseEDN (E.NoTag _) = fail "no tag"
instance (ToEDN a) => ToEDN (E.Tagged a) where
toEDN (E.Tagged v ns t) = E.setTag ns t $ toEDN v
toEDN (E.NoTag v) = toEDN v
instance (FromEDN a) => FromEDN (E.Tagged a) where
parseEDN (E.Tagged v ns t) = E.tag ns t <$> parseEDNv v
parseEDN (E.NoTag v) = E.notag <$> parseEDNv v
instance ToEDN Bool where
toEDN = E.bool
instance FromEDN Bool where
parseEDNv (E.Boolean b) = pure b
parseEDNv v = typeMismatch "Boolean" v
instance ToEDN () where
toEDNv _ = E.List []
instance FromEDN () where
parseEDNv (E.List l) | null l = pure ()
parseEDNv v = typeMismatch "()" v
instance ToEDN [Char] where
toEDNv = E.String . T.pack
instance FromEDN [Char] where
parseEDNv (E.String t) = pure $ T.unpack t
parseEDNv (E.Symbol "" s) = pure $ BS.unpack s
parseEDNv (E.Symbol ns s) = pure . BS.unpack $ BS.concat [ns, "/", s]
parseEDNv (E.Keyword k) = pure . BS.unpack $ BS.cons ':' k
parseEDNv v = typeMismatch "String/Symbol/Keyword" v
instance ToEDN T.Text where
toEDNv = E.String
instance FromEDN T.Text where
parseEDNv (E.String t) = pure t
parseEDNv v = typeMismatch "String" v
instance ToEDN TL.Text where
toEDNv = E.String . TL.toStrict
instance FromEDN TL.Text where
parseEDNv (E.String t) = pure $ TL.fromStrict t
parseEDNv v = typeMismatch "String" v
instance ToEDN BS.ByteString where
toEDNv = E.String . TE.decodeUtf8
instance FromEDN BS.ByteString where
parseEDNv (E.String t) = pure $ TE.encodeUtf8 t
parseEDNv v = typeMismatch "String" v
instance ToEDN BSL.ByteString where
toEDNv = E.String . TL.toStrict . TLE.decodeUtf8
instance FromEDN BSL.ByteString where
parseEDNv (E.String t) = pure . TLE.encodeUtf8 . TL.fromStrict $ t
parseEDNv v = typeMismatch "String" v
instance ToEDN Char where
toEDNv = E.Character
instance FromEDN Char where
parseEDNv (E.Character c) = pure $ c
parseEDNv v = typeMismatch "Character" v
instance ToEDN Double where
toEDNv = E.Floating
instance FromEDN Double where
parseEDNv (E.Floating d) = pure d
parseEDNv v = typeMismatch "Floating" v
instance ToEDN Integer where
toEDNv = E.Integer
instance FromEDN Integer where
parseEDNv (E.Integer i) = pure i
parseEDNv v = typeMismatch "Integer" v
instance ToEDN a => ToEDN [a] where
toEDNv = E.List . map toEDN
instance FromEDN a => FromEDN [a] where
parseEDNv (E.List vs) = mapM parseEDN vs
parseEDNv v = typeMismatch "List" v
instance ToEDN a => ToEDN (V.Vector a) where
toEDNv = E.Vec . V.map toEDN
instance FromEDN a => FromEDN (V.Vector a) where
parseEDNv (E.Vec as) = V.mapM parseEDN as
parseEDNv v = typeMismatch "Vec" v
instance (Ord a, ToEDN a) => ToEDN (S.Set a) where
toEDNv = E.Set . S.map toEDN
instance (Ord a, FromEDN a) => FromEDN (S.Set a) where
parseEDNv (E.Set s) = mapMset parseEDN s
parseEDNv v = typeMismatch "Set" v
instance (ToEDN a, ToEDN b) => ToEDN (M.Map a b) where
toEDNv m = E.Map $! M.fromList [(toEDNv k, toEDN v) | (k, v) <- M.assocs m]
instance (Ord a, FromEDN a, FromEDN b) => FromEDN (M.Map a b) where
parseEDNv (E.Map m) = mapMmap parseEDNv parseEDN m
parseEDNv v = typeMismatch "Map" v
instance ToEDN E.Value where
toEDNv = id
instance FromEDN E.Value where
parseEDNv = pure
instance ToEDN E.TaggedValue where
toEDN = id
instance FromEDN E.TaggedValue where
parseEDN = pure
fromEDN :: FromEDN a => E.TaggedValue -> P.Result a
fromEDN = P.parse parseEDN
fromEDNv :: FromEDN a => E.Value -> P.Result a
fromEDNv = P.parse parseEDNv
(.:) :: (Show k, ToEDN k, FromEDN a) => E.EDNMap -> k -> P.Parser a
emap .: key = case M.lookup (toEDNv key) emap of
Nothing -> fail $ "key " ++ show key ++ " not present"
Just v -> parseEDN v
(.:?) :: (ToEDN k, FromEDN a) => E.EDNMap -> k -> P.Parser (Maybe a)
emap .:? key = case M.lookup (toEDNv key) emap of
Nothing -> pure Nothing
Just v -> parseEDN v
typeMismatch :: String
-> E.Value
-> P.Parser a
typeMismatch expected actual =
fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
" instead"
where
name = case actual of
E.Nil -> "Nil"
E.Boolean _ -> "Boolean"
E.String _ -> "String"
E.Character _ -> "Character"
E.Symbol _ _ -> "Symbol"
E.Keyword _ -> "Keyword"
E.Integer _ -> "Integer"
E.Floating _ -> "Floating"
E.List _ -> "List"
E.Vec _ -> "Vec"
E.Map _ -> "Map"
E.Set _ -> "Set"
mapMset :: (Monad m, Ord b) => (a -> m b) -> S.Set a -> m (S.Set b)
mapMset f s = mapM f (S.toList s) >>= return . S.fromList
mapMmap :: (Ord a2, Monad m) => (a1 -> m a2) -> (b1 -> m b2) -> M.Map a1 b1 -> m (M.Map a2 b2)
mapMmap kf vf = liftM M.fromList . mapM (\(k, v) -> liftM2 (,) (kf k) (vf v)) . M.assocs