    {-# 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, tagSingleConstructors)
    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
      { A.sumEncoding             = A.ObjectWithSingleField
      , A.fieldLabelModifier      = id
      , A.constructorTagModifier  = id
      , A.allNullaryToStringTag   = True
      , A.omitNothingFields       = False
      , A.unwrapUnaryRecords      = 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 { A.fieldLabelModifier = lower . drop n }
        where
            lower :: String -> String
    lower String
    ""     = String
    ""
            lower (Char
    x:String
    xs) = Char -> Char
    toLower Char
    x Char -> String -> String
    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 $(Type -> Q Exp
    compileType Type
    a) $(Type -> Q Exp
    compileType Type
    b)|]
          ConT Name
    name ->
              let n :: String
    n = Name -> String
    nameBase Name
    name
              in  [|ETyCon (ETCon n)|]
          Type
    _ -> String -> Q Exp
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    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 a] -> (Q Exp -> Q Exp) -> Q [Dec]
    runDerive :: forall a. Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    runDerive Name
    name [TyVarBndr a]
    vars Q Exp -> Q Exp
    mkBody =
        (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) Q Dec
    elmDefInst
        where
          elmDefInst :: Q Dec
    elmDefInst =
              Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD ([Q Type] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt [])
                  (Q Type
    classType Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    instanceType)
                  [ Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'compileElmDef
                             [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [ Pat -> Q Pat
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Pat
    WildP ] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB Q Exp
    body) []
                             ]
                  ]

          classType :: Q Type
    classType = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT ''IsElmDefinition
          instanceType :: Q Type
    instanceType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    appT (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    name) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ (Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    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 = $Q Exp
    args }|]

          nameStr :: String
    nameStr = Name -> String
    nameBase Name
    name
          args :: Q Exp
    args =
              [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> Q Exp) -> [Name] -> [Q Exp]
    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 =
              ((TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name])
    -> [TyVarBndr a] -> (TyVarBndr a -> Name) -> [Name]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map [TyVarBndr a]
    vars ((TyVarBndr a -> Name) -> [Name])
    -> (TyVarBndr a -> Name) -> [Name]
    forall a b. (a -> b) -> a -> b
    $ \TyVarBndr a
    v ->
                  case TyVarBndr a
    v of
                    PlainTV Name
    tv a
    _  -> Name
    tv
                    KindedTV Name
    tv a
    _ Type
    _ -> Name
    tv

    deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
    deriveAlias :: forall a.
    Bool
    -> Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
    deriveAlias Bool
    isNewtype Options
    opts Name
    name [TyVarBndr a]
    vars [VarStrictType]
    conFields =
            Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a. Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    runDerive Name
    name [TyVarBndr a]
    vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ \Q Exp
    typeName ->
                    [|ETypeAlias (EAlias $Q Exp
    typeName $Q Exp
    fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype
        where
          unwrapUnary :: Bool
    unwrapUnary = Options -> Bool
    unwrapUnaryRecords Options
    opts
          fields :: Q Exp
    fields = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (VarStrictType -> Q Exp) -> [VarStrictType] -> [Q Exp]
    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, $Q Exp
    fldType)|]
              where
                fldName :: String
    fldName = Options -> String -> String
    A.fieldLabelModifier Options
    opts (String -> String) -> String -> String
    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 a] -> [Con] -> Q [Dec]
    deriveSum :: forall a. Options -> Name -> [TyVarBndr a] -> [Con] -> Q [Dec]
    deriveSum Options
    opts Name
    name [TyVarBndr a]
    vars [Con]
    constrs =
        Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a. Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    runDerive Name
    name [TyVarBndr a]
    vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ \Q Exp
    typeName ->
            [|ETypeSum (ESum $Q Exp
    typeName $Q Exp
    sumOpts $Q Exp
    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 = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Con -> Q Exp) -> [Con] -> [Q Exp]
    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 = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (BangType -> Q Exp) -> [BangType] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Bang
    _, Type
    ty) -> Type -> Q Exp
    compileType Type
    ty) [BangType]
    args
                    in [|STC b n (Anonymous $Q Exp
    tyArgs)|]
                RecC Name
    name' [VarStrictType]
    args ->
                    let (String
    b, String
    n) = Name -> (String, String)
    modifyName Name
    name'
                        tyArgs :: Q Exp
    tyArgs = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (VarStrictType -> Q Exp) -> [VarStrictType] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name
    nm, Bang
    _, Type
    ty) -> let nm' :: String
    nm' = Options -> String -> String
    A.fieldLabelModifier Options
    opts (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    nameBase Name
    nm
                                                              in  [|(nm', $(Type -> Q Exp
    compileType Type
    ty))|]) [VarStrictType]
    args
                    in [|STC b n (Named $Q Exp
    tyArgs)|]
                Con
    _ -> String -> Q Exp
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Can't derive this sum: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    c)

    deriveSynonym :: A.Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym :: forall a. Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym Options
    _ Name
    name [TyVarBndr a]
    vars Type
    otherT =
        Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a. Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
    runDerive Name
    name [TyVarBndr a]
    vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ \Q Exp
    typeName ->
            [|ETypePrimAlias (EPrimAlias $Q Exp
    typeName $Q Exp
    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 = [Dec] -> [Dec] -> [Dec]
    forall a. [a] -> [a] -> [a]
    (++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Options -> Name -> Q [Dec]
    deriveElmDef Options
    o Name
    n Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
    forall a b. Q (a -> b) -> Q a -> Q b
    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 tyCon <- Name -> Q Info
    reify Name
    name
           case tyCon of
             DataD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    tyVars Maybe Type
    _ [Con]
    constrs [DerivClause]
    _ ->
                 case [Con]
    constrs of
                   [] -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Can not derive empty data decls"
                   [RecC Name
    _ [VarStrictType]
    conFields] | Bool -> Bool
    not (Options -> Bool
    tagSingleConstructors Options
    opts) -> Bool
    -> Options
    -> Name
    -> [TyVarBndr BndrVis]
    -> [VarStrictType]
    -> Q [Dec]
    forall a.
    Bool
    -> Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
    deriveAlias Bool
    False Options
    opts Name
    name [TyVarBndr BndrVis]
    tyVars [VarStrictType]
    conFields
                   [Con]
    _ -> Options -> Name -> [TyVarBndr BndrVis] -> [Con] -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> [Con] -> Q [Dec]
    deriveSum Options
    opts Name
    name [TyVarBndr BndrVis]
    tyVars [Con]
    constrs
             NewtypeD [] Name
    _ [] Maybe Type
    Nothing (NormalC Name
    _ [(Bang SourceUnpackedness
    NoSourceUnpackedness SourceStrictness
    NoSourceStrictness, Type
    otherTy)]) [] ->
                Options -> Name -> [TyVarBndr (ZonkAny 0)] -> Type -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> 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 (ZonkAny 1)] -> Type -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym Options
    opts Name
    name [] Type
    otherTy
                else Bool
    -> Options
    -> Name
    -> [TyVarBndr (ZonkAny 2)]
    -> [VarStrictType]
    -> Q [Dec]
    forall a.
    Bool
    -> Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
    deriveAlias Bool
    True Options
    opts Name
    name [] [VarStrictType]
    conFields
             TySynD Name
    _ [TyVarBndr BndrVis]
    vars Type
    otherTy ->
                 Options -> Name -> [TyVarBndr BndrVis] -> Type -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym Options
    opts Name
    name [TyVarBndr BndrVis]
    vars Type
    otherTy
             NewtypeD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    tyvars Maybe Type
    Nothing (NormalC Name
    _ [(Bang SourceUnpackedness
    NoSourceUnpackedness SourceStrictness
    NoSourceStrictness, Type
    otherTy)]) [] ->
                 Options -> Name -> [TyVarBndr BndrVis] -> Type -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym Options
    opts Name
    name [TyVarBndr BndrVis]
    tyvars Type
    otherTy
             NewtypeD Cxt
    _ Name
    _ [TyVarBndr BndrVis]
    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 BndrVis] -> Type -> Q [Dec]
    forall a. Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
    deriveSynonym Options
    opts Name
    name [TyVarBndr BndrVis]
    tyvars Type
    otherTy
                else Bool
    -> Options
    -> Name
    -> [TyVarBndr BndrVis]
    -> [VarStrictType]
    -> Q [Dec]
    forall a.
    Bool
    -> Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
    deriveAlias Bool
    True Options
    opts Name
    name [TyVarBndr BndrVis]
    tyvars [VarStrictType]
    conFields
             Dec
    _ -> String -> Q [Dec]
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "Oops, can only derive data and newtype, not this: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Dec -> String
    forall a. Show a => a -> String
    show Dec
    tyCon)