TiPretty.hs

module TiPretty where
import TiTypes hiding (forall')
import TiNames
import TiKinds
import PrettyPrint
import SpecialNames
import PrettySymbols(forall',imp,el)
import Syntax(hsTyVar)
import HsDeclPretty(ppFunDeps,ppContext)
import MUtils(( # ),ifM)

instance (TypeId i,ValueId i)
      => Printable (Scheme i) where
  ppi (Forall [] [] qt) = ppi qt
  ppi (Forall aks vks qt@(_:=>t)) =
      ppIfUnicode (ppForall varnames) (ppForall asciinames)
    where
      ppForall names = sep [forall' <+> vs'' <+> ".",letNest qt'']
        where
          qt'' = ifM (debugInfo # getPPEnv) (ppi qt) (ppi qt')

          vs'' = ifM (debugInfo # getPPEnv) (asep (k vs)) (asep (k vs'))
	    where k vs = map ppKinded (zipTyped (vs:>:ks))
          vs' = map snd s
	  qt' = apply (S s) qt
	  s = [(v,hsTyVar (ltvar name) `asTypeOf` t) | (v,name) <- zip vs names]
	  vs:>:ks = unzipTyped (aks++vks) -- hmm
	  n = length aks
	  asep avs =
              if null as
	      then fsep vs
	      else braces (fsep as)<+>fsep vs
           where (as,vs) = splitAt n avs
      -- Infinite supplies of variables names:
      varnames = map single [alpha..omega]++asciinames
        where alpha='\x03b1'; omega='\x03c9'
      asciinames = map single letters++[a:show n|n<-[1..],a<-letters]
      single x = [x]
      letters = ['a'..'z']

ppKinded (x:>:k) = if k==kstar then ppi x else parens (x<>el<>k)

instance (IsSpecialName i,Printable i,Printable t)
      => Printable (Qual i t) where
  ppi ([]:=>t) = ppi t
  ppi (ps:=>t) = sep [ppiFTuple ps <+> imp, letNest t]

instance (Printable x,Printable t) => Printable (Typing x t) where
  ppi (x:>:t) = sep [wrap x <+> el,letNest t]
  ppiList xts = vcat xts

instance (ValueId i,TypeId i) => Printable (TypeInfo i) where
  ppi i =
      case i of
	Data -> ppi "data" -- <+> o
	Newtype -> ppi "newtype" -- <+> o
	Class super ps fundeps methods ->
	  "class" <+> sep [ppi (ppContext super<+>"_"<+>fsep (map ppKinded ps)),
			    ppFunDeps fundeps,
			    ppi "where", letNest methods]
	Synonym ps t -> 
	  "type" <+> appv (p:ps) <+> "=" <+> letNest t
	Tyvar -> ppi "type variable"
    where
      p =  localVal "_"
      appv = asType . appT . map tyvar

asType = id :: Type i -> Type i

instance (IsSpecialName i,Printable i) => Printable (Subst i) where
  ppi (S s) = ppi s