1 module Type
    2        (TVarId, TConId,
    3         MonoType (TVar, TCon), arrow,
    4         PolyType (All),
    5         freeTVarMono, freeTVarPoly)
    6        where
    7 
    8 import Parse
    9 import Shows
   10 import MyList
   11 import List(nub)--1.3
   12 
   13 type  TVarId          =  String
   14 type  TConId          =  String
   15 data  MonoType        =  TVar TVarId
   16                       |  TCon TConId [MonoType]
   17 --ToDo:               deriving (Eq)
   18 
   19 data  PolyType        =  All [TVarId] MonoType
   20 u `arrow` v           =  TCon "->" [u,v]
   21 freeTVarMono                  :: MonoType -> [TVarId]
   22 freeTVarMono (TVar x)         =  [x]
   23 freeTVarMono (TCon k ts)      =  concat (map freeTVarMono ts)
   24 freeTVarPoly                  :: PolyType -> [TVarId]
   25 freeTVarPoly (All xs t)       =  nub (freeTVarMono t) `minus` xs
   26 
   27 -- WDP: too bad deriving doesn't work
   28 instance Eq MonoType where
   29     (TVar tv1)       == (TVar tv2)       = tv1 == tv2
   30     (TCon tc1 args1) == (TCon tc2 args2) = tc1 == tc2 && (args1 == args2)
   31     other1           == other2              = False
   32 -- end of too bad
   33 
   34 instance  Read MonoType  where
   35       readsPrec d     =  readsMono d
   36 instance  Show MonoType  where
   37       showsPrec d     =  showsMono d
   38 
   39 readsMono             :: Int -> Parses MonoType
   40 readsMono d           =       ((d<=1) `guardP` readsArrow)
   41                       `elseP` ((d<=9) `guardP` readsTCon)
   42                       `elseP` (readsTVar)
   43                       `elseP` (parenP (readsMono 0))
   44 
   45 readsArrow            :: Parses MonoType
   46 readsArrow            =  readsMono 2          `thenP` (\u ->
   47                          lexP "->"            `thenP` (\_ ->
   48                          readsMono 1          `thenP` (\v ->
   49                                               returnP (u `arrow` v))))
   50 readsTCon             :: Parses MonoType
   51 readsTCon             =  readsTConId          `thenP` (\k  ->
   52                          starP (readsMono 10) `thenP` (\ts ->
   53                                               returnP (TCon k ts)))
   54 readsTVar             :: Parses MonoType
   55 readsTVar             =  readsTVarId          `thenP` (\x ->
   56                                               returnP (TVar x))
   57 readsTVarId           :: Parses String
   58 readsTVarId           =  lexicalP (lowerP `consP` starP alphaP)
   59 readsTConId           :: Parses String
   60 readsTConId           =  lexicalP (upperP `consP` starP alphaP)
   61 showsMono             :: Int -> Shows MonoType
   62 showsMono d (TVar xx)
   63       =  showsString xx
   64 showsMono d (TCon "->" [uu,vv])
   65       =  showsParenIf (d>1)
   66          (showsMono 2 uu . showsString " -> " . showsMono 1 vv)
   67 showsMono d (TCon kk tts)
   68       =  showsParenIf (d>9)
   69          (showsString kk .
   70           showsStar (\tt -> showsString " " . showsMono 10 tt) tts)
   71 instance  Read PolyType  where
   72       readsPrec d             =  reads `eachP` polyFromMono
   73 instance  Show PolyType  where
   74       showsPrec d (All xs t)  =  showsString "All " . showsString (unwords xs) .
   75                                  showsString ". " . showsMono 0 t
   76 polyFromMono          :: MonoType -> PolyType
   77 polyFromMono t        =  All (nub (freeTVarMono t)) t