{-# 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)