{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Printer
  ( HSDoc (..),
    Printer (..),
    apply,
    infix',
    print',
    unpack,
    wrapped,
    (.<>),
    optional,
    ignore,
    pack,
  )
where

import Data.Morpheus.Types.Internal.AST
  ( DirectiveLocation,
    Name,
    TypeRef (..),
    TypeWrapper (..),
    packName,
    unpackName,
  )
import qualified Data.Text as T
import qualified Language.Haskell.TH as TH
import Prettyprinter (Doc, Pretty (..), list, pretty, tupled, (<+>))
import Relude hiding (optional, print, show)
import Prelude (show)

infix' :: HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' :: forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' HSDoc n
a HSDoc n
op HSDoc n
b = Doc n -> HSDoc n
forall n. Doc n -> HSDoc n
pack (Doc n -> HSDoc n) -> Doc n -> HSDoc n
forall a b. (a -> b) -> a -> b
$ HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
rawDocument HSDoc n
a Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
rawDocument HSDoc n
op Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
rawDocument HSDoc n
b

(.<>) :: HSDoc n -> HSDoc n -> HSDoc n
.<> :: forall n. HSDoc n -> HSDoc n -> HSDoc n
(.<>) HSDoc n
a HSDoc n
b = Bool -> Doc n -> HSDoc n
forall n. Bool -> Doc n -> HSDoc n
HSDoc Bool
True (Doc n -> HSDoc n) -> Doc n -> HSDoc n
forall a b. (a -> b) -> a -> b
$ HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
unpack HSDoc n
a Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
unpack HSDoc n
b

apply :: Name t -> [HSDoc n] -> HSDoc n
apply :: forall (t :: NAME) n. Name t -> [HSDoc n] -> HSDoc n
apply Name t
name [HSDoc n]
xs = Bool -> Doc n -> HSDoc n
forall n. Bool -> Doc n -> HSDoc n
HSDoc Bool
True ((Doc n -> HSDoc n -> Doc n) -> Doc n -> [HSDoc n] -> Doc n
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Doc n
b HSDoc n
a -> Doc n
b Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
unpack HSDoc n
a) (Name t -> Doc n
forall a n. Printer a => a -> Doc n
print' Name t
name) [HSDoc n]
xs)

renderMaybe :: Bool -> HSDoc n -> HSDoc n
renderMaybe :: forall n. Bool -> HSDoc n -> HSDoc n
renderMaybe Bool
True = HSDoc n -> HSDoc n
forall a. a -> a
id
renderMaybe Bool
False = HSDoc n -> HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n -> HSDoc n
(.<>) HSDoc n
"Maybe"

