{-# LANGUAGE TemplateHaskell #-}

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

adtInstanceDec :: ADT -> Q [Dec]
adtInstanceDec :: ADT -> Q [Dec]
adtInstanceDec ADT {..} =
  let con :: Name
con = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name
      opt :: Options
opt = Modifier -> Options
mkOption (Map String String -> Modifier
mkModifier Map String String
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

genDec :: FilePath -> Q [Dec]
genDec :: String -> Q [Dec]
genDec fp :: String
fp = do
  [ADT]
adts <- IO [ADT] -> Q [ADT]
forall a. IO a -> Q a
runIO (IO [ADT] -> Q [ADT]) -> IO [ADT] -> Q [ADT]
forall a b. (a -> b) -> a -> b
$ do
    Text
f <- 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
f
    case Either (ParseErrorBundle Text Void) Program
mprog of
      Left _ -> String -> IO [ADT]
forall a. HasCallStack => String -> a
error "parse failed"
      Right prog :: Program
prog -> do
        let (datas :: [ADT]
datas, functions :: [Function]
functions) = Program -> ([ADT], [Function])
convProgram Program
prog
        let adts :: [ADT]
adts = (ADT -> ADT) -> [ADT] -> [ADT]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> ADT -> ADT
convADT TyMap
defTyMap) [ADT]
datas
        let funDefs :: [FunDef]
funDefs = (Function -> FunDef) -> [Function] -> [FunDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Function -> FunDef
convFun TyMap
defTyMap) [Function]
functions
        [ADT] -> IO [ADT]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ADT]
adts
  [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]
adtInstanceDec [ADT]
adts

genDec' :: FilePath -> Q [Dec]
genDec' :: String -> Q [Dec]
genDec' fp :: String
fp = do
  [ADT]
adts <- IO [ADT] -> Q [ADT]
forall a. IO a -> Q a
runIO (IO [ADT] -> Q [ADT]) -> IO [ADT] -> Q [ADT]
forall a b. (a -> b) -> a -> b
$ do
    Text
f <- 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
f
    case Either (ParseErrorBundle Text Void) Program
mprog of
      Left _ -> String -> IO [ADT]
forall a. HasCallStack => String -> a
error "parse failed"
      Right prog :: Program
prog -> do
        let (datas :: [ADT]
datas, functions :: [Function]
functions) = Program -> ([ADT], [Function])
convProgram Program
prog
        let adts :: [ADT]
adts = (ADT -> ADT) -> [ADT] -> [ADT]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> ADT -> ADT
convADT TyMap
defTyMap) [ADT]
datas
        let funDefs :: [FunDef]
funDefs = (Function -> FunDef) -> [Function] -> [FunDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyMap -> Function -> FunDef
convFun TyMap
defTyMap) [Function]
functions
        [ADT] -> IO [ADT]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FunDef -> ADT) -> [FunDef] -> [ADT]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunDef -> ADT
paramADT [FunDef]
funDefs)
  [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]
adtInstanceDec [ADT]
adts

instancesDec :: Q [Dec]
instancesDec :: Q [Dec]
instancesDec = String -> Q [Dec]
genDec "data/td_api.tl"

instancesDec' :: Q [Dec]
instancesDec' :: Q [Dec]
instancesDec' = String -> Q [Dec]
genDec' "data/td_api.tl"

genFunDef :: TyMap -> FunDef -> Q [Dec]
genFunDef :: TyMap -> FunDef -> Q [Dec]
genFunDef m :: TyMap
m d :: FunDef
d = Q [Dec]
forall a. HasCallStack => a
undefined