{-|
Copyright  :  (C) 2013-2016, University of Twente
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

{-# LANGUAGE Safe #-}

{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Promoted.Symbol
  (SSymbol (..), ssymbolProxy, ssymbolToString)
where

import Language.Haskell.TH.Syntax
import GHC.Show     (appPrec)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

-- | Singleton value for a type-level string @s@
data SSymbol (s :: Symbol) where
  SSymbol :: KnownSymbol s => SSymbol s

instance KnownSymbol s => Lift (SSymbol (s :: Symbol)) where
--  lift :: t -> Q Exp
  lift :: SSymbol s -> Q Exp
lift t :: SSymbol s
t = Exp -> Q Exp
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'SSymbol) Type
tt)
    where
      tt :: Type
tt = TyLit -> Type
LitT (String -> TyLit
StrTyLit (SSymbol s -> String
forall (s :: Symbol). SSymbol s -> String
ssymbolToString SSymbol s
t))


instance Show (SSymbol s) where
  showsPrec :: Int -> SSymbol s -> ShowS
showsPrec d :: Int
d s :: SSymbol s
s@SSymbol s
SSymbol = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString "SSymbol @" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows (SSymbol s -> String
forall (s :: Symbol). SSymbol s -> String
ssymbolToString SSymbol s
s)

{-# INLINE ssymbolProxy #-}
-- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for
-- /s/
ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s
ssymbolProxy :: proxy s -> SSymbol s
ssymbolProxy _ = SSymbol s
forall (s :: Symbol). KnownSymbol s => SSymbol s
SSymbol

{-# INLINE ssymbolToString #-}
-- | Reify the type-level 'Symbol' @s@ to it's term-level 'String'
-- representation.
ssymbolToString :: SSymbol s -> String
ssymbolToString :: SSymbol s -> String
ssymbolToString s :: SSymbol s
s@SSymbol s
SSymbol = SSymbol s -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal SSymbol s
s