-- |
-- Module      : Math.LaTeX.Internal.OperatorGenerator
-- Copyright   : (c) Justus Sagemüller 2017
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 

{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE CPP                 #-}

module Math.LaTeX.Internal.OperatorGenerator where

import CAS.Dumb.Tree
import CAS.Dumb.Symbols

import Language.Haskell.TH
import Language.Haskell.Meta.Parse
import Data.Char

import qualified Data.HashSet as HS
import qualified Data.Hashable as HS

operatorExpression :: Fixity -> s² -> CAS' γ (Infix s²) s¹ s⁰
                -> CAS' γ (Infix s²) s¹ s⁰ -> CAS' γ (Infix s²) s¹ s⁰
operatorExpression :: forall s² γ s¹ s⁰.
Fixity
-> s²
-> CAS' γ (Infix s²) s¹ s⁰
-> CAS' γ (Infix s²) s¹ s⁰
-> CAS' γ (Infix s²) s¹ s⁰
operatorExpression Fixity
fxty s²
iop = forall s² γ s¹ s⁰.
s² -> CAS' γ s² s¹ s⁰ -> CAS' γ s² s¹ s⁰ -> CAS' γ s² s¹ s⁰
symbolInfix (forall s. Fixity -> s -> Infix s
Infix Fixity
fxty s²
iop)

chainOperatorExpression :: (Eq s², HS.Hashable s²)
          => Fixity -> HS.HashSet s² -> s² -> CAS' γ (Infix s²) s¹ s⁰
                -> CAS' γ (Infix s²) s¹ s⁰ -> CAS' γ (Infix s²) s¹ s⁰
chainOperatorExpression :: forall s² γ s¹ s⁰.
(Eq s², Hashable s²) =>
Fixity
-> HashSet s²
-> s²
-> CAS' γ (Infix s²) s¹ s⁰
-> CAS' γ (Infix s²) s¹ s⁰
-> CAS' γ (Infix s²) s¹ s⁰
chainOperatorExpression Fixity
fxty HashSet s²
caste s²
iop = forall s² γ s¹ s⁰.
(s² -> Bool)
-> s² -> CAS' γ s² s¹ s⁰ -> CAS' γ s² s¹ s⁰ -> CAS' γ s² s¹ s⁰
chainableInfix Infix s² -> Bool
isInCaste (forall s. Fixity -> s -> Infix s
Infix Fixity
fxty s²
iop)
 where isInCaste :: Infix s² -> Bool
isInCaste (Infix Fixity
_ s²
iop') = s²
iop' forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet s²
caste

makeOperatorCaste :: String   -- ^ What to call the collection of operators
                  -> (Name, Name)
                              -- ^ Haskell type of the final operators
                              --   and of the infix primitives therein
                  -> Fixity
                  -> Bool     -- ^ Should the ops in this caste be chainable?
                  -> [(String, ExpQ)]
                              -- ^ The operator symbols with corresponding implementation
                  -> DecsQ
makeOperatorCaste :: String
-> (Name, Name) -> Fixity -> Bool -> [(String, ExpQ)] -> DecsQ
makeOperatorCaste String
caste (Name
typeSig, Name
opType) Fixity
fxty Bool
isChainable [(String, ExpQ)]
ops
                = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecsQ
mkCollection
                                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Monad m => (String, m Exp) -> m [Dec]
mkOp [(String, ExpQ)]
ops
 where mkCollection :: DecsQ
mkCollection
        | Bool
isChainable  = do
           [Exp]
opRenditions <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a, b) -> b
snd [(String, ExpQ)]
ops
           forall (m :: * -> *) a. Monad m => a -> m a
return
            [ Name -> Type -> Dec
SigD Name
casteName forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''HS.HashSet Type -> Type -> Type
`AppT` Name -> Type
ConT Name
opType
            , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
casteName)
                   (Exp -> Body
NormalB
                     forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'HS.fromList
                        Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
opRenditions )
                   []
            ]
        | Bool
otherwise    = forall (m :: * -> *) a. Monad m => a -> m a
return []
       mkOp :: (String, m Exp) -> m [Dec]
mkOp (String
op, m Exp
implementation) = do
        Exp
impExp <- m Exp
implementation
        forall (m :: * -> *) a. Monad m => a -> m a
return
         [ Fixity -> Name -> Dec
InfixD Fixity
fxty Name
opName
         , Name -> Type -> Dec
SigD Name
opName forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
typeSig
         , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
opName)
                (Exp -> Body
NormalB
                   forall a b. (a -> b) -> a -> b
$ if Bool
isChainable
                      then Name -> Exp
VarE 'chainOperatorExpression
                             Exp -> Exp -> Exp
`AppE` Exp
fxtyE Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
casteName Exp -> Exp -> Exp
`AppE` Exp
impExp
                      else Name -> Exp
VarE 'operatorExpression Exp -> Exp -> Exp
`AppE` Exp
fxtyE Exp -> Exp -> Exp
`AppE` Exp
impExp)
                [] ]
        where opName :: Name
opName = String -> Name
mkName String
op
              fxtyE :: Exp
fxtyE = case String -> Either String Exp
parseExp forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Fixity
fxty of
                 Right Exp
fe -> Exp
fe
                 Left String
err -> forall a. HasCallStack => String -> a
error String
err
       casteName :: Name
casteName = String -> Name
mkName String
caste