module Functor

import StdEnv

/*
 * Olykor előfordulhat, hogy bizonyos függvényeket vagy operátorokat
 * többféleképpen, több típussal is fel szeretnénk használni.  Ez
 * tulajdonképpen túlterhelés (overloading), amelyet nagyon egyszerűen akár
 * algebrai típusdefiníciók használatával is meg lehet valósítani.
 *
 * Például tekintsük az egyenlőségvizsgálatot, és ehhez hozzuk létre az
 * `Equals` típust.  Ennek legyen típusparamétere, amelyen keresztül
 * szabályozni tudjuk, hogy melyik típusra vonatkozóan akarjuk ezt a
 * műveletet értelmezni.  Maga a művelet ebből a típusból vesz két elemet,
 * és egy logikai értékkel jelzi az eredményt.  Ezt egyszerűen egy
 * függvényként adjuk meg és belecsomagoljuk a típusba.
 */
:: Equals a = Equals (a a -> Bool)

/*
 * Az így becsomagolt értékekből egy megfelelő függvénnyel ki tudjuk nyerni
 * a tartalmat.
 */
equals :: (Equals a) -> (a a -> Bool)
equals (Equals f) = f

/*
 * Amikor valamilyen típusra meg akarjuk adni a túlterhelt művelet, akkor
 * egyszerűen létre kell hoznunk egy ilyen értéket, ahol a függvénnyel
 * megadjuk az arra a típusra vonatkozó implementációt.
 */
eqBool = Equals boolEquals
  where
    boolEquals True  True  = True
    boolEquals False False = True
    boolEquals _     _     = False

/*
 * Ez a típus lényegében egy szótárként funkcionál, ahol a típusokhoz ki
 * tudjuk keresni a nekik megfelelő műveleteket.  Ez olyankor is hasznosnak
 * bizonyulhat, amikor a műveletet egy nagyobb függvény részeként használjuk
 * fel.  A `compareLists` két lista egyenlőségét vizsgálja úgy, hogy
 * feltételként az elemek egyenlőségvizsgálatának meglétét várja le.  A
 * függvény ugyanis csak a listák struktúrájával kapcsolatosan tud döntést
 * hozni, az elemekre vonatkozóan a hozzájuk tartozó műveletet kell
 * alkalmaznia.
 */
compareLists :: (Equals a) [a] [a] -> Bool
compareLists _  []     []     = True
compareLists eq [x:xs] [y:ys] = (equals eq) x y && compareLists eq xs ys
compareLists _  _      _      = False

equalsTest =
  [ compareLists eqBool [] [True,False]
  , compareLists eqBool [True,True,True] [True,True,True]
  ]

/*
 * A túlterhelt függvények készítésére a Clean tartalmaz egy külön szintaxist,
 * ezek a típusosztályok.  Az ilyen jellegű definíciókban a `class` kulcsszó
 * után megadhatjuk az osztály nevét, valamint legalább egy típusváltozót,
 * amely alapján ki tudjuk majd választani az adott típuskörnyezetben
 * alkalmazandó függvényt.  Ezek alkotják a fejléct, majd a `where` kulcsszó
 * után fel tudjuk sorolni az osztály tagjait vagy metódusait.  Ezek azok a
 * műveletek, amelyeket meg kell adnunk az egyes típusuk esetén.
 *
 * Ezért azt mondhatjuk, hogy a típusosztályok nem feleltethetőek meg az
 * objektumorientált nyelvek osztályfogalmának.  A típusosztályok csak és
 * kizárólag a túlterhelés lehetőségét adják meg, ún. korlátozott
 * polimorfizmus (bounded polymorphism) formájában, miközben az OO osztályok
 * az altípusos polimorfizmust valósítják meg.  A korlátozott polimorfizmus
 * lényege, hogy a típusváltozókra megszorításokat teszük, vagyis a nyelv
 * nem mindegyik típusa alkalmazható az adott környezetben, hanem csak azok,
 * amelyek a típusosztálynak az elemei.  Ezért leginkább interfészként
 * tekinthetünk rájuk, de azokkal sem teljes az analógia.
 */
class Eqs a where
  (===) infix 4 :: a a -> Bool

