{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'ToJSON'/'FromJSON' instances using template haskell
module Language.Haskell.Codegen.TH where

import Codegen
import Data.Aeson.TH
import Data.Text (unpack)
import qualified Data.Text.IO as T
import Language.Haskell.Codegen
import Language.Haskell.TH
import Language.TL.Parser
import Processing
import Text.Megaparsec

adtI :: ADT -> Q [Dec]
adtI :: ADT -> Q [Dec]
adtI a :: ADT
a@ADT {..} =
  let con :: Name
con = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name
      mapping :: FieldMapping
mapping = (ADT, FieldMapping) -> FieldMapping
forall a b. (a, b) -> b
snd ((ADT, FieldMapping) -> FieldMapping)
-> (ADT, FieldMapping) -> FieldMapping
forall a b. (a -> b) -> a -> b
$ ADT -> (ADT, FieldMapping)
sanitizeADT ADT
a
      opt :: Options
opt = Modifier -> Options
mkOption (FieldMapping -> Modifier
mkModifier FieldMapping
mapping)
   in Options -> Name -> Q [Dec]
deriveJSON Options
opt Name
con

concatDec :: [Q [Dec]] -> Q [Dec]
concatDec :: [Q [Dec]] -> Q [Dec]
concatDec = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence

preProcess :: FilePath -> IO ([ADT], [ADT])
preProcess :: String -> IO ([ADT], [ADT])
preProcess fp :: String
fp = do
  Text
file <- String -> IO Text
T.readFile String
fp
  let mprog :: Either (ParseErrorBundle Text Void) Program
mprog = Parsec Void Text Program
-> String -> Text -> Either (ParseErrorBundle Text Void) Program
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Text Program
program "td_api.tl" Text
file
  case Either (ParseErrorBundle Text Void) Program
mprog of
    Left _ -> String -> IO ([ADT], [ADT])
forall a. HasCallStack => String -> a
error "parse failed!"
    Right prog :: Program
prog -> do
      let (d :: [ADT]
d, f :: [Function]
f) = Program -> ([ADT], [Function])
convProgram Program
prog
      let types :: [ADT]
types = (ADT -> ADT) -> [ADT] -> [ADT]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> ADT -> ADT
convADT TyMap
defTyMap) [ADT]
d
      let funs :: [FunDef]
funs = (Function -> FunDef) -> [Function] -> [FunDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Function -> FunDef
convFun TyMap
defTyMap) [Function]
f
      let funArgs :: [ADT]
funArgs = (FunDef -> ADT) -> [FunDef] -> [ADT]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunDef -> ADT
paramADT [FunDef]
funs
      ([ADT], [ADT]) -> IO ([ADT], [ADT])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ADT]
types, [ADT]
funArgs)

preProcessQ :: Q ([ADT], [ADT])
preProcessQ :: Q ([ADT], [ADT])
preProcessQ = IO ([ADT], [ADT]) -> Q ([ADT], [ADT])
forall a. IO a -> Q a
runIO (String -> IO ([ADT], [ADT])
preProcess "data/td_api.tl")

typeInstances :: Q [Dec]
typeInstances :: Q [Dec]
typeInstances = do
  ([ADT], [ADT])
p <- Q ([ADT], [ADT])
preProcessQ
  [Q [Dec]] -> Q [Dec]
concatDec ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (ADT -> Q [Dec]) -> [ADT] -> [Q [Dec]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ADT -> Q [Dec]
adtI ([ADT] -> [Q [Dec]]) -> [ADT] -> [Q [Dec]]
forall a b. (a -> b) -> a -> b
$ ([ADT], [ADT]) -> [ADT]
forall a b. (a, b) -> a
fst ([ADT], [ADT])
p

funArgInstances :: Q [Dec]
funArgInstances :: Q [Dec]
funArgInstances = do
  ([ADT], [ADT])
p <- Q ([ADT], [ADT])
preProcessQ
  [Q [Dec]] -> Q [Dec]
concatDec ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (ADT -> Q [Dec]) -> [ADT] -> [Q [Dec]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ADT -> Q [Dec]
adtI ([ADT] -> [Q [Dec]]) -> [ADT] -> [Q [Dec]]
forall a b. (a -> b) -> a -> b
$ ([ADT], [ADT]) -> [ADT]
forall a b. (a, b) -> b
snd ([ADT], [ADT])
p