{-# LANGUAGE LambdaCase, DeriveFunctor, FlexibleContexts #-}

module ParserD where

import Data.Char
import Control.Arrow
import Control.Applicative
import Control.Monad
import Data.Functor

newtype Parser a = Parser { parse :: String -> [(a, String)] }

runParser :: Parser a -> String -> Maybe a
runParser = (match .). parse
  where
    match [(a, [])] = Just a -- Consumed entire string, success
    match _ = Nothing -- had tokens left / other reason

-- to get a better understanding of the process, let's write a simple parser
-- it will consume a single character from the input and do nothing with it
item :: Parser Char
item = Parser $ \case
  (x:xs) -> [(x,xs)]
  _ -> []

-- what if we only wanted the next character to only be 'c', for example?
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
  c <- item
  if p c
    then pure c
    else empty

char :: Char -> Parser Char
char c = satisfy (== c)

instance Functor Parser where
  -- change the type of parser
  fmap f (Parser sa) = Parser $ fmap (first f) . sa 

instance Applicative Parser where
  -- inject a value into the parser
  pure a = Parser $ \s -> [(a,s)]
  -- sequence two parsers together
  (Parser fab) <*> (Parser fa) = Parser $ \s ->
    [(ab a,s2) | (ab, s1) <- fab s, (a, s2) <- fa s1]

instance Monad Parser where
  return = pure
  -- sequence two parsers, second one depending on the first
  pa >>= apb = Parser $ \s -> (\(a, s1) -> parse (apb a) s1) =<< parse pa s 

instance Alternative Parser where
  empty = Parser $ \s -> []
  Parser a <|> Parser b = Parser $ \s -> a s <> b s

string :: String -> Parser String
string [] = pure ""
string (x:xs) = char x *> string xs
-- string = foldM ( (*>) . char )

numbern :: (Read a, Integral a) => Int -> Parser a
numbern n = read <$> replicateM n (satisfy isDigit)

-- HH:MM:SS
timestamp :: Parser (Int,Int,Int)
timestamp = do
  h <- numbern 2
  guard (h >= 0 && h <= 24)
  char ':'
  m <- numbern 2
  guard (m >= 0 && m < 60)
  char ':'
  s <- numbern 2
  guard (s >= 0 && s < 60)
  pure (h,m,s)

-- toy parsing 
evalParser :: Parser x -> String -> x
evalParser p s = case parse p s of
  ((x,_):_) -> x
  _ -> error "error"

data Toy a next =
  Output a next
  | Bell next
  | Done
  deriving Functor

data Free f r = Free (f (Free f r)) | Pure r deriving Functor
instance Functor f => Monad (Free f) where
  return = Pure
  (Pure r) >>= f = f r
  (Free x) >>= f = Free (fmap (>>= f) x)

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

liftF x = Free ( fmap Pure x )
output x = liftF (Output x ())
bell = liftF (Bell ())
done = liftF Done

whitespace = "\t \n"
noneOf set = some $ satisfy (not . (`elem` set))
someOf set = some $ satisfy (`elem` set)

reserved = do
  outParse <|> bellParse <|> doneParse
  where
    outParse = do
      string "output"
      satisfy (`elem` whitespace)
      cmd <- timestamp
      pure $ output cmd
    bellParse = string "bell" *> pure bell
    doneParse = string "done" *> pure done

toyParser = foldr (>>) (Pure ()) <$> many (reserved <* satisfy (== '\n'))
  
data FreeF f a b = PureF a | FreeF (f b)
  deriving Functor

project (Pure r) = PureF r
project (Free f) = FreeF f

cata :: (FreeF (Toy a) r b -> b) -> Free (Toy a) r -> b
cata f = h where h = f . fmap h . project

countBells :: FreeF (Toy a) r Int -> Int
countBells (PureF x) = 0 -- no done termination, could ve error instead?
countBells (FreeF r) = case r of
  Done -> 0
  Bell r -> 1 + r
  Output _ r -> r

eval :: Show a => FreeF (Toy a) r (IO ()) -> IO ()
eval (PureF x) = pure () --error "improper termination"
eval (FreeF r) = case r of
  Done -> pure ()
  Bell r -> putChar '\7' >> r
  Output x r -> print x >> r
{-
instance Alternative Parser where
  empty = Parser $ \s -> []
  -- parse with the first, or if it fails, the second
  p1 <|> p2 = Parser $ \s ->
    case parse p1 s of
      [] -> parse p2 s
      res -> res
-}

-- let's give them a spin!
-- parse (satisfy (== 'c') *> item <* satisfy (== 'e')) "caaae"
-- parse (satisfy (== 'c') *> many item <* satisfy (== 'e')) "caaae"
-- the second one doesn't work. why?
-- answer: our alternative instance
-- doesn't produce a stream of all possible parses