/*
 * Az egyes osztályok tagsági viszonyait ún. példánydefiníciók megadásával
 * lehet deklarálni.  Ekkor szintén adott egy fejléc, amelyet az `instance`
 * kulcsszóval kezdünk, majd megadjuk az osztály, és annak a típusnak a
 * nevét, amelyre vonatkozóan a deklarációt meg akarjuk adni.  Ekkor az
 * osztály definíciójában szereplő függvényeket kell megadnunk.  Ilyenkor
 * a típusokat már nem kell hozzátenni, mivel azok az osztály és a példány
 * definíciójából már maguktól adódnak.
 */
instance Eqs Bool where
  (===) True  True  = True
  (===) False False = True
  (===) _     _     = False

/*
 * Amikor olyan példányokat adunk meg, amikor paraméteres típusokról van
 * szó, általában meg kell kötni az elemek típusára is ugyanannak az
 * osztálynak a tagságát.  Például, a listák esetében, ahogy fentebb már
 * láthattuk, csak a listákról és azok szerkezetéről tudunk megállapításokat
 * tenni, az elemek egyenlőségét már annak a típusnak megfelelő példánynak
 * kell kezelnie.  A megszorításokat a `|` szimbólummal vezetjük be, utána
 * tudjuk felsorolni az osztályokat és az érintett típusváltozókat.
 */
instance Eqs [a] | Eqs a where
  (===) []     []     = True
  (===) [x:xs] [y:ys] = x === y && xs === ys
  (===) _      _      = False
/*
 * Vegyük észre, hogy az iménti definíció második sorában az `===` operátor
 * egyszer az elemek közti egyenlőségre utal (`x === y`), másszor viszont
 * egy rekurzív hívás, mivel az adott típus maga a lista (`xs === ys`).
 *
 * Ez a megközelítés egyébként nagyon előnyös abba a tekintetben, hogy
 * amikor megadunk egy ilyen definíciót, automatikusan összekapcsolhatóvá
 * válik a típusosztály összes többi példányával.  A típusosztályok akár
 * később is szabadon bővíthetőek.
 */

equalsTest2 =
  [ [] === [True,False]
  , [True,True,True] === [True,True,True]
  ]

/*
 * A típusosztályoknak van egy speciális fajtájuk, amelyeket típuskonstruktor-
 * osztálynak nevezünk.  Ebben az esetben a típusosztály paraméterében szereplő
 * típusa nem egy `*`, hanem annál egy magasabb fajtájú típust jelent.  Ez
 * azért fontos, mert az osztály leírásában a típusváltozót függvénynek tudjuk
 * tekinteni és további típusváltózkat tudunk neki paraméterként megadni.
 * Ekkor lényegében az osztályban egy másikat befoglaló típus túlterhelt
 * műveleteivel dolgozunk.
 *
 * Példaképpen tekintsük most a `Functor` osztály definícióját, ahol `f`
 * egy `* -> *` fajtájú paraméter:
 */
class Functor f where
  (<$>) infixl 4 :: (a -> b) (f a) -> f b

/*
 * Clean nyelven ugyanezt a következő módon is meg tudjuk adni.  Itt az
 * osztályt a rá jellemző művelet, az `fmap` (functor map, funktor
 * leképezés) segítségével adjuk meg, külön nem nevesítjük):
 *
 *     class fmap f :: (a -> b) (f a) -> f b
 *
 * A `Functor` osztály példányai néhány már ismert típuskonstruktorra
 * (mint példák):
 */
instance Functor [] where
  (<$>) _ []     = []
  (<$>) f [x:xs] = [f x : f <$> xs]
/*
 * Láthatjuk, hogy listák esetén ez tulajdonképpen a `map` (leképezés)
 * függvény.
 *
 * Bináris fák esetén ezt úgy terjeszthetjük ki, hogy bejárjuk a fa összes
 * elemét, mindegyikre alkalmazzuk a paraméterként megadott függvényt, és
 * újra felépítjük vele a fát.
 */
:: Tree a = Node a (Tree a) (Tree a) | Leaf

instance Functor Tree where
  (<$>) _ Leaf           = Leaf
  (<$>) f (Node x lt rt) = Node (f x) (f <$> lt) (f <$> rt)

