Skip to content

Instantly share code, notes, and snippets.

@deniok

deniok/Fp09.hs Secret

Last active Nov 12, 2020
Embed
What would you like to do?
FP_HSE2020Fall_09
{-# LANGUAGE InstanceSigs #-}
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
-}
multiplication :: Parser Char Int
multiplication = (*) <$> digit <* char '*' <*> digit
{-
GHCi> runParser multiplication "6*7"
Just ("",42)
-}
-- Альтернативы
{-
СЕМАНТИКА
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) = pure (:) <*> 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