module Elm.Print.Decoder
( prettyShowDecoder
, decodeEnum
, decodeChar
, decodeEither
, decodePair
, decodeTriple
) where
import Data.List.NonEmpty (toList)
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, colon, concatWith, dquotes, emptyDoc, equals, line, nest,
parens, pretty, surround, vsep, (<+>))
import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..),
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
prettyShowDecoder :: ElmDefinition -> Text
prettyShowDecoder def = showDoc $ case def of
DefAlias elmAlias -> aliasDecoderDoc elmAlias
DefType elmType -> typeDecoderDoc elmType
DefPrim _ -> emptyDoc
aliasDecoderDoc :: ElmAlias -> Doc ann
aliasDecoderDoc ElmAlias{..} =
decoderDef elmAliasName []
<> line
<> if elmAliasIsNewtype
then newtypeDecoder
else recordDecoder
where
newtypeDecoder :: Doc ann
newtypeDecoder = name <+> "D.map" <+> qualifiedAliasName
<+> wrapParens (typeRefDecoder $ elmRecordFieldType $ NE.head elmAliasFields)
recordDecoder :: Doc ann
recordDecoder = nest 4
$ vsep
$ (name <+> "D.succeed" <+> qualifiedAliasName)
: map fieldDecode (toList elmAliasFields)
name :: Doc ann
name = decoderName elmAliasName <+> equals
qualifiedAliasName :: Doc ann
qualifiedAliasName = mkQualified elmAliasName
fieldDecode :: ElmRecordField -> Doc ann
fieldDecode ElmRecordField{..} = case elmRecordFieldType of
RefPrim ElmUnit -> "|> D.hardcoded ()"
t -> "|> required"
<+> dquotes (pretty elmRecordFieldName)
<+> wrapParens (typeRefDecoder t)
typeDecoderDoc :: ElmType -> Doc ann
typeDecoderDoc t@ElmType{..} =
decoderDef elmTypeName elmTypeVars
<> line
<> if isEnum t
then enumDecoder
else if elmTypeIsNewtype
then newtypeDecoder
else sumDecoder
where
name :: Doc ann
name = decoderName elmTypeName <+> equals
typeName :: Doc ann
typeName = pretty elmTypeName
qualifiedTypeName :: Doc ann
qualifiedTypeName = mkQualified elmTypeName
enumDecoder :: Doc ann
enumDecoder = name <+> "elmStreetDecodeEnum T.read" <> typeName
newtypeDecoder :: Doc ann
newtypeDecoder = name <+> "D.map" <+> qualifiedTypeName <+> fieldDecoderDoc
where
fieldDecoderDoc :: Doc ann
fieldDecoderDoc = case elmConstructorFields $ NE.head elmTypeConstructors of
[] -> "(D.fail \"Unknown field type of the newtype constructor\")"
f : _ -> wrapParens $ typeRefDecoder f
sumDecoder :: Doc ann
sumDecoder = nest 4 $ vsep
[ name
, nest 4 (vsep $ ("let decide : String -> Decoder" <+> qualifiedTypeName) :
[ nest 4
( vsep $ "decide x = case x of"
: map cases (toList elmTypeConstructors)
++ ["c -> D.fail <|" <+> dquotes (typeName <+> "doesn't have such constructor: ") <+> "++ c"]
)
])
, "in D.andThen decide (D.field \"tag\" D.string)"
]
cases :: ElmConstructor -> Doc ann
cases ElmConstructor{..} = dquotes cName <+> arrow <+>
case elmConstructorFields of
[] -> "D.succeed" <+> qualifiedConName
[f] -> "D.field \"contents\" <| D.map" <+> qualifiedConName <+> wrapParens (typeRefDecoder f)
l -> "D.field \"contents\" <| D.map" <> mapNum (length l) <+> qualifiedConName <+> createIndexes
where
cName :: Doc ann
cName = pretty elmConstructorName
qualifiedConName :: Doc ann
qualifiedConName = mkQualified elmConstructorName
mapNum :: Int -> Doc ann
mapNum 1 = emptyDoc
mapNum i = pretty i
createIndexes :: Doc ann
createIndexes = concatWith (surround " ") $ zipWith oneField [0..] elmConstructorFields
oneField :: Int -> TypeRef -> Doc ann
oneField i typeRef = parens $ "D.index"
<+> pretty i
<+> wrapParens (typeRefDecoder typeRef)
typeRefDecoder :: TypeRef -> Doc ann
typeRefDecoder (RefCustom TypeName{..}) = "decode" <> pretty (T.takeWhile (/= ' ') unTypeName)
typeRefDecoder (RefPrim elmPrim) = case elmPrim of
ElmUnit -> "D.map (always ()) (D.list D.string)"
ElmNever -> "D.fail \"Never is not possible\""
ElmBool -> "D.bool"
ElmChar -> "elmStreetDecodeChar"
ElmInt -> "D.int"
ElmFloat -> "D.float"
ElmString -> "D.string"
ElmTime -> "Iso.decoder"
ElmMaybe t -> "nullable"
<+> wrapParens (typeRefDecoder t)
ElmResult l r -> "elmStreetDecodeEither"
<+> wrapParens (typeRefDecoder l)
<+> wrapParens (typeRefDecoder r)
ElmPair a b -> "elmStreetDecodePair"
<+> wrapParens (typeRefDecoder a)
<+> wrapParens (typeRefDecoder b)
ElmTriple a b c -> "elmStreetDecodeTriple"
<+> wrapParens (typeRefDecoder a)
<+> wrapParens (typeRefDecoder b)
<+> wrapParens (typeRefDecoder c)
ElmList l -> "D.list" <+> wrapParens (typeRefDecoder l)
decoderDef
:: Text
-> [Text]
-> Doc ann
decoderDef typeName vars =
decoderName typeName
<+> colon
<+> "Decoder"
<+> wrapParens (qualifiedTypeWithVarsDoc typeName vars)
decoderName :: Text -> Doc ann
decoderName typeName = "decode" <> pretty typeName
decodeEnum :: Text
decodeEnum = T.unlines
[ "decodeStr : (String -> Maybe a) -> String -> Decoder a"
, "decodeStr readX x = case readX x of"
, " Just a -> D.succeed a"
, " Nothing -> D.fail \"Constructor not matched\""
, ""
, "elmStreetDecodeEnum : (String -> Maybe a) -> Decoder a"
, "elmStreetDecodeEnum r = D.andThen (decodeStr r) D.string"
]
decodeChar :: Text
decodeChar = T.unlines
[ "elmStreetDecodeChar : Decoder Char"
, "elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string"
]
decodeEither :: Text
decodeEither = T.unlines
[ "elmStreetDecodeEither : Decoder a -> Decoder b -> Decoder (Result a b)"
, "elmStreetDecodeEither decA decB = D.oneOf "
, " [ D.field \"Left\" (D.map Err decA)"
, " , D.field \"Right\" (D.map Ok decB)"
, " ]"
]
decodePair :: Text
decodePair = T.unlines
[ "elmStreetDecodePair : Decoder a -> Decoder b -> Decoder (a, b)"
, "elmStreetDecodePair decA decB = D.map2 Tuple.pair (D.index 0 decA) (D.index 1 decB)"
]
decodeTriple :: Text
decodeTriple = T.unlines
[ "elmStreetDecodeTriple : Decoder a -> Decoder b -> Decoder c -> Decoder (a, b, c)"
, "elmStreetDecodeTriple decA decB decC = D.map3 (\\a b c -> (a,b,c)) (D.index 0 decA) (D.index 1 decB) (D.index 2 decC)"
]