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