{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module:      TextShow.Language.Haskell.TH
Copyright:   (C) 2014-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

'TextShow' instances for data types in the @template-haskell@ library.

/Since: 2/
-}
module TextShow.Language.Haskell.TH (showbName, showbName') where

import           Data.Char (isAlpha)
import           Data.Maybe (fromJust)
import qualified Data.Text.Lazy as TL (Text, dropWhile, null, tail)
import           Data.Text.Lazy (uncons)

import           Prelude ()
import           Prelude.Compat

#if !(MIN_VERSION_template_haskell(2,10,0))
import           GHC.Exts (Int(I#))
#endif

import           Language.Haskell.TH.PprLib (Doc, to_HPJ_Doc)
import           Language.Haskell.TH.Syntax

import           TextShow (TextShow(..), Builder,
                           fromString, singleton, toLazyText)
import           TextShow.Text.PrettyPrint (renderB)
import           TextShow.TH (deriveTextShow)

-- | Convert a 'Name' to a 'Builder'.
--
-- /Since: 2/
showbName :: Name -> Builder
showbName = showbName' Alone

-- | Convert a 'Name' to a 'Builder' with the given 'NameIs' settings.
--
-- /Since: 2/
showbName' :: NameIs -> Name -> Builder
showbName' ni nm = case ni of
    Alone           -> nms
    Applied
        | pnam      -> nms
        | otherwise -> singleton '(' <> nms <> singleton ')'
    Infix
        | pnam      -> singleton '`' <> nms <> singleton '`'
        | otherwise -> nms
  where
    -- For now, we make the NameQ and NameG print the same, even though
    -- NameQ is a qualified name (so what it means depends on what the
    -- current scope is), and NameG is an original name (so its meaning
    -- should be independent of what's in scope.
    -- We may well want to distinguish them in the end.
    -- Ditto NameU and NameL
    nms :: Builder
    nms = case nm of
               Name occ NameS         -> occB occ
               Name occ (NameQ m)     -> modB m   <> singleton '.' <> occB occ
               Name occ (NameG _ _ m) -> modB m   <> singleton '.' <> occB occ
               Name occ (NameU u)     -> occB occ <> singleton '_' <> showb (mkInt u)
               Name occ (NameL u)     -> occB occ <> singleton '_' <> showb (mkInt u)

#if MIN_VERSION_template_haskell(2,10,0)
    mkInt = id
#else
    mkInt i# = I# i#
#endif

    occB :: OccName -> Builder
    occB = fromString . occString

    modB :: ModName -> Builder
    modB = fromString . modString

    pnam :: Bool
    pnam = classify $ toLazyText nms

    -- True if we are function style, e.g. f, [], (,)
    -- False if we are operator style, e.g. +, :+
    classify :: TL.Text -> Bool
    classify t
        | TL.null t  = False -- shouldn't happen; . operator is handled below
        | otherwise = case fromJust $ uncons t of
              (x, xs) -> if isAlpha x || (x `elem` "_[]()")
                            then let t' = TL.dropWhile (/= '.') xs
                                 in if TL.null t'
                                       then True
                                       else classify $ TL.tail t'
                            else False

-- | /Since: 2/
$(deriveTextShow ''AnnLookup)
-- | /Since: 2/
$(deriveTextShow ''AnnTarget)
-- | /Since: 2/
$(deriveTextShow ''Body)
-- | /Since: 2/
$(deriveTextShow ''Callconv)
-- | /Since: 2/
$(deriveTextShow ''Clause)
-- | /Since: 2/
$(deriveTextShow ''Con)
-- | /Since: 2/
$(deriveTextShow ''Dec)
-- | /Since: 2/
$(deriveTextShow ''Exp)
#if !(MIN_VERSION_template_haskell(2,13,0))
-- | /Since: 2/
$(deriveTextShow ''FamFlavour)
#endif
-- | /Since: 2/
$(deriveTextShow ''Fixity)
-- | /Since: 2/
$(deriveTextShow ''FixityDirection)
-- | /Since: 2/
$(deriveTextShow ''Foreign)
-- | /Since: 2/
$(deriveTextShow ''FunDep)
-- | /Since: 2/
$(deriveTextShow ''Guard)
-- | /Since: 2/
$(deriveTextShow ''Info)
-- | /Since: 2/
$(deriveTextShow ''Inline)
-- | /Since: 2/
$(deriveTextShow ''Lit)
-- | /Since: 2/
$(deriveTextShow ''Loc)
-- | /Since: 2/
$(deriveTextShow ''Match)
-- | /Since: 2/
$(deriveTextShow ''ModName)
-- | /Since: 2/
$(deriveTextShow ''Module)
-- | /Since: 2/
$(deriveTextShow ''ModuleInfo)

-- | /Since: 2/
instance TextShow Name where
    showb = showbName

-- | /Since: 3.3/
$(deriveTextShow ''NameFlavour)
-- | /Since: 3.3/
$(deriveTextShow ''NameSpace)
-- | /Since: 2/
$(deriveTextShow ''OccName)
-- | /Since: 2/
$(deriveTextShow ''Pat)
-- | /Since: 2/
$(deriveTextShow ''Phases)
-- | /Since: 2/
$(deriveTextShow ''PkgName)
-- | /Since: 2/
$(deriveTextShow ''Pragma)
-- | /Since: 2/
$(deriveTextShow ''Range)
-- | /Since: 2/
$(deriveTextShow ''Role)
-- | /Since: 2/
$(deriveTextShow ''RuleBndr)
-- | /Since: 2/
$(deriveTextShow ''RuleMatch)
-- | /Since: 2/
$(deriveTextShow ''Safety)
-- | /Since: 2/
$(deriveTextShow ''Stmt)
-- | /Since: 2/
$(deriveTextShow ''TyLit)
-- | /Since: 2/
$(deriveTextShow ''Type)
-- | /Since: 2/
$(deriveTextShow ''TySynEqn)
-- | /Since: 2/
$(deriveTextShow ''TyVarBndr)

-- | /Since: 2/
instance TextShow Doc where
    showb = renderB . to_HPJ_Doc

#if !(MIN_VERSION_template_haskell(2,10,0))
-- | Only available with @template-haskell-2.10@ or earlier.
--
-- /Since: 2/
$(deriveTextShow ''Pred)
#endif

#if MIN_VERSION_template_haskell(2,11,0)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''Bang)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''DecidedStrictness)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''FamilyResultSig)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''InjectivityAnn)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''Overlap)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''SourceStrictness)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''SourceUnpackedness)
-- | Only available with @template-haskell-2.11.0.0@ or later.
--
-- /Since: 3/
$(deriveTextShow ''TypeFamilyHead)
#else
-- | Only available with @template-haskell-2.11@ or earlier.
--
-- /Since: 3/
$(deriveTextShow ''Strict)
#endif

#if MIN_VERSION_template_haskell(2,12,0)
-- | Only available with @template-haskell-2.12.0.0@ or later.
--
-- /Since: 3.6/
$(deriveTextShow ''DerivClause)
-- | Only available with @template-haskell-2.12.0.0@ or later.
--
-- /Since: 3.6/
$(deriveTextShow ''DerivStrategy)
-- | Only available with @template-haskell-2.12.0.0@ or later.
--
-- /Since: 3.3/
$(deriveTextShow ''PatSynArgs)
-- | Only available with @template-haskell-2.12.0.0@ or later.
--
-- /Since: 3.3/
$(deriveTextShow ''PatSynDir)
#endif