module Data.Singletons.Single.Fixity where

import Prelude hiding ( exp )
import Language.Haskell.TH hiding ( cxt )
import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))
import Data.Singletons.Util
import Data.Singletons.Names
import Language.Haskell.TH.Desugar

singInfixDecl :: DsMonad q => Name -> Fixity -> q DLetDec
singInfixDecl :: Name -> Fixity -> q DLetDec
singInfixDecl name :: Name
name fixity :: Fixity
fixity = do
  Maybe NameSpace
mb_ns <- Name -> q (Maybe NameSpace)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe NameSpace)
reifyNameSpace Name
name
  DLetDec -> q DLetDec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DLetDec -> q DLetDec) -> DLetDec -> q DLetDec
forall a b. (a -> b) -> a -> b
$ Fixity -> Name -> DLetDec
DInfixD Fixity
fixity
       (Name -> DLetDec) -> Name -> DLetDec
forall a b. (a -> b) -> a -> b
$ case Maybe NameSpace
mb_ns of
           Just TcClsName -> Name -> Name
singTyConName Name
name
           Just DataName  -> Name -> Name
singDataConName Name
name
           Just VarName   -> Name -> Name
singValName Name
name
           -- If we can't find the Name for some odd reason,
           -- fall back to singValName
           Nothing        -> Name -> Name
singValName Name
name

singFixityDeclaration :: DsMonad q => Name -> q [DDec]
singFixityDeclaration :: Name -> q [DDec]
singFixityDeclaration name :: Name
name = do
  Maybe Fixity
mFixity <- Name -> q (Maybe Fixity)
forall (m :: * -> *). Quasi m => Name -> m (Maybe Fixity)
qReifyFixity Name
name
  case Maybe Fixity
mFixity of
    Nothing     -> [DDec] -> q [DDec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just fixity :: Fixity
fixity -> [q DDec] -> q [DDec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [DLetDec -> DDec
DLetDec (DLetDec -> DDec) -> q DLetDec -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Fixity -> q DLetDec
forall (q :: * -> *). DsMonad q => Name -> Fixity -> q DLetDec
singInfixDecl Name
name Fixity
fixity]

singFixityDeclarations :: DsMonad q => [Name] -> q [DDec]
singFixityDeclarations :: [Name] -> q [DDec]
singFixityDeclarations = (Name -> q [DDec]) -> [Name] -> q [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [DDec]
forall (m :: * -> *). DsMonad m => Name -> m [DDec]
trySingFixityDeclaration
  where
    trySingFixityDeclaration :: Name -> m [DDec]
trySingFixityDeclaration name :: Name
name =
      m [DDec] -> m [DDec] -> m [DDec]
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover ([DDec] -> m [DDec]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (Name -> m [DDec]
forall (m :: * -> *). DsMonad m => Name -> m [DDec]
singFixityDeclaration Name
name)