59 lines
1.9 KiB
Haskell
59 lines
1.9 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 qualified Data.Text as T
|
|
|
|
import Type
|
|
import Data.List (sort)
|
|
|
|
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
|
|
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))) initialState
|
|
|
|
goS :: MonoT -> Subst
|
|
goS = M.fromList . map (\(x,y) -> (x, TVar y)) . go
|
|
|
|
instance Pretty TypeError where
|
|
pretty = \case
|
|
Oop -> "oop"
|
|
UnificationFailure t1 t2 -> "UnificationFailure:\n" <> pretty t1 <> "\n" <> pretty t2
|
|
UnificationRight t1 t2 -> "UnificationRight:\n" <> pretty t1 <> "\n" <> pretty t2
|
|
InfiniteType (Id i) t -> "InfiniteType:\n" <> i <> "\n" <> pretty t
|
|
UnboundVariable (Just (l,c)) (Id i) -> "UnboundVariable: '" <> i <> "' at " <> T.pack (show l) <> ":" <> T.pack (show c)
|
|
UnboundVariable Nothing (Id i) -> "UnboundVariable: '" <> i <> "'"
|
|
AlreadyDefined (Just (l,c)) (Id i) -> "'" <> i <> "' already defined at " <> T.pack (show l) <> ":" <> T.pack (show c)
|
|
AlreadyDefined Nothing (Id i) -> "'" <> i <> "' already defined"
|
|
PositivityCheck (Id i) -> "PositivityCheck failed for type '" <> i <> "'"
|
|
t -> T.pack (show t)
|