{-# OPTIONS_GHC -cpp -fglasgow-exts #-}

-- 
-- Copyright (C) 2005 Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

#ifdef ABSTRACT_SYNTAX
module Phrac.AbstractSyntax
#else
module Phrac.ParseSyntax 
#endif
where

import List (intersperse,lookup,intersect,deleteBy)
import qualified Data.Set as Set
import qualified Data.Generics as Gen

import Phrac.Builtins as Builtins
import Phrac.Pretty
import Phrac.Error
import Phrac.Substitution
import qualified Phrac.Map as Map

#ifdef ABSTRACT_SYNTAX
import qualified Phrac.UniqIdents as UniqIdents
#else
#endif

#ifdef ABSTRACT_SYNTAX
type TypeVarId = UniqIdents.TypeVarId
type TypeId = UniqIdents.TypeId
type ValId = UniqIdents.ValId
type DataId = UniqIdents.DataId
type ClassId = UniqIdents.ClassId
type AssocTypeId = UniqIdents.AssocTypeId

isPairTypeConstructor = UniqIdents.isPairTypeConstructor
isFunTypeConstructor = UniqIdents.isFunTypeConstructor

#else

type Id = String
type TypeVarId = Id
type TypeId = Id
type ValId = Id
type DataId = Id
type ClassId = Id
type AssocTypeId = Id

isPairTypeConstructor = (==) Builtins.pairTypeConstructor
isFunTypeConstructor = (==) Builtins.funTypeConstructor

#endif

data Info = Info { info_builtin    :: Bool,
                   info_toplevel   :: Bool  -- only relevant for bindings
                   -- more info to follow (line numbers etc.)
                 }
            deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

emptyInfo = Info { info_builtin = False,
                   info_toplevel = False }

data Program = Program { prog_typeDefs :: [TypeDef], 
                         prog_classes :: [ClassDec],
                         prog_instances :: [ClassInst],
                         prog_bindings :: [ValBind]
                       }
               deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data TypeDef   = TypeDef { tydef_name :: TypeId,
                           tydef_params :: [TypeVarId],
                           tydef_alts :: [DataConstructor],
                           tydef_info :: Info
                         }
                    deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data DataConstructor = DataConstructor { dconstr_name :: DataId,
                                         dconstr_params :: [Type] }
                    deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data ClassDec  = ClassDec { class_name :: ClassId,
                            class_params :: [TypeVarId],
                            class_constraints :: [ClassConstraint],
                            class_tsigs :: [AssocTypeSig],
                            class_vsigs :: [VSig],
                            class_info :: Info
                          }
                 deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data AssocTypeSig = AssocTypeSig { assocSig_name :: AssocTypeId,
                                   assocSig_params :: [TypeVarId],
                                   assocSig_fixed :: Maybe Type }
                 deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

type VSig = (ValId, TypeScheme)

data ClassInst = ClassInst { inst_class :: ClassId,
                             inst_types :: [Type],
                             inst_constraints :: [Constraint],
                             inst_typeBinds :: [AssocTypeBind],
                             inst_valBinds :: [ValBind],
                             inst_info :: Info
                           }
                 deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data AssocTypeStatus = AssocTypeNotAbstract | AssocTypeAbstract
                       deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data AssocTypeBind = AssocTypeBind { assocBind_name :: AssocTypeId,
                                     assocBind_indices :: [Type],
                                     assocBind_params :: [TypeVarId],
                                     assocBind_def :: Type,
                                     assocBind_status :: AssocTypeStatus
                                   }
                 deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

class Abstract a where
    isAbstract :: a -> Bool
    isConcrete :: a -> Bool
    isConcrete x = not $ isAbstract x

instance Abstract AssocTypeStatus where
    isAbstract AssocTypeNotAbstract = False
    isAbstract AssocTypeAbstract = True

instance Abstract AssocTypeBind where
    isAbstract atb = isAbstract (assocBind_status atb)

--
-- Constraints
--

data ClassConstraint = ClassConstraint { cc_name :: ClassId,
                                         cc_params :: [Type]
                                       }
                         deriving (Read, Show, Eq, Ord, Gen.Data, Gen.Typeable)

data EqConstraint = EqConstraint { eqc_left :: AssocType,
                                   eqc_right :: Type
                                 }
                    deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data EqualityDefinition = EqualityDefinition { eqd_quants     :: [TypeVarId],
                                               eqd_constraint :: EqConstraint 
                                             }
                    deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

-- simple constraint
data Constraint = CC ClassConstraint
                | EC EqConstraint
                  deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

classConstraints :: [Constraint] -> [ClassConstraint]
classConstraints [] = []
classConstraints (EC _ : rest) = classConstraints rest
classConstraints (CC c : rest) = c : classConstraints rest

eqConstraints :: [Constraint] -> [EqConstraint]
eqConstraints [] = []
eqConstraints (EC e : rest) = e : eqConstraints rest
eqConstraints (CC _ : rest) = eqConstraints rest

splitConstraints :: [Constraint] -> ([ClassConstraint], [EqConstraint])
splitConstraints [] = ([], [])
splitConstraints (x:xs) =
    let (cs,es) = splitConstraints xs
    in case x of
         EC e -> (cs, e:es)
         CC c -> (c:cs, es)

mergeConstraints :: [ClassConstraint] -> [EqConstraint] -> [Constraint]
mergeConstraints cs es = 
    map CC cs ++ map EC es

isClassConstraint :: Constraint -> Bool
isClassConstraint (CC _) = True
isClassConstraint _ = False

isEqConstraint :: Constraint -> Bool
isEqConstraint (EC _) = True
isEqConstraint _ = False


dumpClassConstraints :: [ClassConstraint] -> String
dumpClassConstraints cs = 
    "{ClassConstraints: " ++
    showCommaListed (map ppr cs)
    ++ "}"

dumpEqConstraints :: [EqConstraint] -> String
dumpEqConstraints es = 
    "{EqConstraints: " ++
    showCommaListed (map ppr es)
    ++ "}"

dumpConstraints :: [Constraint] -> String
dumpConstraints cs = 
    "{Constraints: " ++
    showCommaListed (map ppr cs)
    ++ "}"
    
{-
data QualifiedConstraint = QualifiedConstraint [Constraint] ClassConstraint
      deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data ConstraintScheme 
    = QScheme [TypeVarId] QualifiedConstraint
    | EqualityDefinition [TypeVarId] EqConstraint
      deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)
-}

