{-# 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 = forall a. Arbitrary a => Gen a
arbitrary

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

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

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

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

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

instance Example Binary where
    example :: Gen Binary
example = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"an example JSON value"

instance Example UTCTime where
    example :: Gen UTCTime
example = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HasCallStack => 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 = forall a. (a -> Q [Dec]) -> Tool a
simpleTool forall a b. (a -> b) -> a -> b
$ \ API
api ->
                     Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Gen Value)] |]
                                (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ APINode -> ExpQ
gen_sample APINode
nd | ThNode APINode
nd <- API
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 = forall (m :: * -> *). Quote m => String -> m Exp
stringE forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TypeName -> Text
_TypeName 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 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 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool forall a b. (a -> b) -> a -> b
$ \ ToolSettings
ts (APINode
an, SpecNewtype
sn) -> case SpecNewtype -> Maybe Filter
snFilter SpecNewtype
sn of
                               Just (FtrStrg RegEx
_) -> 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                   forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'QC.sized) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] forall a b. (a -> b) -> a -> b
$
                       ExpQ -> [ExpQ] -> ExpQ
applicativeE (APINode -> ExpQ
nodeConE APINode
an) forall a b. (a -> b) -> a -> b
$
                       forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ SpecRecord -> [(FieldName, FieldType)]
srFields SpecRecord
sr) 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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 | 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 = forall a. (ToolSettings -> a -> Q [Dec]) -> Tool a
mkTool 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] []