-- 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| $(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 = ExpQ -> ExpQ -> Q (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 = ExpQ -> ExpQ -> Q (Guard, Exp)
normalGE ExpQ
endGuardPred (String -> ExpQ
endGuardExp String
s)

guardedBody :: [String] -> BodyQ
guardedBody :: [String] -> BodyQ
guardedBody [String]
vs = [Q (Guard, Exp)] -> BodyQ
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 = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
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 = Name -> [ClauseQ] -> DecQ
funD 'parseJSON [[String] -> ClauseQ
parseJSONClauseQ [String]
vs]


toJSONClause :: String -> ClauseQ
toJSONClause :: String -> ClauseQ
toJSONClause String
s = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP (String -> Name
conize String
s) []] (ExpQ -> BodyQ
normalB [| s |]) []

toJSONFun :: [String] -> DecQ
toJSONFun :: [String] -> DecQ
toJSONFun [String]
vs = Name -> [ClauseQ] -> DecQ
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
appT (Name -> TypeQ
conT Name
n) (Name -> TypeQ
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 = [DecQ] -> Q [Dec]
forall a. [Q a] -> Q [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
    CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([TypeQ] -> CxtQ
cxt []) (String -> Name
mkName String
s) [] Maybe Kind
forall a. Maybe a
Nothing ((String -> ConQ) -> [String] -> [ConQ]
forall a b. (a -> b) -> [a] -> [b]
map String -> ConQ
conQ [String]
vs) [DerivClause -> DerivClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [Name]
derive))]
#endif
  , CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''FromJSON) [[String] -> DecQ
parseJSONFun [String]
vs]
  , CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) (String -> Name -> TypeQ
aesonInstance String
s ''ToJSON) [[String] -> DecQ
toJSONFun [String]
vs]
  ]
  where
    conQ :: String -> ConQ
conQ String
v = Name -> [BangTypeQ] -> ConQ
normalC (String -> Name
conize String
v) []