Printer.hs

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

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

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

infix' :: HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' a op b = pack $ rawDocument a <+> rawDocument op <+> rawDocument b

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

apply :: Name t -> [HSDoc n] -> HSDoc n
apply name xs = HSDoc True (foldl' (\b a -> b <+> unpack a) (print' name) xs)

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

renderList :: HSDoc n -> HSDoc n
renderList = pack . list . pure . rawDocument

print' :: Printer a => a -> Doc n
print' = unpack . print

pack :: Doc n -> HSDoc n
pack = HSDoc False

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

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

data HSDoc n = HSDoc
  { isComplex :: Bool,
    rawDocument :: Doc n
  }

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

instance IsString (HSDoc n) where
  fromString = pack . pretty

instance Printer TypeRef where
  print TypeRef {..} = wrapped typeWrappers (print typeConName)

wrapped :: TypeWrapper -> HSDoc n -> HSDoc n
wrapped (TypeList wrapper notNull) = renderMaybe notNull . renderList . wrapped wrapper
wrapped (BaseType notNull) = renderMaybe notNull

instance Printer (Name t) where
  print = pack . pretty . T.unpack . unpackName

instance Printer Text where
  print = pack . pretty

instance Printer String where
  print = pack . pretty

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

renderExtension :: Text -> Doc ann
renderExtension name = "{-#" <+> "LANGUAGE" <+> pretty name <+> "#-}"

renderImport :: (Text, [Text]) -> Doc ann
renderImport (src, ls) = "import" <+> pretty src <> renderImportList ls

renderImportList :: [Text] -> Doc ann
renderImportList ["*"] = ""
renderImportList xs = tupled (map pretty xs)