content: {-# 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
    = 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 = 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 n = defaultOptions { A.fieldLabelModifier = lower . drop n }
      where
          lower ""     = ""
          lower (x:xs) = toLower x : xs
  
  compileType :: Type -> Q Exp
  compileType ty =
      case ty of
        ListT -> [|ETyCon (ETCon "List")|]
        TupleT i -> [|ETyTuple i|]
        VarT name ->
            let n = nameBase name
            in [|ETyVar (ETVar n)|]
        SigT ty' _ ->
            compileType ty'
        AppT a b -> [|ETyApp $(compileType a) $(compileType b)|]
        ConT name ->
            let n = nameBase name
            in  [|ETyCon (ETCon n)|]
        _ -> fail $ "Unsupported type: " ++ show ty
  
  optSumType :: SumEncoding -> Q Exp
  optSumType se =
      case se of
          TwoElemArray          -> [|SumEncoding' TwoElemArray|]
          ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|]
          TaggedObject tn cn    -> [|SumEncoding' (TaggedObject tn cn)|]
          UntaggedValue         -> [|SumEncoding' UntaggedValue|]
  
  runDerive :: Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec]
  runDerive name vars mkBody =
      liftM (:[]) elmDefInst
      where
        elmDefInst =
            instanceD (cxt [])
                (classType `appT` instanceType)
                [ funD 'compileElmDef
                           [ clause [ return WildP ] (normalB body) []
                           ]
                ]
  
        classType = conT ''IsElmDefinition
        instanceType = foldl appT (conT name) $ map varT argNames
  
        body = mkBody [|ETypeName { et_name = nameStr, et_args = $args }|]
  
        nameStr = nameBase name
        args =
            listE $ map mkTVar argNames
        mkTVar :: Name -> Q Exp
        mkTVar n =
            let str = nameBase n
            in [|ETVar str|]
  
        argNames =
            flip map vars $ \v ->
                case v of
                  PlainTV tv _  -> tv
                  KindedTV tv _ _ -> tv
  
  deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec]
  deriveAlias isNewtype opts name vars conFields =
          runDerive name vars $ \typeName ->
                  [|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype
      where
        unwrapUnary = unwrapUnaryRecords opts
        fields = listE $ map mkField conFields
        omitNothing = A.omitNothingFields opts
        mkField :: VarStrictType -> Q Exp
        mkField (fname, _, ftype) =
            [|(fldName, $fldType)|]
            where
              fldName = A.fieldLabelModifier opts $ nameBase fname
              fldType = compileType ftype
  
  deriveSum :: A.Options -> Name -> [TyVarBndr a] -> [Con] -> Q [Dec]
  deriveSum opts name vars constrs =
      runDerive name vars $ \typeName ->
          [|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|]
      where
        allNullary = A.allNullaryToStringTag opts
        sumEncOpts = optSumType (A.sumEncoding opts)
        omitNothing = A.omitNothingFields opts
        sumOpts = listE $ map mkOpt constrs
        mkOpt :: Con -> Q Exp
        mkOpt c =
          let modifyName n = (nameBase n, A.constructorTagModifier opts (nameBase n))
          in case c of
              NormalC name' args ->
                  let (b, n) = modifyName name'
                      tyArgs = listE $ map (\(_, ty) -> compileType ty) args
                  in [|STC b n (Anonymous $tyArgs)|]
              RecC name' args ->
                  let (b, n) = modifyName name'
                      tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm
                                                            in  [|(nm', $(compileType ty))|]) args
                  in [|STC b n (Named $tyArgs)|]
              _ -> fail ("Can't derive this sum: " ++ show c)
  
  deriveSynonym :: A.Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec]
  deriveSynonym _ name vars otherT =
      runDerive name vars $ \typeName ->
          [|ETypePrimAlias (EPrimAlias $typeName $otherType)|]
      where
        otherType = compileType 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 o n = (++) <$> deriveElmDef o n <*> deriveJSON o 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 opts name =
      do TyConI tyCon <- reify name
         case tyCon of
           DataD _ _ tyVars _ constrs _ ->
               case constrs of
                 [] -> fail "Can not derive empty data decls"
                 [RecC _ conFields] | not (tagSingleConstructors opts) -> deriveAlias False opts name tyVars conFields
                 _ -> deriveSum opts name tyVars constrs
           NewtypeD [] _ [] Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
              deriveSynonym opts name [] otherTy
           NewtypeD [] _ [] Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
            if A.unwrapUnaryRecords opts
              then deriveSynonym opts name [] otherTy
              else deriveAlias True opts name [] conFields
           TySynD _ vars otherTy ->
               deriveSynonym opts name vars otherTy
           NewtypeD _ _ tyvars Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
               deriveSynonym opts name tyvars otherTy
           NewtypeD _ _ tyvars Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
            if A.unwrapUnaryRecords opts
              then deriveSynonym opts name tyvars otherTy
              else deriveAlias True opts name tyvars conFields
           _ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)
  