--
-- Types & Kinds
--

data Kind = KindStar
          | KindFun Kind Kind
  deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

kindFun :: [Kind] -> Kind -> Kind
kindFun args result = 
    foldr KindFun result args

data Type
    = TyVar TypeVarId                       -- a type var
    | TyApp Type  Type                      -- application 
    | TyConstruct TypeId                    -- regular type constructor or
    | TyAssoc AssocType
  deriving (Read, Show, Eq, Ord, Gen.Data, Gen.Typeable)

data AssocType = AssocType { assoc_name :: AssocTypeId,
                             assoc_params :: [Type]
                           }
               deriving (Read, Show, Eq, Ord, Gen.Data, Gen.Typeable)


data QualifiedType = QualifiedType { qtype_context :: [Constraint],
                                     qtype_mono    :: Type }
  deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)

data TypeScheme  
    = TypeScheme { tyscheme_quants   :: [TypeVarId],
                   tyscheme_qtype    :: QualifiedType
                 }
  deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)


--
-- Useful operations on Types. Most of them are only needed for types of the
-- AbstractSyntax module, but we implement them here because we want to
-- apply some operations in ParseSyntax types as well.
--

isTypeVar :: Type -> Bool
isTypeVar (TyVar _) = True
isTypeVar _ = False

maybeTypeVar :: Monad m => Type -> m TypeVarId
maybeTypeVar (TyVar i) = return i
maybeTypeVar t = fail ("not a type variable: " ++ showPpr' t)

type TypeSubst = Subst TypeVarId Type

class Substitution TypeVarId Type a => Types a where
    freeTypeVars :: a -> Set.Set TypeVarId
    fixedTypeVars :: a -> Set.Set TypeVarId

instance Substitution TypeVarId Type Type where
    applySubst s t@(TyVar id) = 
        case substLookup id s of
          Just t' -> t'
          Nothing -> t
    applySubst s (TyApp t1 t2) = 
        TyApp (applySubst s t1) (applySubst s t2)
    applySubst s t@(TyConstruct _) = t
    applySubst s (TyAssoc t) = TyAssoc (applySubst s t)

instance Types Type where
    freeTypeVars t = 
        case t of
          TyVar i -> Set.singleton i
          TyApp t1 t2 -> Set.union (freeTypeVars t1) (freeTypeVars t2)
          TyConstruct _ -> Set.empty
          TyAssoc at -> freeTypeVars at
    fixedTypeVars t = 
        case t of
          TyVar i -> Set.singleton i
          TyApp t1 t2 -> Set.union (fixedTypeVars t1) (fixedTypeVars t2)
          TyConstruct _ -> Set.empty
          TyAssoc at -> fixedTypeVars at

instance Substitution TypeVarId Type AssocType where
    applySubst s (AssocType id ts) = AssocType id (applySubst s ts)

instance Types AssocType where
    freeTypeVars (AssocType _ ts) = 
        Set.unions (map freeTypeVars ts)
    fixedTypeVars (AssocType id ts) = 
        -- does not work with multiple parameters classes
        Set.unions (map fixedTypeVars (drop 1 ts))

instance Substitution TypeVarId Type QualifiedType where
    applySubst s (QualifiedType c t) = 
        QualifiedType (applySubst s c) (applySubst s t)

instance Types QualifiedType where
    freeTypeVars (QualifiedType c t) = 
        freeTypeVars c `Set.union` freeTypeVars t
    fixedTypeVars (QualifiedType c t) = 
        fixedTypeVars c `Set.union` fixedTypeVars t


instance Substitution TypeVarId Type TypeScheme where
    applySubst s (TypeScheme quant qt) =
        let s' = removeListFromSubst quant s
            in TypeScheme quant (applySubst s' qt)

instance Types TypeScheme where
    freeTypeVars (TypeScheme quant t) = 
        freeTypeVars t `Set.difference` (Set.fromList quant)
    fixedTypeVars (TypeScheme quant t) = 
        fixedTypeVars t `Set.difference` (Set.fromList quant)

instance Substitution TypeVarId Type EqualityDefinition where
    applySubst s (EqualityDefinition quant c) = 
        let s' = removeListFromSubst quant s
            in EqualityDefinition quant (applySubst s' c)

instance Types EqualityDefinition where
    freeTypeVars (EqualityDefinition quant c) = 
        freeTypeVars c `Set.difference` (Set.fromList quant)
    fixedTypeVars (EqualityDefinition quant c) = 
        fixedTypeVars c `Set.difference` (Set.fromList quant)
    
instance Substitution TypeVarId Type EqConstraint where
    applySubst s (EqConstraint t1 t2) = 
        EqConstraint (applySubst s t1) (applySubst s t2)

instance Types EqConstraint where
    freeTypeVars (EqConstraint t1 t2) =
        (freeTypeVars t1 `Set.union` freeTypeVars t2)
    fixedTypeVars (EqConstraint _ t2) = fixedTypeVars t2

instance Substitution TypeVarId Type ClassConstraint where
    applySubst s (ClassConstraint id t) = 
        ClassConstraint id (applySubst s t)

instance Types ClassConstraint where
    freeTypeVars (ClassConstraint _ t) = 
        freeTypeVars t
    fixedTypeVars (ClassConstraint _ _) = Set.empty

instance Substitution TypeVarId Type Constraint where
    applySubst s (CC cc) = CC $ applySubst s cc
    applySubst s (EC ec) = EC $ applySubst s ec

instance Types Constraint where
    freeTypeVars (CC cc) = freeTypeVars cc
    freeTypeVars (EC ec) = freeTypeVars ec
    fixedTypeVars (CC cc) = fixedTypeVars cc
    fixedTypeVars (EC ec) = fixedTypeVars ec

instance Types a => Types [a] where
    freeTypeVars l = Set.unions (map freeTypeVars l)
    fixedTypeVars l = Set.unions (map fixedTypeVars l)

instance Types a => Types (Map.Map k a) where
    freeTypeVars m = freeTypeVars (Map.elems m)
    fixedTypeVars m = fixedTypeVars (Map.elems m)

freeTypeVarsList t = Set.toList $ freeTypeVars t
fixedTypeVarsList t = Set.toList $ fixedTypeVars t

--
-- Expression
--

data Constant = Number Integer
              | Character Char
                deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) 
data Exp
    = Var ValId          -- variables
    | Const Constant

    | Prim Op [Exp]      -- primitive operations (always saturated)
    | Con DataId [Exp]   -- constructor (a function) (always saturated)

    | App Exp Exp                  -- application: e1 e2
    | Lam [Pat] Exp                -- abstraction: \x.e

    | If Exp Exp Exp

    | Letrec [ValBind] Exp  -- letrec a = e1 ; b = e2 ... in e3

    | Case Exp [Alt]   -- case e of a1 ; a2 .. aN

    -- only used internally
    | Error String                -- indicates a internal error (such as a 
                                  -- type-mismatch at runtime)
    | UserError ValId             -- used to implement the `error' function.
                                  -- the ValId is the identifier to which to
                                  -- error message is bound.
    | Overloading Overloading     -- for overloading resolution
  deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)

data ValBind = ValBind { vbind_name :: ValId,
                         vbind_type :: (Maybe TypeScheme),
                         vbind_pats :: [Pat],
                         vbind_exp :: Exp,
                         vbind_info :: Info
                       }
               deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)

data Alt = Alt { alt_pat :: Pat,
                 alt_exp :: Exp
               }
           deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)

data Pat = PVar ValId
         | PWildcard
         | PCon DataId [Pat]
         | PAs ValId Pat
           deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)
           
data Overloading = --
                   -- used only during transformation
                   --
                   -- Placeholder for a class constraint. Printed <C t1 .. tN>
                   Placeholder ClassConstraint

                   {- `MethodPlaceholder C m [t1, ..., tN]' represents a call of
                      method `m' in class `C'. The types specify which instance
                      of C should be selected. Printed <C::m: t1 .. tN> -}
                 | MethodPlaceholder ClassId  ValId [Type]

                   -- 
                   -- used at runtime
                   --
                 | Dictionary [(ValId, Method)]
                 | DictionaryReference ClassId [Type]    -- dict-C<t1 .. tN>
                 | DictionaryLookup ValId Exp            -- bar@(dict-expr)
                   deriving (Read,Show,Eq, Gen.Data, Gen.Typeable)

data Method = Method [(ValId, ValId)]  {- mapping from variable names used
                                          for dictionaries providing evidence
                                          for instance context constraints to
                                          variables names used in the method
                                          for these dictionaries. -}
                     Exp
            | SuperMethod ValId Exp
              deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) 

