FP_HSE2020Fall_09

Fp09.hs

{-# 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
-}