/*
 * A `Maybe` típus esetén már ennél specializáltabb a definíció: csak abban az
 * esetben alkalmazzuk a függvényt, ha van érték (a `Just` konstruktorral
 * hoztuk létre), ellenkező esetben az eredmény marad `Nothing` (üres).
 */
:: Maybe a = Just a | Nothing

instance Functor Maybe where
  (<$>) _ Nothing  = Nothing
  (<$>) f (Just x) = Just (f x)

/*
 * Az egyparaméteres típuskonstruktorok mintájára lehet természetesen
 * kétparaméteres típuskonstruktorokat is definiálni.  Ezek esetében két
 * típust kell megadni paraméterként, hogy egy konkrét típust kapjunk a
 * felhasználásukkal.  Ennek megfelelően a kindjuk `* -> * -> *` lesz:
 *
 * Pair, Either :: * -> * -> *
 */
:: Pair a b = Pair a b
:: Either a b = Left a | Right b

/*
 * Ezekhez a típusokhoz megadhatjuk a funktorok kétparaméteres változatát,
 * szintén egy típuskonstruktor-osztály segítségével (amely értelemszerűen
 * `* -> * -> *` kindú típusokat fogad el paraméterként).  Ilyen többek
 * között a `Bifunctor` osztály:
 */
class Bifunctor f where
  bimap :: (a -> c) (b -> d) (f a c) -> f b d
  bimap f g x = first f (second g x)

  first :: (a -> b) (f a c) -> f b c
  second :: (b -> c) (f a b) -> f a c

/*
 * A `Bifunctor` osztályban a `bimap` függvény szerepel, amelyet a `first`
 * és `second` függvények segítségével fejezünk ki.  Az osztály példányaiban
 * ez utóbbiakat kell csak megadnunk, ezekből már automatikusan megkapjuk a
 * `bimap` viselkedését.
 */
instance Bifunctor Pair where
  first  f (Pair x y) = Pair (f x) y
  second f (Pair x y) = Pair x (f y)

/*
 * A párok esetében a példány definíciója gyakorlatilag annyit jelent, hogy
 * a két függvényünket (`f` és `g`) rendre a rendezett pár első, illetve
 * második tagjára alkalmazhatjuk.
 */
instance Bifunctor Either where
  first  f (Left x)  = Left (f x)
  second f (Right x) = Right (f x)

/*
 * A típusok uniója esetén viszont érdemes megjegyezni, hogy a függvények
 * nem adhatóak meg totális módon, mivel az értékekre egyszerre a két
 * függvényt sosem tudjuk alkalmazni.
 *
 * Ilyenkor mindig az (adat)konstruktorok (vagyis a `Left` és `Right`)
 * segítségével választjuk ki, hogy melyik függvényt tudjuk alkalmazni.  Ennek
 * megfelelően az `f` mindig csak az első típus, a `g` pedig a második típus
 * elemeire alkalmazható.  Minden más esetben a függvény értéke nem definiált.
 *
 * Érdemes továbbá megjegyezni, hogy a fajták hasonlóan viselkednek a
 * függvények típusához, vagyis a típuskonstruktorokat lehet parciálisan
 * alkalmazni.  Ez azt jelenti, hogy nem kötelező mindegyik típusparaméterüket
 * megadni, anélkül is kaphatunk olyan típust, amelyet felhasználhatunk más
 * típuskonstruktor-osztályok paramétereként.
 */
instance Functor (Pair a) where
  (<$>) f (Pair x y) = Pair x (f y)

instance Functor (Either a) where
  (<$>) f (Right x) = Right (f x)
/*
 * Például a `Pair` és `Either` típusoknak megadható a `Functor` példánya.  De
 * természetesen csak úgy, ha lekötjük az egyik típusparaméterüket, hiszen így
 * tudjuk a `Functor` számára szükséges `* -> *` fajtájú típust létrehozni az
 * eredetileg `* -> * -> *` típusokból.
 */

