123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420 |
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE OverloadedLists #-}
- {-# LANGUAGE TypeSynonymInstances #-}
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE FlexibleContexts #-}
- {-# LANGUAGE TypeOperators #-}
- {-# 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.Adnot.Parse
- 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
- import qualified Data.Map.Lazy as ML
- import qualified Data.Map.Strict as MS
- import qualified Data.Sequence as Seq
- import qualified Data.Text as T
- import qualified Data.Text.Lazy as TL
- import qualified Data.Vector as V
- import GHC.Generics
- import GHC.TypeLits (KnownSymbol)
- encode :: ToAdnot a => a -> BSL.ByteString
- encode = encodeValue . toAdnot
- class GenToAdnot f where
- genToAdnot :: f p -> Value
- instance (GenToAdnot l, GenToAdnot r) => GenToAdnot (l :+: r) where
- genToAdnot (L1 x) = genToAdnot x
- genToAdnot (R1 y) = genToAdnot y
- instance ToAdnot x => GenToAdnot (K1 i x) where
- genToAdnot (K1 x) = toAdnot x
- instance (GatherSequence f, Constructor name) => GenToAdnot (C1 name f) where
- genToAdnot (M1 x) = Sum (T.pack (conName c)) (V.fromList (gatherSequence x))
- where c :: M1 c name f ()
- c = undefined
- instance (GenToAdnot f) => GenToAdnot (S1 name f) where
- genToAdnot (M1 x) = genToAdnot x
- instance (GenToAdnot f) => GenToAdnot (D1 name f) where
- genToAdnot (M1 x) = genToAdnot x
- instance (GatherSequence l, GatherSequence r) => GenToAdnot (l :*: r) where
- genToAdnot x = List (V.fromList (gatherSequence x))
- class GatherRecord f where
- gatherRecord :: f p -> [(T.Text, Value)]
- instance (GatherRecord l, GatherRecord r) => GatherRecord (l :*: r) where
- gatherRecord (x :*: y) = gatherRecord x ++ gatherRecord y
- instance (GenToAdnot f, Selector name) => GatherRecord (S1 name f) where
- gatherRecord (M1 x) = [(T.pack (selName s), genToAdnot x)]
- where s :: S1 name f ()
- s = undefined
- instance GatherRecord U1 where
- gatherRecord U1 = []
- class GatherSequence f where
- gatherSequence :: f p -> [Value]
- instance GatherSequence U1 where
- gatherSequence U1 = []
- instance (GatherSequence l, GatherSequence r) => GatherSequence (l :*: r) where
- gatherSequence (x :*: y) = gatherSequence x ++ gatherSequence y
- instance ToAdnot x => GatherSequence (K1 i x) where
- gatherSequence (K1 x) = [toAdnot x]
- instance GenToAdnot f => GatherSequence (S1 name f) where
- gatherSequence (M1 x) = [genToAdnot x]
- instance GenToAdnot f => GatherSequence (D1 name f) where
- gatherSequence (M1 x) = [genToAdnot x]
- instance GenToAdnot U1 where
- genToAdnot U1 = List []
- genericToAdnot :: (GenToAdnot (Rep t), Generic t) => t -> Value
- genericToAdnot x = genToAdnot (from x)
- class ToAdnot a where
- toAdnot :: a -> Value
- default toAdnot :: (Generic a, GenToAdnot (Rep a)) => a -> Value
- toAdnot = genericToAdnot
- -- Integral types
- instance ToAdnot Int where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Integer where
- toAdnot n = Integer n
- instance ToAdnot Int8 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Int16 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Int32 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Int64 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Word where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Word8 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Word16 where
- toAdnot n = Integer (fromIntegral n)
- instance ToAdnot Word32 where
- toAdnot n = Integer (fromIntegral n)
- 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)
- instance ToAdnot T.Text where
- toAdnot s = String s
- instance ToAdnot TL.Text where
- toAdnot s = String (TL.toStrict s)
- 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))
- instance ToAdnot a => ToAdnot (V.Vector a) where
- toAdnot ls = List (fmap toAdnot ls)
- instance ToAdnot a => ToAdnot (Seq.Seq a) where
- toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
- 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)
- product :: [(T.Text, Value)] -> Value
- product = Product . MS.fromList
- (.=) :: ToAdnot t => T.Text -> t -> (T.Text, Value)
- key .= val = (key, toAdnot val)
- -- * Tuples
- instance ToAdnot () where
- toAdnot () = List []
- instance (ToAdnot a, ToAdnot b) => ToAdnot (a, b) where
- toAdnot (a, b) = List [toAdnot a, toAdnot b]
- instance (ToAdnot a, ToAdnot b, ToAdnot c) => ToAdnot (a, b, c) where
- toAdnot (a, b, c) = List [toAdnot a, toAdnot b, toAdnot c]
- 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]
- instance (ToAdnot a, ToAdnot b) => ToAdnot (Either a b) where
- toAdnot (Left x) = Sum "Left" [toAdnot x]
- toAdnot (Right y) = Sum "Right" [toAdnot y]
- instance ToAdnot Bool where
- toAdnot True = String "True"
- toAdnot False = String "False"
- -- Parsing
- decode :: FromAdnot a => BS.ByteString -> Either String a
- decode = decodeValue >=> parseAdnot
- type ParseError = String
- type Parser a = Either ParseError a
- niceType :: Value -> String
- niceType Sum {} = "sum"
- niceType Product {} = "product"
- niceType List {} = "list"
- niceType Integer {} = "integer"
- niceType Double {} = "double"
- niceType String {} = "string"
- withSum :: String -> (T.Text -> Array -> Parser a) -> Value -> Parser a
- withSum n k val = case val of
- Sum t as -> k t as
- _ -> Left ("Expected sum in " ++ n)
- withSumNamed :: String -> T.Text -> (Array -> Parser a) -> Value -> Parser a
- withSumNamed n tag k val = case val of
- Sum t as
- | tag == t -> k as
- | otherwise -> Left $ unwords
- [ "Expected tag", T.unpack tag, "in", n, "but found", T.unpack t ]
- _ -> 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
- Integer i -> k (fromIntegral i)
- _ -> 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)
- (.:) :: FromAdnot a => Product -> T.Text -> Parser a
- map .: key = case MS.lookup key map of
- Just x -> parseAdnot x
- Nothing -> Left ("Missing key " ++ show key)
- (.:?) :: FromAdnot a => Product -> T.Text -> Parser (Maybe a)
- map .:? key = case MS.lookup key map of
- Just x -> Just <$> parseAdnot x
- Nothing -> return Nothing
- (.!=) :: Parser (Maybe a) -> a -> Parser a
- c .!= r = fmap (maybe r id) c
- 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"
|