--
-- Pretty Printing
--

tyFunAppSpec = (RightAssoc, 2)
tyAppSpec = (LeftAssoc, 3)

instance Pretty Kind where
    pprPrec prec KindStar = text "*"
    pprPrec prec (KindFun k1 k2) =
        pprInfixOp prec tyFunAppSpec k1 (space <> text "->" <> space) k2

instance Pretty Type where
    pprPrec prec ty = case ty of
        TyVar t -> pprPrec prec t
        TyApp (TyApp (TyConstruct id) t1) t2 
            | isPairTypeConstructor id ->
                parens (pprPrec minPrec t1 <> comma <+>
                        pprPrec minPrec t2)
            | isFunTypeConstructor id ->
                pprInfixOp prec tyFunAppSpec t1 (space <> text "->" <> space) t2
        TyApp t1 t2 -> pprInfixOp prec tyAppSpec t1 space t2 
        TyConstruct id -> pprPrec prec id
        TyAssoc assoc -> pprPrec prec assoc

assocTypeSpec = tyAppSpec
instance Pretty AssocType where
    pprPrec prec (AssocType name params) = 
        foldl (\t1 t2 -> pprInfixOp prec assocTypeSpec t1 space t2)
              (ppr name)
              params


qualifiedTypeSpec = (NoAssoc, 0)
instance Pretty QualifiedType where
    pprPrec prec (QualifiedType constrs ty) = 
        if not (null constrs)
           then pprInfixOp prec qualifiedTypeSpec
                    (pprList ", " constrs)
                    (space <> text "=>" <> space)
                    ty
           else pprPrec prec ty

