fields-and-cases (empty) → 0.1.0.0
raw patch · 6 files changed
+1031/−0 lines, 6 filesdep +basedep +fields-and-casesdep +lima
Dependencies added: base, fields-and-cases, lima, process, regex-compat, relude, string-conversions, tasty, tasty-hunit
Files
- CHANGELOG.md +5/−0
- fields-and-cases.cabal +79/−0
- lib/FieldsAndCases.hs +324/−0
- tests/Readme.hs +388/−0
- tests/Spec.hs +175/−0
- tests/test.hs +60/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for haskell-codegen++## 0.1.0.0 -- 2024-07-12++* Initial release
+ fields-and-cases.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.4+name: fields-and-cases+version: 0.1.0.0+synopsis: Codegen Haskell types to other languages+description:+ This package provides a way to generate code for other languages from Haskell types.+ It's target language agnostic and based on type classes.++bug-reports: https://github.com/thought2/fields-and-cases/issues+license: BSD-3-Clause+author: Michael Bock+maintainer: no-day@posteo.net+category: codegen+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/thought2/fields-and-cases++common common-opts+ default-language: Haskell2010+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeFamilyDependencies+ TypeOperators+ UndecidableInstances+ UndecidableSuperClasses++library+ import: common-opts+ exposed-modules: FieldsAndCases+ build-depends:+ , base ^>=4.17.2.0+ , relude >=1.2.1 && <1.3+ , string-conversions >=0.4.0 && <0.5++ hs-source-dirs: lib++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ other-modules:+ Readme+ Spec++ hs-source-dirs: tests+ main-is: test.hs+ build-depends:+ , base ^>=4.17.2.0+ , fields-and-cases+ , lima+ , process+ , regex-compat+ , relude+ , string-conversions+ , tasty+ , tasty-hunit
+ lib/FieldsAndCases.hs view
@@ -0,0 +1,324 @@+{- | ++Code generate type definitions in any language based on Haskell types.++-}+module FieldsAndCases+ ( matchRecordLikeDataType,+ isEnumWithoutData,+ ToTypeDefs (..),+ ToTypeDef (..),+ IsTypeExpr (..),+ TypeExpr (..),+ TypeDef (..),+ Case (..),+ CaseArgs (..),+ Field (..),+ PositionalArg (..),+ QualifiedName (..),+ )+where++import Data.String.Conversions (cs)+import GHC.Generics+import GHC.TypeLits (KnownSymbol, symbolVal)+import Relude++-- | Haskell type definition.+data TypeDef texpr = TypeDef+ { qualifiedName :: QualifiedName,+ cases :: [Case texpr]+ }+ deriving (Show, Eq)++-- | Haskell type constructor.+data Case texpr = Case+ { tagName :: Text,+ caseArgs :: Maybe (CaseArgs texpr)+ }+ deriving (Show, Eq)++-- | Haskell type constructor arguments.+data CaseArgs texpr+ = CasePositionalArgs [PositionalArg texpr]+ | CaseFields [Field texpr]+ deriving (Show, Eq)++-- | Haskell type labeled field.+data Field texpr = Field+ { fieldName :: Text,+ fieldType :: texpr+ }+ deriving (Show, Eq)++-- | Haskell type positional field.+newtype PositionalArg texpr = PositionalArg+ { fieldType :: texpr+ }+ deriving (Show, Eq)++-- | Haskell type qualified name.+data QualifiedName = QualifiedName+ { moduleName :: Text,+ typeName :: Text+ }+ deriving (Show, Eq)++-- | Data types with a single constructor and labeled fields+-- | are considered record-like.+matchRecordLikeDataType :: TypeDef texpr -> Maybe (Text, [Field texpr])+matchRecordLikeDataType (TypeDef {qualifiedName = QualifiedName {typeName}, cases}) =+ case cases of+ [Case {tagName, caseArgs = Just (CaseFields fields)}]+ | typeName == tagName -> Just (typeName, fields)+ _ -> Nothing+++-- | Data types with all of their constructors having no arguments+isEnumWithoutData :: TypeDef texpr -> Bool+isEnumWithoutData (TypeDef {qualifiedName = QualifiedName {typeName}, cases}) =+ all isEnumCase cases+ where+ isEnumCase (Case {caseArgs = Nothing}) = True+ isEnumCase _ = False++---++-- | Like 'ToTypeDef' but for a list of types.+class ToTypeDefs (xs :: [Type]) texpr where+ toTypeDefs :: [TypeDef texpr]++instance ToTypeDefs '[] texpr where+ toTypeDefs = []++instance (ToTypeDef x texpr, ToTypeDefs xs texpr) => ToTypeDefs (x ': xs) texpr where+ toTypeDefs = toTypeDef @x @texpr : toTypeDefs @xs @texpr++---++-- | A class of types which can be used as type expressions.+class IsTypeExpr texpr where+ typeRef :: QualifiedName -> texpr++instance IsTypeExpr Text where+ typeRef (QualifiedName {typeName}) = fromString $ cs typeName++--- ToTypeRef ---++-- | Describes how to convert a type to a type expression of a specific language.+class TypeExpr a texpr where+ typeExpr :: texpr+ default typeExpr ::+ (IsTypeExpr texpr, Generic a, GToTypeRef (Rep a)) => texpr+ typeExpr =+ typeRef $ gToTypeRef $ getRep (Proxy :: Proxy a)++class GToTypeRef rep where+ gToTypeRef :: rep a -> QualifiedName++-- Match Data Type+instance+ (KnownSymbol typeName, KnownSymbol moduleName) =>+ GToTypeRef+ (M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)+ where+ gToTypeRef _ = result+ where+ moduleName :: Text+ moduleName = fromString $ symbolVal (Proxy @moduleName)++ typeName :: Text+ typeName = fromString $ symbolVal (Proxy @typeName)++ result :: QualifiedName+ result = QualifiedName {moduleName, typeName}++--- ToTypeDef ---++-- | Get the type definition of a type.+class ToTypeDef a texpr where+ toTypeDef :: TypeDef texpr++instance (Generic a, GToTypeDef (Rep a) (TypeDef texpr)) => ToTypeDef a texpr where+ toTypeDef = gToTypeDef $ getRep (Proxy :: Proxy a)++class GToTypeDef rep def where+ gToTypeDef :: rep a -> def++-- Match Data Type+instance+ (GToTypeDef cases [Case texpr], KnownSymbol typeName, KnownSymbol moduleName) =>+ GToTypeDef+ (M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)+ (TypeDef texpr)+ where+ gToTypeDef _ = result+ where+ cases :: [Case texpr]+ cases = gToTypeDef (error "no value" :: cases x)++ moduleName :: Text+ moduleName = fromString $ symbolVal (Proxy @moduleName)++ typeName :: Text+ typeName = fromString $ symbolVal (Proxy @typeName)++ qualifiedName :: QualifiedName+ qualifiedName = QualifiedName {moduleName, typeName}++ result :: TypeDef texpr+ result = TypeDef qualifiedName (coerce cases)++-- Match Sum+instance+ (GToTypeDef lhs [Case texpr], GToTypeDef rhs [Case texpr]) =>+ GToTypeDef+ (lhs :+: rhs)+ [Case texpr]+ where+ gToTypeDef _ = result+ where+ lhs :: [Case texpr]+ lhs = gToTypeDef (error "no value" :: lhs x)++ rhs :: [Case texpr]+ rhs = gToTypeDef (error "no value" :: rhs x)++ result :: [Case texpr]+ result = lhs <> rhs++-- Match Constructor with fields+instance+ {-# OVERLAPPABLE #-}+ (KnownSymbol ctorName, GToTypeDef fields [Field texpr]) =>+ GToTypeDef+ (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'True {- hasSelectors -}) fields)+ [Case texpr]+ where+ gToTypeDef _ = result+ where+ fields :: [Field texpr]+ fields = gToTypeDef (error "no value" :: fields x)++ tagName :: Text+ tagName = fromString $ symbolVal (Proxy @ctorName)++ case_ :: Case texpr+ case_ =+ Case+ { tagName,+ caseArgs = Just $ CaseFields (coerce fields)+ }++ result :: [Case texpr]+ result = coerce [case_]++-- Match Constructor with positional fields+instance+ {-# OVERLAPPABLE #-}+ (KnownSymbol ctorName, GToTypeDef fields [PositionalArg texpr]) =>+ GToTypeDef+ (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) fields)+ [Case texpr]+ where+ gToTypeDef _ = result+ where+ tagName :: Text+ tagName = fromString $ symbolVal (Proxy @ctorName)++ fields :: [PositionalArg texpr]+ fields = gToTypeDef (error "no value" :: fields x)++ case_ :: Case texpr+ case_ =+ Case+ { tagName,+ caseArgs = Just $ CasePositionalArgs (coerce fields)+ }++ result :: [Case texpr]+ result = coerce [case_]++-- Match Constructor without fields+instance+ {-# OVERLAPPABLE #-}+ (KnownSymbol ctorName) =>+ GToTypeDef+ (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) U1 {- Unit -})+ [Case texpr]+ where+ gToTypeDef _ = result+ where+ tagName :: Text+ tagName = fromString $ symbolVal (Proxy @ctorName)++ case_ :: Case texpr+ case_ = Case {tagName, caseArgs = Nothing}++ result :: [Case texpr]+ result = coerce [case_]++-- Match Product+instance+ (GToTypeDef lhs fields, GToTypeDef rhs fields, Semigroup fields) =>+ GToTypeDef+ (lhs :*: rhs)+ fields+ where+ gToTypeDef _ = result+ where+ lhs :: fields+ lhs = gToTypeDef (error "no value" :: lhs x)++ rhs :: fields+ rhs = gToTypeDef (error "no value" :: rhs x)++ result :: fields+ result = lhs <> rhs++-- Match Field+instance+ {-# OVERLAPPABLE #-}+ (TypeExpr a texpr, KnownSymbol fieldName) =>+ GToTypeDef+ (M1 {- MetaInfo -} S {- Selector -} ('MetaSel ('Just fieldName) srcUnpackedness srcStrictness inferedStrictness) (K1 R a))+ [Field texpr]+ where+ gToTypeDef _ = result+ where+ fieldName :: Text+ fieldName = fromString $ symbolVal (Proxy @fieldName)++ fieldType :: texpr+ fieldType = typeExpr @a @texpr++ field :: Field texpr+ field = Field {fieldName, fieldType}++ result :: [Field texpr]+ result = coerce [field]++-- Match Positional Field+instance+ {-# OVERLAPPABLE #-}+ (TypeExpr a texpr) =>+ GToTypeDef+ (M1 {- MetaInfo -} S {- Selector -} ('MetaSel 'Nothing srcUnpackedness srcStrictness inferedStrictness) (K1 R a))+ [PositionalArg texpr]+ where+ gToTypeDef _ = result+ where+ fieldType :: texpr+ fieldType = typeExpr @a @texpr++ field :: PositionalArg texpr+ field = PositionalArg {fieldType}++ result :: [PositionalArg texpr]+ result = coerce [field]++--- Utils ---++-- Function to get the Rep of a type without a value+getRep :: forall rep a x. (Generic a, Rep a ~ rep) => Proxy a -> rep x+getRep _ = from (error "no value" :: a)
+ tests/Readme.hs view
@@ -0,0 +1,388 @@+{-+### Module setup++We'll need to activate the following language extensions:+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-+<!--+-}++module Readme (main) where++{-+-->+-}++{-+As well as those imports for this demo:+-}++import Control.Exception (catch, throw)+import qualified Data.Text as Txt+import qualified FieldsAndCases as FnC+import qualified GHC.IO.Exception as Ex+import Relude+import System.Process (callCommand)+import qualified Test.Tasty as Spec+import qualified Test.Tasty.HUnit as Spec+import GHC.IO.Exception (ExitCode(ExitSuccess))++{-+### Define custom types++Let' say we have the following data types in Haskell:+-}++data Activity+ = Working+ | Studying {hours :: Int, subject :: Maybe Text}+ | Training {place :: Place}+ deriving+ (Show, Eq, Generic)++data Place+ = Indoor+ | Outdoor+ deriving+ (Show, Eq, Generic)++data Vector = Vector+ { x :: Int,+ y :: Int+ }+ deriving+ (Show, Eq, Generic)++data Person = Person+ { name :: Text,+ age :: Int,+ isStudent :: Bool,+ friends :: [Text],+ activity :: Maybe Activity,+ coordinates :: Vector+ }+ deriving+ (Show, Eq, Generic)++{-++We use those types in other codebases that are written in different languages.+Now we want to have a flexible yet automated way to generate the equivalent data types in those languages.+We'll do so as an example for Rust and for TypeScript. The library is language agnostic and can be used for any language.++### Define types representing code of target languages++First we define a types that represents the type expressions of the target languages.+In this demo it's a simple newtype wrapper around Text.+That already works very well, but you could also define and use a custom AST type instead.+Most importantly it needs an instance of `FnC.IsTypeExpr`.+In our case we can derive all instances.++-}++{-+Rust:+-}++newtype Rust = Rust Text+ deriving (Show, Eq, IsString, Semigroup, ToText, FnC.IsTypeExpr)++{-+TypeScript:+-}++newtype TypeScript = TypeScript Text+ deriving (Show, Eq, IsString, Semigroup, ToText, FnC.IsTypeExpr)++{-++### Specify how to generate code for each type++Now we define instances for the `FnC.TypeExpr` typeclass.+It's a typeclass parameterized by two types:+- The type we want to generate a reference for (`Text`, `Int`, `Bool`, `Maybe a`, `[a]`, ...)+- The language type (`Rust` or `TypeScript` in this case)++This works like the well known `Show` typeclass.+With the difference that we don't show values but types.++#### Primitive types++Let's start with instance for the primitive types.+Note that since we are using 'OverloadedStrings' we can use string literals directly,+`typeExpr = "bool"` is equivalent to `typeExpr = fromString "bool" :: Rust`:++-}++{-+Rust:+-}++instance FnC.TypeExpr Bool Rust where+ typeExpr = "bool"++instance FnC.TypeExpr Int Rust where+ typeExpr = "i32"++instance FnC.TypeExpr Text Rust where+ typeExpr = "String"++{-+TypeScript:+-}++instance FnC.TypeExpr Bool TypeScript where+ typeExpr = "boolean"++instance FnC.TypeExpr Int TypeScript where+ typeExpr = "number"++instance FnC.TypeExpr Text TypeScript where+ typeExpr = "string"++{-++#### Composite types++And then add some instance for composite types.+We use `FnC.typeExpr` to recursively reference type arguments.++-}++{-+Rust:+-}++instance (FnC.TypeExpr a Rust) => FnC.TypeExpr (Maybe a) Rust where+ typeExpr =+ "Option<" <> FnC.typeExpr @a <> ">"++instance (FnC.TypeExpr a Rust) => FnC.TypeExpr [a] Rust where+ typeExpr =+ "Vec<" <> FnC.typeExpr @a <> ">"++{-+TypeScript:+-}++instance (FnC.TypeExpr a TypeScript) => FnC.TypeExpr (Maybe a) TypeScript where+ typeExpr =+ "(null | " <> FnC.typeExpr @a <> ")"++instance (FnC.TypeExpr a TypeScript) => FnC.TypeExpr [a] TypeScript where+ typeExpr =+ "Array<" <> FnC.typeExpr @a <> ">"++{-++#### Custom types++Until now we have covered the basic types. Now we define instances for our custom types.+Luckily they can be easily derived, we can even derive them each for all target languages at once:++-}++instance (FnC.IsTypeExpr lang) => FnC.TypeExpr Person lang++instance (FnC.IsTypeExpr lang) => FnC.TypeExpr Activity lang++instance (FnC.IsTypeExpr lang) => FnC.TypeExpr Place lang++instance (FnC.IsTypeExpr lang) => FnC.TypeExpr Vector lang++{-+Now let's demonstrate what we can do with the definitions we have so far.+The library provides a function `toTypeDef`+that generates a `FnC.TypeDef` for a given type.+We need to pass two types via "visible type application":+-}++typeDefActivityRust1 :: FnC.TypeDef Rust+typeDefActivityRust1 = FnC.toTypeDef @Activity @Rust++{-+This results in the following data:+-}+typeDefActivityRust2 :: FnC.TypeDef Rust+typeDefActivityRust2 =+ FnC.TypeDef+ { qualifiedName = FnC.QualifiedName {moduleName = "Readme", typeName = "Activity"},+ cases =+ [ FnC.Case+ { tagName = "Working",+ caseArgs = Nothing+ },+ FnC.Case+ { tagName = "Studying",+ caseArgs =+ Just+ ( FnC.CaseFields+ [ FnC.Field {fieldName = "hours", fieldType = Rust "i32"},+ FnC.Field {fieldName = "subject", fieldType = Rust "Option<String>"}+ ]+ )+ },+ FnC.Case+ { tagName = "Training",+ caseArgs =+ Just+ ( FnC.CaseFields+ [ FnC.Field {fieldName = "place", fieldType = Rust "Place"}+ ]+ )+ }+ ]+ }++{-+In a small unit test we can proof+that the manual and the auto generated type definitions are equal:+-}++unitTests :: Spec.TestTree+unitTests =+ Spec.testCase+ "toTypeDef"+ (Spec.assertEqual "" typeDefActivityRust1 typeDefActivityRust2)++{-++### Print "fields and cases" of the type definitions to text++After having seen the generated data we can now convert it to text.+It is very straightforward to implement,+we just need to pattern match on the given data structure.+We don't need to deal with tricky wizardry like generics or typeclasses, this is all handled by the library:++-}++{-+Rust:+-}++printRustDef :: FnC.TypeDef Rust -> Text+printRustDef = unwords . printType+ where+ printType typeDef@(FnC.TypeDef {qualifiedName = FnC.QualifiedName {typeName}, cases}) =+ case FnC.matchRecordLikeDataType typeDef of+ Just (tagName, fields) ->+ ["struct", typeName, "{"] <> concatMap printField fields <> ["}\n"]+ Nothing ->+ ["enum", typeName, "{"] <> concatMap printCase cases <> ["}\n"]++ printField (FnC.Field {fieldName, fieldType}) =+ [fieldName, ":", toText fieldType, ","]++ printCase (FnC.Case {tagName, caseArgs}) =+ case caseArgs of+ Nothing ->+ [tagName, ","]+ Just (FnC.CaseFields fields) ->+ [tagName, "{"] <> concatMap printField fields <> ["},"]++{-+TypeScript:+-}++printTypeScriptDef :: FnC.TypeDef TypeScript -> Text+printTypeScriptDef = unwords . printDef+ where+ printDef typeDef@(FnC.TypeDef {qualifiedName = FnC.QualifiedName {typeName}}) =+ ["type", typeName, "="] <> printType typeDef <> ["\n"]++ printType typeDef@(FnC.TypeDef {cases}) =+ case FnC.matchRecordLikeDataType typeDef of+ Just (tagName, fields) ->+ ["{"] <> concatMap printField fields <> ["}"]+ Nothing ->+ concatMap (printCase $ FnC.isEnumWithoutData typeDef) cases++ printField (FnC.Field {fieldName, fieldType}) =+ [fieldName, if omittable then "?" else "", ":", toText fieldType, ";"]+ where+ omittable = Txt.isPrefixOf "(null |" $ toText fieldType++ printCase noData (FnC.Case {tagName, caseArgs}) =+ ["|"]+ <> if noData+ then ["'" <> tagName <> "'"]+ else ["{", "tag:", "'" <> tagName <> "'"] <> printCaseArgs caseArgs <> ["}"]++ printCaseArgs = \case+ Nothing ->+ []+ Just (FnC.CaseFields fields) ->+ [",", "value:", "{"] <> concatMap printField fields <> ["}"]++{-++### Compose modules for the target language++Since we want to generate code for the same types in multiple languages,+we can define a list of the types we want to export:+-}++type ExportTypes =+ '[ Person,+ Activity,+ Place,+ Vector+ ]++{-+And finally we can define modules containing the generated code:+-}++codeRust :: Text+codeRust =+ unlines+ [ "//! This is an auto generated Rust Module\n",+ unlines $ map printRustDef (FnC.toTypeDefs @ExportTypes @Rust)+ ]++codeTypeScript :: Text+codeTypeScript =+ unlines+ [ "// This is an auto generated TypeScript Module\n",+ unlines $ map printTypeScriptDef (FnC.toTypeDefs @ExportTypes @TypeScript)+ ]++{-++### Write generated code to a file++And we can write the generated code to a file,+as well as format it with appropriate code formatters:+-}++main :: IO ()+main = do+ -- Verify the assertions from above+ Spec.defaultMain unitTests+ `catch` \e ->+ when (e /= ExitSuccess) $ throw e++ do+ let filePath = "tests/outputs/demo.rs"+ writeFile filePath (toString codeRust)+ callCommand ("rustfmt --force " <> filePath)++ do+ let filePath = "tests/outputs/demo.ts"+ writeFile filePath (toString codeTypeScript)+ callCommand ("npx prettier --write " <> filePath)
+ tests/Spec.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+++++module Spec where++import Data.String.Conversions (cs)+import Data.Text (replace)+import qualified FieldsAndCases as FnC+import GHC.Generics+import qualified GHC.Generics as GHC+import Lima.Converter (Format (..), convertTo, def)+import Relude+import Test.Tasty+import Test.Tasty.HUnit+import FieldsAndCases (IsTypeExpr)+import FieldsAndCases (TypeExpr)++newtype Code = Code Text+ deriving (Show, Eq)+ deriving newtype (IsString, Semigroup, IsTypeExpr, ToText)++instance TypeExpr Int Code where+ typeExpr = "Int"++instance TypeExpr Float Code where+ typeExpr = "Float"++instance TypeExpr Bool Code where+ typeExpr = "Bool"++instance TypeExpr Text Code where+ typeExpr = "Text"++instance (TypeExpr a Code) => TypeExpr [a] Code where+ typeExpr = "Vec<" <> FnC.typeExpr @a <> ">"++data SampleType2 = SampleType2 Int Bool+ deriving (Eq, Show, Generic)++instance TypeExpr SampleType2 Code++data SampleType+ = Case1 {fieldA :: Int, fieldB :: SampleType2, fieldC :: [Float]}+ | Case2 Int Text Float+ | Case3+ deriving (Eq, Show, Generic)++instance TypeExpr SampleType Code++-- ghci> :kind! Rep SampleType+-- Rep SampleType :: * -> *+type Re =+ M1+ D+ ('MetaData "SampleType" "Spec" "main" 'False)+ ( M1+ C+ ('MetaCons "Case1" 'PrefixI 'True)+ ( M1+ S+ ( 'MetaSel+ ('Just "fieldA")+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R Int)+ :*: ( M1+ S+ ( 'MetaSel+ ('Just "fieldB")+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R SampleType2)+ :*: M1+ S+ ( 'MetaSel+ ('Just "fieldC")+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R [Float])+ )+ )+ :+: ( M1+ C+ ('MetaCons "Case2" 'PrefixI 'False)+ ( M1+ S+ ( 'MetaSel+ 'Nothing+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R Int)+ :*: ( M1+ S+ ( 'MetaSel+ 'Nothing+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R Text)+ :*: M1+ S+ ( 'MetaSel+ 'Nothing+ 'NoSourceUnpackedness+ 'NoSourceStrictness+ 'DecidedLazy+ )+ (K1 R Float)+ )+ )+ :+: M1 C ('MetaCons "Case3" 'PrefixI 'False) U1+ )+ )++unitTests :: TestTree+unitTests =+ testGroup+ "Unit tests"+ [ testCase "..."+ $ ( FnC.toTypeDef @SampleType @Code+ @?= FnC.TypeDef+ { qualifiedName =+ FnC.QualifiedName+ { moduleName = "Spec",+ typeName = "SampleType"+ },+ cases =+ [ FnC.Case+ { tagName = "Case1",+ caseArgs =+ Just+ ( FnC.CaseFields+ [ FnC.Field {fieldName = "fieldA", fieldType = Code "Int"},+ FnC.Field {fieldName = "fieldB", fieldType = Code "SampleType2"},+ FnC.Field {fieldName = "fieldC", fieldType = Code "Vec<Float>"}+ ]+ )+ },+ FnC.Case+ { tagName = "Case2",+ caseArgs =+ Just+ ( FnC.CasePositionalArgs+ [ FnC.PositionalArg {fieldType = Code "Int"},+ FnC.PositionalArg {fieldType = Code "Text"},+ FnC.PositionalArg {fieldType = Code "Float"}+ ]+ )+ },+ FnC.Case {tagName = "Case3", caseArgs = Nothing}+ ]+ }+ )+ ]
+ tests/test.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.String.Conversions (cs)+import Data.Text (replace)+import GHC.Generics+import qualified GHC.Generics as GHC+import Lima.Converter (Format (..), convertTo, def)+import qualified Readme+import Relude+import Spec (unitTests)+import Test.Tasty+import Test.Tasty.HUnit+import Text.Regex (mkRegex, subRegex)++main :: IO ()+main = do+ genReadme+ defaultMain tests++genReadme :: IO ()+genReadme = do+ readmeMd <- readFileBS "README.md"++ readmeHs <- readFileBS "tests/Readme.hs"++ let readmeExample = convertTo Hs Md def (cs readmeHs)++ Readme.main++ readmeOutputRust <- readFileBS "tests/outputs/demo.rs"+ readmeOutputTypeScript <- readFileBS "tests/outputs/demo.ts"++ let readmeMd' =+ cs readmeMd+ & replaceSection "example" readmeExample+ & replaceSection+ "exampleOutRust"+ ("```rust\n" <> cs readmeOutputRust <> "\n```")+ & replaceSection+ "exampleOutTypeScript"+ ("```ts\n" <> cs readmeOutputTypeScript <> "\n```")++ writeFileBS "README.md" (cs readmeMd')++tests :: TestTree+tests = testGroup "Tests" [unitTests]++replaceSection :: Text -> Text -> Text -> Text+replaceSection name new doc =+ let pattern = "<!-- START:" <> name <> " -->(.|\n)*?<!-- END:" <> name <> " -->"+ replacement = "<!-- START:" <> name <> " -->\n" <> new <> "\n<!-- END:" <> name <> " -->"+ in regexReplace (cs pattern) replacement doc++-- Replace all occurrences of a pattern in a string+regexReplace :: Text -> Text -> Text -> Text+regexReplace pattern replacement input =+ let regex = mkRegex $ cs pattern+ in cs $ subRegex regex (cs input) (cs replacement)