--
-- 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