{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}

-- | Tool for generating documentation-friendly examples
module Data.API.Tools.Example
    ( Example(..)
    , exampleTool
    , samplesTool
    ) where

import           Data.API.TH
import           Data.API.Time
import           Data.API.Tools.Combinators
import           Data.API.Tools.Datatypes
import           Data.API.Types

import           Control.Applicative
import           Data.Aeson
import qualified Data.ByteString.Char8          as B
import           Data.Monoid
import           Data.Time
import           Language.Haskell.TH
import           Test.QuickCheck                as QC
import qualified Data.Text                      as T
import           Prelude


-- | The Example class is used to generate a documentation-friendly
-- example for each type in the model

class Example a where
    -- | Generator for example values; defaults to 'arbitrary' if not
    -- specified
    example :: Gen a
    default example :: Arbitrary a => Gen a
    example = Gen a
forall a. Arbitrary a => Gen a
arbitrary

instance Example a => Example (Maybe a) where
    example :: Gen (Maybe a)
example = [Gen (Maybe a)] -> Gen (Maybe a)
forall a. [Gen a] -> Gen a
oneof [Maybe a -> Gen (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Example a => Gen a
example]

instance Example a => Example [a] where
    example :: Gen [a]
example = Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
listOf Gen a
forall a. Example a => Gen a
example

instance Example Int where
    example :: Gen Int
example = Gen Int
forall a. (Bounded a, Integral a) => Gen a
arbitrarySizedBoundedIntegral Gen Int -> (Int -> Bool) -> Gen Int
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)

instance Example Bool where
    example :: Gen Bool
example = (Bool, Bool) -> Gen Bool
forall a. Random a => (a, a) -> Gen a
choose (Bool
False, Bool
True)

instance Example T.Text where
    example :: Gen Text
example = Text -> Gen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Mary had a little lamb"

instance Example Binary where
    example :: Gen Binary
example = Binary -> Gen Binary
forall (m :: * -> *) a. Monad m => a -> m a
return (Binary -> Gen Binary) -> Binary -> Gen Binary
forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary (ByteString -> Binary) -> ByteString -> Binary
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
"lots of 1s and 0s"

instance Example Value where
    example :: Gen Value
example = Value -> Gen Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"an example JSON value"

instance Example UTCTime where
    example :: Gen UTCTime
example = UTCTime -> Gen UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Gen UTCTime) -> UTCTime -> Gen UTCTime
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> UTCTime
Text -> UTCTime
unsafeParseUTC Text
"2013-06-09T15:52:30Z"


-- | Generate a list of (type name, sample generator) pairs
-- corresponding to each type in the API, with samples encoded as
-- JSON.  This depends on the 'Example' instances generated by
-- 'exampleTool'.  It generates something like this:
--
-- > samples :: [(String, Gen Value)]
-- > samples = [("Foo", fmap toJSON (example :: Gen Foo)), ... ]

samplesTool :: Name -> APITool
samplesTool :: Name -> APITool
samplesTool Name
nm = ([Thing] -> Q [Dec]) -> APITool
forall a. (a -> Q [Dec]) -> Tool a
simpleTool (([Thing] -> Q [Dec]) -> APITool)
-> ([Thing] -> Q [Dec]) -> APITool
forall a b. (a -> b) -> a -> b
$ \ [Thing]
api ->
                     Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Gen Value)] |]
                                ([ExpQ] -> ExpQ
listE [ APINode -> ExpQ
gen_sample APINode
nd | ThNode APINode
nd <- [Thing]
api ])
  where
    gen_sample :: APINode -> ExpQ
    gen_sample :: APINode -> ExpQ
gen_sample APINode
an = [e| ($str, fmap toJSON (example :: Gen $(nodeT an))) |]
      where
        str :: ExpQ
str = String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TypeName -> Text
_TypeName (TypeName -> Text) -> TypeName -> Text
forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an


-- | Tool to generate 'Example' instances for types generated by
-- 'datatypesTool'.  This depends on 'quickCheckTool'.
exampleTool :: APITool
exampleTool :: APITool
exampleTool = Tool APINode -> APITool
apiNodeTool (Tool APINode -> APITool) -> Tool APINode -> APITool
forall a b. (a -> b) -> a -> b
$ Tool (APINode, SpecNewtype)
-> Tool (APINode, SpecRecord)
-> Tool (APINode, SpecUnion)
-> Tool (APINode, SpecEnum)
-> Tool (APINode, APIType)
-> Tool APINode
apiSpecTool Tool (APINode, SpecNewtype)
gen_sn_ex Tool (APINode, SpecRecord)
gen_sr_ex Tool (APINode, SpecUnion)
gen_su_ex Tool (APINode, SpecEnum)
gen_se_ex Tool (APINode, APIType)
forall a. Monoid a => a
mempty


