Printer.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Printer (
    ppFuncons, ppValues, ppTypes,
    showValues, showFuncons, showTypes,
    ) where

import Funcons.Types
import Funcons.RunOptions

import Data.List (intercalate)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.MultiSet as MS
import qualified Data.Vector as V
import qualified Data.BitVector as BV
import Data.Text (unpack)

-- | Pretty-print a 'Values'.
showValues :: Values -> String
showValues = ppValues defaultRunOptions 

-- | Pretty-print a 'Funcons'.
showFuncons :: Funcons -> String
showFuncons = ppFuncons defaultRunOptions

-- | Pretty-print a 'Types'. 
showTypes :: Types -> String
showTypes = ppTypes defaultRunOptions

ppFuncons :: RunOptions -> Funcons -> String
ppFuncons opts (FList fs)    = "[" ++ showArgs opts False fs ++ "]"
ppFuncons opts (FTuple fs)   = "(" ++ showArgs opts False fs ++ ")"
ppFuncons opts (FSet fs)     = "{" ++ showArgs opts False fs ++ "}"
ppFuncons opts (FMap fs)     = "{" ++ intercalate "," (map toKeyFValue fs) ++ "}"
 where  toKeyFValue (FTuple [k,v]) = ppFuncons opts k ++ " |-> " ++ ppFuncons opts v
        toKeyFValue _ = error "pretty-print map"
ppFuncons opts (FValue v)            = ppValues opts v
ppFuncons opts (FName nm)      = unpack nm
ppFuncons opts (FSortSeq f o)  = ppFuncons opts f ++ ppOp o  
ppFuncons opts (FSortUnion f1 f2) = "(" ++ ppFuncons opts f1 ++ "|" ++ ppFuncons opts f2 ++ ")"
ppFuncons opts (FSortComputes f) = "=>" ++ ppFuncons opts f
ppFuncons opts (FSortComputesFrom s t) = ppFuncons opts s ++ "=>" ++ ppFuncons opts t
-- some hard-coded funcons
ppFuncons opts (FApp "closure" (FTuple [x, y])) =
    let env | pp_full_environments opts = y
            | otherwise                 = string_ "..."
    in showFn opts "closure" [x, env]
ppFuncons opts (FApp "scope" (FTuple [x, y])) =
    let env | Prelude.not (pp_full_environments opts) && isMap x = string_ "..."
            | otherwise                                          = x
    in showFn opts "scope" [env, y]
ppFuncons opts (FApp nm f)     = unpack nm ++ ppFuncons opts f

ppValues :: RunOptions -> Values -> String
ppValues opts (ADTVal c []) = unpack c
ppValues opts (ADTVal c vs) = unpack c ++ showArgs opts True (map FValue vs) 
ppValues _ (Atom c)       = "atom("++ c ++")"
ppValues _ (Ascii c)      = "`" ++ [toEnum c] ++ "`"
ppValues _ (Bit i)        = "bits(" ++ show (BV.size i)
                                        ++ ", " ++ show (BV.int i) ++ ")"
ppValues _ (Char c)       = show c
ppValues _ (Float f)      = show f
-- rationals
ppValues _ (IEEE_Float_32 f) = show f
ppValues _ (IEEE_Float_64 d) = show d
ppValues _ (Rational r)   = show r
ppValues _ (Int f)        = show f
ppValues _ (Nat f)        = show f
ppValues opts (List vs)      =   if Prelude.null vs
                                then "[]"
                                else "[" ++ showArgs opts False (map FValue vs) ++ "]"
ppValues opts (Map m)        = if M.null m then "map-empty"
                               else "{" ++ key_values ++ "}"
 where key_values = intercalate ", " (map (\(k,v) -> ppValues opts k++" |-> "++ 
                                                     ppValues opts v)$ M.toList m)
ppValues opts (Multiset s) 
    | MS.size s == 0 = "{}"
    | otherwise = "{" ++ showArgs opts False (map FValue (MS.toList s)) ++ "}"
ppValues opts (Set s) 
    | S.size s == 0 = "{}"
    | otherwise =  "{" ++ showArgs opts False (map FValue (S.toList s)) ++ "}"
