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