{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy           #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | A (slightly unsafe) term level implementation for 'Symbol'.
--
-- As 'Symbol' in @base@ doesn't have any term-level operations,
-- it's sometimes necessary to have two copies of the same data,
-- the first one using 'String' on term level and
-- second one using 'Symbol' to be promtoed to type level.
--
-- In GHC-9.2 the similar problem was fixed for @Nat@ and @Natural@,
-- which were distinct types (kinds) before that.
--
-- As 'String' is a list of 'Char's, we cannot make @type 'Symbol' = 'String'@,
-- but we could do @newtype 'Symbol' = MkSymbol 'String'@.
-- This module /fakes/ that by using 'unsafeCoerce' under the hood.
--
-- Fleshing out 'Symbol' on term level is suggested in
-- https://gitlab.haskell.org/ghc/ghc/-/issues/10776#note_109601
-- in 2015.
--
-- This implementation is slightly unsafe, as currently 'Symbol' is defined
-- as empty data type:
--
-- @
-- data 'Symbol'
-- @
--
-- This means that you can write
--
-- @
-- dangerous :: Symbol -> Int
-- dangerous x = case x of
-- @
--
-- and because GHC sees through everything, and knows that 'Symbol' is empty,
-- the above compiles without a warning.
--
-- If 'Symbol' was defined as @newtype Symbol = Symbol Any@, the
-- above problem would go away, and also implementation of this
-- module would be safer, as 'unsafeCoerce'ing from lifted type to 'Any'
-- and back is guaranteed to work.
--
-- Of course life would be easier if we just had
--
-- @
-- newtype 'Symbol' = MkSymbol 'String'
-- @
--
-- but until that is done, you may find this module useful.
--
-- /Note:/ 'Symbol' is not @Text@. @Text@ has an invariant: it represents /valid/ Unicode text.
-- 'Symbol' is just a list of characters (= Unicode codepoints), like 'String'.
-- E.g.
--
-- >>> "\55555" :: String
-- "\55555"
--
-- >>> "\55555" :: Symbol
-- "\55555"
--
-- but @text@ replaces surrogate codepoints:
--
-- >>> "\55555" :: Text
-- "\65533"
--
-- 'Symbol' could use some packed representation of list of characters,
-- if also 'KnownSymbol' would use it as well. Currently
-- 'KnownSymbol' dictionary carries a 'String', so having
-- 'Symbol' be a 'String' is justified'.
--
module GHC.Symbol (
    -- * Symbol type
    Symbol,
    symbolToString,
    consSymbol,
    unconsSymbol,
    -- * Type level
    KnownSymbol,
    symbolVal,
    symbolVal',
    AppendSymbol,
    CmpSymbol,
    someSymbolVal,
    SomeSymbol (..),
    sameSymbol,
) where

import Control.DeepSeq            (NFData (..))
import Data.Binary                (Binary (..))
import Data.String                (IsString (..))
import GHC.Exts                   (IsList (..), Proxy#)
import GHC.TypeLits
       (AppendSymbol, CmpSymbol, KnownSymbol, SomeSymbol, Symbol, sameSymbol)
import Language.Haskell.TH.Syntax (Lift (..))
import Text.Printf                (PrintfArg (..))
import Unsafe.Coerce              (unsafeCoerce)

import qualified GHC.TypeLits as GHC

-- $setup
-- >>> :set -XOverloadedStrings -XTypeApplications -XDataKinds
-- >>> import Data.Text (Text)
-- >>> import Data.Proxy (Proxy (..))

-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------

symbolToString :: Symbol -> String
symbolToString :: Symbol -> String
symbolToString = Symbol -> String
forall a b. a -> b
unsafeCoerce @Symbol @String

symbolFromString :: String -> Symbol
symbolFromString :: String -> Symbol
symbolFromString = String -> Symbol
forall a b. a -> b
unsafeCoerce @String @Symbol

-------------------------------------------------------------------------------
-- Public interface
-------------------------------------------------------------------------------

-- this is not exported though, use mempty or "".
emptySymbol :: Symbol
emptySymbol :: Symbol
emptySymbol = String -> Symbol
symbolFromString String
""

-- | Prepend a character to a 'Symbol'
--
-- >>> consSymbol 'a' "cute"
-- "acute"
--
consSymbol :: Char -> Symbol -> Symbol
consSymbol :: Char -> Symbol -> Symbol
consSymbol Char
c Symbol
s = String -> Symbol
symbolFromString (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Symbol -> String
symbolToString Symbol
s)

-- | Inverse of 'consSymbol'
--
-- >>> unconsSymbol ""
-- Nothing
--
-- >>> unconsSymbol "mother"
-- Just ('m',"other")
--
unconsSymbol :: Symbol -> Maybe (Char, Symbol)
unconsSymbol :: Symbol -> Maybe (Char, Symbol)
unconsSymbol Symbol
s = case Symbol -> String
symbolToString Symbol
s of
    []   -> Maybe (Char, Symbol)
forall a. Maybe a
Nothing
    Char
c:String
s' -> (Char, Symbol) -> Maybe (Char, Symbol)
forall a. a -> Maybe a
Just (Char
c, String -> Symbol
symbolFromString String
s')

-- instances

-- |
--
-- >>> "foo" :: Symbol
-- "foo"
--
instance Show Symbol where
    showsPrec :: Int -> Symbol -> String -> String
showsPrec Int
d Symbol
s = Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
d (Symbol -> String
symbolToString Symbol
s)

instance Read Symbol where
    readsPrec :: Int -> ReadS Symbol
readsPrec Int
d String
s = [ (String -> Symbol
symbolFromString String
x, String
s') | ~(String
x, String
s') <- Int -> ReadS String
forall a. Read a => Int -> ReadS a
readsPrec Int
d String
s ]

instance Eq Symbol where
    Symbol
x == :: Symbol -> Symbol -> Bool
== Symbol
y = Symbol -> String
symbolToString Symbol
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> String
symbolToString Symbol
y

instance Ord Symbol where
    compare :: Symbol -> Symbol -> Ordering
compare Symbol
x Symbol
y = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Symbol -> String
symbolToString Symbol
x) (Symbol -> String
symbolToString Symbol
y)

-- |
--
-- >>> "foo" :: Symbol
-- "foo"
--
instance IsString Symbol where
    fromString :: String -> Symbol
fromString = String -> Symbol
symbolFromString

instance Semigroup Symbol where
     Symbol
x <> :: Symbol -> Symbol -> Symbol
<> Symbol
y = String -> Symbol
symbolFromString (Symbol -> String
symbolToString Symbol
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Symbol -> String
symbolToString Symbol
y)

instance Monoid Symbol where
    mempty :: Symbol
mempty = Symbol
emptySymbol
    mappend :: Symbol -> Symbol -> Symbol
mappend = Symbol -> Symbol -> Symbol
forall a. Semigroup a => a -> a -> a
(<>)

instance NFData Symbol where
    rnf :: Symbol -> ()
rnf Symbol
s = String -> ()
forall a. NFData a => a -> ()
rnf (Symbol -> String
symbolToString Symbol
s)

instance Binary Symbol where
    get :: Get Symbol
get = (String -> Symbol) -> Get String -> Get Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Symbol
symbolFromString Get String
forall t. Binary t => Get t
get
    put :: Symbol -> Put
put Symbol
s = String -> Put
forall t. Binary t => t -> Put
put (Symbol -> String
symbolToString Symbol
s)

instance Lift Symbol where
    liftTyped :: Symbol -> Q (TExp Symbol)
liftTyped Symbol
s = [|| symbolFromString s' ||] where s' :: String
s' = Symbol -> String
symbolToString Symbol
s

instance PrintfArg Symbol where
    formatArg :: Symbol -> FieldFormatter
formatArg Symbol
s = String -> FieldFormatter
forall a. PrintfArg a => a -> FieldFormatter
formatArg (Symbol -> String
symbolToString Symbol
s)

instance IsList Symbol where
    type Item Symbol = Char
    fromList :: [Item Symbol] -> Symbol
fromList = String -> Symbol
[Item Symbol] -> Symbol
symbolFromString
    toList :: Symbol -> [Item Symbol]
toList   = Symbol -> String
Symbol -> [Item Symbol]
symbolToString

-------------------------------------------------------------------------------
-- TypeLits
-------------------------------------------------------------------------------

-- |
--
-- >>> symbolVal (Proxy @"foobar")
-- "foobar"
--
symbolVal :: forall n proxy. KnownSymbol n => proxy n -> Symbol
symbolVal :: proxy n -> Symbol
symbolVal proxy n
p = String -> Symbol
symbolFromString (proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
GHC.symbolVal proxy n
p)

symbolVal' :: forall n. KnownSymbol n => Proxy# n -> Symbol
symbolVal' :: Proxy# n -> Symbol
symbolVal' Proxy# n
p = String -> Symbol
symbolFromString (Proxy# n -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
GHC.symbolVal' Proxy# n
p)

-- |
--
-- >>> someSymbolVal "foobar"
-- "foobar"
--
someSymbolVal :: Symbol -> SomeSymbol
someSymbolVal :: Symbol -> SomeSymbol
someSymbolVal Symbol
s = String -> SomeSymbol
GHC.someSymbolVal (Symbol -> String
symbolToString Symbol
s)