Skip to content

Instantly share code, notes, and snippets.

@jiribenes
Last active May 28, 2021 12:34
Show Gist options
  • Save jiribenes/0cc7049355bee3b23f7ae947fa53da5e to your computer and use it in GitHub Desktop.
Save jiribenes/0cc7049355bee3b23f7ae947fa53da5e to your computer and use it in GitHub Desktop.
Cvičení z Neprocedurálního programování - 13
{-# 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
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
{-# 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! :)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment