    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Singletons.Deriving.Show
    -- Copyright   :  (C) 2017 Ryan Scott
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  Ryan Scott
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Implements deriving of Show instances
    --
    ----------------------------------------------------------------------------
    {-# LANGUAGE ScopedTypeVariables #-}
    module Data.Singletons.Deriving.Show (
        mkShowInstance
      , mkShowSingContext
      ) where

    import Language.Haskell.TH.Syntax hiding (showName)
    import Language.Haskell.TH.Desugar
    import Data.Singletons.Names
    import Data.Singletons.Util
    import Data.Singletons.Syntax
    import Data.Singletons.Deriving.Infer
    import Data.Singletons.Deriving.Util
    import Data.Maybe (fromMaybe)
    import GHC.Lexeme (startsConSym, startsVarSym)
    import GHC.Show (appPrec, appPrec1)

    mkShowInstance :: DsMonad q => DerivDesc q
    mkShowInstance mb_ctxt ty (DataDecl _ _ cons) = do
      clauses <- mk_showsPrec cons
      constraints <- inferConstraintsDef mb_ctxt (DConPr showName) ty cons
      return $ InstDecl { id_cxt = constraints
                        , id_name = showName
                        , id_arg_tys = [ty]
                        , id_sigs  = mempty
                        , id_meths = [ (showsPrecName, UFunction clauses) ] }

    mk_showsPrec :: DsMonad q => [DCon] -> q [DClause]
    mk_showsPrec cons = do
        p <- newUniqueName "p" -- The precedence argument (not always used)
        if null cons
           then do v <- newUniqueName "v"
                   pure [DClause [DWildPa, DVarPa v] (DCaseE (DVarE v) [])]
           else mapM (mk_showsPrec_clause p) cons

    mk_showsPrec_clause :: forall q. DsMonad q
                        => Name -> DCon
                        -> q DClause
    mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields
      where
        go :: DConFields -> q DClause

        -- No fields: print just the constructor name, with no parentheses
        go (DNormalC _ []) = return $
          DClause [DWildPa, DConPa con_name []] $
            DVarE showStringName `DAppE` dStringE (parenInfixConName con_name "")

        -- Infix constructors have special Show treatment.
        go (DNormalC True [_, _]) = do
          argL <- newUniqueName "argL"
          argR <- newUniqueName "argR"
          fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name
          let con_prec = case fi of Fixity prec _ -> prec
              op_name  = nameBase con_name
              infixOpE = DAppE (DVarE showStringName) . dStringE $
                           if isInfixDataCon op_name
                              then " "  ++ op_name ++ " "
                              -- Make sure to handle infix data constructors
                              -- like (Int `Foo` Int)
                              else " `" ++ op_name ++ "` "
          return $ DClause [DVarPa p, DConPa con_name [DVarPa argL, DVarPa argR]] $
            (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
                                                       `DAppE` dIntegerE con_prec))
              `DAppE` (DVarE composeName
                         `DAppE` showsPrecE (con_prec + 1) argL
                         `DAppE` (DVarE composeName
                                    `DAppE` infixOpE
                                    `DAppE` showsPrecE (con_prec + 1) argR))

        go (DNormalC _ tys) = do
          args <- mapM (const $ newUniqueName "arg") tys
          let show_args     = map (showsPrecE appPrec1) args
              composed_args = foldr1 (\v q -> DVarE composeName
                                               `DAppE` v
                                               `DAppE` (DVarE composeName
                                                         `DAppE` DVarE showSpaceName
                                                         `DAppE` q)) show_args
              named_args = DVarE composeName
                             `DAppE` (DVarE showStringName
                                       `DAppE` dStringE (parenInfixConName con_name " "))
                             `DAppE` composed_args
          return $ DClause [DVarPa p, DConPa con_name $ map DVarPa args] $
            DVarE showParenName
              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
              `DAppE` named_args

        -- We show a record constructor with no fields the same way we'd show a
        -- normal constructor with no fields.
        go (DRecC []) = go (DNormalC False [])

        go (DRecC tys) = do
          args <- mapM (const $ newUniqueName "arg") tys
          let show_args =
                concatMap (\((arg_name, _, _), arg) ->
                            let arg_nameBase = nameBase arg_name
                                infix_rec    = showParen (isSym arg_nameBase)
                                                         (showString arg_nameBase) ""
                            in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
                               , showsPrecE 0 arg
                               , DVarE showCommaSpaceName
                               ])
                          (zip tys args)
              brace_comma_args =   (DVarE showCharName `DAppE` dCharE '{')
                                 : take (length show_args - 1) show_args
              composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
                                    (DVarE showCharName `DAppE` dCharE '}')
                                    brace_comma_args
              named_args = DVarE composeName
                             `DAppE` (DVarE showStringName
                                       `DAppE` dStringE (parenInfixConName con_name " "))
                             `DAppE` composed_args
          return $ DClause [DVarPa p, DConPa con_name $ map DVarPa args] $
            DVarE showParenName
              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
              `DAppE` named_args

    -- | Parenthesize an infix constructor name if it is being applied as a prefix
    -- function (e.g., data Amp a = (:&) a a)
    parenInfixConName :: Name -> ShowS
    parenInfixConName conName =
        let conNameBase = nameBase conName
        in showParen (isInfixDataCon conNameBase) $ showString conNameBase

    showsPrecE :: Int -> Name -> DExp
    showsPrecE prec n = DVarE showsPrecName `DAppE` dIntegerE prec `DAppE` DVarE n

    dCharE :: Char -> DExp
    dCharE c = DLitE $ StringL [c] -- There aren't type-level characters yet,
                                   -- so fake it with a string

    dStringE :: String -> DExp
    dStringE = DLitE . StringL

    dIntegerE :: Int -> DExp
    dIntegerE = DLitE . IntegerL . fromIntegral

    isSym :: String -> Bool
    isSym ""      = False
    isSym (c : _) = startsVarSym c || startsConSym c

    -- | Turn a context like @('Show' a, 'Show' b)@ into @('ShowSing' a, 'ShowSing' b)@.
    -- This is necessary for standalone-derived 'Show' instances for singleton types.
    mkShowSingContext :: DCxt -> DCxt
    mkShowSingContext = map show_to_SingShow
      where
        show_to_SingShow :: DPred -> DPred
        show_to_SingShow = modifyConNameDPred $ \n ->
                             if n == showName
                                then showSingName
                                else n