-- |
-- Module      : CAS.Dumb.Symbols.PatternGenerator
-- 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 CAS.Dumb.Symbols.PatternGenerator (makeSymbols, makeQualifiedSymbols) where

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

import Language.Haskell.TH
import Data.Char


makeSymbols :: Name   -- ^ Desired type of the symbols.
            -> [Char] -- ^ The letters you want as symbols.
            -> DecsQ
makeSymbols :: Name -> [Char] -> DecsQ
makeSymbols Name
t = Name -> [Char] -> [Char] -> DecsQ
makeQualifiedSymbols Name
t [Char]
""

plainTVinf :: Name -> TyVarBndr
#if MIN_VERSION_template_haskell(2,17,0)
                                Specificity
plainTVinf :: Name -> TyVarBndr Specificity
plainTVinf Name
n = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
inferredSpec
#else
plainTVinf = PlainTV
#endif

conPnoTA :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conPnoTA :: Name -> [Pat] -> Pat
conPnoTA Name
n [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
n [] [Pat]
pats
#else
conPnoTA = ConP
#endif

makeQualifiedSymbols
            :: Name   -- ^ Desired type of the symbols.
            -> String -- ^ Prefix for the generated Haskell names.
            -> [Char] -- ^ The letters you want as symbols.
            -> DecsQ
makeQualifiedSymbols :: Name -> [Char] -> [Char] -> DecsQ
makeQualifiedSymbols Name
casType [Char]
namePrefix = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Monad m => Char -> m [Dec]
mkSymbol
 where mkSymbol :: Char -> m [Dec]
mkSymbol Char
c
        | Char -> Bool
isLower (forall a. [a] -> a
head [Char]
idfyer) = forall (m :: * -> *) a. Monad m => a -> m a
return
         [ Name -> Type -> Dec
SigD Name
symbName forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [Name -> TyVarBndr Specificity
plainTVinf Name
γ, Name -> TyVarBndr Specificity
plainTVinf Name
s¹, Name -> TyVarBndr Specificity
plainTVinf Name
s², Name -> TyVarBndr Specificity
plainTVinf Name
ζ] [] Type
typeName
        -- c :: casType γ s² s¹ ζ
         , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
symbName)
                (Exp -> Body
NormalB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Symbol)
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'PrimitiveSymbol)
                         forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Char -> Lit
CharL Char
c) )
                []
        -- c = Symbol $ StringSymbol "c"
         ]
#if __GLASGOW_HASKELL__ > 801
        | Char -> Bool
isUpper (forall a. [a] -> a
head [Char]
idfyer) = forall (m :: * -> *) a. Monad m => a -> m a
return
         [ Name -> Type -> Dec
PatSynSigD Name
symbName ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [] [] forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [] [] Type
typeName)
        -- pattern c :: casType γ s² s¹ ζ
         , Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
symbName
                   ([Name] -> PatSynArgs
PrefixPatSyn [])
                   PatSynDir
ImplBidir
                   ('Symbol Name -> [Pat] -> Pat
`conPnoTA` ['PrimitiveSymbol Name -> [Pat] -> Pat
`conPnoTA` [Lit -> Pat
LitP forall a b. (a -> b) -> a -> b
$ Char -> Lit
CharL Char
c]])
        -- pattern c = Symbol (StringSymbol ['c'])
         ] 
#endif
        | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error
             forall a b. (a -> b) -> a -> b
$ [Char]
"Can only make symbols out of lower- or uppercase letters, which '"
                                forall a. [a] -> [a] -> [a]
++ [Char
c] forall a. [a] -> [a] -> [a]
++ [Char]
"' is not."
        where idfyer :: [Char]
idfyer = [Char]
namePrefix forall a. [a] -> [a] -> [a]
++ [Char
c]
              symbName :: Name
symbName = [Char] -> Name
mkName [Char]
idfyer
              typeName :: Type
typeName = Name -> Type
ConT Name
casTypeType -> Type -> Type
`AppT`Name -> Type
VarT Name
γType -> Type -> Type
`AppT`Name -> Type
VarT Name
s²Type -> Type -> Type
`AppT`Name -> Type
VarT Name
s¹Type -> Type -> Type
`AppT`Name -> Type
VarT Name
ζ
              [Name
γ,Name
s²,Name
s¹,Name
ζ] = [Char] -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"γ",[Char]
"s²",[Char]
"s¹",[Char]
"ζ"]