Got schema for sum types working

Author: Antonio Alonso Dominguez

src/Data/Schema.hs

@@ -3,5 +3,5 @@ module Data.Schema
      , module Data.Schema.Types
      ) where
 
-import Data.Schema.JSON
-import Data.Schema.Types
+import           Data.Schema.JSON
+import           Data.Schema.Types

src/Data/Schema/JSON.hs

@@ -1,25 +1,26 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE OverloadedStrings         #-}
 
 module Data.Schema.JSON
      ( serializer
      , deserializer
      ) where
 
-import Data.Aeson (parseJSON)
-import qualified Data.Aeson as Json
-import qualified Data.Aeson.Types as Json
-import Data.Schema.Types
-import Control.Applicative.Free
-import Control.Lens
-import Control.Monad.State (State)
-import qualified Control.Monad.State as ST
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as Map
-import Data.Text (Text)
+import           Control.Applicative.Free
+import           Control.Lens
+import           Control.Monad.State      (State)
+import qualified Control.Monad.State      as ST
+import           Data.Aeson               (parseJSON)
+import qualified Data.Aeson               as Json
+import qualified Data.Aeson.Types         as Json
+import           Data.HashMap.Strict      (HashMap)
+import qualified Data.HashMap.Strict      as Map
+import           Data.Maybe
+import           Data.Schema.Types
+import           Data.Text                (Text)
 
-serializer :: Serializer a Json.Value
+serializer :: Schema a -> (a -> Json.Value)
 serializer IntSchema = Json.Number . fromIntegral
 serializer BoolSchema = Json.Bool
 serializer StringSchema = Json.String
