Cvičení z Neprocedurálního programování - 13

1-state.hs

{-# LANGUAGE InstanceSigs #-} -- Jako na minulém cvičení chceme typové anotace u instancí typových tříd

-- Opakování: stavové výpočty
newtype State s a = State { runState :: s -> (s, a) }
-- Připomínám: runState :: State s a -> s -> (s, a)

-- Jako na minulém cvičení:
instance Functor (State s) where
--  fmap :: (a -> b) -> (s -> (s, a)) -> s -> (s, b)
    fmap :: (a -> b) -> State s a -> State s b
    fmap f stavovyVypocet = State $ \s ->       -- Nový stavový výpočet bere stav
        let (s', a) = runState stavovyVypocet s -- spustí starý výpočet, čímž dostane nový stav a ačko 
         in (s', f a)                           -- a vrátí nový stav a 'f a :: b'

instance Monad (State s) where
    return :: a -> State s a
    return a = State $ \s -> (s, a)

    (>>=) :: State s a -> (a -> State s b) -> State s b
    stavovyVypocet >>= f = State $ \s -> 
        let (s', a) = runState stavovyVypocet s  -- spustíme starý výpočet, dostaneme nový stav a ačko
            stavovyVypocet' = f a                -- aplikací f na a dostaneme nový stavový výpočet
         in runState stavovyVypocet' s'          -- který spustíme aplikací na nový stav

-- | Vrátí aktuální stav
get :: State s s
get = State $ \s -> (s, s)

-- | Nastaví nový stav
set :: s -> State s ()
set s = State $ \_ -> (s, ())

-- | Příklad: přičte jedničku ke stavu
--
-- Konkrétněji je to jako `state++` v C++ (tedy postinkrementace)
increment :: State Int Int
increment = do
    i <- get
    set (i + 1)
    return i

-- Alternativně:
-- increment = State $ \s -> (s + 1, s)

-- | Typ pro binární strom jako z domácího úkolu
data Strom a = Konec | Vetev (Strom a) a (Strom a)
  deriving (Eq, Show)

-- | Chceme funkci, která do každého vnitřního vrcholu stromu
-- vloží i číslo, které odpovídá inorder průchodu.
--
-- Tohle se hodí modelovat jako stavový výpočet,
-- abychom si nemuseli stav protahovat programem ručně.
label :: Strom a -> Strom (a, Int)
label strom = snd $ runState (labelStatefully strom) initialState
  where
    initialState :: Int
    initialState = 1
  
    labelStatefully :: Strom a -> State Int (Strom (a, Int))
    labelStatefully Konec = return Konec
    labelStatefully (Vetev l x r) = do
        l' <- labelStatefully l    -- rekurze do levého podstromu
        inorder <- increment       -- vrátí aktuální stav a zvýší jej o 1
        r' <- labelStatefully r    -- rekurze do pravého podstromu
        
        let x' = (x, inorder)
        return (Vetev l' x' r')
        
-- Poznámka: Všimněte si, že pouhým prohozením řádek dostanete preorder a postorder průchod!

{- Pro testování:

      testovaciStrom:

         'd'
        /   \ 
      'c'   'e'
      / \
   'a'  'b'
-}

testovaciStrom :: Strom Char
testovaciStrom = Vetev (Vetev (Vetev Konec 'a' Konec) 'b' (Vetev Konec 'c' Konec)) 
                       'd' 
                       (Vetev Konec 'e' Konec)
{-
>>> label testovaciStrom
Vetev (Vetev (Vetev Konec ('a', 1) Konec) ('b', 2) (Vetev Konec ('c', 3) Konec)) 
      ('d', 4) 
      (Vetev Konec ('e', 5) Konec)
-}

-- Opět schovávám instanci Applicative,
-- třídy, která je mezi Functor a Monad.
-- Více viz předchozí cvičení :)
instance Applicative (State s) where
    pure = return
    mf <*> mx = do
        f <- mf
        x <- mx
        return $ f x

2-io.hs

module Main where

import System.IO

-- IO je příklad běžně používané monády
-- Výpočet v IO má neomezené vedlejší efekty (může libovolně interreagovat se systémem)
--
-- Kdybychom mohli předávat celý svět jako stav, pak:
--       IO a == RealWorld -> (RealWorld, a)
-- Samozřejmě, reálná implementace IO je složitější a daná implementací.

{-
Dvě základní funkce pro práci se vstupem:

>>> :t getLine
getLine :: IO String

>>> :t putStrLn
putStrLn :: String -> IO ()
-}

-- | Funkce, která se zeptá na jméno uživatele a pozdraví jej
pozdrav :: IO ()
pozdrav = do
    putStrLn "Ahoj, jak se jmenuješ?"
    jmeno <- getLine
    let pozdrav = "Ahoj, " <> jmeno <> "!"
    putStrLn pozdrav

-- | Funkce 'main' je entrypoint do Haskellového programu
--
-- Pokud máte něco typu 'IO a', pak to nutně musí "probublat" až do mainu.
main :: IO ()
main = do
    pozdrav
{-
Spouštění Haskellového programu v terminálu:

~> ghc <názevsouboru>.hs -o mujprogram
~> ./mujprogram
Ahoj, jak se jmenuješ?
> Jirka
Ahoj, Jirka!
-}
     
{-
Dávejte si pozor na následující: String není to samé jako IO String,
podobně jako recept na dort není to samé jako dort.
IO String je akce s vedlejšími efekty, která když se povede, tak vrátí String.
Podobně recept na dort je jen popis akce, která musí být provedena,
aby byl vytvořen dort.

Jinými slovy: funkce typu 'IO a -> a' nedává smysl
a nemůže existovat její bezpečná varianta!
-}

-- | Vrátí tři řádky vstupu
getThreeLines :: IO [String]
getThreeLines = do
    l1 <- getLine
    l2 <- getLine
    l3 <- getLine
    return [l1, l2, l3]

{-
Obecná návrhová věc:

V IO by měl být jen ten kód, který tam být _musí_.
Návrh programu by tedy měl mít imperativní skořápku s IO,
ale funkcionální jádro bez IO.

Příklad:

-- | Načte vstup
readData :: IO Input
readData = ...

-- | Vezme vstup a vrátí výstup.
-- Obecně je tohle nějaká "business logic"
-- 
-- Nepotřebuje IO!
process :: Input -> Output
process = ...

-- | Velká funkce (skořápka), která načte vstup,
-- předá je `process` a vrátí výstup.
--
-- Typicky je tohle někde poblíž, či rovnou v 'main'u.
readAndProcess :: IO Output 
readAndProcess = do
    data <- readData
    let data' = process data
    return data'

-}

-- Následující funkce se hodí pro každou monádu
-- a obzvlášť se hodí v 'do'-notaci

-- | Pokud platí podmínka, proveď akci, jinak nedělej nic.
when :: Monad m => Bool -> m () -> m ()
when cond action = if cond then action else return ()

{-
Typické použití:

```
when (userId `notIn` database) $ do
  throwError "Stala se chyba"
  redirect
...
```
-}

-- | Pokud _neplatí_ podmínka, proveď akci, jinak nedělej nic.
unless :: Monad m => Bool -> m () -> m ()
unless = when . not

-- | Příklad skoro rozumné IO akce.
--
-- Načte řádek a vypíše jej.
-- Pokud řádek není prázdný, zavolá se znovu.
-- To má podobný efekt jako 'while True:' loop
echo :: IO ()
echo = do
    l <- getLine
    putStrLn l

    unless (null l) echo

-- | Obecná abstrakce pro 'while True: ...'
forever :: Monad m => m () -> m ()
forever m = do
    m
    forever m

{-
Užitečné funkce pro práci s monádami:

'mapM' je jako 'map', ale zároveň skládá vedlejší efekty:

  mapM  :: Monad m => (a -> m b) -> [a] -> m [b]

'sequence' vezme seznam akcí a vrátí akci seznamu:

  sequence  :: Monad m => [m a] -> m [a]

Poznámka:
Funkce s 'M' jsou typicky nějaká varianta klasické funkce pro monády.
Například 'mapM', či 'foldM'.
Funkce s '_' na konci jsou takové, které jen provedou vedlejší efekty
a samotnou hodnotu zahodí.

Příklad funkcí s '_' jsou 'mapM_' a 'sequence_':

  mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
  sequence_ :: Monad m => [m a] -> m ()

-}

-- | 'getThreeLines' výše za pomocí 'sequence' :)
getThreeLines' :: IO [String]
getThreeLines' = sequence [getLine, getLine, getLine]

{- Práce se soubory:

Soubory jdou otevřít v různých módech:
  data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode

Soubory jdou otevřít a zavřít:
  openFile :: FilePath -> IOMode -> IO Handle
  hClose :: Handle -> IO ()

Do souborů jde psát a jde z nich i číst:
  hPutStrLn :: Handle -> String -> IO ()
  hGetLine :: Handle -> IO String

-}

-- | Příklad: Vezme string na vstupu a připíše jej do logu
logLine :: String -> IO ()
logLine myLine = do
    h <- openFile "myprogram.log" WriteMode
    hPutStrLn h myLine
    hClose h 

-- Užitečný kombinátor:
--   withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
-- se chová jako 'with' konstrukce v Pythonu.
-- S ní nezapomenete na to zavřít soubor :)

-- | Homemade verze 'withFile':
withFile' :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile' path iomode action = do
    h <- openFile path iomode
    result <- action h
    hClose h
    return result

-- | 'logLine', ale pomocí 'withFile'
logLine' :: String -> IO ()
logLine' myLine = do
    withFile "myprogram.log" WriteMode $ \h -> do
        hPutStrLn h myLine

3-parser.hs

{-# LANGUAGE InstanceSigs #-}

import           Data.Char -- obsahuje funkce jako (isSpace, isDigit), které se u parserů hodí

-- | Chyba při parsování typicky obsahuje dvě věci:
-- * co parser očekával
-- * co parser dostal/nalezl
data ParseError = ParseError
    { errorExpected :: String
    , errorFound :: String
    }

instance Show ParseError where
    show err = "expected: " <> errorExpected err <> ", but found: " <> errorFound err 

-- Co by mohl být parser?
-- * První aproximace je 'String -> a',
-- ale to nemodeluje situaci, kdy parser selže.
-- * Parser, který může selhat vypadá jako 'String -> Either ParseError a'.
-- Tohle ale pořád ještě nestačí. Ideálně chceme, aby byl Parser _sekvenční_
-- a aby šel hezky skládat.
-- * Dostáváme tedy: 'String -> (String, Either ParseError a)'

newtype Parser a = Parser {
  runParser :: String -> (String, Either ParseError a)
}

-- | Příklad parseru, který vrátí libovolné písmenko na vstupu
parseAny :: Parser Char
parseAny = Parser go
  where
    go :: String -> (String, Either ParseError Char)
    go input = case input of 
                 []     -> ("", Left $ ParseError "any character" "end of file")
                 (x:xs) -> (xs, Right x)

-- | Příklad parseru, který uspěje, pokud už není co dál číst
-- (End Of File)
eof :: Parser ()
eof = Parser go
 where
    go :: String -> (String, Either ParseError ())
    go input = case input of
                 []    -> (""   , Right ())
                 (c:_) -> (input, Left $ ParseError "end of file" [c])

-- | Parser je funktor
instance Functor Parser where
    fmap :: (a -> b) -> Parser a -> Parser b
    fmap f p = Parser $ \input ->                   -- vezmeme vstup
        case runParser p input of                   -- pustíme parser p na vstup
            (rest, Right x) -> (rest, Right $ f x)  -- pokud se parsování povedlo, aplikujeme f na výslednou hodnotu
            (rest, Left err) -> (rest, Left err)    -- pokud se nepovedlo, jen předáme error

instance Monad Parser where
    return :: a -> Parser a
    return x = Parser $ \input -> (input, Right x)  -- parser se nedotkl vstupu a uspěl s 'x'
    
    (>>=) :: Parser a -> (a -> Parser b) -> Parser b
    p >>= f = Parser $ \input ->                    -- vezmeme vstup
        case runParser p input of                   -- pustíme parser na vstup
            (rest, Right x) -> runParser (f x) rest -- pokud se parsování povedlo, pak 'f x :: Parser b', tak jej jen pustíme na zbytek řetězce
            (rest, Left err) -> (rest, Left err)    -- pokud se nepovedlo, jen předáme error

-- Opět jen použijeme ten samý trik jako u 'State',
-- abychom nemuseli psát instanci pro 'Applicative' :)
instance Applicative Parser where
    pure = return
    mf <*> mx = do
        f <- mf
        x <- mx
        return $ f x

-- | Pokusí se spustit parser.
-- Pokud se parsování nepovede, tak vrátí původní vstup
-- (tedy backtrackuje)
try :: Parser a -> Parser a
try p = Parser $ \input ->                 -- vezmeme vstup
    case runParser p input of              -- pustíme parser na vstup
        (_, Left err) -> (input, Left err) -- pokud nastala chyba, vrátíme původní vstup a onu chybu
        success       -> success           -- jinak se parsování povedlo, tak pokračujeme dál

-- | Zkombinuje dva parsery.
-- Pokud první selže, ale nic nezkonzumuje, tak na vstup pustí druhý parser.
-- Pokud první uspěje, tak už druhý parser nepouštíme.
--
-- Operátor čteme jako "nebo".
(<|>) :: Parser a -> Parser a -> Parser a
p1 <|> p2 = Parser $ \input ->
    case runParser p1 input of
        (rest, Left err)
            | rest == input -> runParser p2 input
            | otherwise -> (rest, Left err)
        success -> success

-- | Pomocná funkce, která vrátí parser, který nezkonzumoval vstup, ale selhal
--
-- Reálně jen tvoří 'ParseError'.
parseError :: String -> String -> Parser a
parseError expected found = Parser $ \input -> 
    (input, Left $ ParseError expected found)

-- | Tohle je něco jako 'filter', ale pro Parser.
-- Pokud predikát (funkce 'Char -> Bool') uspěje na prvním písmenku vstupu,
-- pak jej vrátíme. Pokud predikát selže, vyhodíme error.
--
-- Všimněte si, že používá 'try' pro backtrackování!
satisfy :: String -> (Char -> Bool) -> Parser Char
satisfy description p = try $ do
    c <- parseAny
    if p c
        then return c
        else parseError description [c]

-- | Tato funkce vezme parser 'a'-ček a etězec
-- a spustí parser na onom řetězci.
--
-- Vrátí buď error, či naparsované 'a'.
run :: Parser a -> String -> Either ParseError a
run p s = snd $ runParser go s
  where
     go = do
         result <- p    -- použije parser 'p', tím získá výsledek
         eof            -- naparsuje konec souboru/vstupu
         return result  -- vrátí výsledek parseru 'p'
{-
Nyní můžeme parsery spouštět velmi příjemně:

>>> run eof ""
Right ()

>>> run eof "ahoj"
Left expected: end of file, but found: a

-}
-- Malé příklady parserů:

-- | Pokusí se naparsovat přesně zadané písmenko
char :: Char -> Parser Char
char c = satisfy [c] (== c)

-- | Pokusí se naparsovat nějakou mezeru/tabulátor
space :: Parser Char
space = satisfy "space" isSpace 

-- | Pokusí se naparsovat cifru
digit :: Parser Char
digit = satisfy "digit" isDigit

{- Příklady:

>>> run space " "
Right " "

>>> run space "    "
Left expected: end of file, but found:  

[Pozor, 'space' naparsuje jedinou mezeru, ne víc!]

>>> run space ""
Left expected: any character, but found: end of file

>>> run digit ""
Left expected: any character, but found: end of file

>>> run digit "123"
Left expected: end of file, but found: 2

>>> run digit "1"
Right '1'

-}

-- Co kdybychom ale chtěli více mezer, nebo více cifer?
-- Na to by se nám mohly hodit nějaké funkce, které vezmou parser
-- a spustí jej několikrát:

-- | Vezme parser a spustí jej (0..n)-krát
many :: Parser a -> Parser [a]
many p = many1 p <|> return []

-- | Vezme parser a spustí jej (1..n)-krát
many1 :: Parser a -> Parser [a]
many1 p = do
    first <- p
    rest <- many p
    return (first : rest)

{- Příklady:

>>> run (many digit) "123a456"
Left expected: EOF, but found: a456

>>> run (many digit) ""
Right ""

>>> run (many1 digit) ""
Left expected: any character, but found: EOF

>>> run (many1 digit) "1"
Right "1"

>>> run (many digit) "1"
Right "1"

-}

-- Větší parsery:

-- | Pokusí se naparsovat zadaný řetězec
string :: String -> Parser String
string s = mapM char s

-- | Pokusí se naparsovat nějaké číslo
number :: Parser Int
number = do
  numericString <- many1 digit  -- načte alespoň jednu cifru
  return $ read numericString   -- použije 'read :: String -> Int' pro konverzi na číslo

-- | Pokusí se naparsovat mezery
spaces :: Parser String
spaces = many space

-- | Pokusí se naparsovat daný string a zahodí mezery,
-- které po něm následují.
symbol :: String -> Parser String
symbol s = do
    result <- string s
    _ <- spaces
    return result

-- Další zajímavé parsery:

-- | Naparsuje vlevo, vpravo a uprostřed
-- a vrátí naparsované uprostřed.
--
-- Tohle se hodí pro závorky a podobné věci!
between :: Parser a -> Parser c -> Parser b -> Parser b
between left right p = do
    _ <- left
    result <- p
    _ <- right
    return result

-- | Naparsuje něco mezi závorkami
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")

{-
>>> run (parens parseInt) "42"
Left expected: (, but found: 4

>>> run (parens parseInt) "(42)"
Right 42
-}

brackets, braces :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
braces = between (symbol "{") (symbol "}")

-- | Naparsuje 'null', pokud uspěje, vrátí (), pokud neuspěje, vyhodí error.
parseNull :: Parser ()
parseNull = do
    _ <- symbol "null"
    return ()

-- Zhruba sem jsme došli na cvičení.
-- Ještě by se nám ale hodilo pár drobností na to,
-- abychom měli hezký JSON parser.

-- | Naparsuje nějaký řetězec vymezený uvozovkami
parseString :: Parser String
parseString = between (char '"') (char '"') (many parseChar)
  where
    parseChar = satisfy "not a quote" (/= '"')
    
{- Příklady:

>>> run parseString "\"\""
Right ""

>>> run parseString "\"\"\""
Left expected: end of file, but found: "

>>> run parseString "\"ahoj\""
Right "ahoj"
-}
   
-- | Funkce 'sepBy' a 'sepBy1' trochu připomínají 'many' a 'many1'.
-- Vezmou parser 'a'ček a parser 'sep'arátorů
-- a mezi každým načteným 'a'čkem načtou i 'sep'arátor.
-- Praktické použití viz níže
sepBy, sepBy1 :: Parser a -> Parser sep -> Parser [a]
sepBy  p s = sepBy1 p s <|> return []
sepBy1 p s = do
  first <- p
  rest  <- many (s >>= \_ -> p)   -- stručněji jako 'many (s >> p)'
  return (first : rest)

-- | Příklad užití 'sepBy':
-- 
-- Vezme parser 'p' a naparsuje seznam, který vypadá jako "[_, _, _]",
-- kde každý prvek je naparsován pomocí 'p'.
parseListOf :: Parser a -> Parser [a]
parseListOf p = brackets $ p `sepBy` (symbol ",") 

{- Příklady:

>>> run (parseListOf number) "[]"
Right []

>>> run (parseListOf number) "[1,2]"
Right [1,2]

>>> run (parseListOf parseString) "[\"Ahoj\",\"svete\"]"
Right ["Ahoj","svete"]

-}

-- Nakonec se nám hodí ještě jeden kombinátor,
-- který vezme seznam parserů a postupně na ně
-- bude aplikovat (<|>):
choice :: String -> [Parser a] -> Parser a
choice desc = foldr (<|>) noMatch
  where 
    noMatch = parseError desc "no match"

-- | Datový typ pro hodnoty, které budeme chtít naparsovat:
data Value = ValueNull                -- null
           | ValueString String       -- "řetězec"
           | ValueNumber Int          -- 123456
           | ValueList   [Value]      -- [_, _, _]
  deriving (Eq, Show)
  
{- Syntaktická poznámka:

`fmap` se často píše jako operátor `<$>`.
Můžete si to představit jako aplikace funkce `$`, ale v nějakém kontejneru.

-}
  
-- | Hezký parser pro 'Value'
parseValue :: Parser Value
parseValue = do
  _ <- spaces
  choice "list of values or string or number or null"
    [ ValueList <$> parseListOf parseValue
    , ValueString <$> parseString
    , ValueNumber <$> number
    , (\_ -> ValueNull) <$> parseNull    -- Poznámka: Tady se obvykle používá operátor `<$`, který je definován jako `const fmap`
    ]
  
{- Příklady:
 
>>> run parseValue ""
Left expected: list of values or string or number or null, but found: no match

>>> run parseValue "[]"
Right (ValueList [])

>>> run parseValue "[1, 2, 3, \"ahoj\"]"
Right (ValueList [ValueNumber 1,ValueNumber 2,ValueNumber 3,ValueString "ahoj"])
 
>>> run parseValue "[1, 2, [null, null, null], \"ahoj\"]"
Right (ValueList [ValueNumber 1,ValueNumber 2,ValueList [ValueNull,ValueNull,ValueNull],ValueString "ahoj"]) 
 
>>> run parseValue "[[[[null]]]]"
Right (ValueList [ValueList [ValueList [ValueList [ValueNull]]]]) 

>>> run parseValue "            42"
Right (ValueNumber 42)
-}

-- Cvičení: Přijdete do 'Value' konstruktor 'ValueBool Bool',
-- přidejte 'parseBool :: Parse Bool' (hint: použijte 'choice' ;))
-- a upravte 'parseValue' tak, aby uměla naparsovat i booleovské výrazy.

-- Cvičení: Přidejte do 'Value' konstruktor 'ValueMap [(String, Value)]',
-- který bude reprezentovat slovník/objekt jako v JSONu,
-- tedy "{ key: value, key2: value2, ... }"
-- Nejprve napište 'parseMapOf :: Parser a -> Parser [(String, a)]',
-- který bude podobný jako 'parseListOf'.
-- Poté upravte 'parseValue' tak, aby pomocí 'parseMapOf' uměla naparsovat
-- i konstruktor 'ValueMap'.

-- Pokud uděláte obě cvičení, dostáváte tím celkem rozumný parser pro JSON! :)