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