{-# 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 = forall n. Doc n -> HSDoc n
pack forall a b. (a -> b) -> a -> b
$ forall n. HSDoc n -> Doc n
rawDocument HSDoc n
a forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
rawDocument HSDoc n
op forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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 = forall n. Bool -> Doc n -> HSDoc n
HSDoc Bool
True forall a b. (a -> b) -> a -> b
$ forall n. HSDoc n -> Doc n
unpack HSDoc n
a forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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 = forall n. Bool -> Doc n -> HSDoc n
HSDoc Bool
True (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Doc n
b HSDoc n
a -> Doc n
b forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
unpack HSDoc n
a) (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 = forall a. a -> a
id
renderMaybe Bool
False = forall n. HSDoc n -> HSDoc n -> HSDoc n
(.<>) HSDoc n
"Maybe"

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

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

pack :: Doc n -> HSDoc n
pack :: forall n. Doc n -> HSDoc n
pack = 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
isComplex :: forall n. HSDoc n -> Bool
rawDocument :: Doc n
isComplex :: Bool
rawDocument :: forall n. HSDoc n -> Doc n
..} = if Bool
isComplex then 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 :: Doc n
isComplex :: Bool
isComplex :: forall n. HSDoc n -> Bool
rawDocument :: forall n. HSDoc n -> 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 = forall n. Doc n -> HSDoc n
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

instance Printer TypeRef where
  print :: forall ann. TypeRef -> HSDoc ann
print TypeRef {TypeWrapper
TypeName
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeConName :: TypeName
..} = forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
typeWrappers (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) = forall n. Bool -> HSDoc n -> HSDoc n
renderMaybe Bool
notNull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. HSDoc n -> HSDoc n
renderList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
wrapper
wrapped (BaseType Bool
notNull) = forall n. Bool -> HSDoc n -> HSDoc n
renderMaybe Bool
notNull

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

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

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

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

instance Printer TH.Name where
  print :: forall ann. Name -> HSDoc ann
print = forall a ann. Printer a => a -> HSDoc ann
print forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => a -> 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
" " forall a. Semigroup a => a -> a -> a
<> [a] -> Doc n
f [a]
xs