takehome-fp-interview solution

solution.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test where

import Control.Applicative (Alternative (..), Applicative (liftA2))
import Control.Monad (MonadPlus (..), guard)
import Data.Char (isDigit, ord, toLower)

-- notes: solved with IDE Support (HLS)

-- 1) trivial
sumInt :: [Int] -> Int
sumInt [] = 0
sumInt (x : xs) = x + sumInt xs

-- 2) trivial without fold
reverseList :: [a] -> [a]
reverseList [] = []
reverseList (x : xs) = reverseList xs ++ [x]

-- 2) trivial when using ide to get foldl signature
reverseListFold :: [a] -> [a]
reverseListFold = foldl f []
  where
    f a b = [b] ++ a

-- 3) trivial
filterList :: (a -> Bool) -> [a] -> [a]
filterList _ [] = []
filterList p (x : xs)
  | p x = [x] ++ filterList p xs
  | otherwise = filterList p xs

bla :: (a -> Bool) -> [a] -> [a]
bla = takeWhile

-- 4) medium
filterListFold :: (a -> Bool) -> [a] -> [a]
filterListFold p = foldr f []
  where
    f a b | p a = [a] ++ b
    f _ b = b

takeWhileFold :: (a -> Bool) -> [a] -> [a]
takeWhileFold p = foldr f []
  where
    f a b | p a = [a] ++ b
    f _ _ = []

-- 5) trivial
{-
forall a . a -> a
forall a . a -> (a, a)
forall a b . (a -> b) -> a -> b
forall a b c . (a -> b -> c) -> (a,b) -> c
-}

f1 :: forall a. a -> a
f1 a = a

f2 :: forall a. a -> (a, a)
f2 a = (a, a)

f3 :: forall a b. (a -> b) -> a -> b
f3 f a = f a

f4 :: forall a b c. (a -> b -> c) -> (a, b) -> c
f4 f (a, b) = f a b

-- 7) easy
data Maybe' a = Just' a | Nothing'
  deriving (Show)

instance Functor Maybe' where
  fmap f (Just' a) = Just' $ f a
  fmap _ Nothing' = Nothing'

instance Applicative Maybe' where
  pure = Just'
  Just' f <*> Just' a = Just' $ f a
  _ <*> _ = Nothing'

instance Monad Maybe' where
  return = pure
  Just' a >>= f = f a
  _ >>= _ = Nothing'

liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
liftM2' f fa fb = do
  a <- fa
  b <- fb
  return $ f a b

-- liftM2 applies two defined values (Just a, Just b) to a function a -> b -> c while lifting
-- the function into the monadic context.

-- 8) hard
bind :: (a -> b) -> (b -> (a -> c)) -> (a -> c)
bind fa k = \a -> ((k (fa a)) a)

return' :: a -> (b -> a)
return' a = \_ -> a

-- see what liftM2 does..
-- liftM2 f fa fb = fa `bind` (\a -> fb `bind` (\b -> return $ f a b))
-- liftM2 f fa fb = \m -> (((\a -> fb `bind` (\b -> return $ f a b)) (fa m)) m)
-- liftM2 f fa fb = \m -> (((\a -> (\n -> (((\b -> return $ f a b) (fb n)) n))) (fa m)) m)
-- liftM2 f fa fb = \m -> (((\a -> (\n -> (((\b -> (\_ -> f a b)) (fb n)) n))) (fa m)) m)
-- liftM2 f fa fb = \m -> (((\a -> (\n -> ((((\_ -> f a (fb n)))) n))) (fa m)) m)
-- liftM2 f fa fb = \m -> (((\a -> (\n -> ((\_ -> f a (fb n)) n))) (fa m)) m)
-- liftM2 f fa fb = \m -> ( (\n -> (f (fa m) (fb n)))   m)
-- liftM2 f fa fb = \m -> f (fa m) (fb m)

-- liftM2' :: (Monad (->) e) => (a -> b -> c) -> (e -> a) -> (e -> b) -> (e -> c)
{-

        +------- fa e ---[a]---+
        |                      |
e ------|                      |---- f a b ---> c
        |                      |
        +------- fb e ---[b]---+
-}
-- liftM2 applies a values to two functions and combines the result using an operator
-- e.g.: tupleFunc = liftM2 (,)

-- 9) hard
-- special case of Traversable. Implementing it by hand turned out to be
-- kind of technical mystery. It helped a lot specializing it to Maybe
myFunc :: Applicative f => [(f a, b)] -> f [(a, b)]
myFunc [] = pure []
myFunc ((fa, b) : xs) = f <$> fa <*> myFunc xs
  where
    f a = (++) [(a, b)]
    --f = (++) . pure . flip (,) b
-- >>> myFunc [(Just 5, True), (Just 3, False), (Just 1, False)]
-- Just [(5,True),(3,False),(1,False)]

