content: --
  -- Adapted from the program "infer", believed to have been originally
  -- authored by Philip Wadler, and used in the nofib benchmark suite
  -- since at least the late 90s.
  --
  
  module Type
         (TVarId, TConId,
          MonoType (TVar, TCon), arrow, intType,
          PolyType (All),
          freeTVarMono, freeTVarPoly)
         where
  
  import Shows
  import MyList
  import Data.List(nub)--1.3
  import Control.DeepSeq
  
  type  TVarId          =  String
  type  TConId          =  String
  data  MonoType        =  TVar TVarId
                        |  TCon TConId [MonoType]
  
  instance NFData MonoType where
    rnf (TVar s) = head s `seq` ()
    rnf (TCon c ts) = rnf ts `seq` head c `seq` ()
  
  data  PolyType        =  All [TVarId] MonoType
  u `arrow` v           =  TCon "->" [u,v]
  infixr 5 `arrow`
  
  intType               = TCon "Int" []
  
  freeTVarMono                  :: MonoType -> [TVarId]
  freeTVarMono (TVar x)         =  [x]
  freeTVarMono (TCon k ts)      =  concat (map freeTVarMono ts)
  freeTVarPoly                  :: PolyType -> [TVarId]
  freeTVarPoly (All xs t)       =  nub (freeTVarMono t) `minus` xs
  
  -- WDP: too bad deriving doesn't work
  instance Eq MonoType where
      (TVar tv1)       == (TVar tv2)	 = tv1 == tv2
      (TCon tc1 args1) == (TCon tc2 args2) = tc1 == tc2 && (args1 == args2)
      other1	     == other2		 = False
  -- end of too bad
  
  instance  Show MonoType  where
        showsPrec d     =  showsMono d
  
  instance NFData PolyType where
    rnf (All tvs t) = rnf tvs `seq` rnf t
  
  showsMono             :: Int -> Shows MonoType
  showsMono d (TVar xx)
        =  showsString xx
  showsMono d (TCon "->" [uu,vv])
        =  showsParenIf (d>1)
           (showsMono 2 uu . showsString " -> " . showsMono 1 vv)
  showsMono d (TCon kk tts)
        =  showsParenIf (d>9)
           (showsString kk .
            showsStar (\tt -> showsString " " . showsMono 10 tt) tts)
  
  instance  Show PolyType  where
        showsPrec d (All xs t)  =  showsString "All " . showsString (unwords xs) .
                                   showsString ". " . showsMono 0 t
  polyFromMono          :: MonoType -> PolyType
  polyFromMono t        =  All (nub (freeTVarMono t)) t
  