tdlib-gen 0.1.0 → 0.2.0

raw patch · 7 files changed

+254/−172 lines, 7 filesdep +pretty-simplePVP ok

version bump matches the API change (PVP)

Dependencies added: pretty-simple

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• app/Main.hs +64/−76
• src/Codegen.hs +77/−43
• src/Language/Haskell/Codegen.hs +63/−15
• src/Language/Haskell/Codegen/TH.hs +26/−35
• tdlib-gen.cabal +3/−2
• test/Spec.hs +16/−1

@@ -3,3 +3,8 @@ ## 0.1.0  Initial release++## 0.2.0++- flatten function defitions+- less invasive sanitization

@@ -9,73 +9,67 @@ import Processing import Text.Megaparsec -dataDeclHeader :: Text -> Doc ann-dataDeclHeader mname =-  let m = unsafeTextWithoutNewlines mname-   in vsep-        [ "{-# LANGUAGE DeriveGeneric #-}",-          "{-# LANGUAGE DeriveAnyClass #-}",-          "{-# LANGUAGE DerivingStrategies #-}",-          "{-# LANGUAGE DuplicateRecordFields #-}",-          "{-# LANGUAGE TemplateHaskell #-}",-          "",-          "-- | TD API data types generated by tdlib-gen",-          "module" <+> m <+> "where",-          "",-          "import GHC.Generics",-          "import Language.Haskell.Codegen.TH",-          "import Data.ByteString.Base64.Type",-          "import qualified Data.Text as T",-          "import Language.TL.I64",-          "",-          "type I53 = Int",-          "type I32 = Int",-          "type T = T.Text"-        ]--funArgHeader :: Text -> Text -> Doc ann-funArgHeader mname dep =-  let m = unsafeTextWithoutNewlines mname-      d = unsafeTextWithoutNewlines dep-   in vsep-        [ "{-# LANGUAGE DeriveGeneric #-}",-          "{-# LANGUAGE DeriveAnyClass #-}",-          "{-# LANGUAGE DerivingStrategies #-}",-          "{-# LANGUAGE DuplicateRecordFields #-}",-          "{-# LANGUAGE TemplateHaskell #-}",-          "",-          "-- | TD API function call arguments",-          "module" <+> m <+> "where",-          "",-          "import GHC.Generics",-          "import Language.Haskell.Codegen.TH",-          "import Data.ByteString.Base64.Type",-          "import qualified Data.Text as T",-          "import Language.TL.I64",-          "import" <+> d,-          "",-          "type I53 = Int",-          "type I32 = Int",-          "type T = T.Text"-        ]+dataDeclHeader :: Doc ann+dataDeclHeader =+  vsep+    [ "{-# LANGUAGE DeriveGeneric #-}",+      "{-# LANGUAGE DeriveAnyClass #-}",+      "{-# LANGUAGE DerivingStrategies #-}",+      "{-# LANGUAGE DuplicateRecordFields #-}",+      "{-# LANGUAGE TemplateHaskell #-}",+      "",+      "-- | TD API data types generated by tdlib-gen",+      "module TDLib.Generated.Types where",+      "",+      "import GHC.Generics",+      "import Language.Haskell.Codegen.TH",+      "import Data.ByteString.Base64.Type",+      "import qualified Data.Text as T",+      "import Language.TL.I64",+      "",+      "type I53 = Int",+      "type I32 = Int",+      "type T = T.Text",+      ""+    ] -funHeader :: Text -> Text -> Doc ann-funHeader mod dep =-  let m = unsafeTextWithoutNewlines mod-      d = unsafeTextWithoutNewlines dep-   in vsep-        [ "{-# LANGUAGE TypeOperators #-}",-          "-- | TD API functions (methods) generated by tdlib-gen",-          "module" <+> m <+> "where",-          "",-          "import TDLib.Effect",-          "import Polysemy",-          "import" <+> d,-          ""-        ]+funArgHeader :: Doc ann+funArgHeader =+  vsep+    [ "{-# LANGUAGE DeriveGeneric #-}",+      "{-# LANGUAGE DeriveAnyClass #-}",+      "{-# LANGUAGE DerivingStrategies #-}",+      "{-# LANGUAGE DuplicateRecordFields #-}",+      "{-# LANGUAGE TemplateHaskell #-}",+      "",+      "-- | TD API function call arguments",+      "module TDLib.Generated.FunArgs where",+      "",+      "import Data.ByteString.Base64.Type",+      "import GHC.Generics",+      "import Language.Haskell.Codegen.TH",+      "import Language.TL.I64",+      "import TDLib.Generated.Types",+      ""+    ] -sep' :: Doc ann-sep' = "-- * Function Arguments"+funHeader :: Doc ann+funHeader =+  vsep+    [ "{-# LANGUAGE TypeOperators #-}",+      "-- | TD API functions (methods) generated by tdlib-gen",+      "",+      "module TDLib.Generated.Functions where",+      "",+      "import Data.ByteString.Base64.Type",+      "import Language.TL.I64",+      "import Polysemy",+      "import TDLib.Effect",+      "import TDLib.Generated.FunArgs",+      "import TDLib.Generated.Types",+      "import TDLib.Types.Common",+      ""+    ]  main :: IO () main = do@@ -87,18 +81,12 @@     Left _ -> error "parse failed"     Right prog -> do       let (datas, functions) = convProgram prog-      let adts = fmap (convADT defTyMap) datas+      let adts = fmap (fst . sanitizeADT . convADT defTyMap) datas       let funDefs = fmap (convFun defTyMap) functions-      putStrLn "module name for generated data declerations:"-      modName1 <- T.getLine-      putStrLn "module name for generated function definitions:"-      modName2 <- T.getLine-      putStrLn "module name for generated function arguments:"-      modName3 <- T.getLine-      let adts' = fmap paramADT funDefs-      let file1 = dataDeclHeader modName1 <> "\n\n" <> vsep (fmap pretty adts) <> "\n\n" <> "instanceDec"-      let file2 = funHeader modName2 modName3 <> "\n\n" <> vsep (fmap pretty funDefs)-      let file3 = funArgHeader modName3 modName1 <> "\n\n" <> vsep (fmap pretty adts') <> "\n\n" <> "instanceDec'"+      let adts' = fmap (fst . sanitizeADT . paramADT) funDefs+      let file1 = dataDeclHeader <> "\n\n" <> vsep (fmap pretty adts) <> "\n\n" <> "typeInstances"+      let file2 = funHeader <> "\n\n" <> vsep (fmap pretty funDefs)+      let file3 = funArgHeader <> "\n\n" <> vsep (fmap pretty adts') <> "\n\n" <> "funArgInstances"       writeFile "Types.hs" (show file1)       writeFile "Functions.hs" (show file2)       writeFile "FunArgs.hs" (show file3)