{-
myFunc2 ::  [(Maybe a, b)] -> Maybe [(a, b)]
myFunc2 [] = Just []
myFunc2 ((Just a, b):xs) = fmap (\x -> [(a, b)] ++ x) (myFunc2 xs)
myFunc2 ((Nothing, _):_) = Nothing

myFunc3 ::  [(Maybe a, b)] -> Maybe [(a, b)]
myFunc3 [] = Just []
myFunc3 ((fa, b):xs) = (fmap (\x -> \a -> [(a, b)] ++ x) (myFunc2 xs)) <*> fa
-}

-- 10) easy
someFunc :: (Traversable t, Applicative f) => t (f a, b) -> f (t (a, b))
someFunc = traverse (\(a, b) -> (\a -> (a, b)) <$> a)

-- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
-- traverse :: Applicative f => ((f x, y) -> f (x, y)) -> t (f x, y) -> f (t (x, y))

-- 11) easy
data Errer e b = Error e | Success b
  deriving (Show)

instance Functor (Errer e) where
  fmap f (Success b) = Success $ f b
  fmap _ (Error e) = Error e

instance Semigroup e => Applicative (Errer e) where
  pure a = Success a
  Success f <*> Success b = Success $ f b
  Error a <*> Error e = Error (a <> e)
  Error a <*> _ = Error a
  _ <*> Error e = Error e

-- 12) easy (if correct laws are satisfied)
data Pair a = Pair a a

instance Functor Pair where
  fmap f (Pair a b) = Pair (f a) (f b)

-- looks reasonable, but laws are not fully proofed yet
instance Applicative Pair where
  pure a = Pair a a
  Pair f g <*> Pair a b = Pair (f a) (g b)

-- Monad instance would require some kind of combinator,
-- for example Semigroup. Which is not possible to define
-- without introducing and additional type paramerer to Pair
-- e.g. Pair m a
--    instance Semigroup m => Monad (Pair m) where

-- laws
{-
pure id <*> v = v                            -- Identity       -> OK
pure f <*> pure x = pure (f x)               -- Homomorphism   -> OK
u <*> pure y = pure ($ y) <*> u              -- Interchange    -> XXX
pure (.) <*> u <*> v <*> w = u <*> (v <*> w) -- Composition    -> XXX
-}
-- pure id <*> (Pair a b) = (Pair id id) <*> (Pair a b)
--   = Pair (id a) (id b)
--   = Pair a b

-- pure f <*> pure x = Pair f f <*> Pair x x
--   = Pair (f x) (f x)
--   = pure (f x)

-- Pair f g <*> pure y = Pair f g <*> Pair y y
--   = Pair (f y) (g y)
-- pure ($ y) <*> Pair a b
--   = Pair ($ y) ($y) <*> Pair a b
--   = Pair (y a) (y b)
-- XXX TODO last two laws

-- 13) hard, had never implemented a parser, http://dev.stephendiehl.com/fun/002_parsers.html
--     provided basic inspiration for the parse type and examples
-- m MonadPlus container
-- a result type
newtype Parser m a = Parse
  {runParser :: (String -> m (a, String))}

instance Functor f => Functor (Parser f) where
  fmap f (Parse parser) = Parse $ \str -> (\(v, r) -> (f v, r)) <$> parser str

instance Monad m => Applicative (Parser m) where
  pure a = Parse $ \str -> pure (a, str)
  (Parse pf) <*> (Parse p) = Parse $ \str -> do
    (f, n) <- pf str
    (v, r) <- p n
    return $ (f v, r)

applicativeTest :: Parser [] Int
applicativeTest = (*) <$> digit <*> digit

-- >>> runParser applicativeTest $ "234234"
-- [(6,"4234")]

instance MonadPlus f => Alternative (Parser f) where
  empty = Parse $ \_ -> empty
  (Parse p1) <|> (Parse p2) = Parse $ \str -> p1 str <|> p2 str

instance Monad f => Monad (Parser f) where
  return = pure

  -- run parser and use the result to create a new one which is
  -- where the tail if applied to
  (Parse p) >>= fp = Parse $ \str -> do
    (v, s) <- p str
    runParser (fp v) s

monadTest :: Parser [] Int
monadTest = do
  d1 <- digit
  r <- case d1 of
    1 -> empty
    _ -> digit
  return $ d1 * r

-- >>> runParser monadTest "23"
-- [(6,"")]

instance MonadPlus f => MonadPlus (Parser f) where
  mzero = Parse $ const mzero
  mplus (Parse p1) (Parse p2) = Parse $ liftA2 mplus p1 p2

predicate :: MonadPlus f => (Char -> Bool) -> Parser f Char
predicate predicate = do
  char <- anyChar
  guard $ predicate char
  return char

oneOf :: MonadPlus f => [Char] -> Parser f Char
oneOf whitelist = predicate (\s -> s `elem` whitelist)

char :: MonadPlus f => Char -> Parser f Char
char whitelist = predicate (\s -> s == whitelist)

anyChar :: Alternative f => Parser f Char
anyChar = Parse $ \case
  [] -> empty
  (c : cs) -> pure (c, cs)

-- some = >0
-- many = >=0
natural :: MonadPlus f => Parser f Integer
natural = read <$> some (predicate isDigit)

