module Elm.Print.Encoder
( prettyShowEncoder
, encodeMaybe
, encodeEither
, encodePair
, encodeTriple
, encodeNonEmpty
) where
import Data.List.NonEmpty (NonEmpty, toList)
import Data.Text (Text)
import Internal.Prettyprinter.Compat (Doc, brackets, colon, comma, concatWith, dquotes, emptyDoc,
equals, lbracket, line, nest, parens, pretty, rbracket, surround,
vsep, (<+>))
import Elm.Ast (ElmConstructor (..), ElmDefinition (..), ElmPrim (..), ElmRecord (..),
ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), isEnum)
import Elm.Print.Common (arrow, mkQualified, qualifiedTypeWithVarsDoc, showDoc, wrapParens)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
prettyShowEncoder :: ElmDefinition -> Text
prettyShowEncoder :: ElmDefinition -> Text
prettyShowEncoder ElmDefinition
def = forall ann. Doc ann -> Text
showDoc forall a b. (a -> b) -> a -> b
$ case ElmDefinition
def of
DefRecord ElmRecord
elmRecord -> forall ann. ElmRecord -> Doc ann
recordEncoderDoc ElmRecord
elmRecord
DefType ElmType
elmType -> forall ann. ElmType -> Doc ann
typeEncoderDoc ElmType
elmType
DefPrim ElmPrim
_ -> forall ann. Doc ann
emptyDoc
typeEncoderDoc :: ElmType -> Doc ann
typeEncoderDoc :: forall ann. ElmType -> Doc ann
typeEncoderDoc t :: ElmType
t@ElmType{Bool
[Text]
NonEmpty ElmConstructor
Text
elmTypeConstructors :: ElmType -> NonEmpty ElmConstructor
elmTypeIsNewtype :: ElmType -> Bool
elmTypeVars :: ElmType -> [Text]
elmTypeName :: ElmType -> Text
elmTypeConstructors :: NonEmpty ElmConstructor
elmTypeIsNewtype :: Bool
elmTypeVars :: [Text]
elmTypeName :: Text
..} =
forall ann. Text -> [Text] -> Doc ann
encoderDef Text
elmTypeName [Text]
elmTypeVars
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> if ElmType -> Bool
isEnum ElmType
t
then forall ann. Doc ann
enumEncoder
else if Bool
elmTypeIsNewtype
then forall ann. Doc ann
newtypeEncoder
else forall ann. Doc ann
sumEncoder
where
enumEncoder :: Doc ann
enumEncoder :: forall ann. Doc ann
enumEncoder = forall ann. Doc ann
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"E.string << T.show" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
elmTypeName
newtypeEncoder :: Doc ann
newtypeEncoder :: forall ann. Doc ann
newtypeEncoder =
forall ann. Doc ann
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
fieldEncoderDoc forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<< T.un" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
elmTypeName
where
fieldEncoderDoc :: Doc ann
fieldEncoderDoc :: forall ann. Doc ann
fieldEncoderDoc = case ElmConstructor -> [TypeRef]
elmConstructorFields forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty ElmConstructor
elmTypeConstructors of
[] -> Doc ann
"ERROR"
TypeRef
f : [TypeRef]
_ -> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
f)
sumEncoder :: Doc ann
sumEncoder :: forall ann. Doc ann
sumEncoder = forall ann. Int -> Doc ann -> Doc ann
nest Int
4
forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep
forall a b. (a -> b) -> a -> b
$ (forall ann. Doc ann
name forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"x" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"E.object <| case x of")
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall ann. ElmConstructor -> Doc ann
mkCase (forall a. NonEmpty a -> [a]
toList NonEmpty ElmConstructor
elmTypeConstructors)
name :: Doc ann
name :: forall ann. Doc ann
name = forall ann. Text -> Doc ann
encoderName Text
elmTypeName
mkCase :: ElmConstructor -> Doc ann
mkCase :: forall ann. ElmConstructor -> Doc ann
mkCase ElmConstructor{[TypeRef]
Text
elmConstructorName :: ElmConstructor -> Text
elmConstructorFields :: [TypeRef]
elmConstructorName :: Text
elmConstructorFields :: ElmConstructor -> [TypeRef]
..} = forall ann. Text -> Doc ann
mkQualified Text
elmConstructorName
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
vars
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
arrow
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
brackets (forall ann. Text -> Doc ann
mkTag Text
elmConstructorName forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
contents)
where
fields :: [Doc ann]
fields :: forall ann. [Doc ann]
fields = forall a b. (a -> b) -> [a] -> [b]
map (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Text
mkText Text
"x") [Int
1 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRef]
elmConstructorFields]
contents :: Doc ann
contents :: forall ann. Doc ann
contents = Doc ann
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
parens (forall ann. Doc ann -> Doc ann
dquotes Doc ann
"contents" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
comma forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
contentsEnc)
contentsEnc :: Doc ann
contentsEnc :: forall ann. Doc ann
contentsEnc = case [TypeRef]
elmConstructorFields of
[TypeRef
_] -> forall ann. Doc ann
fieldEncs
[TypeRef]
_ -> Doc ann
"E.list identity" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
brackets forall ann. Doc ann
fieldEncs
fieldEncs :: Doc ann
fieldEncs :: forall ann. Doc ann
fieldEncs = forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
surround Doc ann
", ") forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) (forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Doc ann -> Doc ann
wrapParens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. TypeRef -> Doc ann
typeRefEncoder) [TypeRef]
elmConstructorFields) forall ann. [Doc ann]
fields
mkText :: Text -> Int -> Text
mkText :: Text -> Int -> Text
mkText Text
x Int
i = Text
x forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
i)
vars :: Doc ann
vars :: forall ann. Doc ann
vars = forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
surround Doc ann
" ") forall ann. [Doc ann]
fields
recordEncoderDoc :: ElmRecord -> Doc ann
recordEncoderDoc :: forall ann. ElmRecord -> Doc ann
recordEncoderDoc ElmRecord{Bool
NonEmpty ElmRecordField
Text
elmRecordIsNewtype :: ElmRecord -> Bool
elmRecordFields :: ElmRecord -> NonEmpty ElmRecordField
elmRecordName :: ElmRecord -> Text
elmRecordIsNewtype :: Bool
elmRecordFields :: NonEmpty ElmRecordField
elmRecordName :: Text
..} =
forall ann. Text -> [Text] -> Doc ann
encoderDef Text
elmRecordName []
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> if Bool
elmRecordIsNewtype
then forall ann. Doc ann
newtypeEncoder
else forall ann. Doc ann
recordEncoder
where
newtypeEncoder :: Doc ann
newtypeEncoder :: forall ann. Doc ann
newtypeEncoder = forall ann. Doc ann
leftPart forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ElmRecordField -> Doc ann
fieldEncoderDoc (forall a. NonEmpty a -> a
NE.head NonEmpty ElmRecordField
elmRecordFields)
recordEncoder :: Doc ann
recordEncoder :: forall ann. Doc ann
recordEncoder = forall ann. Int -> Doc ann -> Doc ann
nest Int
4
forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep
forall a b. (a -> b) -> a -> b
$ (forall ann. Doc ann
leftPart forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"E.object")
forall a. a -> [a] -> [a]
: forall ann. NonEmpty ElmRecordField -> [Doc ann]
fieldsEncode NonEmpty ElmRecordField
elmRecordFields
leftPart :: Doc ann
leftPart :: forall ann. Doc ann
leftPart = forall ann. Text -> Doc ann
encoderName Text
elmRecordName forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"x" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals
fieldsEncode :: NonEmpty ElmRecordField -> [Doc ann]
fieldsEncode :: forall ann. NonEmpty ElmRecordField -> [Doc ann]
fieldsEncode NonEmpty ElmRecordField
fields =
forall ann. Doc ann
lbracket forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Text -> Doc ann
mkTag Text
elmRecordName
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((forall ann. Doc ann
comma forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. ElmRecordField -> Doc ann
recordFieldDoc) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty ElmRecordField
fields)
forall a. [a] -> [a] -> [a]
++ [forall ann. Doc ann
rbracket]
recordFieldDoc :: ElmRecordField -> Doc ann
recordFieldDoc :: forall ann. ElmRecordField -> Doc ann
recordFieldDoc field :: ElmRecordField
field@ElmRecordField{Text
TypeRef
elmRecordFieldName :: ElmRecordField -> Text
elmRecordFieldType :: ElmRecordField -> TypeRef
elmRecordFieldName :: Text
elmRecordFieldType :: TypeRef
..} = forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$
forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Text
elmRecordFieldName)
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
comma
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ElmRecordField -> Doc ann
fieldEncoderDoc ElmRecordField
field
fieldEncoderDoc :: ElmRecordField -> Doc ann
fieldEncoderDoc :: forall ann. ElmRecordField -> Doc ann
fieldEncoderDoc ElmRecordField{Text
TypeRef
elmRecordFieldName :: Text
elmRecordFieldType :: TypeRef
elmRecordFieldName :: ElmRecordField -> Text
elmRecordFieldType :: ElmRecordField -> TypeRef
..} =
forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
elmRecordFieldType) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"x." forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
elmRecordFieldName
mkTag :: Text -> Doc ann
mkTag :: forall ann. Text -> Doc ann
mkTag Text
txt = forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
dquotes Doc ann
"tag" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
comma forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"E.string" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty Text
txt)
encoderDef
:: Text
-> [Text]
-> Doc ann
encoderDef :: forall ann. Text -> [Text] -> Doc ann
encoderDef Text
typeName [Text]
vars =
forall ann. Text -> Doc ann
encoderName Text
typeName
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
colon
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Text -> [Text] -> Doc ann
qualifiedTypeWithVarsDoc Text
typeName [Text]
vars
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
arrow
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Value"
encoderName :: Text -> Doc ann
encoderName :: forall ann. Text -> Doc ann
encoderName Text
typeName = Doc ann
"encode" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
typeName
typeRefEncoder :: TypeRef -> Doc ann
typeRefEncoder :: forall ann. TypeRef -> Doc ann
typeRefEncoder (RefCustom TypeName{Text
unTypeName :: TypeName -> Text
unTypeName :: Text
..}) = Doc ann
"encode" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') Text
unTypeName)
typeRefEncoder (RefPrim ElmPrim
elmPrim) = case ElmPrim
elmPrim of
ElmPrim
ElmUnit -> Doc ann
"always <| E.list identity []"
ElmPrim
ElmNever -> Doc ann
"never"
ElmPrim
ElmBool -> Doc ann
"E.bool"
ElmPrim
ElmChar -> Doc ann
"E.string << String.fromChar"
ElmPrim
ElmInt -> Doc ann
"E.int"
ElmPrim
ElmFloat -> Doc ann
"E.float"
ElmPrim
ElmString -> Doc ann
"E.string"
ElmPrim
ElmTime -> Doc ann
"Iso.encode"
ElmPrim
ElmValue -> Doc ann
"Basics.identity"
ElmMaybe TypeRef
t -> Doc ann
"elmStreetEncodeMaybe"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
t)
ElmResult TypeRef
l TypeRef
r -> Doc ann
"elmStreetEncodeEither"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
l)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
r)
ElmPair TypeRef
a TypeRef
b -> Doc ann
"elmStreetEncodePair"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
a)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
b)
ElmTriple TypeRef
a TypeRef
b TypeRef
c -> Doc ann
"elmStreetEncodeTriple"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
a)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
b)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
c)
ElmList TypeRef
l -> Doc ann
"E.list" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
l)
ElmNonEmptyPair TypeRef
a -> Doc ann
"elmStreetEncodeNonEmpty"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
wrapParens (forall ann. TypeRef -> Doc ann
typeRefEncoder TypeRef
a)
encodeMaybe :: Text
encodeMaybe :: Text
encodeMaybe = [Text] -> Text
T.unlines
[ Text
"elmStreetEncodeMaybe : (a -> Value) -> Maybe a -> Value"
, Text
"elmStreetEncodeMaybe enc = Maybe.withDefault E.null << Maybe.map enc"
]
encodeEither :: Text
encodeEither :: Text
encodeEither = [Text] -> Text
T.unlines
[ Text
"elmStreetEncodeEither : (a -> Value) -> (b -> Value) -> Result a b -> Value"
, Text
"elmStreetEncodeEither encA encB res = E.object <| case res of"
, Text
" Err a -> [(\"Left\", encA a)]"
, Text
" Ok b -> [(\"Right\", encB b)]"
]
encodePair :: Text
encodePair :: Text
encodePair = [Text] -> Text
T.unlines
[ Text
"elmStreetEncodePair : (a -> Value) -> (b -> Value) -> (a, b) -> Value"
, Text
"elmStreetEncodePair encA encB (a, b) = E.list identity [encA a, encB b]"
]
encodeNonEmpty :: Text
encodeNonEmpty :: Text
encodeNonEmpty = [Text] -> Text
T.unlines
[ Text
"elmStreetEncodeNonEmpty : (a -> Value) -> (a, List a) -> Value"
, Text
"elmStreetEncodeNonEmpty encA (a, xs) = E.list encA <| a :: xs"
]
encodeTriple :: Text
encodeTriple :: Text
encodeTriple = [Text] -> Text
T.unlines
[ Text
"elmStreetEncodeTriple : (a -> Value) -> (b -> Value) -> (c -> Value) -> (a, b, c) -> Value"
, Text
"elmStreetEncodeTriple encA encB encC (a, b, c) = E.list identity [encA a, encB b, encC c]"
]