Added basic FromAdnot class as well

Data/Adnot.hs

@@ -3,8 +3,10 @@ module Data.Adnot ( Value(..)
                   , Product
                   , decodeValue
                   , encodeValue
+                  , module Data.Adnot.Class
                   ) where
 
 import Data.Adnot.Emit
 import Data.Adnot.Parse
 import Data.Adnot.Type
+import Data.Adnot.Class

Data/Adnot/Class.hs

@@ -7,13 +7,17 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 
 module Data.Adnot.Class where
 
+import           Control.Monad ((>=>))
+import           Data.Adnot.Parse
 import           Data.Adnot.Type
 import           Data.Adnot.Emit
 import           Data.Int
 import           Data.Word
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Foldable as F
 import qualified Data.List.NonEmpty as NE
@@ -97,7 +101,7 @@ class ToAdnot a where
   default toAdnot :: (Generic a, GenToAdnot (Rep a)) => a -> Value
   toAdnot = genericToAdnot
 
+-- Integral types
 instance ToAdnot Int where
   toAdnot n = Integer (fromIntegral n)
 
@@ -131,14 +135,14 @@ instance ToAdnot Word32 where
 instance ToAdnot Word64 where
   toAdnot n = Integer (fromIntegral n)
 
+-- Rational/Floating types
 instance ToAdnot Double where
   toAdnot d = Double d
 
 instance ToAdnot Float where
   toAdnot d = Double (fromRational (toRational d))
 