/*
 * Ha tovább gondoljuk a funktorok koncepcióját a curry-zésen keresztül, akkor
 * észrevehetjük, hogy kiterjeszthetőek akár többparaméteres függvényekre is.
 * Ekkor kapjuk az egyik részosztályukat, az ún. applikatív funktorokat.  Ez
 * lényegében a `Functor` osztály bővítése, amellyel funktorokat tudunk
 * függvényszerűen használni.  Az így keletkező `Applicative` típusosztály
 * egy újabb példa a típuskonstruktor-osztályokra, illetve arra, amikor a
 * paraméterül szereplő típusváltozóra egy korábban definiált osztállyal
 * teszünk megkötést.
 */
class Applicative f | Functor f where
  pure           :: a -> f a
  (<*>) infixl 4 :: (f (a -> b)) (f a) -> f b

/*
 * A `<*>` műveletnek vannak változatai, amelyek a számítás során a bal vagy
 * jobb oldali, funktorba csomagolt értéket figyelmen kívül hagyja.  Ezek a
 * függvények nem elemei az sosztálynak, viszont a típusaikban szerepel az
 * `Applicative` megkötés.  Ez utal arra, hogy implementációjukban annak a
 * műveleteit használják.  Ez a megkötés természetesen tranzitív, így az `f`
 * típusváltozóra a `Functor` megszorítás is automatikusan érvényessé válik.
 */
(*>) infixl 4 :: (f a) (f b) -> f b | Applicative f
(*>) u v = (\_ x -> x) <$> u <*> v

(<*) infixl 4 :: (f a) (f b) -> f a | Applicative f
(<*) u v = (\x _ -> x) <$> u <*> v

/*
 * Az applikatív funktorok egyik közkedvelt alkalmazási területe a szintaktikai
 * elemzők, segítségükkel meglehetősen egy könnyen használható, kompozícionális
 * stílusú definíciójukat adhatjuk meg.
 *
 * Ehhez elsőként a `Parser` típuskonstruktort adjuk meg, amely függvényt
 * csomagol be.  Erre azért van szükség, mert meg akarjuk rá adni a `Functor`
 * és `Applicative` osztályok példányait, és ha a csomagolással nem tennénk
 * külön típussá, akkor a későbbiekben nem lenne egyértelmű, melyik példányt
 * kell választani.  Funktorokat ugyanis nagyon gyakran meg szoktak adni
 * hasonló (`a -> b`) szignatúrájú típusú esetén, mivel ezzel a megközelítéssel
 * sok más leírható még.
 */
:: Parser a = P ([Char] -> [(a, [Char])])
/*
 * Az elemzőt tehát úgy valósítjuk meg, hogy a típusba csomagolt függvény egy
 * bemenetből képez le a felismert értékek és a bemenetben fennmaradó rész
 * lehetséges sorozatára (amit itt most az egyszerűség kedvéért egy listaként
 * ábrázolunk).  Azért sorozatot ad vissza, mert az elemzés nem feltétlenül
 * egyértelmű, és a lista az elemzőnek megfelelő lehetséges összes elemzési
 * eredményt tartalmazza (ld. a későbbi példákat).
 *
 * A `Parser` típushoz rendelünk egy függvényt, amelynek a segítségével ki
 * tudjuk értékelni az ilyen típusú értékeket, ez lesz a `parse`.
 */
parse :: (Parser a) [Char] -> [(a, [Char])]
parse (P f) s = f s

/*
 * Legegyszerűbb elemezőnk a `char` lesz, amely visszadja az adott karaktert,
 * ha a bemenet első eleme az, ellenkező esetben üres lista keletkezik, vagyis
 * a felismerés nem volt sikeres.
 *
 * Például:
 *
 *     parse (char 'a') ['a','a','a']      -->  [('a', ['a','a'])]
 *     parse (char 'a') ['b','a','b','a']  -->  []
 */
char :: Char -> Parser Char
char c = P f
  where
    f [x:xs] | (c == x) = [(x, xs)]
    f _                 = []

/*
 * Ez a felírás attól lesz kompozicionális, vagyis kisebb egységekből (például
 * primitív `char` elemzőkből) nagyobb egységek (például teljes kulcsszavak)
 * létrehozását úgy teszi lehetővé, ha megadjuk hozzá a megfelelő kompozíciós
 * műveletet.  Ez nem más, mint a `Parser` `Applicative` példánya, ahol a `<*>`
 * operátor lesz ez a kompozíció.
 */
