elmental (empty) → 0.1.0.0
raw patch · 8 files changed
+2002/−0 lines, 8 filesdep +basedep +containersdep +directory
Dependencies added: base, containers, directory, elmental, filepath, hspec, hspec-golden, kind-generics, kind-generics-th, neat-interpolation, pretty-show, text
Files
- CHANGELOG.md +5/−0
- elmental.cabal +89/−0
- src/Elmental.hs +350/−0
- src/Elmental/ElmStructure.hs +76/−0
- src/Elmental/Generate.hs +713/−0
- test/Codegen/SampleTypes.hs +636/−0
- test/GenerateMain.hs +7/−0
- test/Main.hs +126/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for elmental++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ elmental.cabal view
@@ -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
+ src/Elmental.hs view
@@ -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))
+ src/Elmental/ElmStructure.hs view
@@ -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)
+ src/Elmental/Generate.hs view
@@ -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)
+ test/Codegen/SampleTypes.hs view
@@ -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+ }
+ test/GenerateMain.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Codegen.SampleTypes (sampleTypes)+import Elmental.Generate++main :: IO ()+main = generateAll "src" sampleTypes
+ test/Main.hs view
@@ -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