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

module Elm.Print.Encoder
       ( prettyShowEncoder

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


{- | Returns the encoder for the given type.


TODO

 +-------------------+------------------+------------------+--------------------+
 |    Haskell Type   |     Eml Type     |     Encoder      |       JSON         |
 +===================+==================+==================+====================+
 |   'Int'           |      'Int'       | standard encoder |                    |
 +-------------------+------------------+------------------+--------------------+

-}
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

-- | Encoder for 'ElmType' (which is either enum or the Sum type).
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
..} =
    -- function definition: @encodeTypeName : TypeName -> Value@.
       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
       -- if this is Enum just using the show instance we wrote.
       then forall ann. Doc ann
enumEncoder
       else if Bool
elmTypeIsNewtype
            -- if this is type with one constructor and one field then it should just call encoder for wrapped type
            then forall ann. Doc ann
newtypeEncoder
            -- If it's sum type then it should look like: @{"tag": "Foo", "contents" : ["string", 1]}@
            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)

    -- | Encoder function name
    name :: Doc ann
    name :: forall ann. Doc ann
name = forall ann. Text -> Doc ann
encoderName Text
elmTypeName

    -- | Create case clause for each of the sum Constructors.
    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
        -- | Creates variables: @x1@ to @xN@, where N is the number of the constructor fields.
        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)

        -- JSON encoder for the "contents" key
        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

        -- | @encoderA x1@
        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

        -- | Makes variable like: @x11@ etc.
        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

-- | Create pair of view: @("tag", E.string "SomeName")@.
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)

-- | The definition of the @encodeTYPENAME@ function.
encoderDef
    :: Text  -- ^ Type name
    -> [Text] -- ^ List of type variables
    -> 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"

-- | Create the name of the encoder function.
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

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

-- | @JSON@ encoder Elm help function for 'Maybe's.
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"
    ]

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

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

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

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