Eugen Wissner
09135c581a
Let's try MonadThrow/MonadCatch. It looks nice at a first glance. The monad transformer stack contains only the ReaderT, less lifts are required. Exception subtyping is easier, the user can (and should) define custom error types and throw them. And it is still possible to use pure error handling, if someone doesn't like runtime exceptions or need to run a query in a pure environment. Fixes #42.
205 lines
4.5 KiB
Haskell
205 lines
4.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Test.StarWars.Data
|
|
( Character
|
|
, StarWarsException(..)
|
|
, appearsIn
|
|
, artoo
|
|
, getDroid
|
|
, getDroid'
|
|
, getEpisode
|
|
, getFriends
|
|
, getHero
|
|
, getHuman
|
|
, id_
|
|
, homePlanet
|
|
, name_
|
|
, secretBackstory
|
|
, typeName
|
|
) where
|
|
|
|
import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
|
|
import Control.Applicative (Alternative(..), liftA2)
|
|
import Data.Maybe (catMaybes)
|
|
import Data.Text (Text)
|
|
import Data.Typeable (cast)
|
|
import Language.GraphQL.Error
|
|
import Language.GraphQL.Type
|
|
|
|
-- * Data
|
|
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
|
|
|
-- ** Characters
|
|
|
|
type ID = Text
|
|
|
|
data CharCommon = CharCommon
|
|
{ _id_ :: ID
|
|
, _name :: Text
|
|
, _friends :: [ID]
|
|
, _appearsIn :: [Int]
|
|
} deriving (Show)
|
|
|
|
|
|
data Human = Human
|
|
{ _humanChar :: CharCommon
|
|
, homePlanet :: Text
|
|
}
|
|
|
|
data Droid = Droid
|
|
{ _droidChar :: CharCommon
|
|
, primaryFunction :: Text
|
|
}
|
|
|
|
type Character = Either Droid Human
|
|
|
|
id_ :: Character -> ID
|
|
id_ (Left x) = _id_ . _droidChar $ x
|
|
id_ (Right x) = _id_ . _humanChar $ x
|
|
|
|
name_ :: Character -> Text
|
|
name_ (Left x) = _name . _droidChar $ x
|
|
name_ (Right x) = _name . _humanChar $ x
|
|
|
|
friends :: Character -> [ID]
|
|
friends (Left x) = _friends . _droidChar $ x
|
|
friends (Right x) = _friends . _humanChar $ x
|
|
|
|
appearsIn :: Character -> [Int]
|
|
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
|
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
|
|
|
data StarWarsException = SecretBackstory | InvalidArguments
|
|
|
|
instance Show StarWarsException where
|
|
show SecretBackstory = "secretBackstory is secret."
|
|
show InvalidArguments = "Invalid arguments."
|
|
|
|
instance Exception StarWarsException where
|
|
toException = toException . ResolverException
|
|
fromException e = do
|
|
ResolverException resolverException <- fromException e
|
|
cast resolverException
|
|
|
|
secretBackstory :: Resolve (Either SomeException)
|
|
secretBackstory = throwM SecretBackstory
|
|
|
|
typeName :: Character -> Text
|
|
typeName = either (const "Droid") (const "Human")
|
|
|
|
luke :: Character
|
|
luke = Right luke'
|
|
|
|
luke' :: Human
|
|
luke' = Human
|
|
{ _humanChar = CharCommon
|
|
{ _id_ = "1000"
|
|
, _name = "Luke Skywalker"
|
|
, _friends = ["1002","1003","2000","2001"]
|
|
, _appearsIn = [4,5,6]
|
|
}
|
|
, homePlanet = "Tatooine"
|
|
}
|
|
|
|
vader :: Human
|
|
vader = Human
|
|
{ _humanChar = CharCommon
|
|
{ _id_ = "1001"
|
|
, _name = "Darth Vader"
|
|
, _friends = ["1004"]
|
|
, _appearsIn = [4,5,6]
|
|
}
|
|
, homePlanet = "Tatooine"
|
|
}
|
|
|
|
han :: Human
|
|
han = Human
|
|
{ _humanChar = CharCommon
|
|
{ _id_ = "1002"
|
|
, _name = "Han Solo"
|
|
, _friends = ["1000","1003","2001" ]
|
|
, _appearsIn = [4,5,6]
|
|
}
|
|
, homePlanet = mempty
|
|
}
|
|
|
|
leia :: Human
|
|
leia = Human
|
|
{ _humanChar = CharCommon
|
|
{ _id_ = "1003"
|
|
, _name = "Leia Organa"
|
|
, _friends = ["1000","1002","2000","2001"]
|
|
, _appearsIn = [4,5,6]
|
|
}
|
|
, homePlanet = "Alderaan"
|
|
}
|
|
|
|
tarkin :: Human
|
|
tarkin = Human
|
|
{ _humanChar = CharCommon
|
|
{ _id_ = "1004"
|
|
, _name = "Wilhuff Tarkin"
|
|
, _friends = ["1001"]
|
|
, _appearsIn = [4]
|
|
}
|
|
, homePlanet = mempty
|
|
}
|
|
|
|
threepio :: Droid
|
|
threepio = Droid
|
|
{ _droidChar = CharCommon
|
|
{ _id_ = "2000"
|
|
, _name = "C-3PO"
|
|
, _friends = ["1000","1002","1003","2001" ]
|
|
, _appearsIn = [ 4, 5, 6 ]
|
|
}
|
|
, primaryFunction = "Protocol"
|
|
}
|
|
|
|
artoo :: Character
|
|
artoo = Left artoo'
|
|
|
|
artoo' :: Droid
|
|
artoo' = Droid
|
|
{ _droidChar = CharCommon
|
|
{ _id_ = "2001"
|
|
, _name = "R2-D2"
|
|
, _friends = ["1000","1002","1003"]
|
|
, _appearsIn = [4,5,6]
|
|
}
|
|
, primaryFunction = "Astrometch"
|
|
}
|
|
|
|
-- ** Helper functions
|
|
|
|
getHero :: Int -> Character
|
|
getHero 5 = luke
|
|
getHero _ = artoo
|
|
|
|
getHuman :: ID -> Maybe Character
|
|
getHuman = fmap Right . getHuman'
|
|
|
|
getHuman' :: ID -> Maybe Human
|
|
getHuman' "1000" = pure luke'
|
|
getHuman' "1001" = pure vader
|
|
getHuman' "1002" = pure han
|
|
getHuman' "1003" = pure leia
|
|
getHuman' "1004" = pure tarkin
|
|
getHuman' _ = empty
|
|
|
|
getDroid :: ID -> Maybe Character
|
|
getDroid = fmap Left . getDroid'
|
|
|
|
getDroid' :: ID -> Maybe Droid
|
|
getDroid' "2000" = pure threepio
|
|
getDroid' "2001" = pure artoo'
|
|
getDroid' _ = empty
|
|
|
|
getFriends :: Character -> [Character]
|
|
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
|
|
|
getEpisode :: Int -> Maybe Text
|
|
getEpisode 4 = pure "NEW_HOPE"
|
|
getEpisode 5 = pure "EMPIRE"
|
|
getEpisode 6 = pure "JEDI"
|
|
getEpisode _ = empty
|