Pretty.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
module Data.API.Tools.PureScript.Pretty where

import           Data.String.Conv
import qualified Data.Text as T
import qualified Language.PureScript.AST.Declarations as PS
import qualified Language.PureScript.Environment as PS
import qualified Language.PureScript.Kinds as PS
import qualified Language.PureScript.Names as PS
import qualified Language.PureScript.Pretty as PS
import qualified Language.PureScript.Pretty.Types as PS
import qualified Language.PureScript.Types as PS
import           Text.PrettyPrint.Boxes as Box

--------------------------------------------------------------------------------
-- | Pretty-print only a subset of a `Declaration`, useful to pretty print the
-- subset of the AST we are interested in.
prettyPrintDeclaration :: PS.Declaration -> Box
prettyPrintDeclaration (PS.DataDeclaration dt tn typeParams decl) =
  dataDeclTypeAsBox dt <> text " "
                       <> text (PS.runProperName tn)
                       <> typeParamsAsBox typeParams
                       <+> typeDeclAsBox decl
prettyPrintDeclaration (PS.TypeSynonymDeclaration tn typeParams aliasType) =
  text "type " <> text (PS.runProperName tn)
               <> typeParamsAsBox typeParams
               <> text " = "
               <> PS.typeAsBox aliasType
prettyPrintDeclaration (PS.TypeInstanceDeclaration (PS.Ident ident) _ className [theType] PS.DerivedInstance) =
  text "derive instance" <+> text ident <+> "::" <+> text (PS.runProperName (PS.disqualify className)) <+> PS.typeAsBox theType
prettyPrintDeclaration (PS.TypeInstanceDeclaration (PS.Ident ident) _ className [theType] (PS.ExplicitInstance [decl])) =
  Box.vsep 0 Box.top [ text "instance" <+> text ident <+> "::" <+> text (PS.runProperName (PS.disqualify className)) <+> PS.typeAsBox theType <+> "where"
                     , text " " <+> prettyPrintDeclaration decl
                     ]
prettyPrintDeclaration (PS.ValueDeclaration ident _ [] (Right val)) =
 text (PS.showIdent ident ++ " = ") <> PS.prettyPrintValue maxBound val
prettyPrintDeclaration _ = error "Unsupported, sorry."

--------------------------------------------------------------------------------
typeParamsAsBox :: [(String, Maybe PS.Kind)] -> Box
typeParamsAsBox = text . toS . T.intercalate " " . map (toS . fst)

--------------------------------------------------------------------------------
dataDeclTypeAsBox :: PS.DataDeclType -> Box
dataDeclTypeAsBox = text . PS.showDataDeclType

--------------------------------------------------------------------------------
typeDeclAsBox :: [(PS.ProperName 'PS.ConstructorName, [PS.Type])] -> Box
typeDeclAsBox []     = text ""
typeDeclAsBox (x:xs) = Box.vsep 0 Box.top ((text "=" <+> toBox x) : map (\v -> text "|" <+> toBox v) xs)
  where
    toBox :: (PS.ProperName 'PS.ConstructorName, [PS.Type]) -> Box
    toBox (cn, types) =
      let ctor = text (PS.runProperName cn)
          in case types of
               [] -> ctor
               l -> ctor <+> Box.vsep 4 Box.top (map recordAsBox l)

--------------------------------------------------------------------------------
-- | Exploit the native PureScript `typeAsBox`, but with some extra changes to
-- ensure we display record brackets.
recordAsBox :: PS.Type -> Box
recordAsBox (PS.TypeApp _ t@PS.RCons{}) =
  let (fields, _) = PS.rowToList t
  in Box.vsep 0 Box.top (text "{" : mapped fields)
  where
    mapped f  = case f of
      [] -> [text "}"]
      (fn,ty):xs -> (text "  " <> text fn <+> text "::" <+> PS.typeAsBox ty) : go xs

    go [] = [text "}"]
    go ((fn,ty):xs) = (text "," <+> text fn <+> text "::" <+> PS.typeAsBox ty) : go xs
recordAsBox t = PS.typeAsBox t