Delta-Lambda-0.3.0.0: source/Printer.hs

module Printer where

import           AST

import           Text.PrettyPrint.Leijen hiding ((<$>))

import           Control.Parallel

prettyKind :: Show v => Kind m v i -> Doc
prettyKind kind =
  case kind of
    Kind _ -> text "kind"
    Function variable _ parameter body ->
      let (args, bod) = collectAbstr [(variable, parameter)] body
          argsDoc = list $ fmap (\(n, t) -> text (show n) <> colon <+> prettyTerm t) args
          funDoc = argsDoc `par` prettyKind bod

          collectAbstr args' (Function v _ t b) = collectAbstr (args' ++ [(v, t)]) b
          collectAbstr args' fun = (args', fun)
      in argsDoc </> funDoc

prettyTerm :: Show v => Term m v i -> Doc
prettyTerm term' =
  case term' of
    Type _ -> text "type"
    Variable variable _ _ -> text $ show variable
    Application _ arg fun ->
      let (args, fun') = collectApply [arg] fun
          argsDoc = tupled $ map prettyTerm args
          funDoc = argsDoc `par` prettyTerm fun'

          collectApply args' (Application _ arg' fun'') = collectApply (args' ++ [arg']) fun''
          collectApply args' fun'' = (args', fun'')
      in argsDoc </> funDoc
    Abstraction var _ typ bod ->
      let (args, bod') = collectAbstr [(var, typ)] bod
          argsDoc = list $ fmap (\(n, t) -> text (show n) <> colon <+> prettyTerm t) args
          funDoc = argsDoc `par` prettyTerm bod'

          collectAbstr args' (Abstraction v _ t b) = collectAbstr (args' ++ [(v, t)]) b
          collectAbstr args' fun = (args', fun)
      in argsDoc </> funDoc

instance Show v =>
         Show (Term m v i) where
  showsPrec _ term' = displayS $ renderPretty 0.4 100 $ prettyTerm term'

instance Show v =>
         Show (Kind m v i) where
  showsPrec _ kind = displayS $ renderPretty 0.4 100 $ prettyKind kind

instance (Show v) =>
         Show (PseudoTerm m v i) where
  show p =
    case p of
      Term t  -> show t
      Kind' k -> show k