diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for haskell-codegen + +## 0.1.0.0 -- 2024-07-12 + +* Initial release diff --git a/fields-and-cases.cabal b/fields-and-cases.cabal new file mode 100644 --- /dev/null +++ b/fields-and-cases.cabal @@ -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 diff --git a/lib/FieldsAndCases.hs b/lib/FieldsAndCases.hs new file mode 100644 --- /dev/null +++ b/lib/FieldsAndCases.hs @@ -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) diff --git a/tests/Readme.hs b/tests/Readme.hs new file mode 100644 --- /dev/null +++ b/tests/Readme.hs @@ -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 #-} + +{- + +-} + +{- +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"} + ] + ) + }, + 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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -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"} + ] + ) + }, + 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} + ] + } + ) + ] diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -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 = "(.|\n)*?" + replacement = "\n" <> new <> "\n" + 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)