Elm.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.JsonSpec.Elm (
  elmDefs,
  Definitions,
  HasType(..),
) where


import Bound (Scope(Scope), Var(B, F), toScope)
import Control.Monad.Writer (MonadWriter(tell), Writer, execWriter)
import Data.JsonSpec (Specification(JsonArray, JsonBool, JsonDateTime,
  JsonEither, JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject,
  JsonRef, JsonString, JsonTag))
import Data.Proxy (Proxy(Proxy))
import Data.Set (Set)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (ErrorMessage((:$$:), (:<>:)), KnownSymbol, Symbol,
  TypeError, symbolVal)
import Language.Elm.Definition (Definition)
import Language.Elm.Expression ((|>), Expression, bind, if_)
import Language.Elm.Name (Constructor, Qualified)
import Language.Elm.Type (Type)
import Prelude (Applicative(pure), Foldable(foldl), Functor(fmap),
  Maybe(Just, Nothing), Monad((>>)), Semigroup((<>)), Show(show), ($),
  (++), (.), (<$>), Int, error, reverse, zip)
import qualified Data.Char as Char
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified GHC.TypeLits as Lits
import qualified Language.Elm.Definition as Def
import qualified Language.Elm.Expression as Expr
import qualified Language.Elm.Name as Name
import qualified Language.Elm.Pattern as Pat
import qualified Language.Elm.Type as Type


elmDefs
  :: forall spec. (HasType spec)
  => Proxy (spec :: Specification)
  -> Set Definition
elmDefs _ =
  execWriter $ typeOf @spec >> decoderOf @spec


class Record (spec :: [(Symbol, Specification)]) where
  recordDefs :: forall v. Definitions [(Name.Field, Type v)]
  recordEncoders :: Definitions [(Text, Name.Field, Expression Void)]
instance Record '[] where
  recordDefs = pure []
  recordEncoders = pure []
