Глава 3. Специальный (ad-hoc) полиморфизм

std::string toString(int x) { ... }                      // перегрузка: одно имя, несколько функций
std::string toString(std::string fmt, double d) { ... }

class Show a where                 -- сначала объявляем, что перегружается и по какому параметру
  show :: a -> String

instance Show Int where
  show = ...

showPrefixed :: Show a => a -> String -> String          -- требуется словарь Show a

ghci> minBound :: Int                  -- константа в классе: значения-получателя нет вовсе
-9223372036854775808

ghci> pure 1 :: Maybe Int              -- выбор по результату, и даже не по типу — по конструктору
Just 1

ghci> pure 1 :: [Int]
[1]

ghci> :k Show
Show :: Type -> Constraint             -- класс — не тип, а предикат на типах

ghci> :k [Show]
error: Expecting one more argument to ‘Show’
       Expected a type, but ‘Show’ has kind ‘Type -> Constraint’

data OrdDict a = OrdDict { less :: a -> a -> Bool }

intOrd :: OrdDict Int
intOrd = OrdDict { less = (<) }

ghci> sort intOrd [3, 2, 1]
[1,2,3]

listOrd :: OrdDict a -> OrdDict [a]        -- порядок на списках — из порядка на элементах
listOrd d = OrdDict { less = ... less d ... }

ghci> sort (listOrd intOrd) [[3, 2], [2, 1], [0]]
[[0],[2,1],[3,2]]

f :: (Show b => b) -> b
f x = x

error: No instance for ‘Show b’ arising from a use of ‘x’
       Possible fix: add (Show b) to the context of the type signature for:
                       f :: forall b. (Show b => b) -> b

f :: Show b => (Show b => b) -> b
f x = x

sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]     -- ImplicitParams
sort = sortBy ?cmp

ghci> let ?cmp = (>) in sort [1, 3, 2]             -- берётся из области видимости по имени
[3,2,1]

data ShowDict a where
  ShowDict :: Show a => ShowDict a                 -- словарь, сохранённый в структуре данных

f :: ShowDict b -> (Show b => b) -> b
f d x = case d of ShowDict -> x                    -- в ветке инстанс Show b доступен

type data Nat = Zero | Suc Nat

class KnownNat (n :: Nat) where
  natVal :: Int                          -- AllowAmbiguousTypes: n нет в типе метода

instance KnownNat Zero where
  natVal = 0

instance KnownNat n => KnownNat (Suc n) where
  natVal = 1 + natVal @n

ghci> natVal @(Suc (Suc Zero))
2

class Reverse (acc :: [Type]) (tys :: [Type]) where
  showReverse :: String

instance ShowT acc => Reverse acc '[] where
  showReverse = showTypes @acc

instance Reverse (ty : acc) tys => Reverse acc (ty : tys) where
  showReverse = showReverse @(ty : acc) @tys

ghci> showReverse @'[] @'[Char, Int, Double]
"Double Int Char"

reify :: Int -> (forall n. KnownNat n => a) -> a     -- тип вернуть нельзя: принимаем продолжение
reify n k
  | n <= 0 = k @Zero                                -- передаётся knownZero
  | otherwise = reify (n - 1) \ @n' -> k @(Suc n')  -- передаётся knownSuc d
                                                    -- d — словарь KnownNat n'

wonderId :: Int -> Int
wonderId n = reify n (\ @t -> natVal @t)             -- значение → тип → значение

trait Show[T] { def show(x: T): String }                     // класс

implicit object intShow extends Show[Int] {                 // словарь
  def show(x: Int): String = x.toString
}

def showAll[T](xs: List[T])(implicit ev: Show[T]): String =   // параметр
  xs.map(ev.show(_)).mkString(", ")

showAll(List(1, 2, 3))          // "1, 2, 3": компилятор подставляет intShow
showAll(List(1, 2, 3))(intShow) // "1, 2, 3": передаём словарь сами
implicitly[Show[Int]].show(42) // "42": получаем словарь и вызываем его метод

