content: {-# LANGUAGE DefaultSignatures #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TypeAbstractions #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Text.Show.Singletons
  -- Copyright   :  (C) 2017 Ryan Scott
  -- License     :  BSD-style (see LICENSE)
  -- Maintainer  :  Ryan Scott
  -- Stability   :  experimental
  -- Portability :  non-portable
  --
  -- Defines the SShow singleton version of the Show type class.
  --
  -----------------------------------------------------------------------------
  
  module Text.Show.Singletons (
    PShow(..), SShow(..), SymbolS, show_,
    Shows, sShows,
    ShowListWith, sShowListWith,
    ShowChar, sShowChar,
    ShowString, sShowString,
    ShowParen, sShowParen,
    ShowSpace, sShowSpace,
    ShowCommaSpace, sShowCommaSpace,
    AppPrec, sAppPrec,
    AppPrec1, sAppPrec1,
  
    -- * Defunctionalization symbols
    ShowsPrecSym0, ShowsPrecSym1, ShowsPrecSym2, ShowsPrecSym3,
    Show_Sym0, Show_Sym1,
    ShowListSym0, ShowListSym1, ShowListSym2,
    ShowsSym0, ShowsSym1, ShowsSym2,
    ShowListWithSym0, ShowListWithSym1, ShowListWithSym2, ShowListWithSym3,
    ShowCharSym0, ShowCharSym1, ShowCharSym2,
    ShowStringSym0, ShowStringSym1, ShowStringSym2,
    ShowParenSym0, ShowParenSym1, ShowParenSym2,
    ShowSpaceSym0, ShowSpaceSym1,
    ShowCommaSpaceSym0, ShowCommaSpaceSym1,
    AppPrecSym0, AppPrec1Sym0
    ) where
  
  import           Data.Bool.Singletons
  import           Data.Eq.Singletons
  import           Data.Kind
  import           Data.List.NonEmpty (NonEmpty)
  import           Data.List.Singletons.Internal
  import           Data.Ord (Down)
  import           Data.Ord.Singletons
  import           Data.Semigroup.Singletons.Internal.Classes
  import           Data.Singletons
  import           Data.Singletons.Base.Instances
  import           Data.Singletons.TH
  import qualified Data.Text as T
  import           GHC.Base.Singletons
  import           GHC.Num.Singletons
  import           GHC.TypeLits
  import           GHC.TypeLits.Singletons
  import qualified Prelude as P
  import           Prelude hiding (Show(..))
  import           Unsafe.Coerce (unsafeCoerce)
  
  -- | The @shows@ functions return a function that prepends the
  -- output 'Symbol' to an existing 'Symbol'.  This allows constant-time
  -- concatenation of results using function composition.
  type SymbolS :: Type
  type SymbolS = Symbol -> Symbol
  
  $(singletonsOnly [d|
    class Show a where
      showsPrec :: Natural -> a -> SymbolS
      show_     :: a -> Symbol
      showList  :: [a] -> SymbolS
  
      showsPrec _ x s = show_ x <> s
      show_ x         = shows x ""
      showList ls   s = showListWith shows ls s
  
    shows :: Show a => a -> SymbolS
    shows s = showsPrec 0 s
  
    showListWith :: (a -> SymbolS) -> [a] -> SymbolS
    showListWith _     []     s = "[]" <> s
    showListWith showx (x:xs) s = "["  <> showx x (showl xs)
      where
        showl []     = "]" <> s
        showl (y:ys) = "," <> showx y (showl ys)
  
    showChar :: Char -> SymbolS
    showChar = consSymbol
  
    showString :: Symbol -> SymbolS
    showString = (<>)
  
    showParen :: Bool -> SymbolS -> SymbolS
    showParen b p = if b then showChar '(' . p . showChar ')' else p
  
    showSpace :: SymbolS
    showSpace = \xs -> " " <> xs
  
    showCommaSpace :: SymbolS
    showCommaSpace = showString ", "
  
    appPrec, appPrec1 :: Nat
    appPrec  = 10
    appPrec1 = 11
  
    instance Show a => Show [a] where
      showsPrec _ = showList
  
    show_tuple :: [SymbolS] -> SymbolS
    show_tuple ss = showChar '('
                  . foldr1 (\s r -> s . showChar ',' . r) ss
                  . showChar ')'
  
    instance (Show a, Show b) => Show (a,b)  where
      showsPrec _ (a,b) s = show_tuple [shows a, shows b] s
  
    instance (Show a, Show b, Show c) => Show (a, b, c) where
      showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s
  
    instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
      showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s
  
    instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
      showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s
  
    instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where
      showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s
  
    instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
            => Show (a,b,c,d,e,f,g) where
      showsPrec _ (a,b,c,d,e,f,g) s
            = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s
  
    deriving instance Show a => Show (Down a)
    |])
  
  $(promoteOnly [d|
    showsNat :: Natural -> SymbolS
    showsNat 0 = showChar '0'
    showsNat 1 = showChar '1'
    showsNat 2 = showChar '2'
    showsNat 3 = showChar '3'
    showsNat 4 = showChar '4'
    showsNat 5 = showChar '5'
    showsNat 6 = showChar '6'
    showsNat 7 = showChar '7'
    showsNat 8 = showChar '8'
    showsNat 9 = showChar '9'
    showsNat n = showsNat (n `div` 10) . showsNat (n `mod` 10)
    |])
  
  instance PShow Natural where
    type ShowsPrec _ n x = ShowsNat n x
  
  instance SShow Natural where
    sShowsPrec _ sn sx =
      let n = fromSing sn
          x = fromSing sx
      in withSomeSSymbol (P.show n ++ T.unpack x) unsafeCoerce
  
  $(promoteOnly [d|
    showsCharPrec :: Natural -> Char -> SymbolS
    showsCharPrec _ '\'' = showString "'\\''"
    showsCharPrec _ c    = showChar '\'' . showLitChar c . showChar '\''
  
    showCharList :: [Char] -> SymbolS
    showCharList cs = showChar '"' . showLitString cs . showChar '"'
  
    -- -| Like 'showCharList', but for 'Symbol's.
    showSymbol :: Symbol -> SymbolS
    showSymbol sym = showChar '"' . showLitSymbol sym . showChar '"'
  
    -- -| Convert a character to a string using only printable characters,
    -- using Haskell source-language escape conventions.  For example:
    --
    -- > showLitChar '\n' s  =  "\\n" ++ s
    --
    showLitChar                :: Char -> SymbolS
    showLitChar c s | c > '\DEL' =  showChar '\\' (protectEsc isDec (shows (charToNat c)) s)
    showLitChar '\DEL'         s =  showString "\\DEL" s
    showLitChar '\\'           s =  showString "\\\\" s
    showLitChar c s | c >= ' '   =  showChar c s
    showLitChar '\a'           s =  showString "\\a" s
    showLitChar '\b'           s =  showString "\\b" s
    showLitChar '\f'           s =  showString "\\f" s
    showLitChar '\n'           s =  showString "\\n" s
    showLitChar '\r'           s =  showString "\\r" s
    showLitChar '\t'           s =  showString "\\t" s
    showLitChar '\v'           s =  showString "\\v" s
    showLitChar '\SO'          s =  protectEsc (== 'H') (showString "\\SO") s
    showLitChar c              s =  showString ('\\' `consSymbol` (asciiTab!!charToNat c)) s
            -- I've done manual eta-expansion here, because otherwise it's
            -- impossible to stop (asciiTab!!charToNat) getting floated out as an MFE
  
    showLitString :: String -> SymbolS
    -- -| Same as 'showLitChar', but for strings
    -- It converts the string to a string using Haskell escape conventions
    -- for non-printable characters. Does not add double-quotes around the
    -- whole thing; the caller should do that.
    -- The main difference from showLitChar (apart from the fact that the
    -- argument is a string not a list) is that we must escape double-quotes
    showLitString []         s = s
    showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s)
    showLitString (c   : cs) s = showLitChar c (showLitString cs s)
       -- Making 's' an explicit parameter makes it clear to GHC that
       -- showLitString has arity 2, which avoids it allocating an extra lambda
       -- The sticking point is the recursive call to (showLitString cs), which
       -- it can't figure out would be ok with arity 2.
  
    -- -| Like 'showLitString', but for 'Symbol's.
    showLitSymbol :: Symbol -> SymbolS
    showLitSymbol sym s = case unconsSymbol sym of
      Nothing        -> s
      Just ('"', cs) -> showString "\\\"" (showLitSymbol cs s)
      Just (c,   cs) -> showLitChar c (showLitSymbol cs s)
  
    isDec :: Char -> Bool
    isDec c = c >= '0' && c <= '9'
  
    protectEsc :: (Char -> Bool) -> SymbolS -> SymbolS
    protectEsc p f             = f . cont
                                 -- where cont s@(c:_) | p c = "\\&" ++ s
                                 --       cont s             = s
                                 where cont s = case unconsSymbol s of
                                         Just (c, _) | p c -> "\\&" <> s
                                         Nothing           -> s
  
    asciiTab :: [Symbol]
    asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
               ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
                "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
                "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
                "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
                "SP"]
    |])
  
  instance PShow Char where
    type ShowsPrec p c x = ShowsCharPrec p c x
    type ShowList cs x = ShowCharList cs x
  
  instance SShow Char where
    sShowsPrec sp sc sx =
      let p  = fromSing sp
          c  = fromSing sc
          x  = fromSing sx
      in withSomeSSymbol (P.showsPrec (fromIntegral p) c (T.unpack x)) unsafeCoerce
  
    sShowList scs sx =
      let cs = fromSing scs
          x  = fromSing sx
      in withSomeSSymbol (P.showList cs (T.unpack x)) unsafeCoerce
  
  instance PShow Symbol where
    type ShowsPrec _ s x = ShowSymbol s x
  
  instance SShow Symbol where
    sShowsPrec _ ss sx =
      let s  = fromSing ss
          x  = fromSing sx
      in withSomeSSymbol (P.show s ++ T.unpack x) unsafeCoerce
  
  -- | 'P.show', but with an extra underscore so that its promoted counterpart
  -- ('Show_') will not clash with the 'Show' class.
  show_ :: P.Show a => a -> String
  show_ = P.show
  
  $(singShowInstances [ ''(), ''Maybe, ''Either, ''NonEmpty, ''Bool,
                        ''Ordering, ''Void ])
  