Created
October 30, 2019 18:14
-
-
Save deniok/2e4791183f477b431c599c6c549903a5 to your computer and use it in GitHub Desktop.
FP_BSSE2019Fall_09
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Fp09 where | |
import Control.Applicative (Alternative(..),optional,ZipList(..)) | |
import Data.Char (isLower,isUpper,digitToInt,isDigit) | |
import Data.Monoid (Alt(..),Ap(..),Sum(..)) | |
import Data.Functor.Identity (Identity(..)) | |
newtype Parser tok a = | |
Parser { runParser :: [tok] -> Maybe ([tok],a) } | |
charA :: Parser Char Char | |
charA = Parser f where | |
f (c:cs) | c == 'A' = Just (cs,c) | |
f _ = Nothing | |
{- | |
> runParser charA "ABC" | |
Just ('A',"BC") | |
> runParser charA "BCD" | |
Nothing | |
-} | |
satisfy :: (tok -> Bool) -> Parser tok tok | |
satisfy pr = Parser f where | |
f (c:cs) | pr c = Just (cs,c) | |
f _ = Nothing | |
{- | |
> runParser (satisfy isUpper) "ABC" | |
Just ('A',"BC") | |
> runParser (satisfy isLower) "ABC" | |
Nothing | |
-} | |
lower :: Parser Char Char | |
lower = satisfy isLower | |
char :: Char -> Parser Char Char | |
char c = satisfy (== c) | |
digit :: Parser Char Int | |
digit = digitToInt <$> satisfy isDigit | |
-- для этого | |
instance Functor (Parser tok) where | |
--fmap :: (a -> b) -> Parser tok a -> Parser tok b | |
fmap g (Parser p) = Parser f where | |
f xs = case p xs of | |
Nothing -> Nothing | |
Just (cs, c) -> Just (cs, g c) | |
-- fmap g (Parser p) = Parser $ (fmap . fmap . fmap) g p | |
{- | |
> runParser digit "12AB" | |
Just ("2AB",1) | |
> runParser digit "AB12" | |
Nothing | |
-} | |
{- | |
СЕМАНТИКА | |
pure: парсер, всегда возвращающий заданное значение; | |
(<*>): нужно получить результаты первого парсера, затем | |
второго, а после этого применить первые ко вторым. | |
-} | |
instance Applicative (Parser tok) where | |
--pure :: a -> Parser tok a | |
pure x = Parser $ \s -> Just (s, x) | |
--(<*>) :: Parser tok (a -> b) -> Parser tok a -> Parser tok b | |
Parser u <*> Parser v = Parser f where | |
f xs = case u xs of | |
Nothing -> Nothing | |
Just (xs', g) -> case v xs' of | |
Nothing -> Nothing | |
Just (xs'', x) -> Just (xs'', g x) | |
{- | |
А вот так не подойдет | |
pure = Parser . pure . pure . pure | |
Parser u <*> Parser v = Parser $ (liftA2 . liftA2) (<*>) u v | |
Хотя это и настоящий композитный аппликативный функтор, но семантика не та. | |
-} | |
{- | |
> runParser (pure (,) <*> digit <*> digit) "12AB" | |
Just ("AB",(1,2)) | |
> runParser (pure (,) <*> digit <*> digit) "1AB2" | |
Nothing | |
-} | |
-- Альтернативы | |
{- | |
СЕМАНТИКА | |
empty - парсер, всегда возвращающий неудачу; | |
<|> - пробуем первый, при неудаче пробуем второй на исходной строке. | |
-} | |
instance Alternative (Parser tok) where | |
--empty :: Parser tok a | |
empty = Parser $ \_ -> Nothing | |
--(<|>) :: Parser tok a -> Parser tok a -> Parser tok a | |
Parser u <|> Parser v = Parser f where | |
f xs = case u xs of | |
Nothing -> v xs | |
z -> z | |
{- | |
> runParser (char 'A' <|> char 'B') "ABC" | |
Just ("BC",'A') | |
> runParser (char 'A' <|> char 'B') "BCD" | |
Just ("CD",'B') | |
> runParser (char 'A' <|> char 'B') "CDE" | |
Nothing | |
GHCi> runParser (many digit) "42abdef" | |
Just ("abdef",[4,2]) | |
GHCi> runParser (some digit) "42abdef" | |
Just ("abdef",[4,2]) | |
GHCi> runParser (many digit) "abdef" | |
Just ("abdef",[]) | |
GHCi> runParser (some digit) "abdef" | |
Nothing | |
GHCi> runParser (optional digit) "42abdef" | |
Just ("2abdef",Just 4) | |
GHCi> runParser (optional digit) "abdef" | |
Just ("abdef",Nothing) | |
-} | |
-- пример рекурсивного разбора | |
lowers :: Parser Char String | |
lowers = (:) <$> lower <*> lowers <|> pure "" | |
--lowers = many lower | |
{- | |
GHCi> runParser lowers "abCd" | |
Just ("Cd","ab") | |
GHCi> runParser lowers "abcd" | |
Just ("","abcd") | |
GHCi> runParser lowers "Abcd" | |
Just ("Abcd","") | |
-} | |
-- Обертки Alt и Ap | |
{- | |
GHCi> Alt "Abc" <> Alt "De" | |
Alt {getAlt = "AbcDe"} | |
GHCi> Alt Nothing <> Alt (Just 1) <> Alt (Just 2) | |
Alt {getAlt = Just 1} | |
GHCi> apLstS1 = Ap $ Sum <$> [1,2,3] | |
GHCi> apLstS2 = Ap $ Sum <$> [10,20] | |
GHCi> getAp $ getSum <$> (apLstS1 <> apLstS2) | |
[11,21,12,22,13,23] | |
GHCi> Ap [10,20] - Ap [1,2,3] | |
Ap {getAp = [9,8,7,19,18,17]} | |
GHCi> Ap [10,20] + pure 2 * Ap [1,2,3] | |
Ap {getAp = [12,14,16,22,24,26]} | |
-} | |
-- Класс типов Traversable | |
dist :: Applicative f => [f a] -> f [a] | |
dist [] = pure [] | |
dist (ax:axs) = (:) <$> ax <*> dist axs | |
{- | |
GHCi> dist [Just 3,Just 5] | |
Just [3,5] | |
GHCi> dist [Just 3,Nothing] | |
Nothing | |
GHCi> getZipList $ dist $ map ZipList [[1,2],[3,4],[5,6]] | |
[[1,3,5],[2,4,6]] | |
GHCi> dist [[1,2],[3,4],[5,6]] | |
[[1,3,5],[1,3,6],[1,4,5],[1,4,6],[2,3,5],[2,3,6],[2,4,5],[2,4,6]] | |
-} | |
{- | |
GHCi> traverse Identity [1,2,3] | |
Identity [1,2,3] | |
GHCi> traverse Just [1,2,3] | |
Just [1,2,3] | |
GHCi> traverse (const Nothing) [1,2,3] | |
Nothing | |
-} | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment