{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections   #-}
{-| This module should be used to derive the Elm instance alongside the
 JSON ones. The prefered usage is to convert statements such as :

> $(deriveJSON defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D)

 into:

> $(deriveBoth defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D)

 Which will derive both the @aeson@ and @elm-bridge@ instances at the same
 time.
-}

module Elm.Derive
    ( -- * Options
      A.Options(..)
    , A.SumEncoding(..)
    , defaultOptions
    , defaultOptionsDropLower
      -- * Template haskell functions
    , deriveElmDef
    , deriveBoth
    )
where

import           Elm.TyRep

import           Control.Applicative
import           Control.Monad
import           Data.Aeson.TH              (SumEncoding (..), deriveJSON)
import qualified Data.Aeson.TH              as A
import           Data.Char                  (toLower)
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           Prelude

-- | Note that This default set of options is distinct from that in
-- the @aeson@ package.
defaultOptions :: A.Options
defaultOptions :: Options
defaultOptions
  = Options
A.defaultOptions
  { sumEncoding :: SumEncoding
A.sumEncoding             = SumEncoding
A.ObjectWithSingleField
  , fieldLabelModifier :: String -> String
A.fieldLabelModifier      = forall a. a -> a
id
  , constructorTagModifier :: String -> String
A.constructorTagModifier  = forall a. a -> a
id
  , allNullaryToStringTag :: Bool
A.allNullaryToStringTag   = Bool
True
  , omitNothingFields :: Bool
A.omitNothingFields       = Bool
False
  , unwrapUnaryRecords :: Bool
A.unwrapUnaryRecords      = Bool
True
  }

unwrapUnaryRecords :: A.Options -> Bool
unwrapUnaryRecords :: Options -> Bool
unwrapUnaryRecords = Options -> Bool
A.unwrapUnaryRecords

{-| This generates a default set of options. The parameter represents the
number of characters that must be dropped from the Haskell field names.
The first letter of the field is then converted to lowercase, ie:

> data Foo = Foo { _fooBarQux :: Int }
> $(deriveBoth (defaultOptionsDropLower 4) ''Foo)

Will be encoded as:

> {"barQux"=12}
-}
defaultOptionsDropLower :: Int -> A.Options
defaultOptionsDropLower :: Int -> Options
defaultOptionsDropLower Int
n = Options
defaultOptions { fieldLabelModifier :: String -> String
A.fieldLabelModifier = String -> String
lower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n }
    where
        lower :: String -> String
lower String
""     = String
""
        lower (Char
x:String
xs) = Char -> Char
toLower Char
x forall a. a -> [a] -> [a]
: String
xs

compileType :: Type -> Q Exp
compileType :: Type -> Q Exp
compileType Type
ty =
    case Type
ty of
      Type
ListT -> [|ETyCon (ETCon "List")|]
      TupleT Int
i -> [|ETyTuple i|]
      VarT Name
name ->
          let n :: String
n = Name -> String
nameBase Name
name
          in [|ETyVar (ETVar n)|]
      SigT Type
ty' Type
_ ->
          Type -> Q Exp
compileType Type
ty'
      AppT Type
a Type
b -> [|ETyApp $(compileType a) $(compileType b)|]
      ConT Name
name ->
          let n :: String
n = Name -> String
nameBase Name
name
          in  [|ETyCon (ETCon n)|]
      Type
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unsupported type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty

optSumType :: SumEncoding -> Q Exp
optSumType :: SumEncoding -> Q Exp
optSumType SumEncoding
se =
    case SumEncoding
se of
        SumEncoding
TwoElemArray          -> [|SumEncoding' TwoElemArray|]
        SumEncoding
ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|]
        TaggedObject String
tn String
cn    -> [|SumEncoding' (TaggedObject tn cn)|]
        SumEncoding
UntaggedValue         -> [|SumEncoding' UntaggedValue|]

runDerive :: Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive :: Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars Q Exp -> Q Exp
mkBody =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> [a] -> [a]
:[]) Q Dec
elmDefInst
    where
      elmDefInst :: Q Dec
elmDefInst =
          forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
              (Q Type
classType forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
instanceType)
              [ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'compileElmDef
                         [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ forall (m :: * -> *) a. Monad m => a -> m a
return Pat
WildP ] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
                         ]
              ]

      classType :: Q Type
classType = forall (m :: * -> *). Quote m => Name -> m Type
conT ''IsElmDefinition
      instanceType :: Q Type
instanceType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
name) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
argNames

      body :: Q Exp
body = Q Exp -> Q Exp
mkBody [|ETypeName { et_name = nameStr, et_args = $args }|]

      nameStr :: String
nameStr = Name -> String
nameBase Name
name
      args :: Q Exp
args =
          forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
mkTVar [Name]
argNames
      mkTVar :: Name -> Q Exp
      mkTVar :: Name -> Q Exp
mkTVar Name
n =
          let str :: String
str = Name -> String
nameBase Name
n
          in [|ETVar str|]

      argNames :: [Name]
argNames =
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [TyVarBndr ()]
vars forall a b. (a -> b) -> a -> b
$ \TyVarBndr ()
v ->
              case TyVarBndr ()
v of
                PlainTV Name
tv ()
_  -> Name
tv
                KindedTV Name
tv ()
_ Type
_ -> Name
tv

deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias :: Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
isNewtype Options
opts Name
name [TyVarBndr ()]
vars [VarStrictType]
conFields =
        Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
                [|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype
    where
      unwrapUnary :: Bool
unwrapUnary = Options -> Bool
unwrapUnaryRecords Options
opts
      fields :: Q Exp
fields = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map VarStrictType -> Q Exp
mkField [VarStrictType]
conFields
      omitNothing :: Bool
omitNothing = Options -> Bool
A.omitNothingFields Options
opts
      mkField :: VarStrictType -> Q Exp
      mkField :: VarStrictType -> Q Exp
mkField (Name
fname, Bang
_, Type
ftype) =
          [|(fldName, $fldType)|]
          where
            fldName :: String
fldName = Options -> String -> String
A.fieldLabelModifier Options
opts forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fname
            fldType :: Q Exp
fldType = Type -> Q Exp
compileType Type
ftype

deriveSum :: A.Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum :: Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum Options
opts Name
name [TyVarBndr ()]
vars [Con]
constrs =
    Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
        [|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|]
    where
      allNullary :: Bool
allNullary = Options -> Bool
A.allNullaryToStringTag Options
opts
      sumEncOpts :: Q Exp
sumEncOpts = SumEncoding -> Q Exp
optSumType (Options -> SumEncoding
A.sumEncoding Options
opts)
      omitNothing :: Bool
omitNothing = Options -> Bool
A.omitNothingFields Options
opts
      sumOpts :: Q Exp
sumOpts = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Con -> Q Exp
mkOpt [Con]
constrs
      mkOpt :: Con -> Q Exp
      mkOpt :: Con -> Q Exp
mkOpt Con
c =
        let modifyName :: Name -> (String, String)
modifyName Name
n = (Name -> String
nameBase Name
n, Options -> String -> String
A.constructorTagModifier Options
opts (Name -> String
nameBase Name
n))
        in case Con
c of
            NormalC Name
name' [BangType]
args ->
                let (String
b, String
n) = Name -> (String, String)
modifyName Name
name'
                    tyArgs :: Q Exp
tyArgs = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Bang
_, Type
ty) -> Type -> Q Exp
compileType Type
ty) [BangType]
args
                in [|STC b n (Anonymous $tyArgs)|]
            RecC Name
name' [VarStrictType]
args ->
                let (String
b, String
n) = Name -> (String, String)
modifyName Name
name'
                    tyArgs :: Q Exp
tyArgs = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
nm, Bang
_, Type
ty) -> let nm' :: String
nm' = Options -> String -> String
A.fieldLabelModifier Options
opts forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
nm
                                                          in  [|(nm', $(compileType ty))|]) [VarStrictType]
args
                in [|STC b n (Named $tyArgs)|]
            Con
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Can't derive this sum: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Con
c)

deriveSynonym :: A.Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym :: Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
_ Name
name [TyVarBndr ()]
vars Type
otherT =
    Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
        [|ETypePrimAlias (EPrimAlias $typeName $otherType)|]
    where
      otherType :: Q Exp
otherType = Type -> Q Exp
compileType Type
otherT

-- | Equivalent to running both 'deriveJSON' and 'deriveElmDef' with the
-- same options, so as to ensure the code on the Haskell and Elm size is
-- synchronized.
deriveBoth :: A.Options -> Name -> Q [Dec]
deriveBoth :: Options -> Name -> Q [Dec]
deriveBoth Options
o Name
n = forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Name -> Q [Dec]
deriveElmDef Options
o Name
n forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Options -> Name -> Q [Dec]
deriveJSON Options
o Name
n

-- | Just derive the @elm-bridge@ definitions for generating the
-- serialization/deserialization code. It must be kept synchronized with
-- the Haskell code manually.
deriveElmDef :: A.Options -> Name -> Q [Dec]
deriveElmDef :: Options -> Name -> Q [Dec]
deriveElmDef Options
opts Name
name =
    do TyConI Dec
tyCon <- Name -> Q Info
reify Name
name
       case Dec
tyCon of
         DataD Cxt
_ Name
_ [TyVarBndr ()]
tyVars Maybe Type
_ [Con]
constrs [DerivClause]
_ ->
             case [Con]
constrs of
               [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can not derive empty data decls"
               [RecC Name
_ [VarStrictType]
conFields] -> Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
False Options
opts Name
name [TyVarBndr ()]
tyVars [VarStrictType]
conFields
               [Con]
_ -> Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum Options
opts Name
name [TyVarBndr ()]
tyVars [Con]
constrs
         NewtypeD [] Name
_ [] Maybe Type
Nothing (NormalC Name
_ [(Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
            Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [] Type
otherTy
         NewtypeD [] Name
_ [] Maybe Type
Nothing (RecC Name
_ conFields :: [VarStrictType]
conFields@[(Name (OccName String
_) NameFlavour
_, Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
          if Options -> Bool
A.unwrapUnaryRecords Options
opts
            then Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [] Type
otherTy
            else Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
True Options
opts Name
name [] [VarStrictType]
conFields
         TySynD Name
_ [TyVarBndr ()]
vars Type
otherTy ->
             Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
vars Type
otherTy
         NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
tyvars Maybe Type
Nothing (NormalC Name
_ [(Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
             Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
tyvars Type
otherTy
         NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
tyvars Maybe Type
Nothing (RecC Name
_ conFields :: [VarStrictType]
conFields@[(Name (OccName String
_) NameFlavour
_, Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
          if Options -> Bool
A.unwrapUnaryRecords Options
opts
            then Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
tyvars Type
otherTy
            else Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
True Options
opts Name
name [TyVarBndr ()]
tyvars [VarStrictType]
conFields
         Dec
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Oops, can only derive data and newtype, not this: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Dec
tyCon)