46 lines
1.1 KiB
Haskell
46 lines
1.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
|
|
module Pretty (Pretty(..)) where
|
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map as M
|
|
|
|
import Type
|
|
import Data.List (sort)
|
|
import TC (initialState, apply, free)
|
|
|
|
class Pretty a where
|
|
pretty :: a -> Text
|
|
|
|
instance Pretty PolyT where
|
|
pretty t = case normalize t of
|
|
Forall s t -> "∀" <> foldMap (\(Id v) -> " " <> v) s <> ": " <> pretty t
|
|
Mono t -> pretty t
|
|
|
|
instance Pretty MonoT where
|
|
pretty = go . normalize
|
|
where
|
|
go = \case
|
|
TArr tl@TArr{} tr -> "(" <> go tl <> ") → " <> go tr
|
|
TArr tl tr -> go tl <> " → " <> go tr
|
|
TVar (Id i) -> i
|
|
TCon (Id i) -> i
|
|
|
|
class Normalize a where
|
|
normalize :: a -> a
|
|
|
|
instance Normalize PolyT where
|
|
normalize = \case
|
|
Forall i t -> Forall (S.fromList (snd <$> go t)) (normalize t)
|
|
t@Mono{} -> normalize t
|
|
|
|
instance Normalize MonoT where
|
|
normalize t = apply (goS t) t
|
|
|
|
go :: MonoT -> [(Id, Id)]
|
|
go t = zip (sort (S.toList (free t))) (variables initialState)
|
|
|
|
goS :: MonoT -> Subst
|
|
goS = M.fromList . map (\(x,y) -> (x, TVar y)) . go
|