instance Applicative Parser where
  // `pure`: Az eredménybe beletesszük az `x` értéket.
  pure x = P f
    where
      f s = [(x, s)]

  // `<*>`: Elemezők egymás utáni végrehajtása.  A második paraméter
  //        mindig az első paraméter kiértékelése után keletkező
  //       (lehetséges) bemeneteket dolgozza fel.
  (<*>) p q = P f
    where
      f s = [ (f x, s2) \\ (f, s1) <- parse p s, (x, s2) <- parse q s1 ]

/*
 * A `<$>` és `<*>` operátorok igazából a függvényalkalmazás műveletét
 * teszik explicitté, és a hozzájuk kapcsolódó típusosztályokkal ezt tudjuk
 * típusonként másképp értelmezni.  Normál esetben ezt mindenhol a szóközzel
 * jelöljük, azonban nem árt tudatosítani, hogy az maga is egy művelet.
 *
 *     ($) infixr 0 :: (a -> b) a -> b
 *     f $ x = f x
 *
 * Ez önmagában elegendő a normál esetben, amikor több paraméterünk is van.
 * Tegyük fel, hogy `f :: a b c -> d`, `x :: a`, `y :: b`, `z :: c`:
 *
 *     (((f x) y) z)  -->  f $ x $ y $ z
 *
 * ahol:
 *
 *     f x         :: b c -> d
 *     (f x) y     :: c -> d
 *     ((f x) y) z :: d
 *
 * Viszont amikor az értékeket egy külső típusa csomagoljuk bele, ezt nem
 * már tudjuk egyetlen operátorral megadni.  Tegyük fel, hogy
 * `f :: a b c -> d`, `x :: F a`, `y :: F b`, `z :: F c`:
 *
 *     f <$> x <*> y <*> z
 *
 * ahol:
 *
 *       (a b c -> d) (F a)
 *     f <$> x :: F (b c -> d)
 *       F (b c -> d) (F b)
 *     ((f <$> x) <*> y) :: F (c -> d)
 *       F (c -> d) (F c)
 *     (((f <$> x) <*> y) <*> z) :: F d
 *
 * Hozzátesszük, hogy az `Applicative` és a `Functor` műveletei között adott
 * egy összefüggés, amelynek köszönhetően a `(<$>)` definícióját nem is kell
 * megadni:
 *
 *     f <$> x = pure f <*> x
 *
 * (Ennek ellenőrzéséhez elegendő csak megnézni a típusokat.)
 */
instance Functor Parser where
  (<$>) f x = pure f <*> x

/*
 * Néhány példa:
 */
parse1 = parse ((\x y -> (x,y)) <$> char 'a' <*> pure 1) ['a','a','a']
// [(('a',1),['a','a')]
/*
 * Ilyenkor nem végzünk elemzést, csak a végeredményt képezzük:
 */
parse2 = parse ((+) <$> pure 1 <*> pure 2) ['a','a','a']
// [(3, ['a','a','a'])]
/*
 * Nem illeszkedik az elemző a bemenetre, ezért nincs eredmény:
 */
parse3 = parse ((\x y -> [x : [y]]) <$> char 'a' <*> char 'b') ['a','a','a']
// []
/*
 * Ebben az esetben viszont már van:
 */
parse4 = parse ((\x y -> [x : [y]]) <$> char 'a' <*> char 'b') ['a','b','a']
// [(['a','b'], ['a'])]

/*
 * Több karakter egymás utáni beolvasását a (`char` elemzőből a kompozícióval
 * felépített) `token` elemzővel lehet megvalósítani:
 */
token :: [Char] -> Parser [Char]
token []     = pure []
token [x:xs] = (\x xs -> [x:xs]) <$> char x <*> token xs

/*
 * Például:
 */
parse5 = parse (token ['a','l','m','a']) ['a','l','m','a','f','a']
// [(['a','l','m','a'],['f','a'])]
parse6 = parse (token ['a','l','m','a']) ['a','l','f','a']
// []