instance
    ( HasType spec
    , KnownSymbol name
    , Record more
    )
  =>
    Record ( '(name, spec) : more )
  where
    recordDefs = do
      type_ <- typeOf @spec
      moreFields <- recordDefs @more
      pure $ (fieldName @name, type_) : moreFields
    recordEncoders = do
      encoder <- encoderOf @spec
      moreFields <- recordEncoders @more
      pure $ (sym @name, fieldName @name, encoder) : moreFields


class HasType (spec :: Specification) where
  typeOf :: forall v. Definitions (Type v)
  decoderOf :: Definitions (Expression Void)
  encoderOf :: Definitions (Expression Void)
instance HasType JsonString where
  typeOf = pure "String.String"
  decoderOf = pure "Json.Decode.string"
  encoderOf = pure "Json.Encode.string"
instance HasType JsonNum where
  typeOf = pure "Basics.Float"
  decoderOf = pure "Json.Decode.float"
  encoderOf = pure "Json.Encode.float"
instance HasType JsonInt where
  typeOf = pure "Basics.Int"
  decoderOf = pure "Json.Decode.int"
  encoderOf = pure "Json.Encode.int"
instance {- HasType (JsonObject fields) -}
    ( Record fields
    , BaseFields (Reverse fields)
    , Lambda (LambdaDepth (Reverse fields))
    , Decoders fields
    )
  =>
    HasType (JsonObject fields)
  where
    typeOf = Type.Record <$> recordDefs @fields
    decoderOf = do
        decoders <- fieldDecoders @fields
        pure $
          foldl
            (\expr (_, decoder) ->
              expr |> ("Json.Decode.andThen" `Expr.App`
                Expr.Lam (toScope (
                  "Json.Decode.map"
                    `Expr.App` Expr.Var (B ())
                    `Expr.App` bind Expr.Global absurd decoder
                ))
              )
            )
            ("Json.Decode.succeed" `Expr.App` lambda)
            decoders
      where
        lambda =
          lam . Expr.Record . reverse $
            [ (name, var)
            | (name, var) <- baseFields @(Reverse fields)
            ]
    encoderOf = do
        fields <- recordEncoders @fields
        pure $
          Expr.Lam . toScope $
            "Json.Encode.object"
            `Expr.App`
            Expr.List
              [ Expr.apps "Basics.," [
                Expr.String jsonField,
                Expr.bind Expr.Global absurd encoder `Expr.App`
                  (Expr.Proj elmField `Expr.App` Expr.Var var)
                ]
              | (jsonField, elmField, encoder) <- fields
              ]
      where
        var :: Bound.Var () a
        var = B ()

instance (HasType spec) => HasType (JsonArray spec) where
  typeOf = do
    elemType <- typeOf @spec
    pure $ Type.App "Basics.List" elemType
  decoderOf = do
    dec <- decoderOf @spec
    pure $ Expr.App "Json.Decode.list" dec
  encoderOf = do
    encoder <- encoderOf @spec
    pure $ "Json.Encode.list" `Expr.App` encoder
instance HasType JsonBool where
  typeOf = pure "Basics.Bool"
  decoderOf = pure "Json.Decode.bool"
  encoderOf =
    pure "Json.Encode.bool"
instance (HasType spec) => HasType (JsonNullable spec) where
  typeOf = do
    type_ <- typeOf @spec
    pure $ Type.App "Maybe.Maybe" type_
  decoderOf = do
    dec <- decoderOf @spec
    pure $ Expr.App "Json.Decode.nullable" dec
  encoderOf = do
    encoder <- encoderOf @spec
    pure $
      Expr.Lam . toScope $
        Expr.apps
          "Maybe.withDefault"
          [ "Json.Decode.null"
          , Expr.apps
              "Maybe.map"
              [ Expr.bind Expr.Global absurd encoder
              , Expr.Var (B ())
              ]
          ]
instance (KnownSymbol const) => HasType (JsonTag const) where
  typeOf = pure "Basics.()"
  decoderOf =
    pure $
      "Json.Decode.string"
      |> Expr.apps "Json.Decode.andThen"
          [ Expr.Lam . toScope $
              if_
                (
                  Expr.apps
                    "Basics.=="
                    [ Expr.Var (B ())
                    , Expr.String (sym @const)
                    ]
                )
                (Expr.App "Json.Decode.succeed" "Basics.()")
                (Expr.App "Json.Decode.fail" (Expr.String "Tag mismatch"))
          ]
  encoderOf =
    pure $
      "Basics.always" `Expr.App`
        ("Json.Encode.string" `Expr.App` Expr.String (sym @const))
instance HasType JsonDateTime where
  typeOf = pure "Time.Posix"
  decoderOf = pure "Iso8601.decoder"
  encoderOf = pure "Iso8601.encode"
instance (KnownSymbol name) => HasType (JsonRef name) where
  typeOf =
    pure
    . Type.Global
    . localName
    $ sym @name
  decoderOf =
    pure . Expr.Global $ decoderName @name
  encoderOf =
    pure . Expr.Global $ encoderName @name
instance (HasType spec) => HasType (JsonLet '[] spec) where
  typeOf = typeOf @spec
  decoderOf = decoderOf @spec
  encoderOf = encoderOf @spec
instance {- HasType (JsonLet ( def : more ) spec) -}
    ( ElmDef def
    , HasType (JsonLet more spec)
    )
  =>
    HasType (JsonLet ( def : more ) spec)
  where
    typeOf = do
      defs @def
      typeOf @(JsonLet more spec)
    decoderOf = do
      defs @def
      decoderOf @(JsonLet more spec)
    encoderOf = do
      defs @def
      encoderOf @(JsonLet more spec)
instance {- HasType (JsonEither left right) -}
    ( TypeError
        ( Lits.Text "Elm doesn't support anonymous sum types, so if you "
          :<>: Lits.Text "want to use (possibly nested) `JsonEither` "
          :<>: Lits.Text "you must give it a name using `JsonLet`, e.g:"
          :$$: Lits.Text ""
          :$$: Lits.Text "> JsonLet"
          :$$: Lits.Text ">   '[ '( \"MySum\""
          :$$: Lits.Text ">       , JsonEither"
          :$$: Lits.Text ">           ( JsonEither"
          :$$: Lits.Text ">               JsonInt"
          :$$: Lits.Text ">               JsonString"
          :$$: Lits.Text ">           )"
          :$$: Lits.Text ">           ( JsonEither"
          :$$: Lits.Text ">               JsonFloat"
          :$$: Lits.Text ">               JsonBool"
          :$$: Lits.Text ">           )"
          :$$: Lits.Text ">       )"
          :$$: Lits.Text ">    ]"
          :$$: Lits.Text ">    (JsonRef \"MySum\")"
          :$$: Lits.Text ""
          :$$: Lits.Text "This will produce the Elm type"
          :$$: Lits.Text ""
          :$$: Lits.Text "> type MySum"
          :$$: Lits.Text ">   = MySum_1 Int"
          :$$: Lits.Text ">   | MySum_2 String"
          :$$: Lits.Text ">   | MySum_3 Float"
          :$$: Lits.Text ">   | MySum_4 Bool"
          :$$: Lits.Text ""

        )
    )
  =>
    HasType (JsonEither left right)
  where
    typeOf = error "undefinable"
    decoderOf = error "undefinable"
    encoderOf = error "undefinable"


type family LambdaDepth (record :: [k]) where
  LambdaDepth '[] = Void
  LambdaDepth (a : more) =
    Bound.Var () (LambdaDepth more)


class Lambda depth where
  lam :: Expression depth -> Expression Void
instance {-# OVERLAPS #-} Lambda (Bound.Var () Void) where
  lam e = Expr.Lam (toScope e)
instance (Lambda deeper) => Lambda (Bound.Var () deeper) where
  lam e = lam (Expr.Lam (toScope e))


class BaseFields (record :: [(Symbol, Specification)]) where
  baseFields :: [(Name.Field, Expression (LambdaDepth record))]
instance BaseFields '[] where
  baseFields = []
instance {- BaseFields ('(name, spec) : more) -}
    (BaseFields more, KnownSymbol name)
  =>
    BaseFields ('(name, spec) : more)
  where
    baseFields =
        (fieldName @name, Expr.Var (B ())) :
        [ (name, b var)
        | (name, var) <- baseFields @more
        ]
      where
        b = bind Expr.Global (Expr.Var . F)


type family Reverse (l :: [k]) where
  Reverse '[] = '[]
  Reverse (a : more) = Concat (Reverse more) '[a]


type family Concat (a :: [k]) (b :: [k]) where
  Concat '[] b = b
  Concat (a : more) b =
    a : Concat more b


class Decoders (spec :: [(Symbol, Specification)]) where
  fieldDecoders :: Definitions [(Text, Expression Void)]
instance Decoders '[] where
  fieldDecoders = pure []
instance {- Decoders ('(name, spec) : more) -}
    (HasType spec, Decoders more, KnownSymbol name)
  =>
    Decoders ('(name, spec) : more)
  where
    fieldDecoders = do
      dec <- decoderOf @spec
      more <- fieldDecoders @more
      pure $ ( sym @name , dec) : more


class ElmDef (def :: (Symbol, Specification)) where
  defs :: Definitions ()
instance {-# OVERLAPS #-}
    ( KnownSymbol name
    , SumDef (JsonEither left right)
    )
  =>
    ElmDef '(name, JsonEither left right)
  where
    defs = do
        branches <- sumDef @(JsonEither left right)
        let
          constructors :: [(Constructor, [Scope Int Type Void])]
          constructors =
            [ ( Name.Constructor (constructorName n)
              , [Scope type_]
              )
            | (n, type_) <- zip [(1 :: Int) ..] branches
            ]
        decoders <- sumDecoders @(JsonEither left right)
        encoders <- sumEncoders @(JsonEither left right)
        tell . Set.fromList $
          [ Def.Type (localName name) 0 constructors
          , Def.Constant
              (decoderName @name)
              0
              ( Scope
                  ( "Json.Decode.Decoder"
                    `Type.App`
                    Type.Global (localName name)
                  )
              )
              (
                "Json.Decode.oneOf"
                `Expr.App`
                Expr.List
                  [ "Json.Decode.map"
                    `Expr.App` Expr.Global (localName (constructorName n))
                    `Expr.App` dec
                  | (n, dec) <-  zip [(1 :: Int) ..] decoders
                  ]
              )
          , Def.Constant
              (encoderName @name)
              0
              (
                toScope $
                  Type.Fun
                    (Type.Global (localName name))
                    "Json.Encode.Value"
              )
              (
                Expr.Lam . toScope $
                  Expr.Case
                    (Expr.Var (B ()))
                    [ ( Pat.Con (localName (constructorName n)) [Pat.Var 0]
                      , toScope $
                        fmap absurd encoder `Expr.App`
                          Expr.Var (B (0 :: Int))
                      )
                    | (n, encoder) <- zip [1..] encoders
                    ]
              )
          ]
      where
        constructorName :: Int -> Text
        constructorName n = name <> "_" <> showt n

        name :: Text
        name = sym @name
instance (HasType spec, KnownSymbol name) => ElmDef '(name, spec) where
  defs = do
    type_ <- typeOf @spec
    dec <- decoderOf @spec
    enc <- encoderOf @spec
    tell . Set.fromList $
      [ Def.Alias
          (localName (sym @name))
          0
          (Scope type_)
      , Def.Constant
          (decoderName @name)
          0
          ( Scope
              ( Type.App
                  "Json.Decode.Decoder"
                  (Type.Global $ localName (sym @name))
              )
          )
          dec
      , Def.Constant
          (encoderName @name)
          0
          ( Scope
              ( Type.Fun
                  (Type.Global $ localName (sym @name))
                  "Json.Encode.Value"
              )
          )
          enc
      ]


class SumDef (spec :: Specification) where
  sumDef :: forall v. Definitions [Type v]
  sumDecoders :: Definitions [Expression Void]
  sumEncoders :: Definitions [Expression Void]
instance {-# OVERLAPS #-}
    (SumDef (JsonEither a b), SumDef (JsonEither c d))
  =>
    SumDef (JsonEither (JsonEither a b) (JsonEither c d))
  where
    sumDef = do
      left <- sumDef @(JsonEither a b)
      right <- sumDef @(JsonEither c d)
      pure $ left ++ right
    sumDecoders = do
      left <- sumDecoders @(JsonEither a b)
      right <- sumDecoders @(JsonEither c d)
      pure (left ++ right)
    sumEncoders = do
      left <- sumEncoders @(JsonEither a b)
      right <- sumEncoders @(JsonEither c d)
      pure (left ++ right)
instance {-# OVERLAPS #-}
    (SumDef (JsonEither a b), HasType right)
  =>
    SumDef (JsonEither (JsonEither a b) right)
  where
    sumDef = do
      left <- sumDef @(JsonEither a b)
      right <- typeOf @right
      pure $ left ++ [right]
    sumDecoders = do
      left <- sumDecoders @(JsonEither a b)
      right <- decoderOf @right
      pure $ left ++ [right]
    sumEncoders = do
      left <- sumEncoders @(JsonEither a b)
      right <- encoderOf @right
      pure $ left ++ [right]
instance {-# OVERLAPS #-}
    (SumDef (JsonEither c d), HasType left)
  =>
    SumDef (JsonEither left (JsonEither c d))
  where
    sumDef = do
      left <- typeOf @left
      right <- sumDef @(JsonEither c d)
      pure $ left : right
    sumDecoders = do
      left <- decoderOf @left
      right <- sumDecoders @(JsonEither c d)
      pure $ left : right
    sumEncoders = do
      left <- encoderOf @left
      right <- sumEncoders @(JsonEither c d)
      pure $ left : right
instance
    (HasType left, HasType right)
  =>
    SumDef (JsonEither left right)
  where
    sumDef = do
      left <- typeOf @left
      right <- typeOf @right
      pure [left, right]
    sumDecoders = do
      left <- decoderOf @left
      right <- decoderOf @right
      pure [left, right]
    sumEncoders = do
      left <- encoderOf @left
      right <- encoderOf @right
      pure [left, right]


localName :: Text -> Qualified
localName =
  Name.Qualified ["Api", "Data"]


type Definitions = Writer (Set Definition)


sym :: forall a b. (KnownSymbol a, IsString b) => b
sym = fromString $ symbolVal (Proxy @a)


showt :: (Show a, IsString b) => a -> b
showt = fromString . show


lower :: Text -> Text
lower txt =
  case Text.uncons txt of
    Nothing -> txt
    Just (c, more) -> Text.cons (Char.toLower c) more


decoderName :: forall name. (KnownSymbol name) => Qualified
decoderName = localName (lower (sym @name) <> "Decoder")

encoderName :: forall name. (KnownSymbol name) => Qualified
encoderName = localName (lower (sym @name) <> "Encoder")


fieldName :: forall name. (KnownSymbol name) => Name.Field
fieldName =
  Name.Field $
    case sym @name of
      "type" -> "type_"
      other -> Text.replace "-" "_" other