{-# LANGUAGE TemplateHaskellQuotes #-}

-- | Generate the operator type.

module Math.Haskellator.Internal.TH.OperGeneration (
      OperatorDef (..)
    , generateOperators
    ) where

import Language.Haskell.TH

operADT :: Name
operADT :: Name
operADT = String -> Name
mkName String
"Op"

-- | Definition of a operator
data OperatorDef = OperDef -- ^ Operator definition
                   String  -- ^ Operator name
                   String  -- ^ Operator symbol

-- | Generate the operator type. Imagine the following call: @generateOperators [OperDef "Plus" "+", OperDef "Minus" "-"]@.
-- This function will then generate the following code:
--
--     * A data type with all the operators
--
-- > data Op = Plus | Minus
--
--     * An instance of Show for the data type
--
-- > instance Show Op where
-- >   show Plus = "+"
-- >   show Minus = "-"
generateOperators :: [OperatorDef] -> Q [Dec]
generateOperators :: [OperatorDef] -> Q [Dec]
generateOperators [OperatorDef]
operators = do
  let operatorConstructors :: [Con]
operatorConstructors = OperatorDef -> Con
mkConstructor (OperatorDef -> Con) -> [OperatorDef] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OperatorDef]
operators
      showClauses :: [Clause]
showClauses          = OperatorDef -> Clause
mkShowClause (OperatorDef -> Clause) -> [OperatorDef] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OperatorDef]
operators

      dataDec :: Dec
dataDec              = Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
operADT [] Maybe Kind
forall a. Maybe a
Nothing [Con]
operatorConstructors [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Kind
ConT ''Enum, Name -> Kind
ConT ''Bounded]]
      showInstance :: Dec
showInstance         = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Show) (Name -> Kind
ConT Name
operADT)) [Name -> [Clause] -> Dec
FunD 'show [Clause]
showClauses]

  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
dataDec, Dec
showInstance]

mkConstructor :: OperatorDef -> Con
mkConstructor :: OperatorDef -> Con
mkConstructor (OperDef String
n String
_) = Name -> [BangType] -> Con
NormalC (String -> Name
mkName String
n) []

mkShowClause :: OperatorDef -> Clause
mkShowClause :: OperatorDef -> Clause
mkShowClause (OperDef String
n String
s) =
  let pattern :: Pat
pattern = Name -> Cxt -> [Pat] -> Pat
ConP (String -> Name
mkName String
n) [] []
      body :: Body
body    = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
s
  in [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pattern] Body
body []