AST.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.AST
  ( AesonField,
    ClientDeclaration (..),
    ClientMethod (..),
    ClientPreDeclaration (..),
    DERIVING_MODE (..),
    MValue (..),
    RequestTypeDefinition (..),
    UnionPat (..),
    ClientTypeDefinition (..),
  )
where

import Data.Aeson (parseJSON)
import Data.Foldable (foldr1)
import Data.Morpheus.Client.CodeGen.Internal
  ( withObject,
    withUnion,
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenType,
    CodeGenTypeName,
    PrintableValue (..),
    TypeClassInstance,
    printTHName,
  )
import Data.Morpheus.CodeGen.TH
  ( PrintExp (..),
    ToName (toName),
    toCon,
    toString,
    toVar,
    v',
  )
import Data.Morpheus.Types.Internal.AST (FieldName, OperationType, TypeKind, TypeName, unpackName)
import Language.Haskell.TH
import Prettyprinter
  ( Doc,
    Pretty (..),
    indent,
    line,
    space,
    vsep,
    (<+>),
  )
import Relude hiding (lift, show, toString)
import Prelude (show)

data DERIVING_MODE = SCALAR_MODE | ENUM_MODE | TYPE_MODE

data ClientDeclaration
  = InstanceDeclaration DERIVING_MODE (TypeClassInstance ClientMethod)
  | ClientTypeDeclaration CodeGenType

data ClientPreDeclaration
  = ToJSONClass DERIVING_MODE CodeGenType
  | FromJSONClass DERIVING_MODE CodeGenType
  | FromJSONUnionClass CodeGenTypeName [(UnionPat, (CodeGenTypeName, Maybe String))]
  | FromJSONObjectClass CodeGenTypeName CodeGenConstructor
  | RequestTypeClass RequestTypeDefinition
  | ClientType CodeGenType

data ClientTypeDefinition = ClientTypeDefinition
  { clientTypeName :: CodeGenTypeName,
    clientCons :: [CodeGenConstructor],
    clientKind :: TypeKind
  }
  deriving (Show)

data RequestTypeDefinition = RequestTypeDefinition
  { requestName :: TypeName,
    requestArgs :: TypeName,
    requestType :: OperationType,
    requestQuery :: String
  }
  deriving (Show)

instance Pretty ClientDeclaration where
  pretty (ClientTypeDeclaration def) = pretty def
  pretty (InstanceDeclaration _ def) = pretty def

data ClientMethod
  = PrintableMethod PrintableValue
  | FunctionNameMethod Name
  | MatchMethod ValueMatch
  | ToJSONObjectMethod Name [(FieldName, Name, Name)]
  | FromJSONObjectMethod TypeName [AesonField]
  | FromJSONUnionMethod [([UnionPat], (Name, Maybe Name))]

type AesonField = (Name, Name, FieldName)

instance Pretty ClientMethod where
  pretty (FunctionNameMethod x) = space <> printTHName x
  pretty (PrintableMethod x) = space <> pretty x
  pretty (MatchMethod x) = space <> printMatchDoc x
  pretty (ToJSONObjectMethod name fields) = line <> indent 2 (printTHName name <> line <> indent 2 (list (map mkEntry fields)))
    where
      mkEntry (n, o, v) = prettyLit n <+> printTHName o <+> printTHName v
  pretty (FromJSONObjectMethod name xs) = withBody $ printObjectDoc (toName name, xs)
    where
      withBody body = line <> indent 2 "withObject" <+> prettyLit name <+> "(\\v ->" <+> body <> ")"
  pretty (FromJSONUnionMethod xs) = line <> indent 2 ("withUnion" <> line <> indent 2 (tuple [indent 1 (matchDoc $ map toMatch xs) <> line]))
    where
      toMatch (pat, expr) = (tuple $ map mapP pat, printVariantDoc expr)
      mapP (UString v) = prettyLit v
      mapP (UVar v) = pretty v

list :: Foldable t => t (Doc ann) -> Doc ann
list xs = "[" <> indent 1 (foldr1 (\a b -> a <> "," <> line <> b) xs) <> line <> "]"

