-- Copyright (C) 2013, 2014, 2016  Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

{-|

Template Haskell shorthand for deriving the /many/ nullary JOSE
data constructors and associated Aeson instances.

-}

module Crypto.JOSE.TH
  (
    deriveJOSEType
  ) where

import Data.Aeson
import Data.Char
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax


capitalize :: String -> String
capitalize :: String -> String
capitalize (Char
x:String
xs) = Char -> Char
toUpper Char
xforall a. a -> [a] -> [a]
:String
xs
capitalize String
s = String
s

sanitize :: String -> String
sanitize :: String -> String
sanitize = forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char -> Bool
isAlphaNum Char
c then Char
c else Char
'_')

conize :: String -> Name
conize :: String -> Name
conize = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
capitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sanitize

guardPred :: String -> ExpQ
guardPred :: String -> ExpQ
guardPred String
s = [e| $(varE $ mkName "s") == s |]

guardExp :: String -> ExpQ
guardExp :: String -> ExpQ
guardExp String
s = [e| pure $(conE $ conize s) |]

guard :: String -> Q (Guard, Exp)
guard :: String -> Q (Guard, Exp)
guard String
s = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE (String -> ExpQ
guardPred String
s) (String -> ExpQ
guardExp String
s)

endGuardPred :: ExpQ
endGuardPred :: ExpQ
endGuardPred = [e| otherwise |]

-- | Expression for an end guard.  Arg describes type it was expecting.
--
endGuardExp :: String -> ExpQ
endGuardExp :: String -> ExpQ
endGuardExp String
s = [e| fail ("unrecognised value; expected: " ++ s) |]

-- | Build a catch-all guard that fails.  String describes what is expected.
--
endGuard :: String -> Q (Guard, Exp)
endGuard :: String -> Q (Guard, Exp)
endGuard String
s = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE ExpQ
endGuardPred (String -> ExpQ
endGuardExp String
s)

guardedBody :: [String] -> BodyQ
guardedBody :: [String] -> BodyQ
guardedBody [String]
vs = forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB (forall a b. (a -> b) -> [a] -> [b]
map String -> Q (Guard, Exp)
guard [String]
vs forall a. [a] -> [a] -> [a]
++ [String -> Q (Guard, Exp)
endGuard (forall a. Show a => a -> String
show [String]
vs)])

parseJSONClauseQ :: [String] -> ClauseQ
parseJSONClauseQ :: [String] -> ClauseQ
parseJSONClauseQ [String]
vs = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"s"] ([String] -> BodyQ
guardedBody [String]
vs) []

parseJSONFun :: [String] -> DecQ
parseJSONFun :: [String] -> DecQ
parseJSONFun [String]
vs = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'parseJSON [[String] -> ClauseQ
parseJSONClauseQ [String]
vs]


toJSONClause :: String -> ClauseQ
toJSONClause :: String -> ClauseQ
toJSONClause String
s = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
conize String
s) []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| s |]) []

toJSONFun :: [String] -> DecQ
toJSONFun :: [String] -> DecQ
toJSONFun [String]
vs = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toJSON (forall a b. (a -> b) -> [a] -> [b]
map String -> ClauseQ
toJSONClause [String]
vs)


aesonInstance :: String -> Name -> TypeQ
aesonInstance :: String -> Name -> TypeQ
aesonInstance String
s Name
n = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n) (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s)

-- | Derive a JOSE sum type with nullary data constructors, along
-- with 'ToJSON' and 'FromJSON' instances
--
deriveJOSEType
  :: String
  -- ^ Type name.
  -> [String]
  -- ^ List of JSON string values.  The corresponding constructor
  -- is derived by upper-casing the first letter and converting
  -- non-alpha-numeric characters are converted to underscores.
  -> Q [Dec]
deriveJOSEType :: String -> [String] -> Q [Dec]
deriveJOSEType String
s [String]
vs = forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequenceQ [
  let
    derive :: [Name]
derive = forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName [String
"Eq", String
"Ord", String
"Show"]
  in
#if ! MIN_VERSION_template_haskell(2,12,0)
    dataD (cxt []) (mkName s) [] Nothing (map conQ vs) (mapM conT derive)
#else
    forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name
mkName String
s) [] forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. Quote m => String -> m Con
conQ [String]
vs) [forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derive))]
#endif
  , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''FromJSON) [[String] -> DecQ
parseJSONFun [String]
vs]
  , forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''ToJSON) [[String] -> DecQ
toJSONFun [String]
vs]
  ]
  where
    conQ :: String -> m Con
conQ String
v = forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC (String -> Name
conize String
v) []