{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Saison.Decoding.Class where import Data.Aeson (Value) import Data.Text (Text) import Data.Void (Void) import qualified Data.Text as T import Saison.Decoding.Result import Saison.Decoding.Tokens import Saison.Decoding.Value ------------------------------------------------------------------------------- -- Class ------------------------------------------------------------------------------- class FromTokens a where fromTokens :: Tokens k String -> Result String k a fromTokensList :: Tokens k String -> Result String k [a] fromTokensList (TkArrayOpen toks0) = Result $ \g f -> goA id toks0 g f where goA :: ([a] -> [a]) -> TkArray k String -> (String -> r) -> ([a] -> k -> r) -> r goA !acc (TkItem toks) g f = unResult (fromTokens toks) g $ \x toks' -> goA (acc . (x :)) toks' g f goA !acc (TkArrayEnd k) _ f = f (acc []) k goA _ (TkArrayErr e) g _ = g e fromTokensList (TkErr err) = failResult err fromTokensList _ = failResult "Expecting array, got ???" ------------------------------------------------------------------------------- -- Combinators ------------------------------------------------------------------------------- withText :: String -> (Text -> k -> Result String k a) -> Tokens k String -> Result String k a withText _ f (TkText t k) = f t k withText name _ _ = Result $ \e _ -> e $ "Expecting textual " ++ name ++ ", got ???" ------------------------------------------------------------------------------- -- base ------------------------------------------------------------------------------- instance FromTokens Char where fromTokens = withText "Char" $ \t k -> if T.length t == 1 then pureResult (T.head t) k else failResult "Expecting single-character string" fromTokensList = withText "String" $ \t -> pureResult (T.unpack t) instance FromTokens a => FromTokens [a] where fromTokens = fromTokensList ------------------------------------------------------------------------------- -- aeson ------------------------------------------------------------------------------- instance FromTokens Value where fromTokens = toResultValue ------------------------------------------------------------------------------- -- containers ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- nats ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- semigroups ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- scientific ------------------------------------------------------------------------------- -- TODO --------------------------------------------------------------------------------- -- text ------------------------------------------------------------------------------- instance FromTokens Text where fromTokens = withText "Text" pureResult ------------------------------------------------------------------------------- -- these ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- uuid-types ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- vector ------------------------------------------------------------------------------- -- TODO ------------------------------------------------------------------------------- -- void ------------------------------------------------------------------------------- instance FromTokens Void where fromTokens _ = failResult "Void cannot be constructed"