{-
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 Data.List
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH hiding (Inline)
import Language.Haskell.TH.Syntax hiding (Inline)
import Text.Pandoc.Builder
import Text.Pandoc.CrossRef.Util.CustomLabels
import Text.Pandoc.CrossRef.Util.Meta
import Text.Pandoc.CrossRef.Util.Template

namedFields :: Con -> [VarStrictType]
namedFields :: Con -> [VarStrictType]
namedFields (RecC Name
_ [VarStrictType]
fs) = [VarStrictType]
fs
namedFields (ForallC [TyVarBndr Specificity]
_ 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 :: forall t a r.
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
                  Info
_ -> 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 Type
_ [Con]
cons' [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
params, [Con]
cons')
               NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
params Maybe Type
_ Con
con' [DerivClause]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBndr ()]
params, [Con
con'])
               Dec
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No cons"
  [a]
decs <- 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 (\ (Name
name,Bang
_,Type
_) -> Name -> Name -> Q [a]
f Name
t Name
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [VarStrictType]
namedFields [Con]
cons
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall t a r.
Name -> t -> (Name -> Name -> Q [a]) -> (t -> [a] -> r) -> Q r
fromRecDef Name
t forall a. HasCallStack => a
undefined (forall a b. a -> b -> a
const Name -> Q [Dec]
makeAcc) (forall a b. a -> b -> a
const 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 |]
    Type
sig <- [t|forall a. ToMetaValue a => a -> Meta|]
    forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Name -> Type -> Dec
SigD Name
accName Type
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 = 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
_ Type
t' Maybe Dec
_ <- Name -> Q Info
reify Name
accName
    Type
funT <- [t|$(conT t) -> Bool -> Int -> [Inline]|]
    Type
inlT <- [t|$(conT t) -> [Inline]|]
    Type
blkT <- [t|$(conT t) -> [Block]|]
    Type
fmtT <- [t|$(conT t) -> Maybe Format|]
    Type
boolT <- [t|$(conT t) -> Bool|]
    Type
strT <- [t|$(conT t) -> Text|]
    Type
intT <- [t|$(conT t) -> Int|]
    Type
tmplT <- [t|$(conT t) -> Template|]
    Type
btmplT <- [t|$(conT t) -> BlockTemplate|]
    Type
idxTmplT <- [t|$(conT t) -> Text -> Template|]
    Type
clT <- [t|$(conT t) -> Text -> Int -> Maybe Text|]
    Type
chlT <- [t|$(conT t) -> Int -> Int -> Maybe Text|]
    let varName :: Q Exp
varName | Name (OccName String
n) NameFlavour
_ <- Name
accName = forall (m :: * -> *). Quote m => String -> m Exp
liftString String
n
    let dtv :: Q Exp
dtv = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"dtv"
    Exp
body <-
      if
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
boolT -> [|getMetaBool $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
intT -> [|read $ T.unpack $ getMetaString $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
funT -> [|tryCapitalizeM (flip (getMetaList (toInlines $(varName))) $(dtv)) $(varName)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
inlT -> [|getMetaInlines $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
blkT -> [|getMetaBlock $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
tmplT -> [|makeTemplate $(dtv) $ getMetaInlines $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
btmplT -> [|makeTemplate $(dtv) $ getMetaBlock $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
idxTmplT -> [|makeIndexedTemplate $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
clT -> [|customLabel $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
chlT -> [|customHeadingLabel $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
strT -> [|getMetaString $(varName) $(dtv)|]
      | Type
t' forall a. Eq a => a -> a -> Bool
== Type
fmtT -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fmt"
      | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
t'
    forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
accName, Exp
body)]