ppValues _ (String s)        = show s
ppValues opts (Thunk f)      = "thunk(" ++ ppFuncons opts f ++ ")"
ppValues opts EmptyTuple     = "()"
ppValues opts (NonEmptyTuple v1 v2 vs)   = showArgs opts True (map FValue (v1:v2:vs))
ppValues opts (Vector v) = showFn opts "vector" (map FValue (V.toList v))
ppValues opts (ComputationType ct) = ppComputationTypes opts ct

ppComputationTypes :: RunOptions -> ComputationTypes -> String
ppComputationTypes opts (Type t) = ppTypes opts t
ppComputationTypes opts (ComputesType ty) = "=>" ++ ppTypes opts ty
ppComputationTypes opts (ComputesFromType s t) = ppTypes opts s ++ "=>" ++ ppTypes opts t

ppTypes :: RunOptions -> Types -> String
ppTypes _ Atoms                     = "atoms"
ppTypes _ AsciiCharacters           = "ascii-characters"
ppTypes _ (BoundedIntegers m n)     = "bounded-integers(" ++ show m ++ ","++ show n ++ ")"
ppTypes _ ComputationTypes          = "computation-types"
ppTypes _ EmptyType                 = "empty-type"
ppTypes _ (UnicodeCharacters)       = "unicode-characters"
ppTypes _ (Integers)                = "integers"
ppTypes _ (Strings)                 = "strings"
ppTypes _ (Values)                  = "values"
ppTypes opts (Maps x y)             = showFn opts "maps" [type_ x, type_ y]
ppTypes _ Types                     = "types"
ppTypes _ ADTs                      = "algebraic-datatypes"
ppTypes opts (ADT nm ts)            = unpack nm ++ showArgs opts True (map (type_) ts)
ppTypes _ (Bits n)                  = "bits(" ++ show n ++ ")"
ppTypes _ (IEEEFloats format)       = "ieee-floats(" ++ show format ++ ")"
ppTypes opts (Lists ty)             = "lists(" ++ ppTypes opts ty ++ ")"
ppTypes opts (Multisets ty)         = showFn opts "multisets" [type_ ty]
ppTypes opts Naturals               = "naturals"
ppTypes opts Rationals              = "rationals"
ppTypes opts (Thunks ct)            = "thunks(" ++ ppComputationTypes opts ct ++ ")"
ppTypes opts (Sets ty)              = "sets(" ++ ppTypes opts ty ++ ")"
ppTypes opts (Vectors ty)           = "vectors(" ++ ppTypes opts ty ++ ")"
ppTypes opts (Tuples tys)           = "tuples(" ++ intercalate "," (map op tys) ++ ")"
    where op (ty, Nothing) = ppTypes opts ty
          op (ty, Just op) = ppTypes opts ty ++ ppOp op
ppTypes opts (Union ty1 ty2)        = "(" ++ ppTypes opts ty1 ++ "|" ++ ppTypes opts ty2 ++")"

ppOp :: SeqSortOp -> String
ppOp StarOp = "*"
ppOp PlusOp = "+"
ppOp QuestionMarkOp = "?"

{-
ppTerms :: FTerm -> String 
ppTerms (TApp nm ts) = unpack nm ++ ppTerms ts
ppTerms (TName nm)   = unpack nm
ppTerms (TVar var)   = var
ppTerms (TTuple ts)  = "(" ++ intercalate "," (map ppTerms ts) ++ ")"
ppTerms (TList ts)   = "[" ++ intercalate "," (map ppTerms ts) ++ "]"
ppTerms (TSet ts)    = "{" ++ intercalate "," (map ppTerms ts) ++ "}"
ppTerms (TMap ts)    = "map" ++ (ppTerms (TTuple ts))
ppTerms (TSortSeq term op) = ppTerms term ++ ppOp op
ppTerms (TSortUnion t1 t2) = ppTerms t1 ++ "|" ++ show t2
ppTerms (TSortComputes to) = "=>" ++ ppTerms to
ppTerms (TSortComputesFrom from to) = ppTerms from ++ "=>" ++ ppTerms to
ppTerms (TFuncon f)  = ppFuncons defaultRunOptions f
-}

-- helpers

showFn :: RunOptions -> String -> [Funcons] -> String
showFn opts n xs = n ++ showArgs opts True xs

showArgs :: RunOptions -> Bool -> [Funcons] -> String
showArgs opts b args | b         = "(" ++ seq ++ ")"
                     | otherwise = seq
 where seq = intercalate "," (map (ppFuncons opts) args)