{-# RULES
  "map/map"    forall f g xs.  map f (map g xs) = map (f . g) xs          -- закон функтора
  "map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys
 #-}

genericLookup :: Ord a => Table a b   -> a   -> b
intLookup     ::          Table Int b -> Int -> b

{-# RULES "genericLookup/Int" genericLookup = intLookup #-}

map :: Fun -> [Int] -> [Int]
map df = \case [] -> []; x:xs -> apply df x : map df xs

class ListSym                                     // символ конструктора List
class Apply<Sym, T>(val value: Any)               // «Sym, применённый к T»: тип значения стёрт

fun <T> List<T>.to(): Apply<ListSym, T> = Apply(this)
fun <T> Apply<ListSym, T>.from(): List<T> = this.value as List<T>

interface Monad<M> {
    fun <T> pure(x: T): Apply<M, T>
    infix fun <T, R> Apply<M, T>.bind(k: (T) -> Apply<M, R>): Apply<M, R>
}

fun <M> Monad<M>.go(x: Apply<M, Int>): Apply<M, Int> =
    x bind { pure(it + 1) } bind { pure(it + 2) }

data family XList elem
data instance XList ()   = UnitList Int
data instance XList Bool = BoolList ByteArray

class XListOp elem where
  xelem :: elem -> XList elem -> Bool

instance XListOp () where
  xelem () (UnitList size) = size > 0

xelemAll :: XListOp elem => XList elem -> [elem] -> Bool
xelemAll xs = all (`xelem` xs)

type family Plus (n :: Nat) (m :: Nat) :: Nat where      -- закрытое: уравнения по порядку
  Plus Zero m = m
  Plus (Suc n) m = Suc (Plus n m)

ghci> :k! Plus (Suc Zero) (Suc (Suc Zero))
Plus (Suc Zero) (Suc (Suc Zero)) :: Nat
= Suc (Suc (Suc Zero))

class Container c where
  type Elem c                          -- тип, который класс ставит в соответствие c
  elements :: c -> [Elem c]

instance Container [a] where
  type Elem [a] = a
  elements = id

instance Container ByteString where
  type Elem ByteString = Word8
  elements = ByteString.unpack

ghci> :k! Elem ByteString
= Word8

f :: NonInjective a -> String

error: Couldn't match type: NonInjective a0
                     with: NonInjective a
       NB: ‘NonInjective’ is a non-injective type family
       The type variable ‘a0’ is ambiguous

type family Inj a = r | r -> a where      -- TypeFamilyDependencies: результат определяет аргумент
  Inj Int = Bool
  Inj Char = Double

type family Map (f :: Type -> Type) (as :: [Type]) :: [Type] where
  Map f '[] = '[]
  Map f (a : as) = f a : Map f as

type family Id (a :: Type) :: Type where
  Id a = a

type Test = Map Id '[Int, Bool]

error: The type family ‘Id’ should have 1 argument, but has been given none

type family Apply (sym :: Type) (a :: Type) :: Type      -- открытое семейство-интерпретатор
data IdSym                                               -- символ вместо семейства Id
type instance Apply IdSym a = a

type family Map (f :: Type) (as :: [Type]) :: [Type] where
  Map f '[] = '[]
  Map f (a : as) = Apply f a : Map f as

ghci> :k! Map IdSym '[Int, Bool]
= [Int, Bool]

ghci> :k Monad
Monad :: (Type -> Type) -> Constraint        -- класс типов строит ограничение

ghci> :k Int ~ Bool
Int ~ Bool :: Constraint                     -- равенство типов — ограничение

ghci> :k (Eq Int, Int ~ Bool)
(Eq Int, Int ~ Bool) :: Constraint           -- кортеж ограничений — ограничение

data Dict (c :: Constraint) where            -- словарь как объект языка
  Dict :: c => Dict c

data HList (tys :: [Type]) where                  -- гетерогенный список из главы 2
  HNil :: HList '[]
  HCons :: ty -> HList tys -> HList (ty : tys)

type family All (c :: k -> Constraint) (tys :: [k]) :: Constraint where
  All c '[] = ()
  All c (ty : tys) = (c ty, All c tys)

hmap :: forall c res tys . All c tys
     => (forall ty . c ty => ty -> res) -> HList tys -> [res]
hmap f = \case
  HNil -> []
  HCons x xs -> f x : hmap @c f xs

ghci> hmap @Show show (HCons (1 :: Int) $ HCons 'a' HNil)
["1","'a'"]

data Rose f x = Rose x (f (Rose f x))

instance (Eq a, forall b. Eq b => Eq (f b)) => Eq (Rose f a) where      -- QuantifiedConstraints
  Rose x1 rs1 == Rose x2 rs2 = x1 == x2 && rs1 == rs2

interface KSerializer<T> {
    fun serialize(encoder: Encoder, value: T)
    fun deserialize(decoder: Decoder): T            // объекта ещё нет: методом объекта не сделать
}

class PairSerializer<K, V>(
    keySerializer: KSerializer<K>,                  // словари компонент передаются руками
    valueSerializer: KSerializer<V>,
) : KSerializer<Pair<K, V>> { ... }

data Has (c :: Type -> Constraint) where
  Has :: c a => a -> Has c                           -- тип a спрятан, словарь c a сохранён

showAll :: [Has Show] -> String
showAll = List.intercalate "," . map \(Has x) -> show x

ghci> showAll [Has (42 :: Int), Has "Hello", Has (Just True)]
"42,\"Hello\",Just True"

foldHas :: Has c -> (forall a . c a => a -> b) -> b      -- общий способ разобрать Has
foldHas (Has x) k = k x

class IsLabel (s :: Symbol) a where
  fromLabel :: a                                   -- OverloadedLabels: #name ≡ fromLabel @"name"

data Pet = Pet { name :: String }
instance (r ~ String) => IsLabel "name" (Pet -> r) where
  fromLabel Pet{ name } = name

data Person = Person { name :: String, pets :: [Pet] }
instance (r ~ String) => IsLabel "name" (Person -> r) where
  fromLabel Person{ name } = name

ghci> #name pet
"Rex"

f :: forall a b . a ~ b => a -> b       -- четыре параметра: два типа, коерция и аргумент
f = id

type family Plus (n :: Nat) (m :: Nat) :: Nat where
  Plus Zero m = m
  Plus (Suc n) m = Suc (Plus n m)

axiom Plus Zero m    ~ m                        -- порождает компилятор
axiom Plus (Suc n) m ~ Suc (Plus n m)

newtype Csv = Csv { unCsv :: String }

concatC :: [Csv] -> Csv
concatC = Csv . concat . map unCsv          -- map проходит по списку и ничего не меняет

concatC :: [Csv] -> Csv
concatC = coerce (concat :: [String] -> String)

class Coercible from to where               -- упрощённо; инстансы строит компилятор
  coerce :: from -> to

{-# LANGUAGE RoleAnnotations #-}
type role Map nominal representational            -- по одной роли на параметр: k, v
data Map k v = Tip | Bin k v (Map k v) (Map k v)    -- упрощённое дерево поиска

ghci> coerce (Just (ModuleId 1)) :: Maybe CourseId
Just (CourseId 1)

ghci> coerce m :: Map (Down Int) String              -- m :: Map Int String
error: Couldn't match type ‘Int’ with ‘Down Int’ arising from a use of ‘coerce’

typeName :: forall a. Typeable a => String          -- инстансы Typeable строит компилятор
typeName = tyConName $ typeRepTyCon $ typeRep $ Proxy @a

ghci> typeName @(Maybe Int)
"Maybe"

data Dynamic where
  Dynamic :: Typeable a => a -> Dynamic             -- экзистенциальный тип со словарём Typeable

ghci> d = toDyn (42 :: Int)
ghci> fromDynamic d :: Maybe Int
Just 42
ghci> fromDynamic d :: Maybe Bool
Nothing

class (Typeable a, Show a) => Exception a where
  toException :: a -> SomeException
  toException = SomeException                          -- по умолчанию родитель — корень

  fromException :: SomeException -> Maybe a
  fromException (SomeException e) = cast e

data SomeException where
  SomeException :: Exception a => a -> SomeException   -- экзистенциальная обёртка, как Dynamic

data SomeArithException where
  SomeArithException :: Exception a => a -> SomeArithException
instance Exception SomeArithException                 -- родитель — SomeException

data DivisionByZero = DivisionByZero deriving Show
instance Exception DivisionByZero where
  toException = toException . SomeArithException      -- заворачиваемся в родителя
  fromException e = do
    SomeArithException e' <- fromException e          -- снимаем обёртку родителя
    cast e'

ghci> throwIO DivisionByZero `catch` \(e :: SomeArithException) -> putStrLn "caught"
caught

ghci> throwIO DivisionByZero `catch` \(e :: MyError) -> putStrLn "caught"
*** Exception: DivisionByZero

myHead :: HasCallStack => [a] -> a
myHead []    = error "empty"
myHead (x:_) = x

bad :: Int
bad = myHead []                        -- у bad ограничения нет: выше трейс не идёт

ghci> bad
*** Exception: empty
CallStack (from HasCallStack):
  error, called at Bad.hs:5:17 in main:Main
  myHead, called at Bad.hs:9:7 in main:Main

type HasCallStack = (?callStack :: CallStack)

instance (TypeError
  ( Text "Attempting to show a function of type "
    :<>: Text "'" :<>: ShowType (a -> b) :<>: Text "'"
    :$$: Text "Did you forget to apply an argument?"
  )) => Show (a -> b) where
  show = undefined                     -- до исполнения дело не дойдёт

test = show not

error: Attempting to show a function of type 'Bool -> Bool'
       Did you forget to apply an argument?

ghci> xs = [1, undefined, 3] :: [Int]

ghci> xs `seq` "ok"
"ok"

ghci> length xs
3

ghci> xs `deepseq` "ok"
*** Exception: Prelude.undefined

class NFData a where
  rnf :: a -> ()                        -- reduce to normal form

instance NFData Int where
  rnf x = x `seq` ()

instance NFData a => NFData [a] where
  rnf [] = ()
  rnf (x : xs) = rnf x `seq` rnf xs

force :: NFData a => a -> a
force x = rnf x `seq` x

safe, safe' :: [Int] -> IO (Either SomeException [Int])
safe  xs = try (evaluate xs)            -- не поймает: вычислен только первый конструктор
safe' xs = try (evaluate (force xs))    -- поймает