hedn 0.1.4.1 → 0.1.5.0
raw patch · 6 files changed
+399/−11 lines, 6 filesdep +deepseqdep +mtl
Dependencies added: deepseq, mtl
Files
- hedn.cabal +3/−2
- src/Data/EDN.hs +5/−1
- src/Data/EDN/Parser.hs +1/−1
- src/Data/EDN/Types.hs +11/−7
- src/Data/EDN/Types/Class.hs +248/−0
- src/Data/Parser.hs +131/−0
hedn.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hedn-version: 0.1.4.1+version: 0.1.5.0 synopsis: EDN parsing and encoding homepage: https://bitbucket.org/dpwiz/hedn license: BSD3@@ -28,8 +28,9 @@ library exposed-modules: Data.EDN, Data.EDN.Types, Data.EDN.Parser, Data.EDN.Encode+ other-modules: Data.Parser, Data.EDN.Types.Class hs-source-dirs: src/- build-depends: base ==4.5.*, attoparsec, text, bytestring, containers, vector, stringsearch+ build-depends: base ==4.5.*, attoparsec, text, bytestring, containers, vector, stringsearch, mtl, deepseq if flag(developer) ghc-options: -Werror
src/Data/EDN.hs view
@@ -1,7 +1,10 @@ module Data.EDN ( -- * Core EDN types- Value(..), TaggedValue(..),+ Value(..), TaggedValue, Tagged(..), + -- ** Type conversion+ ToEDN, FromEDN, toEDN, fromEDN, fromEDNv,+ -- * Tag manipulation setTag, getTag, stripTag, @@ -26,5 +29,6 @@ ) where import Data.EDN.Types+import Data.EDN.Types.Class (FromEDN, ToEDN, toEDN, fromEDN, fromEDNv) import Data.EDN.Encode (encode, fromValue, fromTagged) import Data.EDN.Parser (decode, parseValue, parseTagged)
src/Data/EDN/Parser.hs view
@@ -20,7 +20,7 @@ import qualified Data.Text.Lazy.Encoding as TLE import Data.ByteString.Search (replace) -import Data.EDN.Types (Value(..), TaggedValue(..), makeVec, makeMap, makeSet)+import Data.EDN.Types (Value(..), Tagged(..), TaggedValue, makeVec, makeMap, makeSet) isSpaceOrComma :: Char -> Bool isSpaceOrComma ' ' = True
src/Data/EDN/Types.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE FlexibleInstances #-}+ module Data.EDN.Types ( -- * Types- TaggedValue(..), Value(..),+ Value(..), Tagged(..), TaggedValue, -- ** Internal containers EDNList, EDNVec, EDNSet, EDNMap, Pair,@@ -31,6 +33,13 @@ import qualified Data.Map as M import qualified Data.Set as S +-- | Abstract namespaced tag.+data Tagged a = NoTag !a+ | Tagged !a !ByteString !ByteString+ deriving (Eq, Ord, Show)++type TaggedValue = Tagged Value+ type EDNList = [TaggedValue] type EDNVec = V.Vector TaggedValue type EDNMap = M.Map Value TaggedValue@@ -51,11 +60,6 @@ | Set !EDNSet deriving (Eq, Ord, Show) --- | A 'Value' wrapped into a namespaced tag.-data TaggedValue = NoTag !Value- | Tagged !Value !ByteString !ByteString- deriving (Eq, Ord, Show)- -- | Strings starting with \":\" will become keywords. instance IsString Value where fromString (':':s) = Keyword . BS.pack $ s@@ -63,7 +67,7 @@ {-# INLINE fromString #-} -- | Strings will become an tagless EDN strings.-instance IsString TaggedValue where+instance IsString (Tagged Value) where fromString = string . T.pack {-# INLINE fromString #-}
+ src/Data/EDN/Types/Class.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, IncoherentInstances #-}++module Data.EDN.Types.Class (+ ToEDN, FromEDN, toEDN, fromEDN, fromEDNv+) where++import Control.Applicative (pure, (<$>))+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+ {-# INLINE toEDN #-}++ toEDNv :: a -> E.Value+ toEDNv = E.stripTag . toEDN+ {-# INLINE toEDNv #-}++class FromEDN a where+ parseEDN :: E.TaggedValue -> P.Parser a+ parseEDN = parseEDNv . E.stripTag+ {-# INLINE parseEDN #-}++ parseEDNv :: E.Value -> P.Parser a+ parseEDNv = parseEDN . E.notag+ {-# INLINE parseEDNv #-}++instance (ToEDN a) => ToEDN (Maybe a) where+ toEDN (Just a) = toEDN a+ toEDN Nothing = E.nil+ {-# INLINE toEDN #-}++instance (FromEDN a) => (FromEDN (Maybe a)) where+ parseEDNv E.Nil = pure Nothing+ parseEDNv a = Just <$> parseEDNv a+ {-# INLINE parseEDNv #-}++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+ {-# INLINE toEDN #-}++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"+ {-# INLINE parseEDN #-}++instance ToEDN Bool where+ toEDN = E.bool+ {-# INLINE toEDN #-}++instance FromEDN Bool where+ parseEDNv (E.Boolean b) = pure b+ parseEDNv v = typeMismatch "Boolean" v+ {-# INLINE parseEDNv #-}++instance ToEDN () where+ toEDNv _ = E.List []+ {-# INLINE toEDNv #-}++instance FromEDN () where+ parseEDNv (E.List l) | null l = pure ()+ parseEDNv v = typeMismatch "()" v+ {-# INLINE parseEDNv #-}++instance ToEDN [Char] where+ toEDNv = E.String . T.pack+ {-# INLINE toEDNv #-}++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+ {-# INLINE parseEDNv #-}++instance ToEDN T.Text where+ toEDNv = E.String+ {-# INLINE toEDNv #-}++instance FromEDN T.Text where+ parseEDNv (E.String t) = pure t+ parseEDNv v = typeMismatch "String" v+ {-# INLINE parseEDNv #-}++instance ToEDN TL.Text where+ toEDNv = E.String . TL.toStrict+ {-# INLINE toEDNv #-}++instance FromEDN TL.Text where+ parseEDNv (E.String t) = pure $ TL.fromStrict t+ parseEDNv v = typeMismatch "String" v+ {-# INLINE parseEDNv #-}++instance ToEDN BS.ByteString where+ toEDNv = E.String . TE.decodeUtf8+ {-# INLINE toEDNv #-}++instance FromEDN BS.ByteString where+ parseEDNv (E.String t) = pure $ TE.encodeUtf8 t+ parseEDNv v = typeMismatch "String" v+ {-# INLINE parseEDNv #-}++instance ToEDN BSL.ByteString where+ toEDNv = E.String . TL.toStrict . TLE.decodeUtf8+ {-# INLINE toEDNv #-}++instance FromEDN BSL.ByteString where+ parseEDNv (E.String t) = pure . TLE.encodeUtf8 . TL.fromStrict $ t+ parseEDNv v = typeMismatch "String" v+ {-# INLINE parseEDNv #-}++instance ToEDN Char where+ toEDNv = E.Character+ {-# INLINE toEDNv #-}++instance FromEDN Char where+ parseEDNv (E.Character c) = pure $ c+ parseEDNv v = typeMismatch "Character" v+ {-# INLINE parseEDNv #-}++instance ToEDN Double where+ toEDNv = E.Floating+ {-# INLINE toEDNv #-}++instance FromEDN Double where+ parseEDNv (E.Floating d) = pure d+ parseEDNv v = typeMismatch "Floating" v+ {-# INLINE parseEDNv #-}++instance ToEDN Integer where+ toEDNv = E.Integer+ {-# INLINE toEDNv #-}++instance FromEDN Integer where+ parseEDNv (E.Integer i) = pure i+ parseEDNv v = typeMismatch "Integer" v+ {-# INLINE parseEDNv #-}++instance ToEDN a => ToEDN [a] where+ toEDNv = E.List . map toEDN+ {-# INLINE toEDNv #-}++instance FromEDN a => FromEDN [a] where+ parseEDNv (E.List vs) = mapM parseEDN vs+ parseEDNv v = typeMismatch "List" v+ {-# INLINE parseEDNv #-}++instance ToEDN a => ToEDN (V.Vector a) where+ toEDNv = E.Vec . V.map toEDN+ {-# INLINE toEDNv #-}++instance FromEDN a => FromEDN (V.Vector a) where+ parseEDNv (E.Vec as) = V.mapM parseEDN as+ parseEDNv v = typeMismatch "Vec" v+ {-# INLINE parseEDNv #-}++instance (Ord a, ToEDN a) => ToEDN (S.Set a) where+ toEDNv = E.Set . S.map toEDN+ {-# INLINE toEDNv #-}++instance (Ord a, FromEDN a) => FromEDN (S.Set a) where+ parseEDNv (E.Set s) = mapMset parseEDN s+ parseEDNv v = typeMismatch "Set" v+ {-# INLINE parseEDNv #-}++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]+ {-# INLINE toEDNv #-}++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+ {-# INLINE parseEDNv #-}++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++-- | Convert a value from 'E.TaggedValue', failing if the types do not match.+fromEDN :: FromEDN a => E.TaggedValue -> P.Result a+fromEDN = P.parse parseEDN+{-# INLINE fromEDN #-}++-- | Convert a value from 'E.Value', failing if the types do not match.+fromEDNv :: FromEDN a => E.Value -> P.Result a+fromEDNv = P.parse parseEDNv+{-# INLINE fromEDNv #-}++-- | Fail parsing due to a type mismatch, with a descriptive message.+typeMismatch :: String -- ^ The name of the type you are trying to parse.+ -> E.Value -- ^ The actual value encountered.+ -> 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+{-# INLINE mapMset #-}++mapMmap :: (Ord a2, Monad m) => (a1 -> m a2) -> (b1 -> m b2) -> M.Map a1 b1 -> m (M.Map a2 b2)+mapMmap kf vf m = do+ let pairsIn = M.assocs m+ pairsOut <- mapM fs pairsIn+ return $! M.fromList pairsOut+ where+ fs (k, v) = do+ newK <- kf k+ newV <- vf v+ return (newK, newV)+{-# INLINE mapMmap #-}
+ src/Data/Parser.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}++-- | Generic continuation-based parser type.++module Data.Parser (+ Parser, Result(..),+ parse, parseMaybe, parseEither+) where++import Control.Applicative+import Control.DeepSeq (NFData(..))+import Control.Monad.State.Strict+import Data.Monoid (Monoid(..))+import Data.Typeable (Typeable)++-- | The result of running a 'Parser'.+data Result a = Error String+ | Success a+ deriving (Eq, Show, Typeable)++instance (NFData a) => NFData (Result a) where+ rnf (Success a) = rnf a+ rnf (Error err) = rnf err++instance Functor Result where+ fmap f (Success a) = Success (f a)+ fmap _ (Error err) = Error err+ {-# INLINE fmap #-}++instance Monad Result where+ return = Success+ {-# INLINE return #-}+ Success a >>= k = k a+ Error err >>= _ = Error err+ {-# INLINE (>>=) #-}++instance Applicative Result where+ pure = return+ {-# INLINE pure #-}+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance MonadPlus Result where+ mzero = fail "mzero"+ {-# INLINE mzero #-}+ mplus a@(Success _) _ = a+ mplus _ b = b+ {-# INLINE mplus #-}++instance Alternative Result where+ empty = mzero+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++instance Monoid (Result a) where+ mempty = fail "mempty"+ {-# INLINE mempty #-}+ mappend = mplus+ {-# INLINE mappend #-}++-- | Failure continuation.+type Failure f r = String -> f r+-- | Success continuation.+type Success a f r = a -> f r++-- | A continuation-based parser type.+newtype Parser a = Parser {+ runParser :: forall f r.+ Failure f r+ -> Success a f r+ -> f r+ }++instance Monad Parser where+ m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks+ in runParser m kf ks'+ {-# INLINE (>>=) #-}+ return a = Parser $ \_kf ks -> ks a+ {-# INLINE return #-}+ fail msg = Parser $ \kf _ks -> kf msg+ {-# INLINE fail #-}++instance Functor Parser where+ fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)+ in runParser m kf ks'+ {-# INLINE fmap #-}++instance Applicative Parser where+ pure = return+ {-# INLINE pure #-}+ (<*>) = apP+ {-# INLINE (<*>) #-}++instance Alternative Parser where+ empty = fail "empty"+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++instance MonadPlus Parser where+ mzero = fail "mzero"+ {-# INLINE mzero #-}+ mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks+ in runParser a kf' ks+ {-# INLINE mplus #-}++instance Monoid (Parser a) where+ mempty = fail "mempty"+ {-# INLINE mempty #-}+ mappend = mplus+ {-# INLINE mappend #-}++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+ b <- d+ a <- e+ return (b a)+{-# INLINE apP #-}++-- | Run a 'Parser'.+parse :: (a -> Parser b) -> a -> Result b+parse m v = runParser (m v) Error Success++-- | Run a 'Parser' with a 'Maybe' result type.+parseMaybe :: (a -> Parser b) -> a -> Maybe b+parseMaybe m v = runParser (m v) (const Nothing) Just++-- | Run a 'Parser' with an 'Either' result type.+parseEither :: (a -> Parser b) -> a -> Either String b+parseEither m v = runParser (m v) Left Right