typeSchemeSpec = (NoAssoc, 0)
instance Pretty TypeScheme where
    pprPrec prec (TypeScheme vars qtype) = 
        if null vars 
           then pprPrec prec qtype
           else pprInfixOp prec typeSchemeSpec
                  (text "forall" <+> pprList " " vars) 
                  (space <> char '.' <> space)
                  qtype

instance Pretty Constraint where
    pprPrec prec (CC cc) = pprPrec prec cc
    pprPrec prec (EC ec) = pprPrec prec ec

eqConstraintSpec = (NoAssoc, 0)
instance Pretty EqConstraint where
    ppr (EqConstraint left right) = 
        pprInfixOp minPrec eqConstraintSpec left (space <> text "=" <> space)
                   right

instance Pretty EqualityDefinition where
    pprPrec prec (EqualityDefinition vars ec) =
        if null vars 
           then pprPrec prec ec
           else pprInfixOp prec eqConstraintSpec
                  (text "forall" <+> ppr vars) 
                  (space <> char '.' <> space)
                  ec

classConstraintSpec = (NoAssoc, 1)
instance Pretty ClassConstraint where 
    ppr (ClassConstraint name params) = 
        ppr name <+> pprList " " (map (pprPrec maxPrec) params)

instance Pretty ClassInst where
  ppr (ClassInst name tys constrs tyBind valBinds _) = 
    text "instance" <> 
    (if not $ null constrs
        then text " " <>
             parens (hsep (punctuate comma (map ppr constrs))) <+> text "=> " 
        else text " ")
    <> ppr name <+> pprList " " (map (pprPrec maxPrec) tys)
    <+> text "where" $$
    nest 4  (vcat ([ppr tyBind] ++ (map ppr valBinds)))

