[get rid of old type printing code, clean up some front end stuff
John Meacham <john@repetae.net>**20060407115653] hunk ./FrontEnd/KindInfer.hs 40
-import Representation hiding (Subst)
+import Representation
hunk ./FrontEnd/Representation.hs 26
-    Subst,
hunk ./FrontEnd/Representation.hs 30
+    prettyPrintType,
+    fromTAp,
+    fromTArrow,
hunk ./FrontEnd/Representation.hs 55
+import Support.Unparse
+import Util.VarName
hunk ./FrontEnd/Representation.hs 154
--- pretty printing for types etc:
-
---instance PPrint a Type where
---  pprint t = fst $ runVarName [] nameSupply $ prettyPrintTypeM t
-
--- the trickery is to map TVars and TGens into nice
--- variable names: a, b, c, d, and so on when we print them
-
-prettyPrintTypeM :: Type -> VarName Doc
-prettyPrintTypeM t
-   = case t of
-           TVar (Tyvar { tyvarName = tv }) -> do
-                            findResult <- lookupInMap t
-                            case findResult of
-                               Nothing -> do nm <- nextName
-                                             updateVMap (t, nm)
-                                             return (text nm)
-                               --Just v  -> return $ text v
-                               Just v  -> return $ text v <> tyvar (text (show tv))
-           TCon tycon -> return $ pprint tycon
-           -- check for the Prelude.[] special case
-           TAp t1 t2  -> do case tList == t1 of
-                               True  -> do doc  <- prettyPrintTypeM t2
-                                           return $ brackets doc
-                               False -> do doc1 <- prettyPrintTypeM t1
-                                           doc2 <- maybeParensAp t2
-                                           return $ doc1 <+> doc2
-           TArrow t1 t2 -> do doc1 <- maybeParensArrow t1
-                              doc2 <- prettyPrintTypeM t2
-                              return $ doc1 <> text " -> " <> doc2
-           TForAll vs t  -> do
-            r <- prettyPrintQualTypeM t
-            return $ text "(forall" <+> hsep (map pprint vs) <> text " . " <> r <> text ")"
-           TExists vs t  -> do
-            r <- prettyPrintQualTypeM t
-            return $ text "(exists" <+> hsep (map pprint vs) <> text " . " <> r <> text ")"
-    where
-    -- puts parentheses around the doc for a type if needed
-    maybeParensAp :: Type -> VarName Doc
-    maybeParensAp t
-       = do case t of
-               TAp t1 _   -> do case tList == t1 of
-                                   True  -> prettyPrintTypeM t
-                                   False -> do doc <- prettyPrintTypeM t
-                                               return $ parens doc
-               _anything  -> maybeParensArrow t
-    maybeParensArrow :: Type -> VarName Doc
-    maybeParensArrow t
-       = do case t of
-               TArrow {} -> do doc <- prettyPrintTypeM t
-                               return $ parens doc
-               _  -> prettyPrintTypeM t
-    tyvar d = if dump FD.Tyvar then parens d else empty
-
-
hunk ./FrontEnd/Representation.hs 179
-   pprint (Kfun Star Star) = text "* -> *"
-   pprint (Kfun k1   Star) = text "(" <> pprint k1 <> text ")" <> text " -> *"
hunk ./FrontEnd/Representation.hs 180
+   pprint (Kfun k1   Star) = text "(" <> pprint k1 <> text ")" <> text " -> *"
hunk ./FrontEnd/Representation.hs 201
-instance PPrint Doc Pred where
-  -- pprint (IsIn c t) = pprint c <+> pprint t
-  pprint pred
-     = fst $ runVarName [] nameSupply $ prettyPrintPredM pred
-
-prettyPrintPredM :: Pred -> VarName Doc
-prettyPrintPredM (IsIn c t)
-   = do typeDoc <- prettyPrintTypeM t
-        return $ pprint c <+> typeDoc
-
hunk ./FrontEnd/Representation.hs 206
-prettyPrintQualPredM :: Qual Pred -> VarName Doc
-prettyPrintQualPredM (preds :=> pred)
-   = do case preds of
-           []            -> prettyPrintPredM pred
-           [p]           -> do leftPredDoc  <- prettyPrintPredM p
-                               rightPredDoc <- prettyPrintPredM pred
-                               return $ hsep [leftPredDoc, text "=>", rightPredDoc]
-           preds@(_:_:_) -> do docs <- mapM prettyPrintPredM preds
-                               let predsDoc = parens (hcat (punctuate comma docs))
-                               rightPredDoc <- prettyPrintPredM pred
-                               return $ hsep [predsDoc, text "=>", rightPredDoc]
-
-
-
--- special case for qualified types
-prettyPrintQualTypeM :: Qual Type -> VarName Doc
-prettyPrintQualTypeM (preds :=> t)
-   = do case preds of
-           []            -> prettyPrintTypeM t
-           [p]           -> do predDoc <- prettyPrintPredM p
-                               typeDoc <- prettyPrintTypeM t
-                               return $ hsep [predDoc, text "=>", typeDoc]
-           preds@(_:_:_) -> do docs <- mapM prettyPrintPredM preds
-                               let predsDoc = parens (hcat (punctuate comma docs))
-                               typeDoc <- prettyPrintTypeM t
-                               return $ hsep [predsDoc, text "=>", typeDoc]
hunk ./FrontEnd/Representation.hs 207
--- Class
-type Class = Name
-
---instance PPrint Doc t => PPrint Doc (Qual t) where
---  pprint (ps :=> t) = pptuple ps <+> text "=>" <+> pprint t
-
-instance PPrint Doc (Qual Pred) where
-    pprint inst = fst $ runVarName [] nameSupply $ prettyPrintQualPredM inst
-
-instance PPrint Doc (Qual Type) where
-    pprint inst = fst $ runVarName [] nameSupply $ prettyPrintQualTypeM inst
-
---prettyPrintInst :: Inst -> Doc
---prettyPrintInst inst
---   = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualPredM inst
-
---------------------------------------------------------------------------------
-
--- substitutions
-
-type Subst = Map.Map Tyvar Type
+instance (DocLike d,PPrint d t) => PPrint d (Qual t) where
+    pprint ([] :=> r) = pprint r
+    pprint ([x] :=> r) = pprint x <+> text "=>" <+> pprint r
+    pprint (xs :=> r) = tupled (map pprint xs) <+> text "=>" <+> pprint r
hunk ./FrontEnd/Representation.hs 212
---------------------------------------------------------------------------------
hunk ./FrontEnd/Representation.hs 219
+type Class = Name
hunk ./FrontEnd/Representation.hs 227
---------------------------------------------------------------------------------
-
--- a monad for matching type variables with nice names for pretty printing
-
-newtype VarName a = VarName (State -> (a, State))  deriving(Typeable)
-
-type VMap = [(Type, String)]  -- maps type (vars) to strings
-type NameSupply = [String]    -- a fresh name supply
-
-data State = State {
-      vmap  :: VMap,       -- the map of variables to names
-      names :: NameSupply  -- a fresh name Supply
-   } deriving(Typeable)
-
-instance Monad VarName where
-    return a
-        = VarName (\state -> (a, state))
-    VarName comp >>= fun
-        = VarName (\state -> let (result, newState) = comp state
-                                 VarName comp' = fun result
-                             in comp' newState)
-
-runVarName :: VMap -> NameSupply -> VarName a -> (a, State)
-runVarName varMap nameSupp (VarName comp)
-   = (result, newState)
-   where
-   (result,newState)
-      = comp (State {vmap  = varMap,
-                     names = nameSupp})
-
-select :: (State -> a) -> VarName a
-select selector = VarName (\state -> (selector state, state))
-
-getVMap :: VarName VMap
-getVMap = select vmap
-
-updateVMap :: (Type, String) -> VarName ()
-updateVMap newEntry
-   = VarName (\state -> let oldmap = vmap state
-                        in ((), state {vmap = newEntry : oldmap}))
-
-nextName :: VarName String
-nextName
-   = VarName (\state -> let (nn:rns) = names state
-                        in (nn, state {names = rns}))
-
-lookupInMap :: Type -> VarName (Maybe String)
-lookupInMap t = do
-    m <- getVMap
-    return $ lookup t m
-
-
hunk ./FrontEnd/Representation.hs 232
-            --put_ bh ad
hunk ./FrontEnd/Representation.hs 236
-    --ad <- get bh
-    --ad <- newIORef Nothing
hunk ./FrontEnd/Representation.hs 238
--- an infinite list of alphabetic strings in the usual order
-nameSupply :: [String]
-nameSupply = [ x++[y] | x <- []:nameSupply, y <- ['a'..'z'] ]
hunk ./FrontEnd/Representation.hs 262
+instance DocLike d => PPrint d Type where
+    pprint = prettyPrintType
+
+prettyPrintType :: DocLike d => Type -> d
+prettyPrintType t  = unparse $ runVarName (f t) where
+    arr = bop (R,0) (space <> text "->" <> space)
+    app = bop (L,100) (text " ")
+    fp (IsIn cn t) = do
+        t' <- f t
+        return (atom (text $ show cn) `app` t')
+    f (TForAll [] ([] :=> t)) = f t
+    f (TForAll vs (ps :=> t)) = do
+        ts' <- mapM (newLookupName ['a'..] ()) vs
+        t' <- f t
+        ps' <- mapM fp ps
+        return $ case ps' of
+            [] ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ")  (atomize t')
+            [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')
+            ps ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')
+    f (TExists [] ([] :=> t)) = f t
+    f (TExists vs (ps :=> t)) = do
+        ts' <- mapM (newLookupName ['a'..] ()) vs
+        t' <- f t
+        ps' <- mapM fp ps
+        return $ case ps' of
+            [] ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text ". ")  (atomize t')
+            [p] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')
+            ps ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')
+    f (TCon tycon) = return $ atom (pprint tycon)
+    f (TVar tyvar) = do
+        vo <- maybeLookupName tyvar
+        case vo of
+            Just c  -> return $ atom $ char c
+            Nothing -> return $ atom $ tshow (tyvarAtom tyvar)
+    f (TAp (TCon (Tycon n _)) x) | n == tc_List = do
+        x <- f x
+        return $ atom (char '[' <> unparse x <> char ']')
+    f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do
+        xs <- mapM f xs
+        return $ atom (tupled (map unparse xs))
+    f (TAp t1 t2) = do
+        t1 <- f t1
+        t2 <- f t2
+        return $ t1 `app` t2
+    f (TArrow t1 t2) = do
+        t1 <- f t1
+        t2 <- f t2
+        return $ t1 `arr` t2
+    f (TMetaVar mv) = return $ atom $ pprint mv
+    f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv)
+
+
+instance DocLike d => PPrint d MetaVarType where
+    pprint  t = case t of
+        Tau -> char 't'
+        Rho -> char 'r'
+        Sigma -> char 's'
+
+
+
+instance DocLike d => PPrint d Pred where
+    pprint (IsIn c t) = text (show c) <+> prettyPrintType t
+
+instance DocLike d => PPrint d MetaVar where
+    pprint MetaVar { metaUniq = u, metaKind = k, metaType = t }
+        | Star <- k =  pprint t <> tshow u
+        | otherwise = parens $ pprint t <> tshow u <> text " :: " <> pprint k
+
+fromTAp t = f t [] where
+    f (TAp a b) rs = f a (b:rs)
+    f t rs = (t,rs)
+
+fromTArrow t = f t [] where
+    f (TArrow a b) rs = f b (a:rs)
+    f t rs = (reverse rs,t)
+
hunk ./FrontEnd/Tc/Monad.hs 77
+import Type()
hunk ./FrontEnd/Tc/Type.hs 13
+    fromTAp,
+    fromTArrow,
hunk ./FrontEnd/Tc/Type.hs 16
+    prettyPrintType,
hunk ./FrontEnd/Tc/Type.hs 35
-import Support.Unparse
-import Type(HasKind(..))
-import Util.VarName
hunk ./FrontEnd/Tc/Type.hs 91
-fromTAp t = f t [] where
-    f (TAp a b) rs = f a (b:rs)
-    f t rs = (t,rs)
-
-fromTArrow t = f t [] where
-    f (TArrow a b) rs = f b (a:rs)
-    f t rs = (reverse rs,t)
hunk ./FrontEnd/Tc/Type.hs 104
-instance DocLike d => PPrint d Type where
-    pprint = prettyPrintType
-
-prettyPrintType :: DocLike d => Type -> d
-prettyPrintType t  = unparse $ runVarName (f t) where
-    arr = bop (R,0) (space <> text "->" <> space)
-    app = bop (L,100) (text " ")
-    fp (IsIn cn t) = do
-        t' <- f t
-        return (atom (text $ show cn) `app` t')
-    f (TForAll [] ([] :=> t)) = f t
-    f (TForAll vs (ps :=> t)) = do
-        ts' <- mapM (newLookupName ['a'..] ()) vs
-        t' <- f t
-        ps' <- mapM fp ps
-        return $ case ps' of
-            [] ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ")  (atomize t')
-            [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')
-            ps ->  fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')
-    f (TExists [] ([] :=> t)) = f t
-    f (TExists vs (ps :=> t)) = do
-        ts' <- mapM (newLookupName ['a'..] ()) vs
-        t' <- f t
-        ps' <- mapM fp ps
-        return $ case ps' of
-            [] ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text ". ")  (atomize t')
-            [p] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text "." <+> unparse p <+> text "=> ")  (atomize t')
-            ps ->  fixitize (N,-3) $ pop (text "exists" <+> hsep (map char ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ")  (atomize t')
-    f (TCon tycon) = return $ atom (pprint tycon)
-    f t | Just tyvar <- extractTyVar t = do
-        vo <- maybeLookupName tyvar
-        case vo of
-            Just c  -> return $ atom $ char c
-            Nothing -> return $ atom $ tshow (tyvarAtom tyvar)
-    f (TAp (TCon (Tycon n _)) x) | n == tc_List = do
-        x <- f x
-        return $ atom (char '[' <> unparse x <> char ']')
-    f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do
-        xs <- mapM f xs
-        return $ atom (tupled (map unparse xs))
-    f (TAp t1 t2) = do
-        t1 <- f t1
-        t2 <- f t2
-        return $ t1 `app` t2
-    f (TArrow t1 t2) = do
-        t1 <- f t1
-        t2 <- f t2
-        return $ t1 `arr` t2
-    f (TMetaVar mv) = return $ atom $ pprint mv
-    f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv)
-
-
-instance DocLike d => PPrint d MetaVarType where
-    pprint  t = case t of
-        Tau -> char 't'
-        Rho -> char 'r'
-        Sigma -> char 's'
-
-instance DocLike d => PPrint d Pred where
-    pprint (IsIn c t) = text (show c) <+> prettyPrintType t
-
-instance DocLike d => PPrint d MetaVar where
-    pprint MetaVar { metaUniq = u, metaKind = k, metaType = t }
-        | Star <- k =  pprint t <> tshow u
-        | otherwise = parens $ pprint t <> tshow u <> text " :: " <> pprint k
-
hunk ./FrontEnd/Tc/Type.hs 241
-instance CanType MetaVar Kind where
-    getType mv = metaKind mv
-
-instance CanType Type Kind where
-    getType = kind
-
-instance CanType Tycon Kind where
-    getType (Tycon _ k) = k
-
-instance CanType Tyvar Kind where
-    getType = tyvarKind
hunk ./FrontEnd/Type.hs 26
-module Type (nullSubst,
-             (@@),
-             Types (..),
-             (+->),
-             merge,
-             HasKind(..),
-             match,
-             tTTuple
-             ) where
+module Type (
+    Types (..),
+    match,
+    Subst,
+    tTTuple
+    ) where
hunk ./FrontEnd/Type.hs 43
+import Support.CanType
hunk ./FrontEnd/Type.hs 52
+-----------------------------------------------------------------------------
hunk ./FrontEnd/Type.hs 54
-class HasKind t where
-  kind :: t -> Kind
-instance HasKind Tyvar where
-  kind Tyvar { tyvarKind = k} = k
-instance HasKind Tycon where
-  kind (Tycon v k) = k
+instance CanType MetaVar Kind where
+    getType mv = metaKind mv
hunk ./FrontEnd/Type.hs 57
-instance HasKind Type where
-  kind (TCon tc) = kind tc
-  kind (TVar u)  = kind u
-  kind (TAp t _) = case (kind t) of
-                     (Kfun _ k) -> k
-                     x -> error $ "Type.kind: Invalid kind in type application for "++show t++": "++show x
-  kind (TArrow _l _r) = Star
-  kind (TForAll _ (_ :=> t)) = kind t
-  kind (TExists _ (_ :=> t)) = kind t
-  kind (TMetaVar mv) = kind mv
-  --kind x = error $ "Type:kind: " ++ show x
-instance HasKind MetaVar where
-    kind = metaKind
+instance CanType Tycon Kind where
+    getType (Tycon _ k) = k
hunk ./FrontEnd/Type.hs 60
------------------------------------------------------------------------------
+instance CanType Tyvar Kind where
+    getType = tyvarKind
+
+instance CanType Type Kind where
+  getType (TCon tc) = getType tc
+  getType (TVar u)  = getType u
+  getType (TAp t _) = case (getType t) of
+                     (Kfun _ k) -> k
+                     x -> error $ "Type.getType: Invalid getType in type application for "++show t++": "++show x
+  getType (TArrow _l _r) = Star
+  getType (TForAll _ (_ :=> t)) = getType t
+  getType (TExists _ (_ :=> t)) = getType t
+  getType (TMetaVar mv) = getType mv
hunk ./FrontEnd/Type.hs 85
+type Subst = Map.Map Tyvar Type
hunk ./FrontEnd/Type.hs 129
---------------------------------------------------------------------------------
-
--- unification
-{-
-
-mgu     :: (MonadIO m,Monad m2) => Type -> Type -> m (m2 Subst)
-varBind :: Monad m => Tyvar -> Type -> m Subst
-
-mgu x y = do
-    r <- runErrorT (mgu'' x y)
-    case r of
-        Right x -> return (return x)
-        Left (err::String) -> return (fail err)
-
-
-mgu'' x y = do
-    x' <- findType x
-    y' <- findType y
-    mgu' x' y'
-
-
-mgu' (TAp l r) (TAp l' r')
-   = do s1 <- mgu'' l l'
-        --s2 <- mgu'' (apply s1 r) (apply s1 r')
-        s2 <- mgu'' r r'
-        return (s2 @@ s1)
-
-mgu' (TArrow l r) (TArrow l' r')
-   = do s1 <- mgu'' l l'
-        --s2 <- mgu'' (apply s1 r) (apply s1 r')
-        s2 <- mgu'' r r'
-        return (s2 @@ s1)
-
-mgu' t@(TVar Tyvar { tyvarRef = Nothing }) (TVar u@Tyvar { tyvarRef = Just _ } )  = varBind' u t
-mgu' (TVar u) t        = varBind' u t
-mgu' t (TVar u)        = varBind' u t
-mgu' (TCon tc1) (TCon tc2)
-           | tc1==tc2 = return nullSubst
-           | otherwise = fail "mgu: Constructors don't match"
-mgu' TForAll {} _ = error "attempt to unify TForall"
-mgu' _ TForAll {} = error "attempt to unify TForall"
-mgu' t1 t2  = fail "mgu: types do not unify"
-
-varBind' u t | t == TVar u      = return nullSubst
-            | u `elem` tv t    = fail "varBind: occurs check fails"
-            | kind u == kind t, Just r <- tyvarRef u = do
-                Nothing <- liftIO $ readIORef r
-                liftIO $ writeIORef r (Just t)
-                return (u +-> t)
-            | otherwise        = error "varBind: kinds do not match"
-
-
-varBind u t | t == TVar u      = return nullSubst
-            | u `elem` tv t    = fail "varBind: occurs check fails"
-            | kind u == kind t = return (u +-> t)
-            | otherwise        = fail "varBind: kinds do not match"
-
-            -}
hunk ./FrontEnd/Type.hs 132
-match x y = do
-    --x' <- findType x
-    --y' <- findType y
-    match' x y
+match x y = do match' x y
hunk ./FrontEnd/Type.hs 145
-   | kind u == kind t = return (u +-> t)
+   | getType u == getType t = return (u +-> t)