Decoder.hs

{- | Pretty-printing functions for @Decoder.elm@ module.
Also contains decoders for common types which go to the @ElmStreet.elm@ module.
-}

module Elm.Print.Decoder
       ( prettyShowDecoder

         -- * Standard missing decoders
       , 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


----------------------------------------------------------------------------
-- Decode
----------------------------------------------------------------------------

{- |

__Sum Types:__

Haskell type

@
type User
    = Foo
    | Bar String Int
@

Encoded JSON on Haskell side

@
    [ { "tag" : "Foo"
      }
    , { "tag" : "Bar"
      , "contents" : ["asd", 42, "qwerty"]
      }
    ]
@

Elm decoder

@
userDecoder : Decoder User
userDecoder =
    let decide : String -> Decoder User
        decide x = case x of
            \"Foo\" -> D.succeed Foo
            \"Bar\" -> D.field "contents" <| D.map2 Bar (D.index 0 D.string) (D.index 1 D.int)
            x -> D.fail <| "There is no constructor for User type:" ++ x
    in D.andThen decide (D.field "tag" D.string)
@

-}
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{..} =
    -- function defenition: @encodeTypeName : TypeName -> Value@.
       decoderDef elmTypeName elmTypeVars
    <> line
    <> if isEnum t
       -- if this is Enum just using the read instance we wrote.
       then enumDecoder
       else if elmTypeIsNewtype
            -- if it newtype then wrap decoder for the field
            then newtypeDecoder
            -- If it sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@
            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

        -- Use function map, map2, map3 etc.
        mapNum :: Int -> Doc ann
        mapNum 1 = emptyDoc
        mapNum i = pretty i

        createIndexes :: Doc ann
        createIndexes = concatWith (surround " ") $ zipWith oneField [0..] elmConstructorFields

        -- create @(D.index 0 D.string)@ etc.
        oneField :: Int -> TypeRef -> Doc ann
        oneField i typeRef = parens $ "D.index"
            <+> pretty i
            <+> wrapParens (typeRefDecoder typeRef)

-- | Converts the reference to the existing type to the corresponding decoder.
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)

-- | The definition of the @decodeTYPENAME@ function.
decoderDef
    :: Text  -- ^ Type name
    -> [Text] -- ^ List of type variables
    -> Doc ann
decoderDef typeName vars =
    decoderName typeName
    <+> colon
    <+> "Decoder"
    <+> wrapParens (qualifiedTypeWithVarsDoc typeName vars)

-- | Create the name of the decoder function.
decoderName :: Text -> Doc ann
decoderName typeName = "decode" <> pretty typeName

-- | @JSON@ decoder Elm help function for Enum types.
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"
    ]

-- | @JSON@ decoder Elm help function for 'Char's.
decodeChar :: Text
decodeChar = T.unlines
    [ "elmStreetDecodeChar : Decoder Char"
    , "elmStreetDecodeChar = D.andThen (decodeStr (Maybe.map Tuple.first << String.uncons)) D.string"
    ]

-- | @JSON@ decoder Elm help function for 'Either's.
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)"
    , "    ]"
    ]

-- | @JSON@ decoder Elm help function for 2-tuples.
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)"
    ]

-- | @JSON@ decoder Elm help function for 3-tuples.
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)"
    ]