{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-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

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)

#if MIN_VERSION_base(4,15,0)
import qualified Data.Text.Foreign as TS (peekCStringLen)
import           Foreign.ForeignPtr (withForeignPtr)
import           Foreign.Ptr (plusPtr)
import           System.IO.Unsafe (unsafePerformIO)
import           TextShow (showtToShowb)
#endif

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

-- | Convert a 'Name' to a 'Builder' with the given 'NameIs' settings.
--
-- /Since: 2/
showbName' :: NameIs -> Name -> Builder
showbName' :: NameIs -> Name -> Builder
showbName' NameIs
ni Name
nm = case NameIs
ni of
    NameIs
Alone           -> Builder
nms
    NameIs
Applied
        | Bool
pnam      -> Builder
nms
        | Bool
otherwise -> Char -> Builder
singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Builder
nms forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
    NameIs
Infix
        | Bool
pnam      -> Char -> Builder
singleton Char
'`' forall a. Semigroup a => a -> a -> a
<> Builder
nms forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'`'
        | Bool
otherwise -> Builder
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 :: Builder
nms = case Name
nm of
               Name OccName
occ NameFlavour
NameS         -> OccName -> Builder
occB OccName
occ
               Name OccName
occ (NameQ ModName
m)     -> ModName -> Builder
modB ModName
m   forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> OccName -> Builder
occB OccName
occ
               Name OccName
occ (NameG NameSpace
_ PkgName
_ ModName
m) -> ModName -> Builder
modB ModName
m   forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> OccName -> Builder
occB OccName
occ
               Name OccName
occ (NameU Uniq
u)     -> OccName -> Builder
occB OccName
occ forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'_' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Uniq
u
               Name OccName
occ (NameL Uniq
u)     -> OccName -> Builder
occB OccName
occ forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'_' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Uniq
u

    occB :: OccName -> Builder
    occB :: OccName -> Builder
occB = String -> Builder
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occString

    modB :: ModName -> Builder
    modB :: ModName -> Builder
modB = String -> Builder
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> String
modString

    pnam :: Bool
    pnam :: Bool
pnam = Text -> Bool
classify forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText Builder
nms

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

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

-- | /Since: 2/
instance TextShow Doc where
    showb :: Doc -> Builder
showb = Doc -> Builder
renderB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
to_HPJ_Doc

#if MIN_VERSION_template_haskell(2,17,0)
instance TextShow Bytes where
   showb :: Bytes -> Builder
showb = forall a. (a -> Text) -> a -> Builder
showtToShowb forall a. TextShow a => a -> Text
showt
   showt :: Bytes -> Text
showt Bytes
b = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Bytes -> ForeignPtr Word8
bytesPtr Bytes
b) forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
                CStringLen -> IO Text
TS.peekCStringLen ( Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Word
bytesOffset Bytes
b)
                                  , forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Word
bytesSize Bytes
b)
                                  )
#endif

-- A significant chunk of these data types are mutually recursive, which makes
-- it impossible to derive TextShow instances for everything individually using
-- Template Haskell. As a workaround, we splice everything together in a single
-- ungodly large splice. One unfortunate consequence of this is that we cannot
-- give Haddocks to each instance :(
$(concat <$> traverse deriveTextShow
  [ ''AnnLookup
  , ''AnnTarget
  , ''Body
  , ''Callconv
  , ''Clause
  , ''Con
  , ''Dec
  , ''Exp
#if !(MIN_VERSION_template_haskell(2,13,0))
  , ''FamFlavour
#endif
  , ''Fixity
  , ''FixityDirection
  , ''Foreign
  , ''FunDep
  , ''Guard
  , ''Info
  , ''Inline
  , ''Lit
  , ''Loc
  , ''Match
  , ''ModName
  , ''Module
  , ''ModuleInfo
  , ''NameFlavour
  , ''NameSpace
  , ''OccName
  , ''Pat
  , ''Phases
  , ''PkgName
  , ''Pragma
  , ''Range
  , ''Role
  , ''RuleBndr
  , ''RuleMatch
  , ''Safety
  , ''Stmt
  , ''TyLit
  , ''Type
  , ''TySynEqn
  , ''TyVarBndr

  , ''Bang
  , ''DecidedStrictness
  , ''FamilyResultSig
  , ''InjectivityAnn
  , ''Overlap
  , ''SourceStrictness
  , ''SourceUnpackedness
  , ''TypeFamilyHead

#if MIN_VERSION_template_haskell(2,12,0)
  , ''DerivClause
  , ''DerivStrategy
  , ''PatSynArgs
  , ''PatSynDir
#endif

#if MIN_VERSION_template_haskell(2,16,0) && !(MIN_VERSION_template_haskell(2,17,0))
  , ''Bytes
#endif

#if MIN_VERSION_template_haskell(2,17,0)
  , ''Specificity
#endif
  ])