-- | Generate an 'Example' instance for a newtype.  If there is no
-- filter, call 'example' on the underlying type; otherwise, use
-- 'arbitrary'.  Like 'Arbitrary', if a regular expression filter is
-- applied the instance must be defined manually.
gen_sn_ex :: Tool (APINode, SpecNewtype)
gen_sn_ex :: Tool (APINode, SpecNewtype)
gen_sn_ex = (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
 -> Tool (APINode, SpecNewtype))
-> (ToolSettings -> (APINode, SpecNewtype) -> Q [Dec])
-> Tool (APINode, SpecNewtype)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
sn) -> case SpecNewtype -> Maybe Filter
snFilter SpecNewtype
sn of
                               Just (FtrStrg RegEx
_) -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                               Just Filter
_           -> ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an [e| QC.arbitrary |]
                               Maybe Filter
Nothing          -> ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an [e| fmap $(nodeNewtypeConE ts an sn) example |]
  where
    inst :: ToolSettings -> APINode -> ExpQ -> Q [Dec]
inst ToolSettings
ts APINode
an ExpQ
e = ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example ExpQ
e]


-- | Generate an 'Example' instance for a record:
--
-- > instance Example Foo where
-- >     example = sized $ \ x -> Foo <$> resize (x `div` 2) example <*> ... <*> resize (x `div` 2) example

gen_sr_ex :: Tool (APINode, SpecRecord)
gen_sr_ex :: Tool (APINode, SpecRecord)
gen_sr_ex = (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
 -> Tool (APINode, SpecRecord))
-> (ToolSettings -> (APINode, SpecRecord) -> Q [Dec])
-> Tool (APINode, SpecRecord)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecRecord
sr) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example (APINode -> SpecRecord -> ExpQ
bdy APINode
an SpecRecord
sr)]
  where
    bdy :: APINode -> SpecRecord -> ExpQ
bdy APINode
an SpecRecord
sr = do Name
x <- String -> Q Name
newName String
"x"
                   ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'QC.sized) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
x] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
                       ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
                       Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate ([(FieldName, FieldType)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(FieldName, FieldType)] -> Int)
-> [(FieldName, FieldType)] -> Int
forall a b. (a -> b) -> a -> b
$ SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr) (ExpQ -> [ExpQ]) -> ExpQ -> [ExpQ]
forall a b. (a -> b) -> a -> b
$
                       [e| QC.resize ($(varE x) `div` 2) example |]


-- | Generate an 'Example' instance for a union:
--
-- > instance Example Foo where
-- >     example = oneOf [ fmap Bar example, fmap Baz example ]

gen_su_ex :: Tool (APINode, SpecUnion)
gen_su_ex :: Tool (APINode, SpecUnion)
gen_su_ex = (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
 -> Tool (APINode, SpecUnion))
-> (ToolSettings -> (APINode, SpecUnion) -> Q [Dec])
-> Tool (APINode, SpecUnion)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecUnion
su) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] [Name -> ExpQ -> DecQ
simpleD 'example (APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su)]
  where
    bdy :: APINode -> SpecUnion -> ExpQ
bdy APINode
an SpecUnion
su | [(FieldName, (APIType, String))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su) = APINode -> ExpQ
nodeConE APINode
an
              | Bool
otherwise          = [e| oneof $(listE (alts an su)) |]

    alts :: APINode -> SpecUnion -> [ExpQ]
alts APINode
an SpecUnion
su = [ [e| fmap $(nodeAltConE an k) example |]
                 | (FieldName
k,(APIType, String)
_) <- SpecUnion -> [(FieldName, (APIType, String))]
suFields SpecUnion
su ]


-- | Generate an 'Example' instance for an enumeration, with no
-- definition for the 'example' method, because we can inherit the
-- behaviour of 'Arbitrary':
--
-- > instance Example Foo

gen_se_ex :: Tool (APINode, SpecEnum)
gen_se_ex :: Tool (APINode, SpecEnum)
gen_se_ex = (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool ((ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
 -> Tool (APINode, SpecEnum))
-> (ToolSettings -> (APINode, SpecEnum) -> Q [Dec])
-> Tool (APINode, SpecEnum)
forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecEnum
_) -> ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]
optionalInstanceD ToolSettings
ts ''Example [APINode -> TypeQ
nodeRepT APINode
an] []