module Type
       (TVarId, TConId,
        MonoType (TVar, TCon), arrow,
        PolyType (All),
        freeTVarMono, freeTVarPoly)
       where

import Parse
import Shows
import MyList
import List(nub)--1.3

type  TVarId          =  String
type  TConId          =  String
data  MonoType        =  TVar TVarId
                      |  TCon TConId [MonoType]
--ToDo:               deriving (Eq)

data  PolyType        =  All [TVarId] MonoType
u `arrow` v           =  TCon "->" [u,v]
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  Read MonoType  where
      readsPrec d     =  readsMono d
instance  Show MonoType  where
      showsPrec d     =  showsMono d

readsMono             :: Int -> Parses MonoType
readsMono d           =       ((d<=1) `guardP` readsArrow)
                      `elseP` ((d<=9) `guardP` readsTCon)
                      `elseP` (readsTVar)
                      `elseP` (parenP (readsMono 0))

readsArrow            :: Parses MonoType
readsArrow            =  readsMono 2          `thenP` (\u ->
                         lexP "->"            `thenP` (\_ ->
                         readsMono 1          `thenP` (\v ->
                                              returnP (u `arrow` v))))
readsTCon             :: Parses MonoType
readsTCon             =  readsTConId          `thenP` (\k  ->
                         starP (readsMono 10) `thenP` (\ts ->
                                              returnP (TCon k ts)))
readsTVar             :: Parses MonoType
readsTVar             =  readsTVarId          `thenP` (\x ->
                                              returnP (TVar x))
readsTVarId           :: Parses String
readsTVarId           =  lexicalP (lowerP `consP` starP alphaP)
readsTConId           :: Parses String
readsTConId           =  lexicalP (upperP `consP` starP alphaP)
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  Read PolyType  where
      readsPrec d             =  reads `eachP` polyFromMono
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