{-# LANGUAGE CPP #-}
module Scheme(Scheme(..), quantify, toScheme) where

#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
import Prelude hiding ((<>))
#endif

import CType
import Type
import Subst
import Pred
import PFPrint
import Position(noPosition, HasPosition(..))
import Eval

-- a scheme is a (possibly qualified) type polymorphic over some type variables
-- referred to as TGen n (where n is the index in the [Kind] list)
data Scheme = Forall [Kind] (Qual Type)
              deriving (Eq, Show)

instance PPrint Scheme where
  pPrint d p (Forall ks qt) = pparen (p>0) $
    foldr (\ (t,k) r -> text "/\\ (" <> pPrint d 0 t <+> text "::" <+> pPrint d 0 k <> text ") ." <+> r) (pPrint d 0 qt)
    (zip (map (TGen noPosition) [0..]) ks)

instance PVPrint Scheme where
  pvPrint d p (Forall ks qt) = pparen (p>0) $
    foldr (\ (t,k) r -> text "/\\ (" <> pPrint d 0 t <+> text "::" <+> pPrint d 0 k <> text ") ." <+> r) (pvPrint d 0 qt)
    (zip (map (TGen noPosition) [0..]) ks)

instance Types Scheme where
    apSub s (Forall ks qt) = Forall ks (apSub s qt)
    tv      (Forall ks qt) = tv qt

instance Hyper Scheme where
    hyper (Forall ks qt) y = hyper2 ks qt y

-- turn a qualified type (qt) into a scheme over some type variables (vs)
-- the reverse of quantify is inst (q.v.)
quantify :: [TyVar] -> Qual Type -> Scheme
quantify vs qt@(ps :=> t) =
        Forall ks (apSub s qt)
  where vs' = [ v | v <- tv qt, v `elem` vs ]
        ks  = map kind vs'
        s   = mkSubst (zipWith (\ v n -> (v, TGen (getPosition v) n)) vs' [0..])

-- turn an unqualified type (t) into a type scheme over no variables
toScheme :: Type -> Scheme
toScheme t = Forall [] ([] :=> t)