instance Pretty AssocTypeBind where
    ppr (AssocTypeBind name indices params def status) =
        (if isAbstract status then text "abstype" else text "type") <+>
        ppr name <+> pprList " " (map (pprPrec maxPrec) indices) 
        <+> hsep (map ppr params) <+> text "=" <+> ppr def

dataConstructorSpec = tyAppSpec
instance Pretty DataConstructor where
    pprPrec prec (DataConstructor name params) = 
        foldl (\t1 t2 -> pprInfixOp prec dataConstructorSpec t1 space t2)
              (ppr name) params

instance Pretty AssocTypeSig where
    ppr (AssocTypeSig id tyvars Nothing) = 
        text "type" <+> ppr id <+> hsep (map ppr tyvars)
    ppr (AssocTypeSig id tyvars (Just def)) = 
        text "type" <+> ppr id <+> hsep (map ppr tyvars) <+> text "+" <+> ppr def

instance Pretty VSig where
    ppr (id, ty) = ppr id <::> ppr ty

instance Pretty ClassDec where
    ppr (ClassDec name params constrs tsigs vsigs _) =
      text "class" <> 
      (if not $ null constrs 
          then text " " <> 
               parens (hsep (punctuate comma (map ppr constrs))) <+> text "=> " 
          else text " ")
      <> ppr name <+> pprList " " params <+> text "where" $$
      nest 4  (vcat (map ppr tsigs ++ map ppr vsigs))

instance Pretty TypeDef where
    ppr (TypeDef name params alts _) = 
        text "data" <+> ppr name <+> hsep (map ppr params) <+> text "=" $$
        if not (null alts)
           then nest 4 (vcat ([ppr (head alts)] ++
                              map (\a -> text "|" <+> ppr a) (tail alts)))
           else empty

instance Pretty Program where
    ppr (Program tydefs classDecs classInsts binds) = 
        vcat (map ppr tydefs ++ map ppr classDecs ++ map ppr classInsts
              ++ map ppr binds)

instance Pretty ValBind where
    ppr (ValBind x Nothing pats e _) = 
        ppr x <+> hsep (map ppr pats) <=> ppr e
    ppr (ValBind x (Just ty) pats e _) = 
        vcat [ppr x <::> ppr ty,
              ppr x <+> hsep (map ppr pats) <=> ppr e]

instance Pretty Alt where
    ppr (Alt pat e) = ppr pat <->> ppr e <> semi

instance Pretty Pat where
    ppr PWildcard = text "_"
    ppr (PVar id) = ppr id
    ppr (PAs id pat) = ppr id <> text "@" <> pprPrec maxPrec pat
    ppr (PCon id pats) = 
        parens `usedWhen` (not (null pats)) $
        hsep (ppr id : map ppr pats)
        
instance Pretty Constant where
    ppr (Number i)    = text (show i)
    ppr (Character c) = text (show c)

appSpec = (LeftAssoc, 9)