@@ -30,7 +31,12 @@ serializer (RecordSchema ps) = \value -> Json.Object $ ST.execState (runAp (step
             let el = view getter obj
             ST.modify $ Map.insert name (serializer schema $ el)
             return el
-serializer (UnionSchema alts) = undefined
+serializer (UnionSchema alts) = \value -> head . catMaybes $ fmap (decodeAlt value) alts
+  where objSingleAttr :: Text -> Json.Value -> Json.Value
+        objSingleAttr n v = Json.Object $ Map.insert n v Map.empty
+
+        decodeAlt :: o -> AltDef o -> Maybe Json.Value
+        decodeAlt obj (AltDef i schema pr) = (objSingleAttr i) <$> (serializer schema) <$> (obj ^? pr)
 
 deserializer :: Schema a -> (Json.Value -> Json.Parser a)
 deserializer IntSchema = parseJSON
@@ -45,4 +51,10 @@ deserializer (RecordSchema ps) = \json -> case json of
           step jsonObj (PropDef name schema _) =
             Json.explicitParseField (\v -> deserializer schema $ v) jsonObj name
   other -> fail $ "Expected JSON Object but got: " ++ (show other)
-deserializer (UnionSchema alts) = undefined
+deserializer (UnionSchema alts) = \json -> case json of
+  Json.Object obj -> head . catMaybes $ fmap lookupParser alts
+    where lookupParser :: AltDef a -> Maybe (Json.Parser a)
+          lookupParser (AltDef i schema pr) = do
+            altParser <- (deserializer schema) <$> Map.lookup i obj
+            return $ (view $ re pr) <$> altParser
+  other ->  fail $ "Expected JSON Object but got: " ++ (show other)

src/Data/Schema/Types.hs

@@ -1,17 +1,18 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs                     #-}
+{-# LANGUAGE RankNTypes                #-}
 
 module Data.Schema.Types where
 
-import Control.Applicative.Free
-import Control.Lens
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Vector (Vector)
+import           Control.Applicative.Free
+import           Control.Lens
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Vector              (Vector)
 
 data PropDef o a = PropDef
-  { propName :: Text
-  , propSchema :: Schema a
+  { propName     :: Text
+  , propSchema   :: Schema a
   , propAccessor :: Getter o a
   }
 
@@ -28,10 +29,10 @@ type Props o = Ap (PropDef o) o
 -- emptyProps :: forall a. Props' a ()
 -- emptyProps = Pure ()
 
-data Alt a = forall b. Alt
-  { altId :: Text
+data AltDef a = forall b. AltDef
+  { altId     :: Text
   , altSchema :: Schema b
-  , altPrism :: Prism' a b
+  , altPrism  :: Prism' a b
   }
 
 data Schema a where
@@ -41,7 +42,7 @@ data Schema a where
   NoSchema :: Schema ()
   ListSchema :: Schema a -> Schema (Vector a)
   RecordSchema :: Props o -> Schema o
-  UnionSchema :: [Alt a] -> Schema a
+  UnionSchema :: [AltDef a] -> Schema a
 
 -- voidGetter :: forall a. Getter a ()
 -- voidGetter = to (const ())
@@ -56,4 +57,4 @@ data Schema a where
 --   in RecordSchema lifted
 
 type Serializer a b   = Schema a -> (a -> b)
-type Deserializer a b = Schema b -> (a -> Either String b)
+type Deserializer a b = Schema b -> (a -> Either String b)

src/Lib.hs

@@ -1,21 +1,21 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module Lib
     ( someFunc
     ) where
 
-import Control.Applicative.Free
-import Control.Lens
-import Data.Schema
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock
+import           Control.Applicative.Free
+import           Control.Lens
+import           Data.Schema
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time.Clock
 
 stringIso :: Iso' String Text
 stringIso = iso T.pack T.unpack
@@ -48,18 +48,16 @@ subordinateCountGetter :: Getter AdminRole Int
 subordinateCountGetter = to subordinateCount
 
 userNameProp = liftAp $ PropDef "name" StringSchema (to userName)
-userRoleAlt = Alt "user" (RecordSchema (UserRole' <$> userNameProp)) _UserRole
+userRoleAlt = AltDef "user" (RecordSchema (UserRole' <$> userNameProp)) _UserRole
 
 departmentProp = liftAp $ PropDef "department" StringSchema adminDept
 subordinateCountProp = liftAp $ PropDef "subordinateCount" IntSchema subordinateCountGetter
-adminRoleAlt = Alt "admin" (RecordSchema (AdminRole' <$> departmentProp <*> subordinateCountProp)) _AdminRole
+adminRoleAlt = AltDef "admin" (RecordSchema (AdminRole' <$> departmentProp <*> subordinateCountProp)) _AdminRole
 
-userSchema :: Schema Role
-userSchema = UnionSchema [userRoleAlt, adminRoleAlt]
+roleSchema :: Schema Role
+roleSchema = UnionSchema [userRoleAlt, adminRoleAlt]
 
-data Person1 = Person1 { aName :: String, aAge :: Int }
-
-data Person = Person { name :: String, birthDate :: UTCTime, roles :: [Role] }
+data Person = Person { name :: Text, birthDate :: UTCTime, roles :: [Role] }
 
 someFunc :: IO ()
 someFunc = putStrLn "someFunc"

stylize.sh

@@ -0,0 +1,29 @@
+#!/usr/bin/env bash
+
+command -v stylish-haskell >/dev/null 2>&1 || { echo "Could not find stylish-haskell. Aborting." >&2; exit 1; }
+
+find . -name \*.hs -and \( -not \( -name Setup.hs -or -path ./.stack-work/\* -or -path ./dist/\* \) \) | xargs stylish-haskell -i > stylish-out 2>&1
+
+# It doesn't do exit codes properly, so we just check if it outputted anything.
+if [ -s stylish-out ];
+then
+    echo "Stylish-haskell reported an error :("
+    cat stylish-out
+    exit 1
+fi
+
+rm stylish-out
+
+if git status --porcelain|grep .; # true if there was any output
+then
+    echo "Git tree is dirty after stylizing.";
+    if [ -n "$TRAVIS" ];
+    then
+        echo "Since we're on Travis, this is a build failure."
+        echo "Run ./stylize.sh to stylize your tree and push the changes."
+        exit 1
+    fi
+else
+    echo "Stylish didn't change anything :)"
+    exit 0;
+fi