tuple :: Foldable t => t (Doc ann) -> Doc ann
tuple ls = "(" <> foldr1 (\a b -> a <> "," <+> b) ls <> ")"

instance PrintExp ClientMethod where
  printExp (FunctionNameMethod v) = varE v
  printExp (PrintableMethod v) = printExp v
  printExp (MatchMethod p) = printMatchExp p
  printExp (ToJSONObjectMethod name fields) = appE (varE name) (listE $ map mkEntry fields)
    where
      mkEntry (n, o, v) = uInfixE (toString n) (toVar o) (toVar v)
  printExp (FromJSONObjectMethod name fields) = withBody $ printObjectExp (toName name, fields)
    where
      withBody body = appE (appE (toVar 'withObject) (toString name)) (lamE [v'] body)
  printExp (FromJSONUnionMethod matches) = appE (toVar 'withUnion) (matchExp $ map toMatch matches)
    where
      toMatch (pat, expr) = (tupP $ map mapP pat, printVariantExp expr)
      --
      mapP (UString v) = toString v
      mapP (UVar v) = toVar v

printVariantExp :: (Name, Maybe Name) -> ExpQ
printVariantExp (con, Just x) = uInfixE (toCon con) [|(<$>)|] (appE (toVar 'parseJSON) (toVar x))
printVariantExp (con, Nothing) = appE [|pure|] (toCon con)

printVariantDoc :: (Name, Maybe Name) -> Doc n
printVariantDoc (con, Just x) = printTHName con <+> "<$>" <+> "parseJSON" <+> printTHName x
printVariantDoc (con, Nothing) = "pure" <+> printTHName con

printObjectExp :: (Name, [AesonField]) -> ExpQ
printObjectExp (con, fields)
  | null fields = appE [|pure|] (toCon con)
  | otherwise = uInfixE (toCon con) [|(<$>)|] $ foldr1 (\x -> uInfixE x [|(<*>)|]) (map printFieldExp fields)

printObjectDoc :: (Name, [AesonField]) -> Doc n
printObjectDoc (name, fields)
  | null fields = "pure" <+> printTHName name
  | otherwise = printTHName name <+> "<$>" <+> foldr1 (\a b -> a <+> "<*>" <+> b) (map printFieldDoc fields)

printFieldExp :: AesonField -> ExpQ
printFieldExp (v, o, str) = uInfixE (toVar v) (toVar o) (toString str)

printFieldDoc :: AesonField -> Doc n
printFieldDoc (v, o, l) = printTHName v <+> printTHName o <+> prettyLit l

prettyLit :: Show a => a -> Doc ann
prettyLit a = pretty (show a)

prettyName :: TypeName -> Doc ann
prettyName a = pretty (unpackName a :: Text)

data UnionPat
  = UString TypeName
  | UVar String

data MValue
  = MFrom TypeName TypeName
  | MTo TypeName TypeName
  | MFunction String Name

type ValueMatch = [MValue]

printMatchDoc :: ValueMatch -> Doc n
printMatchDoc = matchDoc . map buildMatch
  where
    buildMatch (MFrom a b) = (prettyLit a, "pure" <+> prettyName b)
    buildMatch (MTo a b) = (prettyName a, prettyLit b)
    buildMatch (MFunction v name) = (pretty v, printTHName name <+> pretty v)

printMatchExp :: ValueMatch -> ExpQ
printMatchExp = matchExp . map buildMatch
  where
    buildMatch (MFrom a b) = (toString a, appE (toVar 'pure) (toCon b))
    buildMatch (MTo a b) = (toCon a, toString b)
    buildMatch (MFunction v name) = (toVar v, appE (varE name) v')

matchExp :: [(PatQ, ExpQ)] -> ExpQ
matchExp xs = lamCaseE (map buildMatch xs)
  where
    buildMatch (pat, fb) = match pat (normalB fb) []

matchDoc :: [(Doc n, Doc n)] -> Doc n
matchDoc = (("\\case" <> line) <>) . indent 2 . vsep . map buildMatch
  where
    buildMatch (pat, fb) = pat <+> "->" <+> fb