@@ -63,52 +63,19 @@ app :: Type -> [Type] -> Type app t = foldl (\acc ty -> App acc ty) t -convArg :: TyMap -> Int -> Arg -> (Field, (String, String))-convArg m i Arg {..} =-  let newName = argName <> "_" <> pack (show i)-   in ( Field-          { name = newName,-            ty = typeConv m argType,-            ..-          },-        (unpack newName, unpack argName)-      )--convArg' :: TyMap -> Arg -> Field-convArg' m Arg {..} =+convArg :: TyMap -> Arg -> Field+convArg m Arg {..} =   Field-    { name = sanitize argName,+    { name = argName,       ty = typeConv m argType,       ..     } -sanitize :: Text -> Text-sanitize "type" = "type_"-sanitize "data" = "data_"-sanitize x = x--defMapping :: FieldMapping-defMapping =-  M.fromList-    [ ("type_", "type"),-      ("data_", "data")-    ]--combToConstr :: TyMap -> Int -> Combinator -> (Constr, FieldMapping)-combToConstr m i Combinator {..} =-  let (fields, l) = unzip $ fmap (convArg m i) args-   in ( Constr-          { name = upper ident,-            ..-          },-        M.fromList l-      )--combToConstr' :: TyMap -> Combinator -> Constr-combToConstr' m Combinator {..} =+combToConstr :: TyMap -> Combinator -> Constr+combToConstr m Combinator {..} =   Constr     { name = upper ident,-      fields = fmap (convArg' m) args,+      fields = fmap (convArg m) args,       ..     } @@ -119,19 +86,87 @@ combToFun m c@Combinator {..} =   FunDef     { name = ident,-      constr = combToConstr' m c,+      constr = combToConstr m c,       res = typeConv m resType,       ..     }  convADT :: TyMap -> A.ADT -> ADT convADT m A.ADT {..} =-  let (constr, mappings) = unzip $ fmap (uncurry (combToConstr m)) $ zip [1 ..] constructors-      mapping = fold mappings+  let constr = fmap (combToConstr m) constructors    in ADT         { ..         } +countElem :: Eq a => a -> [a] -> Int+countElem a [] = error "Not in list"+countElem a (x : xs) =+  if x == a+    then 0+    else 1 + countElem a xs++sanitize' :: Text -> (Text, FieldMapping)+sanitize' "type" = ("type_", M.fromList [("type_", "type")])+sanitize' "data" = ("data_", M.fromList [("data_", "data")])+sanitize' "pattern" = ("pattern_", M.fromList [("pattern_", "pattern")])+sanitize' t = (t, mempty)++sanitizeArg :: Int -> Text -> (Text, FieldMapping)+sanitizeArg 0 t = sanitize' t+sanitizeArg i t =+  let n = t <> "_" <> pack (show i)+   in (n, M.fromList [(unpack n, unpack t)])++type State = (Map Text [Type], FieldMapping)++sanitizeField :: State -> Field -> (State, Field)+sanitizeField (tyMap, fieldMap) f@Field {..} =+  case M.lookup name tyMap of+    Nothing ->+      let (name', dfm) = sanitizeArg 0 name+       in ((M.insert name [ty] tyMap, fieldMap <> dfm), Field {name = name', ..})+    Just l ->+      if ty `elem` l+        then+          let c = countElem ty l+              (name', dfm) = sanitizeArg c name+           in ((tyMap, fieldMap <> dfm), Field name' ann ty)+        else+          let c = length l + 1+              (name', dfm) = sanitizeArg c name+              tyMap' = M.insert name (l <> [ty]) tyMap+           in ((tyMap', fieldMap <> dfm), Field name' ann ty)++sanitizeField' :: Field -> (State, [Field]) -> (State, [Field])+sanitizeField' f (s, fs) =+  let (s', f') = sanitizeField s f+   in (s', f' : fs)++sanitizeConstr :: State -> Constr -> (State, Constr)+sanitizeConstr s Constr {..} =+  let (s', fields') = foldr sanitizeField' (s, []) fields+   in ( s',+        Constr+          { fields = fields',+            ..+          }+      )++sanitizeConstr' :: Constr -> (State, [Constr]) -> (State, [Constr])+sanitizeConstr' c (s, cs) =+  let (s', c') = sanitizeConstr s c+   in (s', c' : cs)++sanitizeADT :: ADT -> (ADT, FieldMapping)+sanitizeADT adt@ADT {..} =+  let ((_, fm), constr') = foldr sanitizeConstr' mempty constr+   in ( ADT+          { constr = constr',+            ..+          },+        fm+      )+ convFun :: TyMap -> Function -> FunDef convFun m (Function c) = combToFun m c @@ -139,7 +174,6 @@ paramADT FunDef {..} =   ADT     { ann = Just ("Parameter of Function " <> name),-      mapping = defMapping,       constr = [constr],       name = upper name     }

@@ -7,6 +7,7 @@ import Data.Generics.Labels () import Data.List import Data.Map.Strict (Map)+import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Text.Prettyprint.Doc@@ -29,11 +30,13 @@   = ADT       { name :: Text,         ann :: Ann,-        constr :: [Constr],-        mapping :: Map String String+        constr :: [Constr]       }   deriving (Show, Eq, Generic) +constructors :: ADT -> Int+constructors ADT {..} = length constr+ prettyConstrs :: [Doc ann] -> Doc ann prettyConstrs [] = mempty prettyConstrs (x : xs) =@@ -76,6 +79,9 @@       }   deriving (Show, Eq, Generic) +arity :: Constr -> Int+arity = length . fields+ instance Pretty Constr where   pretty Constr {..} =     let doc = prettyDoc ann@@ -96,6 +102,7 @@ instance Pretty Type where   pretty (Type t) = unsafeTextWithoutNewlines t   pretty (Arr ty ty') = pretty ty <+> "->" <+> pretty ty'+  pretty (App (Type "[]") ty) = "[" <> pretty ty <> "]"   pretty (App tyCon ty) = "(" <> pretty tyCon <> ")" <+> "(" <> pretty ty <> ")"  data TypeSig@@ -106,21 +113,26 @@   | Conn       { ty :: Type,         ann :: Ann,-        name :: Text,         res :: TypeSig       }   deriving (Show, Eq, Generic)  instance Pretty TypeSig where   pretty (Result ty doc) =-    prettyDoc doc <> pretty (App io ty)-  pretty (Conn ty doc _ res) =+    prettyDoc doc <> "Sem r" <+> "(" <> "Error ∪" <+> pretty ty <> ")"+  pretty (Conn ty doc res) =     prettyDoc doc       <> vsep         [ pretty ty <+> "->",           pretty res         ] +type Annotated = (Type, Ann)++formArr :: [Annotated] -> Annotated -> TypeSig+formArr [] (ty, ann) = Result ty ann+formArr ((ty, ann) : xs) a = Conn ty ann (formArr xs a)+ data FunDef   = FunDef       { name :: Text,@@ -130,14 +142,50 @@       }   deriving (Show, Eq, Generic) +getAnn :: Field -> Annotated+getAnn Field {..} = (ty, ann)++flattenSig :: FunDef -> Doc ann+flattenSig FunDef {..} =+  let n = unsafeTextWithoutNewlines name+      doc = prettyDoc ann+      c = unsafeTextWithoutNewlines (constr ^. #name)+      sig = pretty $ formArr (fmap getAnn (fields constr)) (res, Nothing)+   in vsep+        [ doc <> n <+> "::",+          indent 2 "Member TDLib r =>",+          indent 2 sig+        ]++vars :: Int -> Doc ann+vars i = hsep $ fmap (fromString . ("_" <>) . show) [1 .. i]++flattenBody :: FunDef -> Doc ann+flattenBody FunDef {..} =+  let n = unsafeTextWithoutNewlines name+      c = unsafeTextWithoutNewlines (constr ^. #name)+      ar = arity constr+      v = vars ar+   in hsep [n, v, "=", "runCmd $", c, v]++flattenPrint :: FunDef -> Doc ann+flattenPrint def =+  vsep+    [ flattenSig def,+      flattenBody def+    ]++simplePretty :: FunDef -> Doc ann+simplePretty FunDef {..} =+  let doc = prettyDoc ann+      n = unsafeTextWithoutNewlines name+      cmd = unsafeTextWithoutNewlines (constr ^. #name)+      resTy = pretty res+   in doc+        <> vsep+          [ n <+> "::" <+> "Member TDLib r" <+> "=>" <+> cmd <+> "->" <+> "Sem r (Error ∪ " <> resTy <> ")",+            n <+> "=" <+> "runCmd"+          ]+ instance Pretty FunDef where-  pretty FunDef {..} =-    let doc = prettyDoc ann-        n = unsafeTextWithoutNewlines name-        cmd = unsafeTextWithoutNewlines (constr ^. #name)-        resTy = pretty res-     in doc-          <> vsep-            [ n <+> "::" <+> "Member TDLib r" <+> "=>" <+> cmd <+> "->" <+> "Sem r (Error :+: " <> resTy <> ")",-              n <+> "=" <+> "runCmd"-            ]+  pretty d@FunDef {..} = flattenPrint d

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Generate 'ToJSON'/'FromJSON' instances using template haskell module Language.Haskell.Codegen.TH where  import Codegen@@ -12,48 +13,38 @@ import Processing import Text.Megaparsec -adtInstanceDec :: ADT -> Q [Dec]-adtInstanceDec ADT {..} =+adtI :: ADT -> Q [Dec]+adtI a@ADT {..} =   let con = mkName $ unpack name+      mapping = snd $ sanitizeADT a       opt = mkOption (mkModifier mapping)    in deriveJSON opt con  concatDec :: [Q [Dec]] -> Q [Dec] concatDec = fmap (concat) . sequence -genDec :: FilePath -> Q [Dec]-genDec fp = do-  adts <- runIO $ do-    f <- T.readFile fp-    let mprog = runParser program "td_api.tl" f-    case mprog of-      Left _ -> error "parse failed"-      Right prog -> do-        let (datas, functions) = convProgram prog-        let adts = fmap (convADT defTyMap) datas-        let funDefs = fmap (convFun defTyMap) functions-        pure adts-  concatDec $ fmap adtInstanceDec adts--genDec' :: FilePath -> Q [Dec]-genDec' fp = do-  adts <- runIO $ do-    f <- T.readFile fp-    let mprog = runParser program "td_api.tl" f-    case mprog of-      Left _ -> error "parse failed"-      Right prog -> do-        let (datas, functions) = convProgram prog-        let adts = fmap (convADT defTyMap) datas-        let funDefs = fmap (convFun defTyMap) functions-        pure (fmap paramADT funDefs)-  concatDec $ fmap adtInstanceDec adts+preProcess :: FilePath -> IO ([ADT], [ADT])+preProcess fp = do+  f <- T.readFile fp+  let mprog = runParser program "td_api.tl" f+  case mprog of+    Left _ -> error "parse failed!"+    Right prog -> do+      let (d, f) = convProgram prog+      let types = fmap (convADT defTyMap) d+      let funs = fmap (convFun defTyMap) f+      let funArgs = fmap paramADT funs+      pure (types, funArgs) -instancesDec :: Q [Dec]-instancesDec = genDec "data/td_api.tl"+preProcessQ :: Q ([ADT], [ADT])+preProcessQ = runIO (preProcess "data/td_api.tl") -instancesDec' :: Q [Dec]-instancesDec' = genDec' "data/td_api.tl"+typeInstances :: Q [Dec]+typeInstances = do+  p <- preProcessQ+  concatDec $ fmap adtI $ fst p -genFunDef :: TyMap -> FunDef -> Q [Dec]-genFunDef m d = undefined+funArgInstances :: Q [Dec]+funArgInstances = do+  p <- preProcessQ+  concatDec $ fmap adtI $ snd p

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 61c7edc3c002bb75ffde87e9f83cc16ea0285693cbeb9c9742783deb2391da3b+-- hash: e4ba9fc90b907e262d2b05af724e73659a5ef1a547e2cf850905eeca9fb99276  name:           tdlib-gen-version:        0.1.0+version:        0.2.0 synopsis:       Codegen for TDLib description:    Please see the README on GitHub at <https://github.com/poscat0x04/tdlib-gen#readme> category:       Codegen@@ -94,6 +94,7 @@     , language-tl >=0.1.0 && <0.2     , lens >=4.18 && <4.20     , megaparsec >=7.0 && <8.1+    , pretty-simple     , prettyprinter >=1.6.1 && <1.7     , tdlib-gen     , template-haskell >=2.15 && <2.17

@@ -1,4 +1,19 @@ module Main where +import Codegen+import qualified Data.Text.IO as T+import Language.Haskell.Codegen+import Language.TL.AST+import Language.TL.Parser+import Processing+import Text.Megaparsec+import Text.Pretty.Simple+ main :: IO ()-main = pure ()+main = do+  f <- T.readFile "test/data/td_api.tl"+  let Right prog = runParser program "" f+  let (datas, functions) = convProgram prog+  let adts = fmap (convADT defTyMap) datas+  let p = fmap sanitizeADT adts+  pPrint p