instance Pretty Exp where
    pprPrec _ (Var v)       = ppr v
    pprPrec prec (Const c)  = pprPrec prec c

    -- because of eta-expansion, es are variables and the whole (Con ...)
    -- expression is wrapped in a lambda
    pprPrec prec (Con id []) = ppr id
    pprPrec prec (Con id es) = 
        pprPrec prec (foldl App (Con id []) es)

    pprPrec prec (Prim op es) = 
        let opSpec@(assoc, opPrec) = specOfPrimOp op
            opStr = primOpToStr op
            arity = arityOfPrimOp op
            in if arity /= length es
                  then panic ("arity of primOp " ++ show op ++ " and length "
                              ++ "of argument list do not match")
                  else case arity of
                         1 -> parens `usedWhen` (prec > opPrec) $
                              text opStr <> pprPrec opPrec (es!!0)
                         2 -> let e1 = es!!0
                                  e2 = es!!1
                                  in pprInfixOp prec opSpec e1 
                                         (space <> text opStr <> space) e2
                         i -> panic ("unexpected arity " ++ show i ++ 
                                     "of primOp " ++ show op)

    pprPrec prec (App e1 e2) = 
        pprInfixOp prec appSpec e1 space e2

    pprPrec prec (Lam xs e) = 
        parens `usedWhen` (prec > minPrec) $
        if not (null xs) 
           then char '\\' <> (hsep (map (pprPrec maxPrec) xs)) <->> ppr e
           else pprPrec prec e

    pprPrec prec (If e e1 e2) =
        parens `usedWhen` (prec > minPrec) $
        hang (text "if" <+> ppr e) 
                 4 ( (text "then" <+> ppr e1) $$ 
                     (text "else" <+> ppr e2) )

    pprPrec prec (Letrec bs e) = 
        parens `usedWhen` (prec > minPrec) $
        text "let" $$ nest 4 
                 (vcat $ intersperse semi (map ppr bs)) $$
                 hang (text "in") 4 (ppr e)

    pprPrec prec (Case e alts) = 
        parens `usedWhen` (prec > minPrec) $
        text "case" <+> parens(ppr e) <+> text "of" $$ 
                            nest 4 (vcat $ (map ppr alts))

    pprPrec prec (Overloading o) = pprPrec prec o

instance Pretty Overloading where
    ppr (Placeholder c) = text "<" <> ppr c <> text ">"
    ppr (MethodPlaceholder cid mid vars) = 
        text "<" <> ppr cid <> text "::" <> ppr mid <> text ": " 
        <> pprList ", " vars <> text ">"
    ppr (DictionaryReference cid ts) = 
        text "dict-" <> ppr cid <> text "<" <> pprList ", " ts <> text ">"
    ppr (DictionaryLookup id e) = 
        ppr id <> text "@" <> parens (ppr e)
    ppr (Dictionary l) = 
        text "{dictionary" $$
        nest 4 (vcat (map (\ (n,m) -> ppr n <> text ":" <+> ppr m) l)) $$
        text "}"

instance Pretty Method where 
    ppr (Method l e) = 
        text "<" <> pprList ", " (map pprPair l) <> text "> " <> ppr e
    ppr (SuperMethod id e) =
        ppr id <> text "@" <> parens (ppr e)

showInstHead :: ClassInst -> String
showInstHead ci = 
    show (ppr (inst_class ci) <+> 
          pprList " " (map (pprPrec maxPrec) (inst_types ci)))

showClassHead :: ClassDec -> String
showClassHead cd = 
    show (ppr (class_name cd) <+> 
          pprList " " (map (pprPrec maxPrec) (class_params cd)))

-- splits a program into the builtin and the non-builtin part
splitProgram :: Program -> (Program, Program)
splitProgram (Program tydefs classes insts binds) = 
    let (t1,t2) = split tydef_info tydefs
        (c1,c2) = split class_info classes 
        (i1,i2) = split inst_info insts
        (b1,b2) = split vbind_info binds
        in (Program t1 c1 i1 b1, Program t2 c2 i2 b2)
    where
    split :: (a -> Info) -> [a] -> ([a], [a])
    split _ [] = ([], [])
    split f (x:xs) = 
        let (b,n) = split f xs
            in if info_builtin (f x) then (x:b, n) else (b, x:n)

mergeProgram :: Program -> Program -> Program
mergeProgram (Program ts1 cs1 is1 bs1) (Program ts2 cs2 is2 bs2) = 
    Program (ts1++ts2) (cs1++cs2) (is1++is2) (bs1++bs2)