renderList :: HSDoc n -> HSDoc n
renderList :: forall n. HSDoc n -> HSDoc n
renderList = Doc n -> HSDoc n
forall n. Doc n -> HSDoc n
pack (Doc n -> HSDoc n) -> (HSDoc n -> Doc n) -> HSDoc n -> HSDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
list ([Doc n] -> Doc n) -> (HSDoc n -> [Doc n]) -> HSDoc n -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc n -> [Doc n]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc n -> [Doc n]) -> (HSDoc n -> Doc n) -> HSDoc n -> [Doc n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
rawDocument

print' :: Printer a => a -> Doc n
print' :: forall a n. Printer a => a -> Doc n
print' = HSDoc n -> Doc n
forall n. HSDoc n -> Doc n
unpack (HSDoc n -> Doc n) -> (a -> HSDoc n) -> a -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HSDoc n
forall ann. a -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print

pack :: Doc n -> HSDoc n
pack :: forall n. Doc n -> HSDoc n
pack = Bool -> Doc n -> HSDoc n
forall n. Bool -> Doc n -> HSDoc n
HSDoc Bool
False

unpack :: HSDoc n -> Doc n
unpack :: forall n. HSDoc n -> Doc n
unpack HSDoc {Bool
Doc n
rawDocument :: forall n. HSDoc n -> Doc n
isComplex :: Bool
rawDocument :: Doc n
isComplex :: forall n. HSDoc n -> Bool
..} = if Bool
isComplex then [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
tupled [Doc n
rawDocument] else Doc n
rawDocument

ignore :: HSDoc n -> Doc n
ignore :: forall n. HSDoc n -> Doc n
ignore HSDoc {Bool
Doc n
rawDocument :: forall n. HSDoc n -> Doc n
isComplex :: forall n. HSDoc n -> Bool
isComplex :: Bool
rawDocument :: Doc n
..} = Doc n
rawDocument

data HSDoc n = HSDoc
  { forall n. HSDoc n -> Bool
isComplex :: Bool,
    forall n. HSDoc n -> Doc n
rawDocument :: Doc n
  }

class Printer a where
  print :: a -> HSDoc ann

instance IsString (HSDoc n) where
  fromString :: String -> HSDoc n
fromString = Doc n -> HSDoc n
forall n. Doc n -> HSDoc n
pack (Doc n -> HSDoc n) -> (String -> Doc n) -> String -> HSDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc n
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance Printer TypeRef where
  print :: forall ann. TypeRef -> HSDoc ann
print TypeRef {TypeName
TypeWrapper
typeConName :: TypeName
typeWrappers :: TypeWrapper
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
..} = TypeWrapper -> HSDoc ann -> HSDoc ann
forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
typeWrappers (TypeName -> HSDoc ann
forall ann. TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print TypeName
typeConName)

wrapped :: TypeWrapper -> HSDoc n -> HSDoc n
wrapped :: forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped (TypeList TypeWrapper
wrapper Bool
notNull) = Bool -> HSDoc n -> HSDoc n
forall n. Bool -> HSDoc n -> HSDoc n
renderMaybe Bool
notNull (HSDoc n -> HSDoc n) -> (HSDoc n -> HSDoc n) -> HSDoc n -> HSDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n
renderList (HSDoc n -> HSDoc n) -> (HSDoc n -> HSDoc n) -> HSDoc n -> HSDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeWrapper -> HSDoc n -> HSDoc n
forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
wrapper
wrapped (BaseType Bool
notNull) = Bool -> HSDoc n -> HSDoc n
forall n. Bool -> HSDoc n -> HSDoc n
renderMaybe Bool
notNull

instance Printer (Name t) where
  print :: forall ann. Name t -> HSDoc ann
print = Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack (Doc ann -> HSDoc ann)
-> (Name t -> Doc ann) -> Name t -> HSDoc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (Name t -> String) -> Name t -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Name t -> Text) -> Name t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name t -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName

instance Printer Text where
  print :: forall ann. Text -> HSDoc ann
print = Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack (Doc ann -> HSDoc ann) -> (Text -> Doc ann) -> Text -> HSDoc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance Printer String where
  print :: forall n. String -> HSDoc n
print = Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack (Doc ann -> HSDoc ann)
-> (String -> Doc ann) -> String -> HSDoc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

instance Printer DirectiveLocation where
  print :: forall ann. DirectiveLocation -> HSDoc ann
print = String -> HSDoc ann
forall a. IsString a => String -> a
fromString (String -> HSDoc ann)
-> (DirectiveLocation -> String) -> DirectiveLocation -> HSDoc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirectiveLocation -> String
forall a. Show a => a -> String
show

instance Printer TH.Name where
  print :: forall ann. Name -> HSDoc ann
print = Name Any -> HSDoc ann
forall ann. Name Any -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print (Name Any -> HSDoc ann) -> (Name -> Name Any) -> Name -> HSDoc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name Any
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Name -> Name t
packName

optional :: ([a] -> Doc n) -> [a] -> Doc n
optional :: forall a n. ([a] -> Doc n) -> [a] -> Doc n
optional [a] -> Doc n
_ [] = Doc n
""
optional [a] -> Doc n
f [a]
xs = Doc n
" " Doc n -> Doc n -> Doc n
forall a. Semigroup a => a -> a -> a
<> [a] -> Doc n
f [a]
xs