/*
 * Bizonyos esetekben hasznosnak bizonyulhat, ha több elemző unióját adjuk meg.
 * Ilyenkor nem azt várjuk el, hogy egymás után fussanak le, hanem választási
 * lehetőségeket, alternatívákat kínálunk az elemzést során.  Ezt foglalják
 * össze az alternatív funktorok, amelyet az `Alternative` osztállyal írhatunk
 * le.  Ez egyébként nem más, mint egy monoid az applikatív funktorok felett.
 */
class Alternative f | Applicative f where
  empty :: f a
  (<|>) infixl 3 :: (f a) (f a) -> f a

/*
 * Két következő műveletünk van, ezek az `empty` (üres funktor) és a `<|>` (két
 * funktor eredménye közül az egyik kiválasztása, ezért is kell megegyezniük a
 * típusaiknak).
 *
 * Ezekből származthatóak még további hasznos műveletek, a `some` és a `many`:
 */
some :: (f a) -> f [a] | Alternative f
some v = (\x xs -> [x:xs]) <$> v <*> many v

many :: (f a) -> f [a] | Alternative f
many v = some v <|> pure []
/*
 * A `some` a `Parser` esetén legalább egy elem felismerését teszi kötelezővé,
 * a `many` pedig visszaadhat üres listát is.
 */

instance Alternative Parser where
  empty   = P (\s -> [])
  (<|>) p q = P f
    where
      f s = (parse p s) ++ (parse q s)
/*
 * A `Parser` esetében a `<|>` operatár tulajdonképpen a két elemező egymástól
 * független kiértékelését, és eredményeinek összefűzését jelenti.
 *
 * Példák:
 */
parse7 = parse (some (char 'a')) ['a','a','a']
// [(['a','a','a'],[]),(['a','a'],['a']),(['a'],['a','a'])]
parse8 = parse (many (char 'a')) ['a','a','a']
// [(['a','a','a'],[]),(['a','a'],['a']),(['a'],['a','a']),([],['a','a','a'])]
parse9 = parse (some (char 'a')) ['b','a','a']
// []
parse10 = parse (many (char 'a')) ['b','a','a']
// [([],['b','a','a'])]
parse11 = parse (some (char 'a')) ['a','a','b']
// [(['a','a'],['b']),(['a'],['a','b'])]

/*
 * Végül tekintsük a `separatedBy` kombinátort, amely segítségével további
 * elemzőket tudunk felépíteni a meglevőekből.  Ennek az a feladata, hogy a `p`
 * elemző által részleteket ismerje fel, amelyeket az `s` elemző által felismert
 * részletek választanak el.
 */
separatedBy :: (Parser a) (Parser b) -> Parser [a]
separatedBy p s = ((\x xs -> [x:xs]) <$> p <*> many (s *> p)) <|> pure []

/*
 * Például:
 */
parse12 = parse (separatedBy (many (char 'a')) (char '|')) ['|','a','|','|','a','a','|','a','a','a','|']
// [([[],['a'],[],['a','a'],['a','a','a'],[]],[]),([[],['a'],[],['a','a'],['a','a','a']],['|'])
// ,([[],['a'],[],['a','a'],['a','a']],['a','|']),([[],['a'],[],['a','a'],['a']],['a','a','|'])
// ,([[],['a'],[],['a','a'],[]],['a','a','a','|']),([[],['a'],[],['a','a']],['|','a','a','a','|'])
// ,([[],['a'],[],['a']],['a','|','a','a','a','|']),([[],['a'],[],[]],['a','a','|','a','a','a','|'])
// ,([[],['a'],[]],['|','a','a','|','a','a','a','|']),([[],['a']],['|','|','a','a','|','a','a','a','|'])
// ,([[],[]],['a','|','|','a','a','|','a','a','a','|']),([[]],['|','a','|','|','a','a','|','a','a','a','|'])
// ,([],['|','a','|','|','a','a','|','a','a','a','|'])
// ]
parse13 = parse (separatedBy (some (char 'a')) (char '|')) ['|','a','|','|','a','a','|','a','a','a','|']
// [([],['|','a','|','|','a','a','|','a','a','a','|'])]

parses = (parse1,parse2,parse3,parse4,parse5,parse6,parse7,parse8,parse9,parse10,parse11,parse12,parse13)

Start = (equalsTest, equalsTest2, parses)