+-- String types
 instance {-# INCOHERENT #-} ToAdnot String where
   toAdnot s = String (T.pack s)
 
@@ -151,7 +155,7 @@ instance ToAdnot TL.Text where
 instance ToAdnot Char where
   toAdnot c = String (T.singleton c)
 
+-- List types
 instance ToAdnot a => ToAdnot [a] where
   toAdnot ls = List (fmap toAdnot (V.fromList ls))
 
@@ -164,11 +168,11 @@ instance ToAdnot a => ToAdnot (Seq.Seq a) where
 instance ToAdnot a => ToAdnot (NE.NonEmpty a) where
   toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
 
+-- Mapping types
 instance ToAdnot a => ToAdnot (MS.Map T.Text a) where
   toAdnot ls = Product (fmap toAdnot ls)
 
+-- Tuples
 instance ToAdnot () where
   toAdnot () = List []
 
@@ -182,7 +186,7 @@ instance (ToAdnot a, ToAdnot b, ToAdnot c, ToAdnot d)
          => ToAdnot (a, b, c, d) where
   toAdnot (a, b, c, d) = List [toAdnot a, toAdnot b, toAdnot c, toAdnot d]
 
+-- Common Haskell algebraic data types
 instance ToAdnot a => ToAdnot (Maybe a) where
   toAdnot Nothing = Sum "Nothing" []
   toAdnot (Just x) = Sum "Just" [toAdnot x]
@@ -195,7 +199,10 @@ instance ToAdnot Bool where
   toAdnot True  = Symbol "True"
   toAdnot False = Symbol "False"
 
+-- Parsing
+
+decode :: FromAdnot a => BS.ByteString -> Either String a
+decode = decodeValue >=> parseAdnot
 
 type ParseError = String
 type Parser a = Either ParseError a
@@ -205,5 +212,172 @@ withSum n k val = case val of
   Sum t as -> k t as
   _        -> Left ("Expected sum in " ++ n)
 
+withProduct :: String -> (Product -> Parser a) -> Value -> Parser a
+withProduct n k val = case val of
+  Product ps -> k ps
+  _          -> Left ("Expected product in " ++ n)
+
+withList :: String -> (Array -> Parser a) -> Value -> Parser a
+withList n k val = case val of
+  List ls -> k ls
+  _       -> Left ("Expected list in " ++ n)
+
+withInteger :: String -> (Integer -> Parser a) -> Value -> Parser a
+withInteger n k val = case val of
+  Integer i -> k i
+  _         -> Left ("Expected integer in " ++ n)
+
+withDouble :: String -> (Double -> Parser a) -> Value -> Parser a
+withDouble n k val = case val of
+  Double d -> k d
+  _        -> Left ("Expected double in " ++ n)
+
+withSymbol :: String -> (T.Text -> Parser a) -> Value -> Parser a
+withSymbol n k val = case val of
+  Symbol s -> k s
+  _        -> Left ("Expected symbol in " ++ n)
+
+withString :: String -> (T.Text -> Parser a) -> Value -> Parser a
+withString n k val = case val of
+  String s -> k s
+  _        -> Left ("Expected string in " ++ n)
+
 class FromAdnot a where
   parseAdnot :: Value -> Parser a
+
+instance FromAdnot Value where
+  parseAdnot = return
+
+-- Integer Types
+instance FromAdnot Int where
+  parseAdnot = withInteger "Int" (return . fromIntegral)
+
+instance FromAdnot Integer where
+  parseAdnot = withInteger "Int" return
+
+instance FromAdnot Int8 where
+  parseAdnot = withInteger "Int8" (return . fromIntegral)
+
+instance FromAdnot Int16 where
+  parseAdnot = withInteger "Int16" (return . fromIntegral)
+
+instance FromAdnot Int32 where
+  parseAdnot = withInteger "Int32" (return . fromIntegral)
+
+instance FromAdnot Int64 where
+  parseAdnot = withInteger "Int64" (return . fromIntegral)
+
+instance FromAdnot Word where
+  parseAdnot = withInteger "Word" (return . fromIntegral)
+
+instance FromAdnot Word8 where
+  parseAdnot = withInteger "Word8" (return . fromIntegral)
+
+instance FromAdnot Word16 where
+  parseAdnot = withInteger "Word16" (return . fromIntegral)
+
+instance FromAdnot Word32 where
+  parseAdnot = withInteger "Word32" (return . fromIntegral)
+
+instance FromAdnot Word64 where
+  parseAdnot = withInteger "Word64" (return . fromIntegral)
+
+-- Rational/Floating types
+
+instance FromAdnot Double where
+  parseAdnot = withDouble "Double" return
+
+instance FromAdnot Float where
+  parseAdnot =
+    withDouble "Float" (return . fromRational . toRational)
+
+-- String types
+
+instance {-# INCOHERENT #-} FromAdnot String where
+  parseAdnot = withString "String" (return . T.unpack)
+
+instance FromAdnot T.Text where
+  parseAdnot = withString "Text" return
+
+instance FromAdnot TL.Text where
+  parseAdnot = withString "Text"  (return . TL.fromStrict)
+
+instance FromAdnot Char where
+  parseAdnot = withString "Char" $ \s -> case T.uncons s of
+    Just (c, "") -> return c
+    _            -> Left "Expected a single-element string"
+
+
+-- List types
+instance FromAdnot a => FromAdnot [a] where
+  parseAdnot = withList "List" $ \ls ->
+    F.toList <$> mapM parseAdnot ls
+
+instance FromAdnot a => FromAdnot (V.Vector a) where
+  parseAdnot = withList "Vector" $ \ls ->
+    mapM parseAdnot ls
+
+instance FromAdnot a => FromAdnot (Seq.Seq a) where
+  parseAdnot = withList "Seq" $ \ls ->
+    Seq.fromList . F.toList <$> mapM parseAdnot ls
+
+instance FromAdnot a => FromAdnot (NE.NonEmpty a) where
+  parseAdnot = withList "NonEmpty" $ \ls -> do
+    lst <- mapM parseAdnot ls
+    case F.toList lst of
+      [] -> Left "Expected non-empty sequence"
+      (x:xs) -> Right (x NE.:| xs)
+
+-- Mapping types
+instance FromAdnot a => FromAdnot (MS.Map T.Text a) where
+  parseAdnot = withProduct "Map" $ \ms -> do
+    lst <- mapM parseAdnot ms
+    return (MS.fromList (F.toList lst))
+
+-- Tuples
+instance FromAdnot () where
+  parseAdnot = withList "()" $ \ls ->
+    case ls of
+      [] -> return ()
+      _  -> Left "Expected empty list"
+
+instance (FromAdnot a, FromAdnot b) => FromAdnot (a, b) where
+  parseAdnot = withList "(a, b)" $ \ls ->
+    case ls of
+      [a, b] -> (,) <$> parseAdnot a <*> parseAdnot b
+      _      -> Left "Expected two-element list"
+
+
+instance (FromAdnot a, FromAdnot b, FromAdnot c) => FromAdnot (a, b, c) where
+  parseAdnot = withList "(a, b, c)" $ \ls ->
+    case ls of
+      [a, b, c] -> (,,) <$> parseAdnot a <*> parseAdnot b <*> parseAdnot c
+      _         -> Left "Expected three-element list"
+
+
+instance (FromAdnot a, FromAdnot b, FromAdnot c, FromAdnot d)
+         => FromAdnot (a, b, c, d) where
+  parseAdnot = withList "(a, b, c, d)" $ \ls ->
+    case ls of
+      [a, b, c, d] -> (,,,) <$> parseAdnot a <*> parseAdnot b
+                            <*> parseAdnot c <*> parseAdnot d
+      _         -> Left "Expected four-element list"
+
+-- Common Haskell algebraic data types
+instance FromAdnot a => FromAdnot (Maybe a) where
+  parseAdnot = withSum "Maybe" go
+    where go "Nothing" []  = return Nothing
+          go "Just"    [x] = Just <$> parseAdnot x
+          go _ _ = Left "Invalid Maybe"
+
+instance (FromAdnot a, FromAdnot b) => FromAdnot (Either a b) where
+  parseAdnot = withSum "Either" go
+    where go "Left"  [x] = Left <$> parseAdnot x
+          go "Right" [x] = Right <$> parseAdnot x
+          go _ _ = Left "Invalid Either"
+
+instance FromAdnot Bool where
+  parseAdnot = withSymbol "Bool" go
+    where go "True"  = return True
+          go "False" = return False
+          go _ = Left "Invalid Bool"