diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for elmental + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/elmental.cabal b/elmental.cabal new file mode 100644 --- /dev/null +++ b/elmental.cabal @@ -0,0 +1,89 @@ +cabal-version: 3.0 + +maintainer: Gaël Deest +name: elmental +version: 0.1.0.0 + +license: BSD-3-Clause +synopsis: Generate Elm datatype definitions, encoders and decoders from Haskell datatypes. + +description: Elmental is a code generator that takes in Haskell type definitions and generates Elm datatypes, along with Aeson-compatible encoders and decoders. + It emphasizes flexibility, support for a large number of Haskell types, and integration into existing Elm codebases. + +homepage: https://github.com/withflint/monorepo +author: Gaël Deest + +category: Codegen + +extra-doc-files: CHANGELOG.md +source-repository head + type: git + location: https://github.com/gdeest/elmental.git + +common warnings + ghc-options: + -- force all warnings to be on and selectively disable some + -Weverything + -Wno-unticked-promoted-constructors + -Wno-unsafe + -Wno-missing-import-lists + -Wno-implicit-prelude + -Wno-missing-safe-haskell-mode + -Wno-missing-deriving-strategies + -Wno-missing-local-signatures + -Wno-monomorphism-restriction + -Wno-safe + -Wno-all-missed-specialisations + -Wno-missing-kind-signatures + -Wno-ambiguous-fields + -Wno-missing-export-lists + -Wunused-packages + +library + import: warnings + hs-source-dirs: src + default-language: GHC2021 + + exposed-modules: Elmental + Elmental.ElmStructure + Elmental.Generate + + build-depends: base >=4.16.4.0 && < 5.0, + containers >= 0.6.7 && < 0.8, + directory >= 1.3.7 && < 1.4, + filepath >= 1.4.2 && < 1.6, + kind-generics >= 0.5.0 && < 0.6, + neat-interpolation >= 0.5.1 && < 0.6, + text >= 2.0.2 && < 2.2, + + +test-suite elmental-test + import: warnings + hs-source-dirs: test + default-language: GHC2021 + + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: Codegen.SampleTypes + build-depends: base >=4.16.4.0 && < 5.0, + containers, + elmental, + text, + kind-generics-th < 0.3, + hspec, + hspec-golden, + pretty-show + +executable generate-test-app-code + import: warnings + hs-source-dirs: test + default-language: GHC2021 + + main-is: GenerateMain.hs + + other-modules: Codegen.SampleTypes + build-depends: base >=4.16.4.0 && < 5.0, + elmental, + text, + kind-generics-th < 0.3 diff --git a/src/Elmental.hs b/src/Elmental.hs new file mode 100644 --- /dev/null +++ b/src/Elmental.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Elmental ( + ElmDeclarable (..), + HasElmStructure, + ElmMapping (..), + HasSymbolInfo, + ElmKind, + defaultMapping, + getElmStructure, + getTypeName, + getModuleName, + getMapping, + setModule, + module Elmental.ElmStructure, +) where + +import Data.Kind (Type) +import Data.Proxy +import Data.Text (Text) +import Data.Text qualified as Text +import Elmental.ElmStructure +import GHC.Generics qualified as GHC +import GHC.TypeLits +import Generics.Kind + +type family KindOf (x :: k) :: Type where + KindOf (_ :: k) = k + +{- | Class mapping a Haskell type constructor @x :: k@ to an Elm type constructor. + + You can define instances for this class for any Haskell data / newtype constructor, + be it unapplied, partially applied or fully applied, provided that its kind is + not Elm-compatible (i.e., not higher-kinded). + + For example: + + @ + data SomeHKT f a = SomeHKT (f a) + + instance ElmDeclarable ((Type -> Type) -> Type) SomeHKT -- Not OK: SomeHKT is higher-kinded. + instance ElmDeclarable (Type -> Type) (SomeHKT Maybe) -- OK + instance ElmDeclarable Type (SomeHKT Maybe Int) -- OK + + instance ElmDeclarable [] -- OK + instance ElmDeclarable [Char] -- OK + @ +-} +class (ElmKind (KindOf x)) => ElmDeclarable x where + -- | Elm mapping information. + -- + -- Contains the name / location of the type and its encoder / decoder. + -- Can be overridden. + -- + -- Example: + -- + -- @ + -- instance ElmDeclarable Type [Char] where + -- mapTo = ElmMapping + -- { typeName = "String" + -- , moduleName = Nothing + -- , encoderLocation = Just $ SymbolLocation + -- { symbolName = "string" + -- , moduleName = "Json.Encode" + -- } + -- , decoderLocation = Just $ SymbolLocation + -- { symbolName = "string" + -- , moduleName = "Json.Decode" + -- } + -- , args = [] + -- } + -- @ + mapTo :: ElmMapping + default mapTo :: (HasSymbolInfo x) => ElmMapping + mapTo = defaultMapping @x + + -- | Internal function. You should not have to define this method yourself. + mkTyRef :: PList (NParams (KindOf x)) TyRef -> TyRef + default mkTyRef :: PList (NParams (KindOf x)) TyRef -> TyRef + mkTyRef pList = TyRef (TyMapping (mapTo @x)) (pListToList pList) + +{- | Instance for applied type constructors. + + Necessary to traverse the list of type constructors down to the root when constructing + type references to applied type constructors. +-} +instance + {-# OVERLAPPABLE #-} + forall k (t :: Type) (x :: Type -> k). + ( ElmDeclarable t + , ElmDeclarable (x :: Type -> k) + ) => + ElmDeclarable (x t) + where + mapTo = + let tMapping = mapTo @t + xMapping = mapTo @x + in xMapping{args = xMapping.args <> [tMapping]} + + mkTyRef remainingParams = mkTyRef @x ((mkTyRef @t PNil) `PCons` remainingParams) + +type HasSymbolInfo x = + ( KnownSymbol (GetTypeNameG (RepK x)) + , KnownSymbol (GetModuleNameG (RepK x)) + ) + +defaultMapping :: forall x. (HasSymbolInfo x) => ElmMapping +defaultMapping = + ElmMapping + { typeName = tName + , moduleName = Just mName + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "encode" <> tName + , symbolModuleName = mName + } + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "decode" <> tName + , symbolModuleName = mName + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + where + tName = symbolToText @(GetTypeNameG (RepK x)) + mName = symbolToText @(GetModuleNameG (RepK x)) + +{- | Overrides / sets the module name everywhere in a mapping. + Often useful in conjunction wit @defaultMapping@. +-} +setModule :: Text -> ElmMapping -> ElmMapping +setModule moduleName mapping = + mapping + { moduleName = Just moduleName + , decoderLocation = + ( \l -> + l + { symbolModuleName = moduleName + } + ) + <$> mapping.decoderLocation + , encoderLocation = + ( \l -> + l + { symbolModuleName = moduleName + } + ) + <$> mapping.encoderLocation + } + +-- Type metadata utilities +type family GetModuleNameG x where + GetModuleNameG (M1 _d ('GHC.MetaData _tyConName moduleName _pkg _isNewtype) _sop) = moduleName + +type family GetTypeNameG x where + GetTypeNameG (M1 _d ('GHC.MetaData tyConName _moduleName _pkg _isNewtype) _sop) = tyConName + +symbolToText :: forall sym. (KnownSymbol sym) => Text +symbolToText = Text.pack $ symbolVal (Proxy @sym) + +getMapping :: forall x. (ElmDeclarable x) => ElmMapping +getMapping = mapTo @x + +getTypeName :: forall x. (ElmDeclarable x) => Text +getTypeName = (getMapping @x).typeName + +getModuleName :: forall x. (ElmDeclarable x) => Maybe Text +getModuleName = (getMapping @x).moduleName + +-- Usual Peano numbers / length-indexed lists stuff. +data PNat = Z | S PNat + +type family PNatToNat (n :: PNat) :: Natural where + PNatToNat Z = 0 + PNatToNat (S n) = 1 + PNatToNat n + +data PList (n :: PNat) a where + PNil :: PList Z a + PCons :: a -> PList n a -> PList (S n) a + +pListToList :: PList n a -> [a] +pListToList PNil = [] +pListToList (a `PCons` as) = a : (pListToList as) + +-- | Constraint establishing that a kind is valid in Elm. +type ElmKind k = ElmKindB k ~ True + +type family ElmKindB k :: Bool where + ElmKindB Type = True + ElmKindB (Type -> k) = ElmKindB k + +-- Compute the number of type parameters of a type constuctor. +type family NParams k :: PNat where + NParams Type = Z + NParams (Type -> k) = S (NParams k) + +-- This shouldn't have to be a class as it only has a single instance, +-- but it seems to be the only way to expose @HasElmStructure@ as a simple +-- constraint. +class (repK ~ RepK x) => HasElmStructure' k (x :: k) repK where + getElmStructure' :: DatatypeStructure x + +instance + ( ElmDeclarable x + , RepK x ~ M1 GHC.D ('GHC.MetaData tName mName pkg isNewtype) sop + , GElmSum sop + , KnownNat (PNatToNat (NParams (KindOf x))) + ) => + HasElmStructure' k x (M1 GHC.D ('GHC.MetaData tName mName pkg isNewtype) sop) + where + getElmStructure' = + DatatypeStructure + { mapping = getMapping @x + , nParams = natVal $ Proxy @(PNatToNat (NParams k)) + , constructors = getValueConstructors @_ @sop + } + +type HasElmStructure k x = HasElmStructure' k x (RepK x) + +{- | Extract the structure of the representation of a datatype in Elm. + +Used by code generation. +-} +getElmStructure :: forall {k} (x :: k). (HasElmStructure k x) => DatatypeStructure x +getElmStructure = getElmStructure' @k @x @(RepK x) + +-- Extraction logic. +-- +-- We essentially pattern-match on the Generic representation to extract: +-- +-- - Elm metadata attached via the @ElmDeclarable@ class (type name and module name). +-- - Constructors (GElmSum). +-- - Fields, their names, and their types (potentially involving type variables). + +class GElmSum (sop :: k) where + getValueConstructors :: [Constructor] + +instance + ( KnownSymbol valConName + , GElmProduct fields + ) => + GElmSum (M1 GHC.C ('GHC.MetaCons valConName 'GHC.PrefixI isNt) fields) + where + getValueConstructors = + [ Constructor + { constructorName = symbolToText @valConName + , constructorFields = getFields @_ @fields + } + ] + +instance + ( KnownSymbol valConName + , GElmProduct fields + , GElmSum otherCons + ) => + GElmSum (M1 GHC.C ('GHC.MetaCons valConName 'GHC.PrefixI isNt) fields :+: otherCons) + where + getValueConstructors = + ( Constructor + { constructorName = Text.pack $ symbolVal (Proxy @valConName) + , constructorFields = getFields @_ @fields + } + ) + : getValueConstructors @_ @otherCons + +instance + ( GElmSum (s1 :+: s2) + , GElmSum otherCons + ) => + GElmSum ((s1 :+: s2) :+: otherCons) + where + getValueConstructors = + getValueConstructors @_ @(s1 :+: s2) + ++ getValueConstructors @_ @otherCons + +class GElmProduct (fields :: k) where + getFields :: [ElmField] + +instance GElmProduct U1 where + getFields = [] + +instance + (GElmField (M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType)) => + GElmProduct (M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType) + where + getFields = [getField @(M1 GHC.S ('GHC.MetaSel mbFName u s l) fieldType)] + +instance (GElmProduct (f1 :*: f2), GElmProduct fields) => GElmProduct ((f1 :*: f2) :*: fields) where + getFields = (getFields @_ @(f1 :*: f2)) ++ (getFields @_ @fields) + +instance (GElmField (M1 s m t), GElmProduct fields) => GElmProduct ((M1 s m t) :*: fields) where + getFields = (getField @(M1 s m t)) : (getFields @_ @fields) + +class GElmField field where + getField :: ElmField + +instance + (GElmFieldType Z fieldType, KnownSymbol fieldName) => + GElmField (M1 GHC.S ('GHC.MetaSel (Just fieldName) u s l) (Field fieldType)) + where + getField = (Just (symbolToText @fieldName), getTyRef @Z @fieldType PNil) + +instance + (GElmFieldType Z fieldType) => + GElmField (M1 GHC.S ('GHC.MetaSel Nothing u s l) (Field fieldType)) + where + getField = (Nothing, getTyRef @Z @fieldType PNil) + +class GElmFieldType (nParams :: PNat) fieldType where + getTyRef :: PList nParams TyRef -> TyRef + +class HasNat (vn :: k) where + type ToNat vn :: Nat + +-- GHC refuses a simple type family declaration (probably because the kinds vary). +instance HasNat VZ where + type ToNat VZ = 0 +instance HasNat (VS vn) where + type ToNat (VS vn) = 1 + (ToNat vn) + +instance (KnownNat (ToNat vn)) => GElmFieldType Z ('Var vn) where + getTyRef _ = TyRef (TyVar $ "a" <> Text.pack (show $ natVal $ Proxy @(ToNat vn))) [] + +instance (ElmDeclarable someType, nParams ~ NParams (KindOf someType)) => GElmFieldType nParams ('Kon someType) where + getTyRef params = mkTyRef @someType params + +instance + (GElmFieldType Z t2, GElmFieldType (S n) t1) => + GElmFieldType n (t1 :@: t2) + where + getTyRef params = getTyRef @(S n) @t1 ((getTyRef @Z @t2 PNil) `append` params) + +append :: a -> PList n a -> PList (S n) a +append a PNil = a `PCons` PNil +append a (b `PCons` bs) = (b `PCons` (a `append` bs)) diff --git a/src/Elmental/ElmStructure.hs b/src/Elmental/ElmStructure.hs new file mode 100644 --- /dev/null +++ b/src/Elmental/ElmStructure.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoFieldSelectors #-} + +module Elmental.ElmStructure where + +import Data.Text (Text) + +{- | Contains the mapping of Haskell type constructor to an Elm type constructor, +and potentially the location of its encoder / decoder. +-} +data ElmMapping = ElmMapping + { typeName :: TypeName + -- ^ Name of the corresponding Elm datatype. + , moduleName :: Maybe ModuleName + -- ^ Name of the module this type should be imported from / generated in. + -- + -- Can be set to @Nothing@ for core Elm types (@List@, @Bool@, @String@, ...) + -- which don't require explicit imports. + , encoderLocation :: Maybe SymbolLocation + -- ^ Location of the encoder for this type. + -- + -- Must be set if you want to generate it, or to generate encoders depending on it. + , decoderLocation :: Maybe SymbolLocation + -- ^ Location of the decoder for this type. + -- + -- Must be set if you want to generate it, or to generate encoders depending on it. + , args :: [ElmMapping] + -- ^ Arguments supplied to the type constructor. + , isTypeAlias :: Bool + -- ^ Indicates whether the generated Elm datataype should be a type alias + , urlPiece :: Maybe SymbolLocation + -- ^ Location of the URL piece builder / parser for this type. + , queryParam :: Maybe SymbolLocation + -- ^ Location of the query param builder / parser for this type. + } + deriving (Eq, Show, Ord) + +type ModuleName = Text +type SymbolName = Text +type TypeName = Text +type ConstructorName = Text +type FieldName = Text +type VarName = Text + +-- | Location of an Elm value (symbol / module name). +data SymbolLocation = SymbolLocation + { symbolName :: SymbolName + , symbolModuleName :: ModuleName + } + deriving (Eq, Show, Ord) + +data TyCon + = TyMapping ElmMapping + | TyVar VarName + deriving (Eq, Show, Ord) + +data TyRef = TyRef + { tyCon :: TyCon + , tyArgs :: [TyRef] + } + deriving (Eq, Show, Ord) + +data DatatypeStructure a = DatatypeStructure + { mapping :: ElmMapping + , nParams :: Integer + , constructors :: [Constructor] + } + deriving (Eq, Show, Ord) + +type ElmField = + (Maybe FieldName, TyRef) + +data Constructor = Constructor + { constructorName :: ConstructorName + , constructorFields :: [ElmField] + } + deriving (Eq, Show, Ord) diff --git a/src/Elmental/Generate.hs b/src/Elmental/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Elmental/Generate.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Elmental.Generate ( + generateTypeDef, + generateEncoder, + generateDecoder, + generateAll, + computeAll, + mkSourceMap, + include, + outputModule, + SomeStructure (..), + ModuleDefinition (..), +) where + +import Elmental + +import Data.Foldable (toList, traverse_) +import Data.Function ((&)) +import Data.List (foldl') +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import NeatInterpolation (trimming, untrimming) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +-- | Generate a type definition +generateTypeDef :: forall {k} (x :: k). (HasElmStructure k x) => Text +generateTypeDef = generateTypeDef' $ getElmStructure @x + +generateTypeDef' :: DatatypeStructure x -> Text +generateTypeDef' DatatypeStructure{..} + | (mapping.isTypeAlias && length constructors == 1 && null mapping.args && nParams == 0) = + [trimming| + type alias $tName = + $aliasDef + |] + | (mapping.isTypeAlias && (length constructors /= 1 || not (null mapping.args) || nParams /= 0)) = + error $ "Cannot generate an Elm type alias for: " <> show mapping.typeName + | (not (null constructors) && null mapping.args) = + [trimming| + type $tName $tVars + = $constructorDefs + |] + where + tName = mapping.typeName + currentModule = case mapping.moduleName of + Nothing -> error $ "Cannot generate mapping for: " <> show mapping.typeName <> " (unknown module)" + Just mName -> mName + tVars = Text.intercalate " " (nToVarName <$> take (fromIntegral nParams) [0 ..]) + aliasDef = Text.intercalate "\n| " (renderAlias <$> constructors) + constructorDefs = Text.intercalate "\n| " (renderConstructor <$> constructors) + renderAlias Constructor{..} = + case constructorFields of + [] -> [trimming|{}|] + _ -> + let + renderedRecordFields = renderRecordFields constructorFields + in + [trimming|$renderedRecordFields|] + + renderConstructor Constructor{..} = + case constructorFields of + [] -> constructorName + ((Nothing, _) : _) -> + [trimming| + $constructorName $renderedAnonymousFields + |] + ((Just _, _) : _) -> + [trimming| + $constructorName + $renderedRecordFields + |] + where + renderedAnonymousFields = renderAnonymousFields constructorFields + renderedRecordFields = renderRecordFields constructorFields + + renderAnonymousFields = Text.intercalate " " . map (renderTyRef currentModule . snd) + renderRecordFields fields = + [trimming| + { $renderedRecordFields + } + |] + where + renderedRecordFields = Text.intercalate "\n, " (renderField <$> fields) + renderField (Just fieldName, tyRef) = mconcat [fieldName, " : ", renderTyRef currentModule tyRef] + renderField a = error ("renderField - unmatched pattern:" ++ show a) + + nToVarName = Text.pack . ('a' :) . show @Integer +generateTypeDef' _ = error "Datatype has no constructor. Impossible to generate Elm definition." + +-- | Generate a decoder +generateDecoder :: forall {k} (x :: k). (HasElmStructure k x) => Text +generateDecoder = generateDecoder' $ getElmStructure @x + +generateDecoder' :: DatatypeStructure x -> Text +generateDecoder' DatatypeStructure{..} = + [trimming| + $decoderName : $decoderType + $decoderName $decoderArgs = + $decoderBody + |] + where + decoderName = case mapping.decoderLocation of + Just location -> location.symbolName + Nothing -> error $ "No decoder location for: " <> show mapping.typeName + decoderType = + mconcat + [ mconcat $ (\n -> "Decoder a" <> n <> " -> ") <$> params + , "Decoder " <> fullTypeName + ] + decoderArgs = + Text.intercalate " " $ ("d" <>) <$> params + decoderBody = case constructors of + [] -> + error $ "Uninhabited datatype: " <> show mapping.typeName + [singleConstructor] -> + if mapping.isTypeAlias + then decodeRecordAlias (mapping.typeName, mapping.moduleName) (singleConstructor.constructorFields) + else decodeConstructor (mapping.typeName, mapping.moduleName) singleConstructor + multiple -> + (if all isNullary constructors then decodeStringTag fullTypeName ((.constructorName) <$> constructors) else decodeTaggedSum (mapping.typeName, mapping.moduleName) fullTypeName multiple) + fullTypeName = + case nParams of + 0 -> mapping.typeName + _ -> + let tVars = Text.intercalate " " $ ("a" <>) <$> params + in mconcat ["(", mapping.typeName, " ", tVars, ")"] + + params = (Text.pack . show @Integer) <$> take (fromIntegral nParams) [0 ..] + +isNullary :: Constructor -> Bool +isNullary Constructor{..} = null constructorFields + +decodeStringTag :: Text -> [ConstructorName] -> Text +decodeStringTag fullTypeName cNames = + let tagBranches = + Text.intercalate "\n" $ + (\name -> mconcat ["\"", name, "\" -> Json.Decode.succeed ", name]) + <$> cNames + in [trimming| + let + decide : String -> Decoder $fullTypeName + decide tag = + case tag of + $tagBranches + other -> + Json.Decode.fail <| "$fullTypeName doesn't have constructor: " ++ other + in + Json.Decode.string + |> Json.Decode.andThen decide + |] + +decodeTaggedSum :: (TypeName, Maybe ModuleName) -> Text -> [Constructor] -> Text +decodeTaggedSum recursionStop fullTypeName constructors = + let tagBranches = Text.intercalate "\n" $ formatTagBranch recursionStop <$> constructors + in [trimming| + let + decide : String -> Decoder $fullTypeName + decide tag = + case tag of + $tagBranches + other -> + Json.Decode.fail <| "$fullTypeName doesn't have constructor: " ++ other + in + Json.Decode.field "tag" Json.Decode.string + |> Json.Decode.andThen decide + |] + +formatTagBranch :: (TypeName, Maybe ModuleName) -> Constructor -> Text +formatTagBranch recursionStop constructor@Constructor{..} = + let objectDecoder = decodeConstructor recursionStop constructor + in [trimming| + "$constructorName" -> + $objectDecoder + |] + +decodeConstructor :: (TypeName, Maybe ModuleName) -> Constructor -> Text +decodeConstructor recursionStop Constructor{..} = + case constructorFields of + [] -> "Json.Decode.succeed " <> constructorName + [(Nothing, tyRef)] -> + mconcat + [ [trimming|Json.Decode.field "contents" <||] + , " Json.Decode.map " + , constructorName + , " " + , mkTypeDecoder recursionStop tyRef + ] + fields@((Nothing, _) : _) -> decodeAnonymousConstructor recursionStop constructorName fields + fields@((Just _, _) : _) -> decodeRecordConstructor recursionStop constructorName fields + +decodeRecordConstructor :: (TypeName, Maybe ModuleName) -> ConstructorName -> [ElmField] -> Text +decodeRecordConstructor recursionStop cName fields = + case fields of + [] -> error "decodeRecordConstructor called on nullary constructor" + fields' -> + let mkFunction = mkFieldsFunction fields' + fieldDecoders = + Text.intercalate "\n" $ + mkFieldDecoder recursionStop <$> fields + in [trimming| + let mkFunction = + $mkFunction + contentDecoder = + Json.Decode.succeed mkFunction + $fieldDecoders + in Json.Decode.field "contents" (Json.Decode.map $cName contentDecoder) + |] + +decodeRecordAlias :: (TypeName, Maybe ModuleName) -> [ElmField] -> Text +decodeRecordAlias recursionStop fields = + case fields of + [] -> [trimming| Json.Decode.succeed {} |] + fields' -> + let mkFunction = mkFieldsFunction fields' + fieldDecoders = + Text.intercalate "\n" $ + mkFieldDecoder recursionStop <$> fields + in [trimming| + let mkFunction = + $mkFunction + contentDecoder = + Json.Decode.succeed mkFunction + $fieldDecoders + in contentDecoder + |] + +mkFieldDecoder :: (TypeName, Maybe ModuleName) -> ElmField -> Text +mkFieldDecoder recursionStop (Just fieldName, tyRef) = + let typDecoder = mkTypeDecoder recursionStop tyRef + in [trimming| + |> andMap (Json.Decode.field "$fieldName" $typDecoder) + |] +mkFieldDecoder _ a = + error $ "mkFieldDecoder - unmatched pattern: " ++ show a + +-- TODO: This recursion stop gimmmick only works if the type is directly recursive. +-- NOT if there is a cycle among decoders. +-- We should: +-- - Switch all decoder invocations to lazy as a MVP. +-- - Keep track of all types referend by a type and only insert lazy invocations where needed. +-- The performance hit may not be worth it. +mkTypeDecoder :: (TypeName, Maybe ModuleName) -> TyRef -> Text +mkTypeDecoder recursionStop@(tName, mName) TyRef{..} = + case tyCon of + TyVar varName -> "d" <> Text.tail varName -- TODO: Identify vars as ints, not strings. + TyMapping mapping -> renderMapping tyArgs mapping + where + renderMapping :: [TyRef] -> ElmMapping -> Text + renderMapping args mapping = + let renderedArgs = + Text.intercalate " " $ + (renderMapping [] <$> mapping.args) + <> (mkTypeDecoder recursionStop <$> args) + in if mapping.moduleName == mName && mapping.typeName == tName + then -- Same module, same type: lazy decoding without module prefix. + "(Json.Decode.lazy (\\_ -> decode" <> tName <> " " <> renderedArgs <> "))" + else + let decoderLocation = case mapping.decoderLocation of + Nothing -> error "No decoder" + Just location -> location + decodeFunction = (if mName == Just decoderLocation.symbolModuleName then (decoderLocation.symbolName) else decoderLocation.symbolModuleName <> "." <> decoderLocation.symbolName) + in case renderedArgs of + "" -> decodeFunction + _ -> "(" <> decodeFunction <> " " <> renderedArgs <> ")" + +mkFieldsFunction :: [ElmField] -> Text +mkFieldsFunction fields = + let fieldNames = (fromJust . fst) <$> fields + args = Text.intercalate " " fieldNames + fieldSetters = Text.intercalate "\n, " $ (\n -> n <> " = " <> n) <$> fieldNames + in [trimming| + \$args -> + { $fieldSetters + } + |] + +decodeAnonymousConstructor :: (TypeName, Maybe ModuleName) -> ConstructorName -> [ElmField] -> Text +decodeAnonymousConstructor recursionStop cName fields = + let contentDecoder = case length fields of + 0 -> error "decodeAnonymous constructor should not be used for nullary constructors" + 1 -> "Json.Decode.map " <> cName <> mkTypeDecoder recursionStop (snd $ head fields) + _ -> + let numberedFields = zip @Integer [0 ..] (snd <$> fields) + mkFieldDecoder' (n, tyRef) = + "|> andMap (Json.Decode.index " + <> Text.pack (show n) + <> " " + <> mkTypeDecoder recursionStop tyRef + <> ")" + fieldDecoders = Text.intercalate "\n" $ mkFieldDecoder' <$> numberedFields + in [trimming| + Json.Decode.succeed $cName + $fieldDecoders + |] + in [trimming| + let contentDecoder = + $contentDecoder + in + Json.Decode.field "contents" contentDecoder + |] + +-- | Generate an encoder +generateEncoder :: forall {k} (x :: k). (HasElmStructure k x) => Text +generateEncoder = generateEncoder' $ getElmStructure @x + +getEncoderLocation :: DatatypeStructure x -> SymbolLocation +getEncoderLocation DatatypeStructure{..} = + case mapping.encoderLocation of + Nothing -> error $ "No encoder location for: " <> show mapping.typeName + Just location -> location + +getEncoderName :: DatatypeStructure x -> Text +getEncoderName = (.symbolName) . getEncoderLocation + +getEncoderModule :: DatatypeStructure x -> Text +getEncoderModule = (.symbolModuleName) . getEncoderLocation + +generateEncoder' :: DatatypeStructure x -> Text +generateEncoder' structure@(DatatypeStructure{..}) + | mapping.isTypeAlias = + [trimming| + $encoderName : $encoderType + $defLineAlias + $bodyAlias + |] + | otherwise = + [trimming| + $encoderName : $encoderType + $defLine + $body + |] + where + encoderName = structure & getEncoderName + encoderType = mkEncoderType structure + defLine = mkEncoderDefLine structure + defLineAlias = mkEncoderDefLineAlias structure + body = mkEncoderBody structure + bodyAlias = mkEncoderBodyAlias structure + +mkEncoderType :: DatatypeStructure x -> Text +mkEncoderType structure = + Text.intercalate " " $ + mconcat + [ paramEncoderTypes + , [qualifiedTypeNameAt structure (structure & getEncoderLocation), "->", "Value"] + ] + where + paramEncoderTypes = + ((\n -> "(e" <> n <> " -> Value) ->") . (Text.pack . show @Integer)) + <$> take (fromIntegral structure.nParams) [0 ..] + +mkEncoderDefLine :: DatatypeStructure x -> Text +mkEncoderDefLine structure = + Text.intercalate " " $ + mconcat + [ [getEncoderName structure] + , (("e" <>) . Text.pack . show @Integer) <$> take (fromIntegral structure.nParams) [0 ..] + , ["v", "="] + ] + +mkEncoderDefLineAlias :: DatatypeStructure x -> Text +mkEncoderDefLineAlias structure = + Text.intercalate " " $ + mconcat + [ [getEncoderName structure] + , (("e" <>) . Text.pack . show @Integer) <$> take (fromIntegral structure.nParams) [0 ..] + , ["r", "="] + ] + +qualifiedTypeNameAt :: DatatypeStructure x -> SymbolLocation -> Text +qualifiedTypeNameAt s@(DatatypeStructure{..}) loc = + let tName = case mapping.moduleName of + Nothing -> mapping.typeName + Just _ -> prefixFor s loc <> mapping.typeName + tArgs = (("e" <>) . Text.pack . show @Integer) <$> take (fromIntegral s.nParams) [0 ..] + allComponents = tName : tArgs + in case allComponents of + [single] -> single + _multiple -> "(" <> Text.intercalate " " allComponents <> ")" + +prefixFor :: DatatypeStructure x -> SymbolLocation -> Text +prefixFor DatatypeStructure{..} loc = + case (mapping.moduleName, loc.symbolModuleName) of + (Nothing, _) -> "" + (Just m1, m2) -> if m1 == m2 then "" else m1 <> "." + +mkEncoderBody :: DatatypeStructure x -> Text +mkEncoderBody structure@(DatatypeStructure{..}) = + [trimming| + case v of + $constructorBranches + |] + where + constructorBranches = case constructors of + [] -> + error $ + "Cannot generate encoder body (no constructors): " + <> show structure.mapping.typeName + [singleConstructor] -> + unwrapConstructorBranch structure singleConstructor + multiple -> + multipleConstructorBranches structure multiple + +mkEncoderBodyAlias :: DatatypeStructure x -> Text +mkEncoderBodyAlias structure@(DatatypeStructure{..}) = + [trimming| + $constructorBranches + |] + where + constructorBranches = case constructors of + [] -> + error $ + "Cannot generate encoder body (no constructors): " + <> show structure.mapping.typeName + [singleConstructor] -> + let (_, _, contentEncoder) = constructorBranchHelper structure singleConstructor + in -- Single constructor with no field is encoded as an empty list + fromMaybe "Json.Encode.list identity []" contentEncoder + _ -> + error $ + "Cannot generate encoder body as type alias (too many constructors): " + <> show structure.mapping.typeName + +unwrapConstructorBranch :: DatatypeStructure x -> Constructor -> Text +unwrapConstructorBranch s@(DatatypeStructure{}) c = + let (cName, cArgs, contentEncoder) = constructorBranchHelper s c + matchLine = Text.intercalate " " (cName : cArgs) + in foldMap + ( \e -> + [trimming| + $matchLine -> + $e + |] + ) + contentEncoder + +constructorBranchHelper :: DatatypeStructure x -> Constructor -> (Text, [Text], Maybe Text) +constructorBranchHelper s@(DatatypeStructure{}) c = + (cName, cArgs, contentEncoder) + where + cName = prefixFor s (s & getEncoderLocation) <> c.constructorName + nFields = length c.constructorFields + contentEncoder = case c.constructorFields of + [] -> + -- Single constructor with no field has no content field + Nothing + [(Nothing, tyRef)] -> + -- Newtype-like: we directly encode the value + Just $ encoderForType s tyRef <> " " <> "p0" + ((Nothing, _tyRef) : _) -> + -- Multiple anonymous fields: encode positionally, as a list. + let encodedValues = + Text.intercalate "\n, " $ + (\(n, (_, tyRef)) -> encoderForType s tyRef <> " p" <> Text.pack (show n)) + <$> (zip @Integer [0 ..] c.constructorFields) + in Just + [trimming| + Json.Encode.list identity + [ $encodedValues + ] + |] + recordFields -> + let encodedPairs = + Text.intercalate "\n, " $ + ( \case + (Just fieldName, tyRef) -> encodePair fieldName tyRef + a -> error $ "unmatched pattern in constructorBranchHelper: " ++ show a + ) + <$> recordFields + encodePair fieldName tyRef = + "(\"" + <> fieldName + <> "\", " + <> encoderForType s tyRef + <> " r." + <> fieldName + <> ")" + in Just + [trimming| + Json.Encode.object + [ $encodedPairs + ] + |] + cArgs = case c.constructorFields of + [] -> [] + ((Just _, _) : _) -> ["r"] + _ -> + -- Anonymous fields + (("p" <>) . Text.pack . show @Integer) <$> take nFields [0 ..] + +multipleConstructorBranches :: DatatypeStructure x -> [Constructor] -> Text +multipleConstructorBranches structure constructors = + let prefix = (prefixFor structure (structure & getEncoderLocation)) + in (if all isNullary constructors then encodeStringTags prefix ((.constructorName) <$> constructors) else encodeTaggedBranches structure constructors) + +encodeStringTags :: Text -> [ConstructorName] -> Text +encodeStringTags prefix cnames = + Text.intercalate "\n" $ + (\cname -> prefix <> cname <> " -> Json.Encode.string \"" <> cname <> "\"") <$> cnames + +encodeTaggedBranches :: DatatypeStructure x -> [Constructor] -> Text +encodeTaggedBranches ds cs = Text.intercalate "\n" $ mkTagBranch <$> cs + where + mkTagBranch c = + let (cName, cArgs, encodedContent) = + constructorBranchHelper ds c + match = Text.intercalate " " (cName : cArgs) + tag = c.constructorName + contentsField = + foldMap + ( \val -> + [untrimming| + , ( "contents" + , $val + ) + |] + ) + encodedContent + in [trimming| + $match -> Json.Encode.object + [ ( "tag", Json.Encode.string "$tag" )$contentsField] + |] + +encoderForType :: DatatypeStructure x -> TyRef -> Text +encoderForType ds TyRef{..} = + case tyCon of + TyVar varName -> "e" <> Text.tail varName -- Won't have args (No HKTs) + TyMapping mapping -> renderMapping mapping + where + renderMapping mapping = + let encoderName = case mapping.encoderLocation of + Nothing -> error $ "Could not find encoder for type: " <> show mapping.typeName + Just location -> + (if location.symbolModuleName == getEncoderModule ds then (location.symbolName) else location.symbolModuleName <> "." <> location.symbolName) + paramEncoders = + (renderMapping <$> mapping.args) + <> (encoderForType ds <$> tyArgs) + in "(" <> Text.intercalate " " (encoderName : paramEncoders) <> ")" + +-- +data SomeStructure = forall x. SomeStructure (DatatypeStructure x) +include :: forall {k} x. (HasElmStructure k x) => SomeStructure +include = SomeStructure $ getElmStructure @x + +data ModuleDefinition = ModuleDefinition + { imports :: Set ModuleName + , typeDefs :: [Text] + , encoders :: [Text] + , decoders :: [Text] + } + deriving (Eq, Show) + +instance Semigroup ModuleDefinition where + m1 <> m2 = + ModuleDefinition + { imports = Set.union m1.imports m2.imports + , typeDefs = m1.typeDefs <> m2.typeDefs + , encoders = m1.encoders <> m2.encoders + , decoders = m1.decoders <> m2.decoders + } +instance Monoid ModuleDefinition where + mempty = ModuleDefinition mempty mempty mempty mempty + +generateAll :: FilePath -> [SomeStructure] -> IO () +generateAll baseDir ds = do + let srcMap = mkSourceMap ds + traverse_ (outputModule baseDir) $ Map.toAscList srcMap + +mkSourceMap :: [SomeStructure] -> Map ModuleName Text +mkSourceMap ds = Map.mapWithKey renderModule $ computeAll ds + +outputModule :: FilePath -> (ModuleName, Text) -> IO () +outputModule baseDir (mName, source) = do + let fileDir = baseDir relDir + filePath = fileDir fileName + fileName = fileComponent <> ".elm" + relDir = foldl' () "" dirComponents + fileComponent = head reversed + dirComponents = reverse $ drop 1 reversed + reversed = reverse moduleComponents + moduleComponents = Text.unpack <$> Text.split (== '.') mName + createDirectoryIfMissing True fileDir + Text.writeFile filePath source + +renderModule :: ModuleName -> ModuleDefinition -> Text +renderModule mName ModuleDefinition{..} = + [trimming| + module $mName exposing (..) + + $importsSrc + import Json.Encode + import Json.Encode exposing (Value) + import Json.Decode + import Json.Decode exposing (Decoder) + import Json.Decode.Extra exposing (andMap) + + + $typeDefsSrc + + $encodersSrc + + $decodersSrc + |] + where + typeDefsSrc = Text.intercalate "\n\n" typeDefs + encodersSrc = Text.intercalate "\n\n" encoders + decodersSrc = Text.intercalate "\n\n" decoders + importsSrc = Text.unlines $ ("import " <>) <$> (Set.toAscList imports) + +computeAll :: [SomeStructure] -> Map ModuleName ModuleDefinition +computeAll = foldl' addToModules Map.empty . mconcat . fmap mkModuleDefs + where + addToModules modules (mName, def) = + Map.insertWith (<>) mName def modules + mkModuleDefs (SomeStructure ds) = + let constructorImports = Set.fromList $ mconcat $ getImports <$> ds.constructors + typeImport = Set.fromList $ toList ds.mapping.moduleName + in catMaybes + [ case ds.mapping.moduleName of + Nothing -> Nothing + Just mName -> Just (mName, mDef) + where + mDef = + mempty + { imports = Set.delete mName constructorImports + , typeDefs = pure $ generateTypeDef' ds + } + , case ds.mapping.encoderLocation of + Nothing -> Nothing + Just encoder -> Just (encoder.symbolModuleName, mDef) + where + mDef = + mempty + { imports = + Set.delete + encoder.symbolModuleName + (constructorImports `Set.union` typeImport) + , encoders = pure $ generateEncoder' ds + } + , case ds.mapping.decoderLocation of + Nothing -> Nothing + Just decoder -> Just (decoder.symbolModuleName, mDef) + where + mDef = + mempty + { imports = + Set.delete + decoder.symbolModuleName + (constructorImports `Set.union` typeImport) + , decoders = pure $ generateDecoder' ds + } + ] + +getImports :: Constructor -> [Text] +getImports Constructor{..} = mconcat $ getFieldImports <$> constructorFields + where + getFieldImports (_, tyRef) = getTypeImports tyRef + getTypeImports :: TyRef -> [Text] + getTypeImports tyRef = + mconcat + [ (mconcat $ getTypeImports <$> tyRef.tyArgs) + , mappingArgs tyRef.tyCon + ] + mappingArgs tyCon = case tyCon of + TyMapping mapping -> + toList mapping.moduleName + <> toList ((.symbolModuleName) <$> mapping.encoderLocation) + <> toList ((.symbolModuleName) <$> mapping.decoderLocation) + <> mconcat (mappingArgs . TyMapping <$> mapping.args) + _ -> mempty + +-- Utility functions +renderTyRef :: ModuleName -> TyRef -> Text +renderTyRef currentModule tyRef = + wrapIfNeeded allRendered + where + wrapIfNeeded :: [Text] -> Text + wrapIfNeeded xs = case xs of + [single] -> single + _multiple -> "(" <> Text.intercalate " " xs <> ")" + + allRendered :: [Text] + allRendered = + renderTyCon tyRef.tyCon <> (renderTyRef currentModule <$> tyRef.tyArgs) + + renderTyCon :: TyCon -> [Text] + renderTyCon tyCon = case tyCon of + TyVar v -> [v] + TyMapping mapping -> renderMapping mapping + + mkTyCon :: ElmMapping -> Text + mkTyCon mapping = case mapping.moduleName of + Nothing -> mapping.typeName + Just mName -> (if mName == currentModule then (mapping.typeName) else mName <> "." <> mapping.typeName) + + renderMapping :: ElmMapping -> [Text] + renderMapping mapping = + (mkTyCon mapping) + : ((wrapIfNeeded . renderMapping) <$> mapping.args) diff --git a/test/Codegen/SampleTypes.hs b/test/Codegen/SampleTypes.hs new file mode 100644 --- /dev/null +++ b/test/Codegen/SampleTypes.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StarIsType #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module Codegen.SampleTypes where + +import Data.Kind (Type) +import Data.Text (Text) +import Elmental +import Elmental.Generate (SomeStructure, include) +import GHC.TypeLits (Nat) +import Generics.Kind.TH (deriveGenericK, deriveGenericKQuiet) + +data SimpleType = SimpleType Int + +data SimpleRecord = SimpleRecord + { name :: PolymorphicRecursiveType SimpleType + , age :: SimpleType + } + +data EmptyAlias = EmptyAlias + +data SimpleRecordAlias = SimpleRecordAlias + { name :: PolymorphicRecursiveType SimpleType + , age :: SimpleType + } + +data RecordWithMultipleConstructors + = FirstRecordConstructor {foo :: Bool} + | SecondRecordConstructor {bar :: Maybe Int} + +data MonomorphicRecursiveType = SMRTNil | SMRTCons Int MonomorphicRecursiveType + +data PolymorphicRecursiveType (a :: Type) = SPRTNil | SPRTCons a (PolymorphicRecursiveType a) + +data SimpleHKT (f :: Type -> Type) = SimpleHKT (f String) + +data HKTWithSpecializedKindStarParams a b f = HKTWithSpecializedKindStarParams b (f a) + +data HKTWithUnspecializedParams (f :: Type -> Type) (a :: Type) (b :: Type) + = HKTWithUnspecializedParams (f (f (f a))) b + +data NatPhantomParameter (n :: Nat) a = NatPhantomParameter [a] + +data Tag = Report | Submission + +type family HKD (tag :: Tag) a where + -- HKD 'Report ByteString64 = Bool + HKD 'Report a = Maybe a + HKD 'Submission (FileUpload 'Submission) = Maybe (FileUpload 'Submission) + HKD 'Submission a = a + +data FileUpload tag = FileUpload + { fileName :: HKD tag Text + -- , content :: HKD tag ByteString64 + } + +data Form tag = Form + { userName :: HKD tag Text + , upload :: HKD tag (FileUpload tag) + } + +data LargeRecord a = LargeRecord + { field0 :: NatPhantomParameter 0 a + , field1 :: NatPhantomParameter 1 a + , field2 :: NatPhantomParameter 2 a + , field3 :: NatPhantomParameter 3 a + , field4 :: NatPhantomParameter 4 a + , field5 :: NatPhantomParameter 5 a + , field6 :: NatPhantomParameter 6 a + , field7 :: NatPhantomParameter 7 a + , field8 :: NatPhantomParameter 8 a + , field9 :: NatPhantomParameter 9 a + , field10 :: NatPhantomParameter 10 a + , field11 :: NatPhantomParameter 11 a + , field12 :: NatPhantomParameter 12 a + , field13 :: NatPhantomParameter 13 a + , field14 :: NatPhantomParameter 14 a + , field15 :: NatPhantomParameter 15 a + , field16 :: NatPhantomParameter 16 a + , field17 :: NatPhantomParameter 17 a + , field18 :: NatPhantomParameter 18 a + , field19 :: NatPhantomParameter 19 a + , field20 :: NatPhantomParameter 20 a + , field21 :: NatPhantomParameter 21 a + , field22 :: NatPhantomParameter 22 a + , field23 :: NatPhantomParameter 23 a + , field24 :: NatPhantomParameter 24 a + , field25 :: NatPhantomParameter 25 a + , field26 :: NatPhantomParameter 26 a + , field27 :: NatPhantomParameter 27 a + , field28 :: NatPhantomParameter 28 a + , field29 :: NatPhantomParameter 29 a + , field30 :: NatPhantomParameter 30 a + , field31 :: NatPhantomParameter 31 a + , field32 :: NatPhantomParameter 32 a + , field33 :: NatPhantomParameter 33 a + , field34 :: NatPhantomParameter 34 a + , field35 :: NatPhantomParameter 35 a + , field36 :: NatPhantomParameter 36 a + , field37 :: NatPhantomParameter 37 a + , field38 :: NatPhantomParameter 38 a + , field39 :: NatPhantomParameter 39 a + , field40 :: NatPhantomParameter 40 a + , field41 :: NatPhantomParameter 41 a + , field42 :: NatPhantomParameter 42 a + , field43 :: NatPhantomParameter 43 a + , field44 :: NatPhantomParameter 44 a + , field45 :: NatPhantomParameter 45 a + , field46 :: NatPhantomParameter 46 a + , field47 :: NatPhantomParameter 47 a + , field48 :: NatPhantomParameter 48 a + , field49 :: NatPhantomParameter 49 a + , field50 :: NatPhantomParameter 50 a + , field51 :: NatPhantomParameter 51 a + , field52 :: NatPhantomParameter 52 a + , field53 :: NatPhantomParameter 53 a + , field54 :: NatPhantomParameter 54 a + , field55 :: NatPhantomParameter 55 a + , field56 :: NatPhantomParameter 56 a + , field57 :: NatPhantomParameter 57 a + , field58 :: NatPhantomParameter 58 a + , field59 :: NatPhantomParameter 59 a + , field60 :: NatPhantomParameter 60 a + , field61 :: NatPhantomParameter 61 a + , field62 :: NatPhantomParameter 62 a + , field63 :: NatPhantomParameter 63 a + , field64 :: NatPhantomParameter 64 a + , field65 :: NatPhantomParameter 65 a + , field66 :: NatPhantomParameter 66 a + , field67 :: NatPhantomParameter 67 a + , field68 :: NatPhantomParameter 68 a + , field69 :: NatPhantomParameter 69 a + , field70 :: NatPhantomParameter 70 a + , field71 :: NatPhantomParameter 71 a + , field72 :: NatPhantomParameter 72 a + , field73 :: NatPhantomParameter 73 a + , field74 :: NatPhantomParameter 74 a + , field75 :: NatPhantomParameter 75 a + , field76 :: NatPhantomParameter 76 a + , field77 :: NatPhantomParameter 77 a + , field78 :: NatPhantomParameter 78 a + , field79 :: NatPhantomParameter 79 a + , field80 :: NatPhantomParameter 80 a + , field81 :: NatPhantomParameter 81 a + , field82 :: NatPhantomParameter 82 a + , field83 :: NatPhantomParameter 83 a + , field84 :: NatPhantomParameter 84 a + , field85 :: NatPhantomParameter 85 a + , field86 :: NatPhantomParameter 86 a + , field87 :: NatPhantomParameter 87 a + , field88 :: NatPhantomParameter 88 a + , field89 :: NatPhantomParameter 89 a + , field90 :: NatPhantomParameter 90 a + , field91 :: NatPhantomParameter 91 a + , field92 :: NatPhantomParameter 92 a + , field93 :: NatPhantomParameter 93 a + , field94 :: NatPhantomParameter 94 a + , field95 :: NatPhantomParameter 95 a + , field96 :: NatPhantomParameter 96 a + , field97 :: NatPhantomParameter 97 a + , field98 :: NatPhantomParameter 98 a + , field99 :: NatPhantomParameter 99 a + } +data CountryCode + = AD + | AE + | AF + | AG + | AI + | AL + | AM + | AO + | AQ + | AR + | AS + | AT + | AU + | AW + | AX + | AZ + | BA + | BB + | BD + | BE + | BF + | BG + | BH + | BI + | BJ + | BL + | BM + | BN + | BO + | BQ + | BR + | BS + | BT + | BV + | BW + | BY + | BZ + | CA + | CC + | CD + | CF + | CG + | CH + | CI + | CK + | CL + | CM + | CN + | CO + | CR + | CU + | CV + | CW + | CX + | CY + | CZ + | DE + | DJ + | DK + | DM + | DO + | DZ + | EC + | EE + | EG + | EH + | ER + | ES + | ET + | FI + | FJ + | FK + | FM + | FO + | FR + | GA + | GB + | GD + | GE + | GF + | GG + | GH + | GI + | GL + | GM + | GN + | GP + | GQ + | GR + | GS + | GT + | GU + | GW + | GY + | HK + | HM + | HN + | HR + | HT + | HU + | ID + | IE + | IL + | IM + | IN + | IO + | IQ + | IR + | IS + | IT + | JE + | JM + | JO + | JP + | KE + | KG + | KH + | KI + | KM + | KN + | KP + | KR + | KW + | KY + | KZ + | LA + | LB + | LC + | LI + | LK + | LR + | LS + | LT + | LU + | LV + | LY + | MA + | MC + | MD + | ME + | MF + | MG + | MH + | MK + | ML + | MM + | MN + | MO + | MP + | MQ + | MR + | MS + | MT + | MU + | MV + | MW + | MX + | MY + | MZ + | NA + | NC + | NE + | NF + | NG + | NI + | NL + | NO + | NP + | NR + | NU + | NZ + | OM + | PA + | PE + | PF + | PG + | PH + | PK + | PL + | PM + | PN + | PR + | PS + | PT + | PW + | PY + | QA + | RE + | RO + | RS + | RU + | RW + | SA + | SB + | SC + | SD + | SE + | SG + | SH + | SI + | SJ + | SK + | SL + | SM + | SN + | SO + | SR + | SS + | ST + | SV + | SX + | SY + | SZ + | TC + | TD + | TF + | TG + | TH + | TJ + | TK + | TL + | TM + | TN + | TO + | TR + | TT + | TV + | TW + | TZ + | UA + | UG + | UM + | US + | UY + | UZ + | VA + | VC + | VE + | VG + | VI + | VN + | VU + | WF + | WS + | YE + | YT + | ZA + | ZM + | ZW + +$(deriveGenericK ''SimpleType) +$(deriveGenericK ''SimpleRecord) +$(deriveGenericK ''SimpleRecordAlias) +$(deriveGenericK ''EmptyAlias) +$(deriveGenericK ''RecordWithMultipleConstructors) +$(deriveGenericK ''MonomorphicRecursiveType) +$(deriveGenericK ''PolymorphicRecursiveType) +$(deriveGenericK ''SimpleHKT) +$(deriveGenericK ''HKTWithSpecializedKindStarParams) +$(deriveGenericK ''HKTWithUnspecializedParams) +$(deriveGenericK ''NatPhantomParameter) +$(deriveGenericK ''LargeRecord) +$(deriveGenericK ''CountryCode) +$(deriveGenericKQuiet ''FileUpload) +$(deriveGenericKQuiet ''Form) + +-- Datatypes defined elsewhere + +$(deriveGenericK ''Bool) +$(deriveGenericK ''Maybe) +$(deriveGenericK ''Either) + +sampleTypes :: [SomeStructure] +sampleTypes = + [ include @SimpleType + , include @SimpleRecord + , include @SimpleRecordAlias + , include @EmptyAlias + , include @MonomorphicRecursiveType + , include @PolymorphicRecursiveType + , include @(SimpleHKT Maybe) + , include @(HKTWithSpecializedKindStarParams Int Text Maybe) + , include @(HKTWithUnspecializedParams (Either Int)) + , include @(NatPhantomParameter 3) + , include @RecordWithMultipleConstructors + , include @LargeRecord + , include @CountryCode + , include @Either + , include @(FileUpload 'Submission) + , include @(FileUpload 'Report) + , include @(Form 'Submission) + , include @(Form 'Report) + ] + +instance ElmDeclarable SimpleType +instance ElmDeclarable SimpleRecord +instance ElmDeclarable RecordWithMultipleConstructors +instance ElmDeclarable MonomorphicRecursiveType +instance ElmDeclarable PolymorphicRecursiveType +instance (ElmDeclarable f, HasSymbolInfo f) => ElmDeclarable (SimpleHKT f) where + mapTo = + (defaultMapping @(SimpleHKT f)) + { typeName = "SimpleHKT" <> getTypeName @f + } + +instance ElmDeclarable (HKTWithSpecializedKindStarParams Int Text Maybe) +instance ElmDeclarable (HKTWithUnspecializedParams (Either Int)) + +instance ElmDeclarable (NatPhantomParameter n) where + mapTo = + (defaultMapping @(NatPhantomParameter n)) + { typeName = "LookMaNoPhantomParam" + } + +instance ElmDeclarable LargeRecord + +instance ElmDeclarable Int where + mapTo = + ElmMapping + { typeName = "Int" + , moduleName = Nothing + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "int" + , symbolModuleName = "Json.Decode" + } + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "int" + , symbolModuleName = "Json.Encode" + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + +instance ElmDeclarable Text where + mapTo = + ElmMapping + { typeName = "String" + , moduleName = Nothing + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "string" + , symbolModuleName = "Json.Decode" + } + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "string" + , symbolModuleName = "Json.Encode" + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + +instance ElmDeclarable [Char] where + mapTo = mapTo @Text + +instance ElmDeclarable CountryCode where + mapTo = setModule "Data.CountryCode" (defaultMapping @CountryCode) + +instance ElmDeclarable Bool where + mapTo = + ElmMapping + { typeName = "Bool" + , moduleName = Nothing + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "bool" + , symbolModuleName = "Json.Decode" + } + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "bool" + , symbolModuleName = "Json.Encode" + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + +instance ElmDeclarable Maybe where + mapTo = + ElmMapping + { typeName = "Maybe" + , moduleName = Just "Maybe" + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "nullable" + , symbolModuleName = "Json.Decode" + } + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "maybe" + , symbolModuleName = "Json.Encode.Extra" + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + +instance ElmDeclarable Either where + mapTo = setModule "Codegen.Either" (defaultMapping @Either) + +instance ElmDeclarable [] where + mapTo = + ElmMapping + { typeName = "List" + , moduleName = Nothing + , decoderLocation = + Just $ + SymbolLocation + { symbolName = "list" + , symbolModuleName = "Json.Decode" + } + , encoderLocation = + Just $ + SymbolLocation + { symbolName = "list" + , symbolModuleName = "Json.Encode" + } + , args = [] + , isTypeAlias = False + , urlPiece = Nothing + , queryParam = Nothing + } + +instance ElmDeclarable (Form 'Submission) where + mapTo = setModule "Codegen.Submission" (defaultMapping @(Form 'Submission)) + +instance ElmDeclarable (Form 'Report) where + mapTo = setModule "Codegen.Report" (defaultMapping @(Form 'Report)) + +instance ElmDeclarable (FileUpload 'Submission) where + mapTo = setModule "Codegen.Submission" (defaultMapping @(FileUpload 'Submission)) + +instance ElmDeclarable (FileUpload 'Report) where + mapTo = setModule "Codegen.Report" (defaultMapping @(FileUpload 'Report)) + +instance ElmDeclarable SimpleRecordAlias where + mapTo = + (defaultMapping @SimpleRecordAlias) + { isTypeAlias = True + } + +instance ElmDeclarable EmptyAlias where + mapTo = + (defaultMapping @EmptyAlias) + { isTypeAlias = True + } diff --git a/test/GenerateMain.hs b/test/GenerateMain.hs new file mode 100644 --- /dev/null +++ b/test/GenerateMain.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Codegen.SampleTypes (sampleTypes) +import Elmental.Generate + +main :: IO () +main = generateAll "src" sampleTypes diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +import Codegen.SampleTypes + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Elmental +import Elmental.Generate + +import Test.Hspec +import Test.Hspec.Golden + +import Text.Show.Pretty (ppShow) + +mkExtractionTest :: forall {k} x. (HasElmStructure k x) => String -> Golden String +mkExtractionTest name = + Golden + { output = ppShow $ getElmStructure @x + , encodePretty = id + , writeToFile = writeFile + , readFromFile = readFile + , goldenFile = "test-output/extraction/golden/" <> name <> ".txt" + , actualFile = Just $ "test-output/extraction/actual/" <> name <> ".txt" + , failFirstTime = True + } + +mkCodegenTest :: [SomeStructure] -> String -> Golden String +mkCodegenTest typs name = + Golden + { output = renderSourceMap $ mkSourceMap typs + , encodePretty = id + , writeToFile = writeFile + , readFromFile = readFile + , goldenFile = "test-output/codegen/golden/" <> name <> ".txt" + , actualFile = Just $ "test-output/codegen/actual/" <> name <> ".txt" + , failFirstTime = True + } + +renderSourceMap :: Map ModuleName Text -> String +renderSourceMap srcMap = unlines (prettifyModule <$> Map.toAscList srcMap) + where + prettifyModule (mName, src) = + unlines + [ hr + , Text.unpack mName <> ": " + , hr + , Text.unpack src + , hr + ] + hr = replicate 80 '#' + +extractionSpec :: Spec +extractionSpec = describe "Extraction" $ do + it "Handles simple types" $ do + mkExtractionTest @SimpleType "SimpleType" + + it "Handles simple records" $ do + mkExtractionTest @SimpleRecord "SimpleRecord" + + it "Handles simple record aliases" $ do + mkExtractionTest @SimpleRecordAlias "SimpleRecordAlias" + + it "Handles empty aliases" $ do + mkExtractionTest @EmptyAlias "EmptyAlias" + + it "Handles records with several constructors" $ do + mkExtractionTest @RecordWithMultipleConstructors "RecordWithMultipleConstructors" + + it "Handles monomorphic recursive types" $ do + mkExtractionTest @MonomorphicRecursiveType "MonomorphicRecursiveType" + + it "Handles polymorphic recursive types" $ do + mkExtractionTest @PolymorphicRecursiveType "PolymorphicRecursiveType" + + it "Handles specialized simple HKTs" $ do + mkExtractionTest @(SimpleHKT Maybe) "SimpleHKT_Maybe" + + it "Handles HKTs with other specialized type variables" $ do + mkExtractionTest + @(HKTWithSpecializedKindStarParams Int Text Maybe) + "HKTWithSpecializedKindStarparams_Int_Text_Maybe" + + it "Handles HKTs with unspecialized type variables" $ do + mkExtractionTest + @(HKTWithUnspecializedParams (Either Int)) + "HKTWithUnspecializedParams_(Either_Int)" + + it "Happily ignores phantom parameters of non Type kind" $ do + mkExtractionTest @(NatPhantomParameter 3) "NatPhantomparameter_3" + + it "Handles large records" $ do + mkExtractionTest @LargeRecord "LargeRecord" + + it "Handles large sum types" $ do + mkExtractionTest @CountryCode "CountryCode" + + it "Handles the higher-kinded data pattern (1/2)" $ + mkExtractionTest @(Form 'Submission) "Form_Submission" + + it "Handles the higher-kinded data pattern (2/2)" $ + mkExtractionTest @(Form 'Report) "Form_Report" + +generationSpec :: Spec +generationSpec = describe "Generation" $ do + it "Generates modules for user types" $ do + mkCodegenTest sampleTypes "SampleTypes" + +generate :: IO () +generate = generateAll "src" sampleTypes + +main :: IO () +main = hspec $ do + extractionSpec + generationSpec