{-# 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 ((</>))
generateTypeDef :: forall {k} (x :: k). (HasElmStructure k x) => Text
generateTypeDef :: forall {k} (x :: k). HasElmStructure k x => ModuleName
generateTypeDef = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateTypeDef' (DatatypeStructure x -> ModuleName)
-> DatatypeStructure x -> ModuleName
forall a b. (a -> b) -> a -> b
$ forall (x :: k). HasElmStructure k x => DatatypeStructure x
forall {k} (x :: k). HasElmStructure k x => DatatypeStructure x
getElmStructure @x
generateTypeDef' :: DatatypeStructure x -> Text
generateTypeDef' :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateTypeDef' DatatypeStructure{Integer
[Constructor]
ElmMapping
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
..}
| (ElmMapping
mapping.isTypeAlias Bool -> Bool -> Bool
&& [Constructor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constructor]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [ElmMapping] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ElmMapping
mapping.args Bool -> Bool -> Bool
&& Integer
nParams Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) =
[trimming|
type alias $tName =
$aliasDef
|]
| (ElmMapping
mapping.isTypeAlias Bool -> Bool -> Bool
&& ([Constructor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constructor]
constructors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 Bool -> Bool -> Bool
|| Bool -> Bool
not ([ElmMapping] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ElmMapping
mapping.args) Bool -> Bool -> Bool
|| Integer
nParams Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)) =
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot generate an Elm type alias for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ElmMapping
mapping.typeName
| (Bool -> Bool
not ([Constructor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constructor]
constructors) Bool -> Bool -> Bool
&& [ElmMapping] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ElmMapping
mapping.args) =
[trimming|
type $tName $tVars
= $constructorDefs
|]
where
tName :: ModuleName
tName = ElmMapping
mapping.typeName
currentModule :: ModuleName
currentModule = case ElmMapping
mapping.moduleName of
Maybe ModuleName
Nothing -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot generate mapping for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ElmMapping
mapping.typeName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" (unknown module)"
Just ModuleName
mName -> ModuleName
mName
tVars :: ModuleName
tVars = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " (Integer -> ModuleName
nToVarName (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nParams) [Integer
0 ..])
aliasDef :: ModuleName
aliasDef = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n| " (Constructor -> ModuleName
renderAlias (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
constructors)
constructorDefs :: ModuleName
constructorDefs = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n| " (Constructor -> ModuleName
renderConstructor (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
constructors)
renderAlias :: Constructor -> ModuleName
renderAlias Constructor{[ElmField]
ModuleName
constructorName :: ModuleName
constructorFields :: [ElmField]
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
..} =
case [ElmField]
constructorFields of
[] -> [trimming|{}|]
[ElmField]
_ ->
let
renderedRecordFields :: ModuleName
renderedRecordFields = [ElmField] -> ModuleName
renderRecordFields [ElmField]
constructorFields
in
[trimming|$renderedRecordFields|]
renderConstructor :: Constructor -> ModuleName
renderConstructor Constructor{[ElmField]
ModuleName
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
constructorName :: ModuleName
constructorFields :: [ElmField]
..} =
case [ElmField]
constructorFields of
[] -> ModuleName
constructorName
((Maybe ModuleName
Nothing, TyRef
_) : [ElmField]
_) ->
[trimming|
$constructorName $renderedAnonymousFields
|]
((Just ModuleName
_, TyRef
_) : [ElmField]
_) ->
[trimming|
$constructorName
$renderedRecordFields
|]
where
renderedAnonymousFields :: ModuleName
renderedAnonymousFields = [ElmField] -> ModuleName
forall {a}. [(a, TyRef)] -> ModuleName
renderAnonymousFields [ElmField]
constructorFields
renderedRecordFields :: ModuleName
renderedRecordFields = [ElmField] -> ModuleName
renderRecordFields [ElmField]
constructorFields
renderAnonymousFields :: [(a, TyRef)] -> ModuleName
renderAnonymousFields = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName)
-> ([(a, TyRef)] -> [ModuleName]) -> [(a, TyRef)] -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, TyRef) -> ModuleName) -> [(a, TyRef)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> TyRef -> ModuleName
renderTyRef ModuleName
currentModule (TyRef -> ModuleName)
-> ((a, TyRef) -> TyRef) -> (a, TyRef) -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TyRef) -> TyRef
forall a b. (a, b) -> b
snd)
renderRecordFields :: [ElmField] -> ModuleName
renderRecordFields [ElmField]
fields =
[trimming|
{ $renderedRecordFields
}
|]
where
renderedRecordFields :: ModuleName
renderedRecordFields = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n, " (ElmField -> ModuleName
renderField (ElmField -> ModuleName) -> [ElmField] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
fields)
renderField :: ElmField -> ModuleName
renderField (Just ModuleName
fieldName, TyRef
tyRef) = [ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat [ModuleName
fieldName, ModuleName
" : ", ModuleName -> TyRef -> ModuleName
renderTyRef ModuleName
currentModule TyRef
tyRef]
renderField ElmField
a = [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char]
"renderField - unmatched pattern:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ElmField -> [Char]
forall a. Show a => a -> [Char]
show ElmField
a)
nToVarName :: Integer -> ModuleName
nToVarName = [Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'a' :) ([Char] -> [Char]) -> (Integer -> [Char]) -> Integer -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer
generateTypeDef' DatatypeStructure x
_ = [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error [Char]
"Datatype has no constructor. Impossible to generate Elm definition."
generateDecoder :: forall {k} (x :: k). (HasElmStructure k x) => Text
generateDecoder :: forall {k} (x :: k). HasElmStructure k x => ModuleName
generateDecoder = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateDecoder' (DatatypeStructure x -> ModuleName)
-> DatatypeStructure x -> ModuleName
forall a b. (a -> b) -> a -> b
$ forall (x :: k). HasElmStructure k x => DatatypeStructure x
forall {k} (x :: k). HasElmStructure k x => DatatypeStructure x
getElmStructure @x
generateDecoder' :: DatatypeStructure x -> Text
generateDecoder' :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateDecoder' DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..} =
[trimming|
$decoderName : $decoderType
$decoderName $decoderArgs =
$decoderBody
|]
where
decoderName :: ModuleName
decoderName = case ElmMapping
mapping.decoderLocation of
Just SymbolLocation
location -> SymbolLocation
location.symbolName
Maybe SymbolLocation
Nothing -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"No decoder location for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ElmMapping
mapping.typeName
decoderType :: ModuleName
decoderType =
[ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat
[ [ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (\ModuleName
n -> ModuleName
"Decoder a" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
n ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" -> ") (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
params
, ModuleName
"Decoder " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
fullTypeName
]
decoderArgs :: ModuleName
decoderArgs =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (ModuleName
"d" <>) (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
params
decoderBody :: ModuleName
decoderBody = case [Constructor]
constructors of
[] ->
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"Uninhabited datatype: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ElmMapping
mapping.typeName
[Constructor
singleConstructor] ->
if ElmMapping
mapping.isTypeAlias
then (ModuleName, Maybe ModuleName) -> [ElmField] -> ModuleName
decodeRecordAlias (ElmMapping
mapping.typeName, ElmMapping
mapping.moduleName) (Constructor
singleConstructor.constructorFields)
else (ModuleName, Maybe ModuleName) -> Constructor -> ModuleName
decodeConstructor (ElmMapping
mapping.typeName, ElmMapping
mapping.moduleName) Constructor
singleConstructor
[Constructor]
multiple ->
(if (Constructor -> Bool) -> [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Constructor -> Bool
isNullary [Constructor]
constructors then ModuleName -> [ModuleName] -> ModuleName
decodeStringTag ModuleName
fullTypeName ((.constructorName) (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
constructors) else (ModuleName, Maybe ModuleName)
-> ModuleName -> [Constructor] -> ModuleName
decodeTaggedSum (ElmMapping
mapping.typeName, ElmMapping
mapping.moduleName) ModuleName
fullTypeName [Constructor]
multiple)
fullTypeName :: ModuleName
fullTypeName =
case Integer
nParams of
Integer
0 -> ElmMapping
mapping.typeName
Integer
_ ->
let tVars :: ModuleName
tVars = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (ModuleName
"a" <>) (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
params
in [ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat [ModuleName
"(", ElmMapping
mapping.typeName, ModuleName
" ", ModuleName
tVars, ModuleName
")"]
params :: [ModuleName]
params = ([Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer) (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nParams) [Integer
0 ..]
isNullary :: Constructor -> Bool
isNullary :: Constructor -> Bool
isNullary Constructor{[ElmField]
ModuleName
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
constructorName :: ModuleName
constructorFields :: [ElmField]
..} = [ElmField] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ElmField]
constructorFields
decodeStringTag :: Text -> [ConstructorName] -> Text
decodeStringTag :: ModuleName -> [ModuleName] -> ModuleName
decodeStringTag ModuleName
fullTypeName [ModuleName]
cNames =
let tagBranches :: ModuleName
tagBranches =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
(\ModuleName
name -> [ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat [ModuleName
"\"", ModuleName
name, ModuleName
"\" -> Json.Decode.succeed ", ModuleName
name])
(ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
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 :: (ModuleName, Maybe ModuleName)
-> ModuleName -> [Constructor] -> ModuleName
decodeTaggedSum (ModuleName, Maybe ModuleName)
recursionStop ModuleName
fullTypeName [Constructor]
constructors =
let tagBranches :: ModuleName
tagBranches = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (ModuleName, Maybe ModuleName) -> Constructor -> ModuleName
formatTagBranch (ModuleName, Maybe ModuleName)
recursionStop (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
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 :: (ModuleName, Maybe ModuleName) -> Constructor -> ModuleName
formatTagBranch (ModuleName, Maybe ModuleName)
recursionStop constructor :: Constructor
constructor@Constructor{[ElmField]
ModuleName
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
constructorName :: ModuleName
constructorFields :: [ElmField]
..} =
let objectDecoder :: ModuleName
objectDecoder = (ModuleName, Maybe ModuleName) -> Constructor -> ModuleName
decodeConstructor (ModuleName, Maybe ModuleName)
recursionStop Constructor
constructor
in [trimming|
"$constructorName" ->
$objectDecoder
|]
decodeConstructor :: (TypeName, Maybe ModuleName) -> Constructor -> Text
decodeConstructor :: (ModuleName, Maybe ModuleName) -> Constructor -> ModuleName
decodeConstructor (ModuleName, Maybe ModuleName)
recursionStop Constructor{[ElmField]
ModuleName
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
constructorName :: ModuleName
constructorFields :: [ElmField]
..} =
case [ElmField]
constructorFields of
[] -> ModuleName
"Json.Decode.succeed " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
constructorName
[(Maybe ModuleName
Nothing, TyRef
tyRef)] ->
[ModuleName] -> ModuleName
forall a. Monoid a => [a] -> a
mconcat
[ [trimming|Json.Decode.field "contents" <||]
, ModuleName
" Json.Decode.map "
, ModuleName
constructorName
, ModuleName
" "
, (ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder (ModuleName, Maybe ModuleName)
recursionStop TyRef
tyRef
]
fields :: [ElmField]
fields@((Maybe ModuleName
Nothing, TyRef
_) : [ElmField]
_) -> (ModuleName, Maybe ModuleName)
-> ModuleName -> [ElmField] -> ModuleName
decodeAnonymousConstructor (ModuleName, Maybe ModuleName)
recursionStop ModuleName
constructorName [ElmField]
fields
fields :: [ElmField]
fields@((Just ModuleName
_, TyRef
_) : [ElmField]
_) -> (ModuleName, Maybe ModuleName)
-> ModuleName -> [ElmField] -> ModuleName
decodeRecordConstructor (ModuleName, Maybe ModuleName)
recursionStop ModuleName
constructorName [ElmField]
fields
decodeRecordConstructor :: (TypeName, Maybe ModuleName) -> ConstructorName -> [ElmField] -> Text
decodeRecordConstructor :: (ModuleName, Maybe ModuleName)
-> ModuleName -> [ElmField] -> ModuleName
decodeRecordConstructor (ModuleName, Maybe ModuleName)
recursionStop ModuleName
cName [ElmField]
fields =
case [ElmField]
fields of
[] -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error [Char]
"decodeRecordConstructor called on nullary constructor"
[ElmField]
fields' ->
let mkFunction :: ModuleName
mkFunction = [ElmField] -> ModuleName
mkFieldsFunction [ElmField]
fields'
fieldDecoders :: ModuleName
fieldDecoders =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
(ModuleName, Maybe ModuleName) -> ElmField -> ModuleName
mkFieldDecoder (ModuleName, Maybe ModuleName)
recursionStop (ElmField -> ModuleName) -> [ElmField] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
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 :: (ModuleName, Maybe ModuleName) -> [ElmField] -> ModuleName
decodeRecordAlias (ModuleName, Maybe ModuleName)
recursionStop [ElmField]
fields =
case [ElmField]
fields of
[] -> [trimming| Json.Decode.succeed {} |]
[ElmField]
fields' ->
let mkFunction :: ModuleName
mkFunction = [ElmField] -> ModuleName
mkFieldsFunction [ElmField]
fields'
fieldDecoders :: ModuleName
fieldDecoders =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
(ModuleName, Maybe ModuleName) -> ElmField -> ModuleName
mkFieldDecoder (ModuleName, Maybe ModuleName)
recursionStop (ElmField -> ModuleName) -> [ElmField] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
fields
in [trimming|
let mkFunction =
$mkFunction
contentDecoder =
Json.Decode.succeed mkFunction
$fieldDecoders
in contentDecoder
|]
mkFieldDecoder :: (TypeName, Maybe ModuleName) -> ElmField -> Text
mkFieldDecoder :: (ModuleName, Maybe ModuleName) -> ElmField -> ModuleName
mkFieldDecoder (ModuleName, Maybe ModuleName)
recursionStop (Just ModuleName
fieldName, TyRef
tyRef) =
let typDecoder :: ModuleName
typDecoder = (ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder (ModuleName, Maybe ModuleName)
recursionStop TyRef
tyRef
in [trimming|
|> andMap (Json.Decode.field "$fieldName" $typDecoder)
|]
mkFieldDecoder (ModuleName, Maybe ModuleName)
_ ElmField
a =
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"mkFieldDecoder - unmatched pattern: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ElmField -> [Char]
forall a. Show a => a -> [Char]
show ElmField
a
mkTypeDecoder :: (TypeName, Maybe ModuleName) -> TyRef -> Text
mkTypeDecoder :: (ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder recursionStop :: (ModuleName, Maybe ModuleName)
recursionStop@(ModuleName
tName, Maybe ModuleName
mName) TyRef{[TyRef]
TyCon
tyCon :: TyCon
tyArgs :: [TyRef]
$sel:tyCon:TyRef :: TyRef -> TyCon
$sel:tyArgs:TyRef :: TyRef -> [TyRef]
..} =
case TyCon
tyCon of
TyVar ModuleName
varName -> ModuleName
"d" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> HasCallStack => ModuleName -> ModuleName
ModuleName -> ModuleName
Text.tail ModuleName
varName
TyMapping ElmMapping
mapping -> [TyRef] -> ElmMapping -> ModuleName
renderMapping [TyRef]
tyArgs ElmMapping
mapping
where
renderMapping :: [TyRef] -> ElmMapping -> Text
renderMapping :: [TyRef] -> ElmMapping -> ModuleName
renderMapping [TyRef]
args ElmMapping
mapping =
let renderedArgs :: ModuleName
renderedArgs =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
([TyRef] -> ElmMapping -> ModuleName
renderMapping [] (ElmMapping -> ModuleName) -> [ElmMapping] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElmMapping
mapping.args)
[ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> ((ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder (ModuleName, Maybe ModuleName)
recursionStop (TyRef -> ModuleName) -> [TyRef] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyRef]
args)
in if ElmMapping
mapping.moduleName Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ModuleName
mName Bool -> Bool -> Bool
&& ElmMapping
mapping.typeName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
tName
then
ModuleName
"(Json.Decode.lazy (\\_ -> decode" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
tName ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
renderedArgs ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"))"
else
let decoderLocation :: SymbolLocation
decoderLocation = case ElmMapping
mapping.decoderLocation of
Maybe SymbolLocation
Nothing -> [Char] -> SymbolLocation
forall a. HasCallStack => [Char] -> a
error [Char]
"No decoder"
Just SymbolLocation
location -> SymbolLocation
location
decodeFunction :: ModuleName
decodeFunction = (if Maybe ModuleName
mName Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just SymbolLocation
decoderLocation.symbolModuleName then (SymbolLocation
decoderLocation.symbolName) else SymbolLocation
decoderLocation.symbolModuleName ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"." ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> SymbolLocation
decoderLocation.symbolName)
in case ModuleName
renderedArgs of
ModuleName
"" -> ModuleName
decodeFunction
ModuleName
_ -> ModuleName
"(" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
decodeFunction ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
renderedArgs ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
mkFieldsFunction :: [ElmField] -> Text
mkFieldsFunction :: [ElmField] -> ModuleName
mkFieldsFunction [ElmField]
fields =
let fieldNames :: [ModuleName]
fieldNames = (Maybe ModuleName -> ModuleName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ModuleName -> ModuleName)
-> (ElmField -> Maybe ModuleName) -> ElmField -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElmField -> Maybe ModuleName
forall a b. (a, b) -> a
fst) (ElmField -> ModuleName) -> [ElmField] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
fields
args :: ModuleName
args = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " [ModuleName]
fieldNames
fieldSetters :: ModuleName
fieldSetters = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n, " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (\ModuleName
n -> ModuleName
n ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" = " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
n) (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
fieldNames
in [trimming|
\$args ->
{ $fieldSetters
}
|]
decodeAnonymousConstructor :: (TypeName, Maybe ModuleName) -> ConstructorName -> [ElmField] -> Text
decodeAnonymousConstructor :: (ModuleName, Maybe ModuleName)
-> ModuleName -> [ElmField] -> ModuleName
decodeAnonymousConstructor (ModuleName, Maybe ModuleName)
recursionStop ModuleName
cName [ElmField]
fields =
let contentDecoder :: ModuleName
contentDecoder = case [ElmField] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ElmField]
fields of
Int
0 -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error [Char]
"decodeAnonymous constructor should not be used for nullary constructors"
Int
1 -> ModuleName
"Json.Decode.map " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
cName ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> (ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder (ModuleName, Maybe ModuleName)
recursionStop (ElmField -> TyRef
forall a b. (a, b) -> b
snd (ElmField -> TyRef) -> ElmField -> TyRef
forall a b. (a -> b) -> a -> b
$ [ElmField] -> ElmField
forall a. HasCallStack => [a] -> a
head [ElmField]
fields)
Int
_ ->
let numberedFields :: [(Integer, TyRef)]
numberedFields = forall a b. [a] -> [b] -> [(a, b)]
zip @Integer [Integer
0 ..] (ElmField -> TyRef
forall a b. (a, b) -> b
snd (ElmField -> TyRef) -> [ElmField] -> [TyRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
fields)
mkFieldDecoder' :: (a, TyRef) -> ModuleName
mkFieldDecoder' (a
n, TyRef
tyRef) =
ModuleName
"|> andMap (Json.Decode.index "
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> [Char] -> ModuleName
Text.pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
n)
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" "
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> (ModuleName, Maybe ModuleName) -> TyRef -> ModuleName
mkTypeDecoder (ModuleName, Maybe ModuleName)
recursionStop TyRef
tyRef
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
fieldDecoders :: ModuleName
fieldDecoders = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (Integer, TyRef) -> ModuleName
forall {a}. Show a => (a, TyRef) -> ModuleName
mkFieldDecoder' ((Integer, TyRef) -> ModuleName)
-> [(Integer, TyRef)] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Integer, TyRef)]
numberedFields
in [trimming|
Json.Decode.succeed $cName
$fieldDecoders
|]
in [trimming|
let contentDecoder =
$contentDecoder
in
Json.Decode.field "contents" contentDecoder
|]
generateEncoder :: forall {k} (x :: k). (HasElmStructure k x) => Text
generateEncoder :: forall {k} (x :: k). HasElmStructure k x => ModuleName
generateEncoder = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateEncoder' (DatatypeStructure x -> ModuleName)
-> DatatypeStructure x -> ModuleName
forall a b. (a -> b) -> a -> b
$ forall (x :: k). HasElmStructure k x => DatatypeStructure x
forall {k} (x :: k). HasElmStructure k x => DatatypeStructure x
getElmStructure @x
getEncoderLocation :: DatatypeStructure x -> SymbolLocation
getEncoderLocation :: forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..} =
case ElmMapping
mapping.encoderLocation of
Maybe SymbolLocation
Nothing -> [Char] -> SymbolLocation
forall a. HasCallStack => [Char] -> a
error ([Char] -> SymbolLocation) -> [Char] -> SymbolLocation
forall a b. (a -> b) -> a -> b
$ [Char]
"No encoder location for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show ElmMapping
mapping.typeName
Just SymbolLocation
location -> SymbolLocation
location
getEncoderName :: DatatypeStructure x -> Text
getEncoderName :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderName = (.symbolName) (SymbolLocation -> ModuleName)
-> (DatatypeStructure x -> SymbolLocation)
-> DatatypeStructure x
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeStructure x -> SymbolLocation
forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation
getEncoderModule :: DatatypeStructure x -> Text
getEncoderModule :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderModule = (.symbolModuleName) (SymbolLocation -> ModuleName)
-> (DatatypeStructure x -> SymbolLocation)
-> DatatypeStructure x
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeStructure x -> SymbolLocation
forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation
generateEncoder' :: DatatypeStructure x -> Text
generateEncoder' :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
generateEncoder' structure :: DatatypeStructure x
structure@(DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..})
| ElmMapping
mapping.isTypeAlias =
[trimming|
$encoderName : $encoderType
$defLineAlias
$bodyAlias
|]
| Bool
otherwise =
[trimming|
$encoderName : $encoderType
$defLine
$body
|]
where
encoderName :: ModuleName
encoderName = DatatypeStructure x
structure DatatypeStructure x
-> (DatatypeStructure x -> ModuleName) -> ModuleName
forall a b. a -> (a -> b) -> b
& DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderName
encoderType :: ModuleName
encoderType = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderType DatatypeStructure x
structure
defLine :: ModuleName
defLine = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderDefLine DatatypeStructure x
structure
defLineAlias :: ModuleName
defLineAlias = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderDefLineAlias DatatypeStructure x
structure
body :: ModuleName
body = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderBody DatatypeStructure x
structure
bodyAlias :: ModuleName
bodyAlias = DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderBodyAlias DatatypeStructure x
structure
mkEncoderType :: DatatypeStructure x -> Text
mkEncoderType :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderType DatatypeStructure x
structure =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat
[ [ModuleName]
paramEncoderTypes
, [DatatypeStructure x -> SymbolLocation -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
qualifiedTypeNameAt DatatypeStructure x
structure (DatatypeStructure x
structure DatatypeStructure x
-> (DatatypeStructure x -> SymbolLocation) -> SymbolLocation
forall a b. a -> (a -> b) -> b
& DatatypeStructure x -> SymbolLocation
forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation), ModuleName
"->", ModuleName
"Value"]
]
where
paramEncoderTypes :: [ModuleName]
paramEncoderTypes =
((\ModuleName
n -> ModuleName
"(e" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
n ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" -> Value) ->") (ModuleName -> ModuleName)
-> (Integer -> ModuleName) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer))
(Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DatatypeStructure x
structure.nParams) [Integer
0 ..]
mkEncoderDefLine :: DatatypeStructure x -> Text
mkEncoderDefLine :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderDefLine DatatypeStructure x
structure =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat
[ [DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderName DatatypeStructure x
structure]
, ((ModuleName
"e" <>) (ModuleName -> ModuleName)
-> (Integer -> ModuleName) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer) (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DatatypeStructure x
structure.nParams) [Integer
0 ..]
, [ModuleName
"v", ModuleName
"="]
]
mkEncoderDefLineAlias :: DatatypeStructure x -> Text
mkEncoderDefLineAlias :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderDefLineAlias DatatypeStructure x
structure =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat
[ [DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderName DatatypeStructure x
structure]
, ((ModuleName
"e" <>) (ModuleName -> ModuleName)
-> (Integer -> ModuleName) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer) (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DatatypeStructure x
structure.nParams) [Integer
0 ..]
, [ModuleName
"r", ModuleName
"="]
]
qualifiedTypeNameAt :: DatatypeStructure x -> SymbolLocation -> Text
qualifiedTypeNameAt :: forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
qualifiedTypeNameAt s :: DatatypeStructure x
s@(DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..}) SymbolLocation
loc =
let tName :: ModuleName
tName = case ElmMapping
mapping.moduleName of
Maybe ModuleName
Nothing -> ElmMapping
mapping.typeName
Just ModuleName
_ -> DatatypeStructure x -> SymbolLocation -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
prefixFor DatatypeStructure x
s SymbolLocation
loc ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ElmMapping
mapping.typeName
tArgs :: [ModuleName]
tArgs = ((ModuleName
"e" <>) (ModuleName -> ModuleName)
-> (Integer -> ModuleName) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer) (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral DatatypeStructure x
s.nParams) [Integer
0 ..]
allComponents :: [ModuleName]
allComponents = ModuleName
tName ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
tArgs
in case [ModuleName]
allComponents of
[ModuleName
single] -> ModuleName
single
[ModuleName]
_multiple -> ModuleName
"(" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " [ModuleName]
allComponents ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
prefixFor :: DatatypeStructure x -> SymbolLocation -> Text
prefixFor :: forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
prefixFor DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..} SymbolLocation
loc =
case (ElmMapping
mapping.moduleName, SymbolLocation
loc.symbolModuleName) of
(Maybe ModuleName
Nothing, ModuleName
_) -> ModuleName
""
(Just ModuleName
m1, ModuleName
m2) -> if ModuleName
m1 ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m2 then ModuleName
"" else ModuleName
m1 ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"."
mkEncoderBody :: DatatypeStructure x -> Text
mkEncoderBody :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderBody structure :: DatatypeStructure x
structure@(DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..}) =
[trimming|
case v of
$constructorBranches
|]
where
constructorBranches :: ModuleName
constructorBranches = case [Constructor]
constructors of
[] ->
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[Char]
"Cannot generate encoder body (no constructors): "
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show DatatypeStructure x
structure.mapping.typeName
[Constructor
singleConstructor] ->
DatatypeStructure x -> Constructor -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> Constructor -> ModuleName
unwrapConstructorBranch DatatypeStructure x
structure Constructor
singleConstructor
[Constructor]
multiple ->
DatatypeStructure x -> [Constructor] -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> [Constructor] -> ModuleName
multipleConstructorBranches DatatypeStructure x
structure [Constructor]
multiple
mkEncoderBodyAlias :: DatatypeStructure x -> Text
mkEncoderBodyAlias :: forall {k} (x :: k). DatatypeStructure x -> ModuleName
mkEncoderBodyAlias structure :: DatatypeStructure x
structure@(DatatypeStructure{Integer
[Constructor]
ElmMapping
$sel:mapping:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> ElmMapping
$sel:nParams:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> Integer
$sel:constructors:DatatypeStructure :: forall {k} (a :: k). DatatypeStructure a -> [Constructor]
mapping :: ElmMapping
nParams :: Integer
constructors :: [Constructor]
..}) =
[trimming|
$constructorBranches
|]
where
constructorBranches :: ModuleName
constructorBranches = case [Constructor]
constructors of
[] ->
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[Char]
"Cannot generate encoder body (no constructors): "
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show DatatypeStructure x
structure.mapping.typeName
[Constructor
singleConstructor] ->
let (ModuleName
_, [ModuleName]
_, Maybe ModuleName
contentEncoder) = DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
forall {k} (x :: k).
DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
constructorBranchHelper DatatypeStructure x
structure Constructor
singleConstructor
in
ModuleName -> Maybe ModuleName -> ModuleName
forall a. a -> Maybe a -> a
fromMaybe ModuleName
"Json.Encode.list identity []" Maybe ModuleName
contentEncoder
[Constructor]
_ ->
[Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$
[Char]
"Cannot generate encoder body as type alias (too many constructors): "
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [Char]
forall a. Show a => a -> [Char]
show DatatypeStructure x
structure.mapping.typeName
unwrapConstructorBranch :: DatatypeStructure x -> Constructor -> Text
unwrapConstructorBranch :: forall {k} (x :: k).
DatatypeStructure x -> Constructor -> ModuleName
unwrapConstructorBranch s :: DatatypeStructure x
s@(DatatypeStructure{}) Constructor
c =
let (ModuleName
cName, [ModuleName]
cArgs, Maybe ModuleName
contentEncoder) = DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
forall {k} (x :: k).
DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
constructorBranchHelper DatatypeStructure x
s Constructor
c
matchLine :: ModuleName
matchLine = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " (ModuleName
cName ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
cArgs)
in (ModuleName -> ModuleName) -> Maybe ModuleName -> ModuleName
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \ModuleName
e ->
[trimming|
$matchLine ->
$e
|]
)
Maybe ModuleName
contentEncoder
constructorBranchHelper :: DatatypeStructure x -> Constructor -> (Text, [Text], Maybe Text)
constructorBranchHelper :: forall {k} (x :: k).
DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
constructorBranchHelper s :: DatatypeStructure x
s@(DatatypeStructure{}) Constructor
c =
(ModuleName
cName, [ModuleName]
cArgs, Maybe ModuleName
contentEncoder)
where
cName :: ModuleName
cName = DatatypeStructure x -> SymbolLocation -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
prefixFor DatatypeStructure x
s (DatatypeStructure x
s DatatypeStructure x
-> (DatatypeStructure x -> SymbolLocation) -> SymbolLocation
forall a b. a -> (a -> b) -> b
& DatatypeStructure x -> SymbolLocation
forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation) ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> Constructor
c.constructorName
nFields :: Int
nFields = [ElmField] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Constructor
c.constructorFields
contentEncoder :: Maybe ModuleName
contentEncoder = case Constructor
c.constructorFields of
[] ->
Maybe ModuleName
forall a. Maybe a
Nothing
[(Maybe ModuleName
Nothing, TyRef
tyRef)] ->
ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleName -> Maybe ModuleName) -> ModuleName -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ DatatypeStructure x -> TyRef -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> TyRef -> ModuleName
encoderForType DatatypeStructure x
s TyRef
tyRef ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" " ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"p0"
((Maybe ModuleName
Nothing, TyRef
_tyRef) : [ElmField]
_) ->
let encodedValues :: ModuleName
encodedValues =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n, " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
(\(Integer
n, (Maybe ModuleName
_, TyRef
tyRef)) -> DatatypeStructure x -> TyRef -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> TyRef -> ModuleName
encoderForType DatatypeStructure x
s TyRef
tyRef ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" p" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> [Char] -> ModuleName
Text.pack (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n))
((Integer, ElmField) -> ModuleName)
-> [(Integer, ElmField)] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. [a] -> [b] -> [(a, b)]
zip @Integer [Integer
0 ..] Constructor
c.constructorFields)
in ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just
[trimming|
Json.Encode.list identity
[ $encodedValues
]
|]
[ElmField]
recordFields ->
let encodedPairs :: ModuleName
encodedPairs =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n, " ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
( \case
(Just ModuleName
fieldName, TyRef
tyRef) -> ModuleName -> TyRef -> ModuleName
encodePair ModuleName
fieldName TyRef
tyRef
ElmField
a -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"unmatched pattern in constructorBranchHelper: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ElmField -> [Char]
forall a. Show a => a -> [Char]
show ElmField
a
)
(ElmField -> ModuleName) -> [ElmField] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
recordFields
encodePair :: ModuleName -> TyRef -> ModuleName
encodePair ModuleName
fieldName TyRef
tyRef =
ModuleName
"(\""
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
fieldName
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"\", "
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> DatatypeStructure x -> TyRef -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> TyRef -> ModuleName
encoderForType DatatypeStructure x
s TyRef
tyRef
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" r."
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
fieldName
ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
in ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just
[trimming|
Json.Encode.object
[ $encodedPairs
]
|]
cArgs :: [ModuleName]
cArgs = case Constructor
c.constructorFields of
[] -> []
((Just ModuleName
_, TyRef
_) : [ElmField]
_) -> [ModuleName
"r"]
[ElmField]
_ ->
((ModuleName
"p" <>) (ModuleName -> ModuleName)
-> (Integer -> ModuleName) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ModuleName
Text.pack ([Char] -> ModuleName)
-> (Integer -> [Char]) -> Integer -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show @Integer) (Integer -> ModuleName) -> [Integer] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
nFields [Integer
0 ..]
multipleConstructorBranches :: DatatypeStructure x -> [Constructor] -> Text
multipleConstructorBranches :: forall {k} (x :: k).
DatatypeStructure x -> [Constructor] -> ModuleName
multipleConstructorBranches DatatypeStructure x
structure [Constructor]
constructors =
let prefix :: ModuleName
prefix = (DatatypeStructure x -> SymbolLocation -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> SymbolLocation -> ModuleName
prefixFor DatatypeStructure x
structure (DatatypeStructure x
structure DatatypeStructure x
-> (DatatypeStructure x -> SymbolLocation) -> SymbolLocation
forall a b. a -> (a -> b) -> b
& DatatypeStructure x -> SymbolLocation
forall {k} (x :: k). DatatypeStructure x -> SymbolLocation
getEncoderLocation))
in (if (Constructor -> Bool) -> [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Constructor -> Bool
isNullary [Constructor]
constructors then ModuleName -> [ModuleName] -> ModuleName
encodeStringTags ModuleName
prefix ((.constructorName) (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
constructors) else DatatypeStructure x -> [Constructor] -> ModuleName
forall {k} (x :: k).
DatatypeStructure x -> [Constructor] -> ModuleName
encodeTaggedBranches DatatypeStructure x
structure [Constructor]
constructors)
encodeStringTags :: Text -> [ConstructorName] -> Text
encodeStringTags :: ModuleName -> [ModuleName] -> ModuleName
encodeStringTags ModuleName
prefix [ModuleName]
cnames =
ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
(\ModuleName
cname -> ModuleName
prefix ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
cname ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
" -> Json.Encode.string \"" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
cname ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"\"") (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
cnames
encodeTaggedBranches :: DatatypeStructure x -> [Constructor] -> Text
encodeTaggedBranches :: forall {k} (x :: k).
DatatypeStructure x -> [Constructor] -> ModuleName
encodeTaggedBranches DatatypeStructure x
ds [Constructor]
cs = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n" ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ Constructor -> ModuleName
mkTagBranch (Constructor -> ModuleName) -> [Constructor] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constructor]
cs
where
mkTagBranch :: Constructor -> ModuleName
mkTagBranch Constructor
c =
let (ModuleName
cName, [ModuleName]
cArgs, Maybe ModuleName
encodedContent) =
DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
forall {k} (x :: k).
DatatypeStructure x
-> Constructor -> (ModuleName, [ModuleName], Maybe ModuleName)
constructorBranchHelper DatatypeStructure x
ds Constructor
c
match :: ModuleName
match = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " (ModuleName
cName ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
cArgs)
tag :: ModuleName
tag = Constructor
c.constructorName
contentsField :: ModuleName
contentsField =
(ModuleName -> ModuleName) -> Maybe ModuleName -> ModuleName
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \ModuleName
val ->
[untrimming|
, ( "contents"
, $val
)
|]
)
Maybe ModuleName
encodedContent
in [trimming|
$match -> Json.Encode.object
[ ( "tag", Json.Encode.string "$tag" )$contentsField]
|]
encoderForType :: DatatypeStructure x -> TyRef -> Text
encoderForType :: forall {k} (x :: k). DatatypeStructure x -> TyRef -> ModuleName
encoderForType DatatypeStructure x
ds TyRef{[TyRef]
TyCon
$sel:tyCon:TyRef :: TyRef -> TyCon
$sel:tyArgs:TyRef :: TyRef -> [TyRef]
tyCon :: TyCon
tyArgs :: [TyRef]
..} =
case TyCon
tyCon of
TyVar ModuleName
varName -> ModuleName
"e" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> HasCallStack => ModuleName -> ModuleName
ModuleName -> ModuleName
Text.tail ModuleName
varName
TyMapping ElmMapping
mapping -> ElmMapping -> ModuleName
forall {a} {a} {r}.
(Show a, HasField "typeName" a a,
HasField "encoderLocation" a (Maybe r), HasField "args" a [a],
HasField "symbolName" r ModuleName,
HasField "symbolModuleName" r ModuleName) =>
a -> ModuleName
renderMapping ElmMapping
mapping
where
renderMapping :: a -> ModuleName
renderMapping a
mapping =
let encoderName :: ModuleName
encoderName = case a
mapping.encoderLocation of
Maybe r
Nothing -> [Char] -> ModuleName
forall a. HasCallStack => [Char] -> a
error ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find encoder for type: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. Show a => a -> [Char]
show a
mapping.typeName
Just r
location ->
(if r
location.symbolModuleName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeStructure x -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> ModuleName
getEncoderModule DatatypeStructure x
ds then (r
location.symbolName) else r
location.symbolModuleName ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"." ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> r
location.symbolName)
paramEncoders :: [ModuleName]
paramEncoders =
(a -> ModuleName
renderMapping (a -> ModuleName) -> [a] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
mapping.args)
[ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> (DatatypeStructure x -> TyRef -> ModuleName
forall {k} (x :: k). DatatypeStructure x -> TyRef -> ModuleName
encoderForType DatatypeStructure x
ds (TyRef -> ModuleName) -> [TyRef] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyRef]
tyArgs)
in ModuleName
"(" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " (ModuleName
encoderName ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
paramEncoders) ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
data SomeStructure = forall x. SomeStructure (DatatypeStructure x)
include :: forall {k} x. (HasElmStructure k x) => SomeStructure
include :: forall {k} (x :: k). HasElmStructure k x => SomeStructure
include = DatatypeStructure x -> SomeStructure
forall {k} (x :: k). DatatypeStructure x -> SomeStructure
SomeStructure (DatatypeStructure x -> SomeStructure)
-> DatatypeStructure x -> SomeStructure
forall a b. (a -> b) -> a -> b
$ forall (x :: k). HasElmStructure k x => DatatypeStructure x
forall {k} (x :: k). HasElmStructure k x => DatatypeStructure x
getElmStructure @x
data ModuleDefinition = ModuleDefinition
{ ModuleDefinition -> Set ModuleName
imports :: Set ModuleName
, ModuleDefinition -> [ModuleName]
typeDefs :: [Text]
, ModuleDefinition -> [ModuleName]
encoders :: [Text]
, ModuleDefinition -> [ModuleName]
decoders :: [Text]
}
deriving (ModuleDefinition -> ModuleDefinition -> Bool
(ModuleDefinition -> ModuleDefinition -> Bool)
-> (ModuleDefinition -> ModuleDefinition -> Bool)
-> Eq ModuleDefinition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModuleDefinition -> ModuleDefinition -> Bool
== :: ModuleDefinition -> ModuleDefinition -> Bool
$c/= :: ModuleDefinition -> ModuleDefinition -> Bool
/= :: ModuleDefinition -> ModuleDefinition -> Bool
Eq, Int -> ModuleDefinition -> [Char] -> [Char]
[ModuleDefinition] -> [Char] -> [Char]
ModuleDefinition -> [Char]
(Int -> ModuleDefinition -> [Char] -> [Char])
-> (ModuleDefinition -> [Char])
-> ([ModuleDefinition] -> [Char] -> [Char])
-> Show ModuleDefinition
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ModuleDefinition -> [Char] -> [Char]
showsPrec :: Int -> ModuleDefinition -> [Char] -> [Char]
$cshow :: ModuleDefinition -> [Char]
show :: ModuleDefinition -> [Char]
$cshowList :: [ModuleDefinition] -> [Char] -> [Char]
showList :: [ModuleDefinition] -> [Char] -> [Char]
Show)
instance Semigroup ModuleDefinition where
ModuleDefinition
m1 <> :: ModuleDefinition -> ModuleDefinition -> ModuleDefinition
<> ModuleDefinition
m2 =
ModuleDefinition
{ imports :: Set ModuleName
imports = Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
Set.union ModuleDefinition
m1.imports ModuleDefinition
m2.imports
, typeDefs :: [ModuleName]
typeDefs = ModuleDefinition
m1.typeDefs [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> ModuleDefinition
m2.typeDefs
, encoders :: [ModuleName]
encoders = ModuleDefinition
m1.encoders [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> ModuleDefinition
m2.encoders
, decoders :: [ModuleName]
decoders = ModuleDefinition
m1.decoders [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> ModuleDefinition
m2.decoders
}
instance Monoid ModuleDefinition where
mempty :: ModuleDefinition
mempty = Set ModuleName
-> [ModuleName] -> [ModuleName] -> [ModuleName] -> ModuleDefinition
ModuleDefinition Set ModuleName
forall a. Monoid a => a
mempty [ModuleName]
forall a. Monoid a => a
mempty [ModuleName]
forall a. Monoid a => a
mempty [ModuleName]
forall a. Monoid a => a
mempty
generateAll :: FilePath -> [SomeStructure] -> IO ()
generateAll :: [Char] -> [SomeStructure] -> IO ()
generateAll [Char]
baseDir [SomeStructure]
ds = do
let srcMap :: Map ModuleName ModuleName
srcMap = [SomeStructure] -> Map ModuleName ModuleName
mkSourceMap [SomeStructure]
ds
((ModuleName, ModuleName) -> IO ())
-> [(ModuleName, ModuleName)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([Char] -> (ModuleName, ModuleName) -> IO ()
outputModule [Char]
baseDir) ([(ModuleName, ModuleName)] -> IO ())
-> [(ModuleName, ModuleName)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map ModuleName ModuleName -> [(ModuleName, ModuleName)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map ModuleName ModuleName
srcMap
mkSourceMap :: [SomeStructure] -> Map ModuleName Text
mkSourceMap :: [SomeStructure] -> Map ModuleName ModuleName
mkSourceMap [SomeStructure]
ds = (ModuleName -> ModuleDefinition -> ModuleName)
-> Map ModuleName ModuleDefinition -> Map ModuleName ModuleName
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ModuleName -> ModuleDefinition -> ModuleName
renderModule (Map ModuleName ModuleDefinition -> Map ModuleName ModuleName)
-> Map ModuleName ModuleDefinition -> Map ModuleName ModuleName
forall a b. (a -> b) -> a -> b
$ [SomeStructure] -> Map ModuleName ModuleDefinition
computeAll [SomeStructure]
ds
outputModule :: FilePath -> (ModuleName, Text) -> IO ()
outputModule :: [Char] -> (ModuleName, ModuleName) -> IO ()
outputModule [Char]
baseDir (ModuleName
mName, ModuleName
source) = do
let fileDir :: [Char]
fileDir = [Char]
baseDir [Char] -> [Char] -> [Char]
</> [Char]
relDir
filePath :: [Char]
filePath = [Char]
fileDir [Char] -> [Char] -> [Char]
</> [Char]
fileName
fileName :: [Char]
fileName = [Char]
fileComponent [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".elm"
relDir :: [Char]
relDir = ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Char] -> [Char] -> [Char]
(</>) [Char]
"" [[Char]]
dirComponents
fileComponent :: [Char]
fileComponent = [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
reversed
dirComponents :: [[Char]]
dirComponents = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
reversed
reversed :: [[Char]]
reversed = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
moduleComponents
moduleComponents :: [[Char]]
moduleComponents = ModuleName -> [Char]
Text.unpack (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ModuleName -> [ModuleName]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ModuleName
mName
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
fileDir
[Char] -> ModuleName -> IO ()
Text.writeFile [Char]
filePath ModuleName
source
renderModule :: ModuleName -> ModuleDefinition -> Text
renderModule :: ModuleName -> ModuleDefinition -> ModuleName
renderModule ModuleName
mName ModuleDefinition{[ModuleName]
Set ModuleName
imports :: ModuleDefinition -> Set ModuleName
typeDefs :: ModuleDefinition -> [ModuleName]
encoders :: ModuleDefinition -> [ModuleName]
decoders :: ModuleDefinition -> [ModuleName]
imports :: Set ModuleName
typeDefs :: [ModuleName]
encoders :: [ModuleName]
decoders :: [ModuleName]
..} =
[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 :: ModuleName
typeDefsSrc = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n\n" [ModuleName]
typeDefs
encodersSrc :: ModuleName
encodersSrc = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n\n" [ModuleName]
encoders
decodersSrc :: ModuleName
decodersSrc = ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
"\n\n" [ModuleName]
decoders
importsSrc :: ModuleName
importsSrc = [ModuleName] -> ModuleName
Text.unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ (ModuleName
"import " <>) (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toAscList Set ModuleName
imports)
computeAll :: [SomeStructure] -> Map ModuleName ModuleDefinition
computeAll :: [SomeStructure] -> Map ModuleName ModuleDefinition
computeAll = (Map ModuleName ModuleDefinition
-> (ModuleName, ModuleDefinition)
-> Map ModuleName ModuleDefinition)
-> Map ModuleName ModuleDefinition
-> [(ModuleName, ModuleDefinition)]
-> Map ModuleName ModuleDefinition
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ModuleName ModuleDefinition
-> (ModuleName, ModuleDefinition)
-> Map ModuleName ModuleDefinition
forall {k} {a}.
(Ord k, Semigroup a) =>
Map k a -> (k, a) -> Map k a
addToModules Map ModuleName ModuleDefinition
forall k a. Map k a
Map.empty ([(ModuleName, ModuleDefinition)]
-> Map ModuleName ModuleDefinition)
-> ([SomeStructure] -> [(ModuleName, ModuleDefinition)])
-> [SomeStructure]
-> Map ModuleName ModuleDefinition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(ModuleName, ModuleDefinition)]]
-> [(ModuleName, ModuleDefinition)]
forall a. Monoid a => [a] -> a
mconcat ([[(ModuleName, ModuleDefinition)]]
-> [(ModuleName, ModuleDefinition)])
-> ([SomeStructure] -> [[(ModuleName, ModuleDefinition)]])
-> [SomeStructure]
-> [(ModuleName, ModuleDefinition)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeStructure -> [(ModuleName, ModuleDefinition)])
-> [SomeStructure] -> [[(ModuleName, ModuleDefinition)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeStructure -> [(ModuleName, ModuleDefinition)]
mkModuleDefs
where
addToModules :: Map k a -> (k, a) -> Map k a
addToModules Map k a
modules (k
mName, a
def) =
(a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) k
mName a
def Map k a
modules
mkModuleDefs :: SomeStructure -> [(ModuleName, ModuleDefinition)]
mkModuleDefs (SomeStructure DatatypeStructure x
ds) =
let constructorImports :: Set ModuleName
constructorImports = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName] -> Set ModuleName) -> [ModuleName] -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ [[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat ([[ModuleName]] -> [ModuleName]) -> [[ModuleName]] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ Constructor -> [ModuleName]
getImports (Constructor -> [ModuleName]) -> [Constructor] -> [[ModuleName]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeStructure x
ds.constructors
typeImport :: Set ModuleName
typeImport = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName] -> Set ModuleName) -> [ModuleName] -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DatatypeStructure x
ds.mapping.moduleName
in [Maybe (ModuleName, ModuleDefinition)]
-> [(ModuleName, ModuleDefinition)]
forall a. [Maybe a] -> [a]
catMaybes
[ case DatatypeStructure x
ds.mapping.moduleName of
Maybe ModuleName
Nothing -> Maybe (ModuleName, ModuleDefinition)
forall a. Maybe a
Nothing
Just ModuleName
mName -> (ModuleName, ModuleDefinition)
-> Maybe (ModuleName, ModuleDefinition)
forall a. a -> Maybe a
Just (ModuleName
mName, ModuleDefinition
mDef)
where
mDef :: ModuleDefinition
mDef =
ModuleDefinition
forall a. Monoid a => a
mempty
{ imports = Set.delete mName constructorImports
, typeDefs = pure $ generateTypeDef' ds
}
, case DatatypeStructure x
ds.mapping.encoderLocation of
Maybe SymbolLocation
Nothing -> Maybe (ModuleName, ModuleDefinition)
forall a. Maybe a
Nothing
Just SymbolLocation
encoder -> (ModuleName, ModuleDefinition)
-> Maybe (ModuleName, ModuleDefinition)
forall a. a -> Maybe a
Just (SymbolLocation
encoder.symbolModuleName, ModuleDefinition
mDef)
where
mDef :: ModuleDefinition
mDef =
ModuleDefinition
forall a. Monoid a => a
mempty
{ imports =
Set.delete
encoder.symbolModuleName
(constructorImports `Set.union` typeImport)
, encoders = pure $ generateEncoder' ds
}
, case DatatypeStructure x
ds.mapping.decoderLocation of
Maybe SymbolLocation
Nothing -> Maybe (ModuleName, ModuleDefinition)
forall a. Maybe a
Nothing
Just SymbolLocation
decoder -> (ModuleName, ModuleDefinition)
-> Maybe (ModuleName, ModuleDefinition)
forall a. a -> Maybe a
Just (SymbolLocation
decoder.symbolModuleName, ModuleDefinition
mDef)
where
mDef :: ModuleDefinition
mDef =
ModuleDefinition
forall a. Monoid a => a
mempty
{ imports =
Set.delete
decoder.symbolModuleName
(constructorImports `Set.union` typeImport)
, decoders = pure $ generateDecoder' ds
}
]
getImports :: Constructor -> [Text]
getImports :: Constructor -> [ModuleName]
getImports Constructor{[ElmField]
ModuleName
$sel:constructorName:Constructor :: Constructor -> ModuleName
$sel:constructorFields:Constructor :: Constructor -> [ElmField]
constructorName :: ModuleName
constructorFields :: [ElmField]
..} = [[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat ([[ModuleName]] -> [ModuleName]) -> [[ModuleName]] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ElmField -> [ModuleName]
forall {a}. (a, TyRef) -> [ModuleName]
getFieldImports (ElmField -> [ModuleName]) -> [ElmField] -> [[ModuleName]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ElmField]
constructorFields
where
getFieldImports :: (a, TyRef) -> [ModuleName]
getFieldImports (a
_, TyRef
tyRef) = TyRef -> [ModuleName]
getTypeImports TyRef
tyRef
getTypeImports :: TyRef -> [Text]
getTypeImports :: TyRef -> [ModuleName]
getTypeImports TyRef
tyRef =
[[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat
[ ([[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat ([[ModuleName]] -> [ModuleName]) -> [[ModuleName]] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ TyRef -> [ModuleName]
getTypeImports (TyRef -> [ModuleName]) -> [TyRef] -> [[ModuleName]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyRef
tyRef.tyArgs)
, TyCon -> [ModuleName]
mappingArgs TyRef
tyRef.tyCon
]
mappingArgs :: TyCon -> [ModuleName]
mappingArgs TyCon
tyCon = case TyCon
tyCon of
TyMapping ElmMapping
mapping ->
Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ElmMapping
mapping.moduleName
[ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((.symbolModuleName) (SymbolLocation -> ModuleName)
-> Maybe SymbolLocation -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElmMapping
mapping.encoderLocation)
[ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> Maybe ModuleName -> [ModuleName]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((.symbolModuleName) (SymbolLocation -> ModuleName)
-> Maybe SymbolLocation -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElmMapping
mapping.decoderLocation)
[ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> [[ModuleName]] -> [ModuleName]
forall a. Monoid a => [a] -> a
mconcat (TyCon -> [ModuleName]
mappingArgs (TyCon -> [ModuleName])
-> (ElmMapping -> TyCon) -> ElmMapping -> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElmMapping -> TyCon
TyMapping (ElmMapping -> [ModuleName]) -> [ElmMapping] -> [[ModuleName]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElmMapping
mapping.args)
TyCon
_ -> [ModuleName]
forall a. Monoid a => a
mempty
renderTyRef :: ModuleName -> TyRef -> Text
renderTyRef :: ModuleName -> TyRef -> ModuleName
renderTyRef ModuleName
currentModule TyRef
tyRef =
[ModuleName] -> ModuleName
wrapIfNeeded [ModuleName]
allRendered
where
wrapIfNeeded :: [Text] -> Text
wrapIfNeeded :: [ModuleName] -> ModuleName
wrapIfNeeded [ModuleName]
xs = case [ModuleName]
xs of
[ModuleName
single] -> ModuleName
single
[ModuleName]
_multiple -> ModuleName
"(" ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName -> [ModuleName] -> ModuleName
Text.intercalate ModuleName
" " [ModuleName]
xs ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
")"
allRendered :: [Text]
allRendered :: [ModuleName]
allRendered =
TyCon -> [ModuleName]
renderTyCon TyRef
tyRef.tyCon [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Semigroup a => a -> a -> a
<> (ModuleName -> TyRef -> ModuleName
renderTyRef ModuleName
currentModule (TyRef -> ModuleName) -> [TyRef] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyRef
tyRef.tyArgs)
renderTyCon :: TyCon -> [Text]
renderTyCon :: TyCon -> [ModuleName]
renderTyCon TyCon
tyCon = case TyCon
tyCon of
TyVar ModuleName
v -> [ModuleName
v]
TyMapping ElmMapping
mapping -> ElmMapping -> [ModuleName]
renderMapping ElmMapping
mapping
mkTyCon :: ElmMapping -> Text
mkTyCon :: ElmMapping -> ModuleName
mkTyCon ElmMapping
mapping = case ElmMapping
mapping.moduleName of
Maybe ModuleName
Nothing -> ElmMapping
mapping.typeName
Just ModuleName
mName -> (if ModuleName
mName ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
currentModule then (ElmMapping
mapping.typeName) else ModuleName
mName ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ModuleName
"." ModuleName -> ModuleName -> ModuleName
forall a. Semigroup a => a -> a -> a
<> ElmMapping
mapping.typeName)
renderMapping :: ElmMapping -> [Text]
renderMapping :: ElmMapping -> [ModuleName]
renderMapping ElmMapping
mapping =
(ElmMapping -> ModuleName
mkTyCon ElmMapping
mapping)
ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: (([ModuleName] -> ModuleName
wrapIfNeeded ([ModuleName] -> ModuleName)
-> (ElmMapping -> [ModuleName]) -> ElmMapping -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElmMapping -> [ModuleName]
renderMapping) (ElmMapping -> ModuleName) -> [ElmMapping] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ElmMapping
mapping.args)