-- playground

-- >>> runParser natural $ "1337abc"
-- (1337,"abc")

-- simple string parser without escape sequences
parseString :: MonadPlus m => Parser m String
parseString = do
  predicate dchar
  result <- many . predicate $ not <$> dchar
  predicate dchar
  return result
  where
    dchar = (==) '"'

-- >>> runParser @[] parseString $ "\"foo\"derp"
-- [("foo","derp")]

letter :: Alternative f => Parser f Char
letter = Parse $ \case
  [] -> empty
  (x : xs)
    | ord x > 64 && ord x < 122 -> pure (x, xs)
    | x == '_' -> pure (x, xs)
    | otherwise -> empty

digit :: Alternative f => Parser f Int
digit = Parse $ \case
  [] -> empty
  ('0' : cs) -> pure (0, cs)
  ('1' : cs) -> pure (1, cs)
  ('2' : cs) -> pure (2, cs)
  ('3' : cs) -> pure (3, cs)
  ('4' : cs) -> pure (4, cs)
  ('5' : cs) -> pure (5, cs)
  ('6' : cs) -> pure (6, cs)
  ('7' : cs) -> pure (7, cs)
  ('8' : cs) -> pure (8, cs)
  ('9' : cs) -> pure (9, cs)
  _ -> empty

-- playground parser / eval of simple expression evaluator

data Operator = Plus | Minus | Multiplication | Division
  deriving (Show, Eq)

data AST
  = Number Float
  | Expr Operator AST AST
  | Function String AST
  deriving (Show, Eq)

parseOperator :: MonadPlus f => Parser f Operator
parseOperator = Parse $ \case
  ('+' : cs) -> pure (Plus, cs)
  ('-' : cs) -> pure (Minus, cs)
  ('/' : cs) -> pure (Division, cs)
  ('*' : cs) -> pure (Multiplication, cs)
  _ -> empty

parseNumber :: MonadPlus f => Parser f Float
parseNumber = read <$> some (predicate isDigit) -- XXX

hull :: MonadPlus f => Char -> Char -> Parser f a -> Parser f a
hull a b p = do
  char a
  result <- p
  char b
  return result

parseExpr :: MonadPlus f => Parser f AST
parseExpr = spaces *> operation <|> dotOperation <|> atom <* spaces
  where
    atom = Number <$> parseNumber <|> hull '(' ')' parseExpr <|> parseFunc
    parseFunc =
      Function
        <$> some (oneOf funcChars)
        <*> hull '(' ')' parseExpr

    operation = do
      a <- dotOperation <|> atom
      operator <- op [Plus, Minus]
      Expr operator a <$> parseExpr

    dotOperation = do
      a <- atom
      operator <- op [Multiplication, Division]
      Expr operator a <$> (dotOperation <|> atom)

    op a = do
      spaces
      operator <- parseOperator
      guard $ operator `elem` a
      spaces
      return operator

    spaces = many $ oneOf [' ', '\t', '\n']

-- >>> runParser parseExpr $ "5*3*2*sin(5+3)"
-- (Expr Multiplication (Number 5.0) (Expr Multiplication (Number 3.0) (Expr Multiplication (Number 2.0) (Function "sin" (Expr Plus (Number 5.0) (Number 3.0))))),"")

evalAST :: AST -> Either String Float
evalAST (Number n) = Right n
evalAST (Expr Plus a b) = (+) <$> evalAST a <*> evalAST b
evalAST (Expr Minus a b) = (-) <$> evalAST a <*> evalAST b
evalAST (Expr Multiplication a b) = (*) <$> evalAST a <*> evalAST b
evalAST (Expr Division a b) = (/) <$> evalAST a <*> evalAST b
evalAST (Function name expr) = case toLower <$> name of
  "sin" -> sin <$> evalAST expr
  "cos" -> cos <$> evalAST expr
  "tan" -> tan <$> evalAST expr
  "abs" -> abs <$> evalAST expr
  name -> Left $ "unkown function name: " ++ name

-- >>> evalAST . fst <$> (runParser @Maybe parseExpr) "abs(20-30)*4-5*2+2"
-- Just (Right 28.0)
-- buggy... need some fix

funcChars =
  [ 'a',
    'b',
    'c',
    'd',
    'e',
    'f',
    'g',
    'h',
    'i',
    'j',
    'k',
    'l',
    'm',
    'n',
    'o',
    'p',
    'q',
    'r',
    's',
    't',
    'u',
    'v',
    'w',
    'x',
    'y',
    'z',
    'A',
    'B',
    'C',
    'D',
    'E',
    'F',
    'G',
    'H',
    'I',
    'J',
    'K',
    'L',
    'M',
    'N',
    'O',
    'P',
    'Q',
    'E',
    'S',
    'T',
    'U',
    'V',
    'W',
    'X',
    'Y',
    'Z',
    '_'
  ]

sources.md

• https://gist.github.com/pchiusano/bf06bd751395e1a6d09794b38f093787
• help on parser http://dev.stephendiehl.com/fun/002_parsers.html