content: module Data.Singletons.TH.Single.Fixity where
  
  import Prelude hiding ( exp )
  import Language.Haskell.TH hiding ( cxt )
  import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))
  import Data.Singletons.TH.Options
  import Data.Singletons.TH.Util
  import Language.Haskell.TH.Desugar
  import qualified GHC.LanguageExtensions.Type as LangExt
  
  -- Single a fixity declaration.
  singInfixDecl :: forall q. OptionsMonad q => Name -> Fixity -> q (Maybe DLetDec)
  singInfixDecl name fixity = do
    opts <- getOptions
    fld_sels <- qIsExtEnabled LangExt.FieldSelectors
    mb_ns <- reifyNameSpace name
    case mb_ns of
      -- If we can't find the Name for some odd reason,
      -- fall back to singValName
      Nothing          -> finish DataNamespaceSpecifier $ singledValueName   opts name
      Just VarName     -> finish DataNamespaceSpecifier $ singledValueName   opts name
      Just (FldName _)
        | fld_sels     -> finish DataNamespaceSpecifier $ singledValueName   opts name
        | otherwise    -> never_mind
      Just DataName    -> finish DataNamespaceSpecifier $ singledDataConName opts name
      Just TcClsName   -> do
        mb_info <- dsReify name
        case mb_info of
          Just (DTyConI DClassD{} _)
            -> finish TypeNamespaceSpecifier $ singledClassName opts name
          _ -> never_mind
            -- Don't produce anything for other type constructors (type synonyms,
            -- type families, data types, etc.).
            -- See [singletons-th and fixity declarations], wrinkle 1.
    where
      finish :: NamespaceSpecifier -> Name -> q (Maybe DLetDec)
      finish ns n = pure $ Just $ DInfixD fixity ns n
  
      never_mind :: q (Maybe DLetDec)
      never_mind = pure Nothing
  
  -- Try producing singled fixity declarations for Names by reifying them
  -- /without/ consulting quoted declarations. If reification fails, recover and
  -- return the empty list.
  -- See [singletons-th and fixity declarations], wrinkle 2.
  singReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]
  singReifiedInfixDecls = mapMaybeM trySingFixityDeclaration
    where
      trySingFixityDeclaration :: Name -> q (Maybe DDec)
      trySingFixityDeclaration name =
        qRecover (return Nothing) $ do
          mFixity <- qReifyFixity name
          case mFixity of
            Nothing     -> pure Nothing
            Just fixity -> fmap (fmap DLetDec) $ singInfixDecl name fixity
  
  {-
  Note [singletons-th and fixity declarations]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Promoting and singling fixity declarations is surprisingly tricky to get right.
  This Note serves as a place to document the insights learned after getting this
  wrong at various points.
  
  As a general rule, when promoting something with a fixity declaration like this
  one:
  
    infixl 5 `foo`
  
  singletons-th will produce promoted and singled versions of them:
  
    infixl 5 type `Foo`
    infixl 5 data `sFoo`
  
  singletons-th will also produce fixity declarations for its defunctionalization
  symbols (see Note [Fixity declarations for defunctionalization symbols] in
  D.S.TH.Promote.Defun):
  
    infixl 5 type `FooSym0`
    infixl 5 type `FooSym1`
    ...
  
  -----
  -- Wrinkle 1: When not to promote/single fixity declarations
  -----
  
  Rules are meant to be broken, and the general rule above is no exception. There
  are certain cases where singletons-th does *not* produce promoted or singled
  versions of fixity declarations:
  
  * During promotion, fixity declarations for the following sorts of names will
    not receive promoted counterparts:
  
    - Data types
    - Type synonyms
    - Type families
    - Data constructors
    - Infix values (when their fixity declaration lack explicit namespaces)
  
    We exclude the first four because the promoted versions of these names are
    the same as the originals, so generating an extra fixity declaration for them
    would run the risk of having duplicates, which GHC would reject with an error.
  
    We exclude infix values when their fixity declarations lack explicit
    namespaces because while their promoted versions are different, they share
    the same name base. In concrete terms, this:
  
      $(promote [d|
        infixl 4 ###
        (###) :: a -> a -> a
        |])
  
    Is promoted to the following:
  
      type family (###) (x :: a) (y :: a) :: a where ...
  
    Note that the original `infixl 4 ###` declaration lacks an explicit
    namespace, which means that it applies to both the term-level *and*
    type-level (###) definitions. This means that giving the type-level (###) a
    fixity declaration would clash with the original fixity declaration.
  
    There *are* scenarios where we should generate a fixity declaration for the
    type-level (###), however:
  
    - Imagine if the fixity declaration had an explicit `data` namespace:
  
        $(promote [d|
          infixl 4 data ###
          (###) :: a -> a -> a
          |])
  
      Then it would be fine to give the promoted (###) definition this fixity
      declaration:
  
        infixl 4 type ###
  
      This is because the two fixity declarations would refer to distinct names
      in a different namespaces, so the two fixity declarations would not clash.
  
    - Imagine the above example used the `promoteOnly` function instead of
      `promote`. Then the type-level (###) would lack a fixity declaration
      altogether because the original fixity declaration was discarded by
      `promoteOnly`! The same problem would arise if one had to choose between
      the `singletons` and `singletonsOnly` functions.
  
      The difference between `promote` and `promoteOnly` (as well as `singletons`
      and `singletonsOnly`) is whether the `genQuotedDecs` option is set to
      `True` or `False`, respectively. Therefore, if `genQuotedDecs` is set to
      `False` when promoting the fixity declaration for an infix value, we opt to
      generate a fixity declaration (with the same name base) so that the
      type-level version of that value gets one.
  
  * During singling, the following things will not have their fixity declarations
    singled:
  
    - Type synonyms or type families. This is because singletons-th does not
      generate singled versions of them in the first place (they only receive
      defunctionalization symbols).
  
    - Data types. This is because the singled version of a data type T is
      always of the form:
  
        data ST :: forall a_1 ... a_n. T a_1 ... a_n -> Type where ...
  
      Regardless of how many arguments T has, ST will have exactly one argument.
      This makes is rather pointless to generate a fixity declaration for it.
  
  -----
  -- Wrinkle 2: Making sure fixity declarations are promoted/singled properly
  -----
  
  There are two situations where singletons-th must promote/single fixity
  declarations:
  
  1. When quoting code, i.e., with `promote` or `singletons`.
  2. When reifying code, i.e., with `genPromotions` or `genSingletons`.
  
  In the case of (1), singletons-th stores the quoted fixity declarations in the
  lde_infix field of LetDecEnv. Therefore, it suffices to call
  promoteInfixDecl/singleInfixDecl when processing LetDecEnvs.
  
  In the case of (2), there is no LetDecEnv to use, so we must instead reify
  the fixity declarations and promote/single those. See D.S.TH.Single.Data.singDataD
  (which singles data constructors) for a place that does this—we will use
  singDataD as a running example for the rest of this section.
  
  One complication is that code paths like singDataD are invoked in both (1) and
  (2). This runs the risk that singletons-th will generate duplicate infix
  declarations for data constructors in situation (1), as it will try to single
  their fixity declarations once when processing them in LetDecEnvs and again
  when reifying them in singDataD.
  
  To avoid this pitfall, when reifying declarations in singDataD we take care
  *not* to consult any quoted declarations when reifying (i.e., we do not use
  reifyWithLocals for functions like it). Therefore, it we are in situation (1),
  then the reification in singDataD will fail (and recover gracefully), so it
  will not produce any singled fixity declarations. Therefore, the only singled
  fixity declarations will be produced by processing LetDecEnvs.
  -}
  