FancyTypeClasses.hs

{-# language GHC2021, UnicodeSyntax, BlockArguments, LambdaCase #-}
{-# language AllowAmbiguousTypes #-}
{-# language MonoLocalBinds #-}

import Data.List (nubBy, sortBy)
import Data.Function (on, fix, (&))
import Data.String (IsString (fromString))
import Text.Read (readMaybe)
import Prelude hiding (lookup)
import Prelude qualified
import Control.Applicative (liftA2)

class Ordered label set where ordered ∷ set → set → Ordering

data Default
data Trivial

instance Ord set ⇒ Ordered Default set where ordered = compare
instance Ordered Trivial set where ordered _ _ = EQ

newtype FancyMap (odering ∷ kind) key value = FancyMap {fancyMap ∷ [(key, value)]} deriving (Show)

empty ∷ FancyMap ordering key value
empty = FancyMap [ ]

derivedEquality ∷ ∀ label set. Ordered label set ⇒ set → set → Bool
derivedEquality = fmap (== EQ) . ordered @label

insert
  ∷ ∀ ordering key value
  . Ordered ordering key
  ⇒ (key, value) → FancyMap ordering key value → FancyMap ordering key value
insert this = FancyMap . nubBy equality . sortBy ordering . (this:) . fancyMap
  where
    ordering = ordered @ordering `on` fst
    equality = derivedEquality @ordering `on` fst

lookup
  ∷ ∀ ordering key value
  . Ordered ordering key
  => FancyMap ordering key value → key → Maybe value
lookup (FancyMap list) givenKey = list & fix \ recurse → \case
  ((key, value): leftovers) →
    if derivedEquality @ordering givenKey key
    then Just value
    else recurse leftovers
  [ ] → Nothing

merge
  ∷ ∀ ordering key value
  . Ordered ordering key
  ⇒ FancyMap ordering key value → FancyMap ordering key value → FancyMap ordering key value
merge this that = FancyMap ((nubBy equality . sortBy ordering) (fancyMap this ++ fancyMap that))
  where
    ordering = ordered @ordering `on` fst
    equality = derivedEquality @ordering `on` fst

-- λ this = (insert (1, 'b') . insert (2, 'b') . insert (1, 'a')) (empty @Trivial)
-- λ this
-- FancyMap {fancyMap = [(1,'b')]}
-- λ that = (insert (1, 'b') . insert (2, 'b') . insert (1, 'a')) (empty @Default)
-- λ that
-- FancyMap {fancyMap = [(1,'b'),(2,'b')]}
-- λ this `merge` that
--
-- <interactive>:45:14: error:
--     • Couldn't match type ‘Default’ with ‘Trivial’
--       Expected: FancyMap Trivial key Char
--         Actual: FancyMap Default key Char
--     • In the second argument of ‘merge’, namely ‘that’
--       In the expression: this `merge` that
--       In an equation for ‘it’: it = this `merge` that

class Onely label set where
  naught ∷ set
  weld ∷ set → set → set

data Addition
data Multiplication

instance Monoid set ⇒ Onely Default set where
  naught = mempty
  weld = mappend

instance Num set ⇒ Onely Addition set where
  naught = 0
  weld = (+)

instance Num set ⇒ Onely Multiplication set where
  naught = 1
  weld = (*)

data Polynomial constant variable
  = Constant constant
  | Variable variable
  | Polynomial constant variable :+ Polynomial constant variable
  | Polynomial constant variable :× Polynomial constant variable

infixl 6 :+
infixl 7 :×

readEither string = (maybe (Left string) Right . readMaybe) string

instance IsString (Polynomial Integer String) where
  fromString = either Variable Constant . readEither

evaluate
  ∷ ∀ ordering constant variable
  . (Onely Addition constant, Onely Multiplication constant, Ordered ordering variable)
  ⇒ FancyMap ordering variable constant → Polynomial constant variable → Maybe constant
evaluate assignment = fix \ recurse → \case
  Constant constant → Just constant
  Variable variable → lookup assignment variable
  this :+ that → liftA2 (weld @Addition) (recurse this) (recurse that)
  this :× that → liftA2 (weld @Multiplication) (recurse this) (recurse that)

-- λ assignment = insert ("x", 10) (empty @Default)
-- λ evaluate @Default @Integer @String assignment ("2" :× "x" :× "x" :+ "3" :× "x" :+ "5")
-- Just 235