-- |
-- Pretty printer for kinds
--
module Language.PureScript.Pretty.Kinds
  ( prettyPrintKind
  ) where

import Prelude.Compat

import Control.Arrow (ArrowPlus(..))
import Control.PatternArrows as PA

import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text)

import Language.PureScript.Crash
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Pretty.Common

typeLiterals :: Pattern () Kind Text
typeLiterals = mkPattern match
  where
  match (KUnknown u) =
    Just $ T.cons 'k' (T.pack (show u))
  match (NamedKind name) =
    Just $ if isQualifiedWith (moduleNameFromString "Prim") name
      then runProperName (disqualify name)
      else showQualified runProperName name
  match _ = Nothing

matchRow :: Pattern () Kind ((), Kind)
matchRow = mkPattern match
  where
  match (Row k) = Just ((), k)
  match _ = Nothing

funKind :: Pattern () Kind (Kind, Kind)
funKind = mkPattern match
  where
  match (FunKind arg ret) = Just (arg, ret)
  match _ = Nothing

-- | Generate a pretty-printed string representing a Kind
prettyPrintKind :: Kind -> Text
prettyPrintKind
  = fromMaybe (internalError "Incomplete pattern")
  . PA.pattern matchKind ()
  where
  matchKind :: Pattern () Kind Text
  matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parensT matchKind)

  operators :: OperatorTable () Kind Text
  operators =
    OperatorTable [ [ Wrap matchRow $ \_ k -> "# " <> k]
                  , [ AssocR funKind $ \arg ret -> arg <> " -> " <> ret ] ]