{-
pandoc-crossref is a pandoc filter for numbering figures,
equations, tables and cross-references to them.
Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}

{-# LANGUAGE TemplateHaskell, RankNTypes, ViewPatterns, MultiWayIf #-}
module Text.Pandoc.CrossRef.Util.Settings.Template where

import Text.Pandoc.Definition
import Text.Pandoc.Builder
import Text.Pandoc.CrossRef.Util.Meta
import qualified Data.Map as M
import Language.Haskell.TH hiding (Inline)
import Language.Haskell.TH.Syntax hiding (Inline)
import Data.List
import Text.Pandoc.CrossRef.Util.Template
import Text.Pandoc.CrossRef.Util.CustomLabels (customLabel)
import Data.Text (Text)
import qualified Data.Text as T

namedFields :: Con -> [VarStrictType]
namedFields :: Con -> [VarStrictType]
namedFields (RecC Name
_ [VarStrictType]
fs) = [VarStrictType]
fs
namedFields (ForallC [TyVarBndr]
_ Cxt
_ Con
c) = Con -> [VarStrictType]
namedFields Con
c
namedFields Con
_ = []

fromRecDef :: forall t a r. Name -> t -> (Name -> Name -> Q [a]) -> (t -> [a] -> r) -> Q r
fromRecDef :: Name -> t -> (Name -> Name -> Q [a]) -> (t -> [a] -> r) -> Q r
fromRecDef Name
t t
cname Name -> Name -> Q [a]
f t -> [a] -> r
c = do
  Info
info <- Name -> Q Info
reify Name
t
  Dec
reified <- case Info
info of
                  TyConI Dec
dec -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
                  Info
_ -> String -> Q Dec
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No cons"
  ([TyVarBndr]
_, [Con]
cons) <- case Dec
reified of
               DataD Cxt
_ Name
_ [TyVarBndr]
params Maybe Kind
_ [Con]
cons' [DerivClause]
_ -> ([TyVarBndr], [Con]) -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
params, [Con]
cons')
               NewtypeD Cxt
_ Name
_ [TyVarBndr]
params Maybe Kind
_ Con
con' [DerivClause]
_ -> ([TyVarBndr], [Con]) -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr]
params, [Con
con'])
               Dec
_ -> String -> Q ([TyVarBndr], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No cons"
  [a]
decs <- ([[a]] -> [a]) -> Q [[a]] -> Q [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[a]] -> Q [a])
-> ([VarStrictType] -> Q [[a]]) -> [VarStrictType] -> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarStrictType -> Q [a]) -> [VarStrictType] -> Q [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Name
name,Bang
_,Kind
_) -> Name -> Name -> Q [a]
f Name
t Name
name) ([VarStrictType] -> Q [[a]])
-> ([VarStrictType] -> [VarStrictType])
-> [VarStrictType]
-> Q [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VarStrictType] -> [VarStrictType]
forall a. Eq a => [a] -> [a]
nub ([VarStrictType] -> Q [a]) -> [VarStrictType] -> Q [a]
forall a b. (a -> b) -> a -> b
$ (Con -> [VarStrictType]) -> [Con] -> [VarStrictType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [VarStrictType]
namedFields [Con]
cons
  r -> Q r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Q r) -> r -> Q r
forall a b. (a -> b) -> a -> b
$ t -> [a] -> r
c t
cname [a]
decs

nameDeriveSetters :: Name -> Q [Dec]
nameDeriveSetters :: Name -> Q [Dec]
nameDeriveSetters Name
t = Name
-> Any
-> (Name -> Name -> Q [Dec])
-> (Any -> [Dec] -> [Dec])
-> Q [Dec]
forall t a r.
Name -> t -> (Name -> Name -> Q [a]) -> (t -> [a] -> r) -> Q r
fromRecDef Name
t Any
forall a. HasCallStack => a
undefined ((Name -> Q [Dec]) -> Name -> Name -> Q [Dec]
forall a b. a -> b -> a
const Name -> Q [Dec]
makeAcc) (([Dec] -> [Dec]) -> Any -> [Dec] -> [Dec]
forall a b. a -> b -> a
const [Dec] -> [Dec]
forall a. a -> a
id)

dropQualifiers :: Name -> Name
dropQualifiers :: Name -> Name
dropQualifiers (Name OccName
occ NameFlavour
_) = String -> Name
mkName (OccName -> String
occString OccName
occ)

makeAcc :: Name -> Q [Dec]
makeAcc :: Name -> Q [Dec]
makeAcc (Name -> Name
dropQualifiers -> Name
accName) = do
    Exp
body <- [| Meta . M.singleton $(liftString $ show accName) . toMetaValue |]
    Kind
sig <- [t|forall a. ToMetaValue a => a -> Meta|]
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Name -> Kind -> Dec
SigD Name
accName Kind
sig
      , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
accName) (Exp -> Body
NormalB Exp
body) []
      ]

makeCon :: Name -> Name -> Q Exp
makeCon :: Name -> Name -> Q Exp
makeCon Name
t Name
cname = Name
-> Name
-> (Name -> Name -> Q [(Name, Exp)])
-> (Name -> [(Name, Exp)] -> Exp)
-> Q Exp
forall t a r.
Name -> t -> (Name -> Name -> Q [a]) -> (t -> [a] -> r) -> Q r
fromRecDef Name
t Name
cname Name -> Name -> Q [(Name, Exp)]
makeCon' Name -> [(Name, Exp)] -> Exp
RecConE

makeCon' :: Name -> Name -> Q [(Name, Exp)]
makeCon' :: Name -> Name -> Q [(Name, Exp)]
makeCon' Name
t Name
accName = do
    VarI Name
_ Kind
t' Maybe Dec
_ <- Name -> Q Info
reify Name
accName
    Kind
funT <- [t|$(conT t) -> Bool -> Int -> [Inline]|]
    Kind
inlT <- [t|$(conT t) -> [Inline]|]
    Kind
blkT <- [t|$(conT t) -> [Block]|]
    Kind
fmtT <- [t|$(conT t) -> Maybe Format|]
    Kind
boolT <- [t|$(conT t) -> Bool|]
    Kind
intT <- [t|$(conT t) -> Int|]
    Kind
tmplT <- [t|$(conT t) -> Template|]
    Kind
clT <- [t|$(conT t) -> Text -> Int -> Maybe Text|]
    let varName :: Q Exp
varName | Name (OccName String
n) NameFlavour
_ <- Name
accName = String -> Q Exp
liftString String
n
    let dtv :: Q Exp
dtv = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"dtv"
    Exp
body <-
      if
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
boolT -> [|getMetaBool $(varName) $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
intT -> [|read $ T.unpack $ getMetaString $(varName) $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
funT -> [|tryCapitalizeM (flip (getMetaList (toInlines $(varName))) $(dtv)) $(varName)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
inlT -> [|getMetaInlines $(varName) $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
blkT -> [|getMetaBlock $(varName) $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
tmplT -> [|makeTemplate $(dtv) $ getMetaInlines $(varName) $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
clT -> [|customLabel $(dtv)|]
      | Kind
t' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
fmtT -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmt"
      | Bool
otherwise -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Kind -> String
forall a. Show a => a -> String
show Kind
t'
    [(Name, Exp)] -> Q [(Name, Exp)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
accName, Exp
body)]