-- 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
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs
capitalize String
s = String
s

sanitize :: String -> String
sanitize :: String -> String
sanitize = (Char -> Char) -> String -> String
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 (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
capitalize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sanitize

guardPred :: String -> ExpQ
guardPred :: String -> ExpQ
guardPred String
s = [e| $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"s") == $(String -> ExpQ
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
s) |]

guardExp :: String -> ExpQ
guardExp :: String -> ExpQ
guardExp String
s = [e| pure $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
conize String
s) |]

guard :: String -> Q (Guard, Exp)
guard :: String -> Q (Guard, Exp)
guard String
s = ExpQ -> ExpQ -> Q (Guard, Exp)
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: " ++ $(String -> ExpQ
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
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 = ExpQ -> ExpQ -> Q (Guard, Exp)
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 = [Q (Guard, Exp)] -> BodyQ
forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB ((String -> Q (Guard, Exp)) -> [String] -> [Q (Guard, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map String -> Q (Guard, Exp)
guard [String]
vs [Q (Guard, Exp)] -> [Q (Guard, Exp)] -> [Q (Guard, Exp)]
forall a. [a] -> [a] -> [a]
++ [String -> Q (Guard, Exp)
endGuard ([String] -> String
forall a. Show a => a -> String
show [String]
vs)])

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

parseJSONFun :: [String] -> DecQ
parseJSONFun :: [String] -> Q Dec
parseJSONFun [String]
vs = Name -> [ClauseQ] -> Q Dec
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 = [Q Pat] -> BodyQ -> [Q Dec] -> ClauseQ
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
conize String
s) []] (ExpQ -> BodyQ
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| $(String -> ExpQ
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
s) |]) []

toJSONFun :: [String] -> DecQ
toJSONFun :: [String] -> Q Dec
toJSONFun [String]
vs = Name -> [ClauseQ] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toJSON ((String -> ClauseQ) -> [String] -> [ClauseQ]
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 = TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n) (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> Name -> TypeQ
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 = [Q Dec] -> Q [Dec]
forall a. [Q a] -> Q [a]
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequenceQ [
  let
    derive :: [Name]
derive = (String -> Name) -> [String] -> [Name]
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
    Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD ([TypeQ] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name
mkName String
s) [] Maybe Type
forall a. Maybe a
Nothing ((String -> Q Con) -> [String] -> [Q Con]
forall a b. (a -> b) -> [a] -> [b]
map String -> Q Con
forall {m :: * -> *}. Quote m => String -> m Con
conQ [String]
vs) [DerivClause -> Q DerivClause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
derive))]
#endif
  , Q Cxt -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''FromJSON) [[String] -> Q Dec
parseJSONFun [String]
vs]
  , Q Cxt -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''ToJSON) [[String] -> Q Dec
toJSONFun [String]
vs]
  ]
  where
    conQ :: String -> m Con
conQ String
v = Name -> [m BangType] -> m Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC (String -> Name
conize String
v) []