{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Simple parser that has options for using logging.
-- Currently used by `Recognize.Parsing.Interpretation`.
--
-----------------------------------------------------------------------------

module Recognize.Parsing.Parser
   ( Parser, runParser
   , ParserT, runParserT
   ) where

import Debug.Trace
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.State
import Data.Maybe
import Recognize.Parsing.Parse
import Ideas.Utils.Prelude

newtype ParserT st s m a = PT { runParserT :: st -> [s] -> m [(a, st, [s])] }

instance MonadTrans (ParserT st s) where
   lift m = PT $ \st ss -> do
      a <- m
      return [(a, st, ss)]

instance Monad m => Functor (ParserT st s m) where
  fmap f p = return f <*> p

instance Monad m => Applicative (ParserT st s m) where
   pure a  = PT $ \st ss -> return [(a, st, ss)]
   p <*> q = bind ($) p (const q)

instance Monad m => Monad (ParserT st s m) where
   (>>=) = bind (const id)
   fail _ = empty

instance Monad m => Alternative (ParserT st s m) where
   empty   = PT $ \_ _ -> return []
   p <|> q = PT $ \st ss -> do
      xs <- runParserT p st ss
      ys <- runParserT q st ss
      return (xs ++ ys)

instance Monad m =>Parse (ParserT st s m) s where
   p |> q = PT $ \st ss -> do
      xs <- runParserT p st ss
      case xs of
         [] -> runParserT q st ss
         _  -> return xs

   satisfyWith f = PT $ \st ss ->
      case ss of
         y:ys -> return [ (a, st, ys) | a <- maybeToList (f y) ]
         _    -> return []

   withInputList f = PT $ \st ss -> return [ (a, st, ss) | a <- f ss ]

instance Monad m => MonadState st (ParserT st s m) where
   state f = PT $ \st ss ->
      let (a, st2) = f st
      in return [(a, st2, ss)]

instance (Monad m, ParseLog m) => ParseLog (ParserT st s m) where
   pLog = lift . pLog

{-# INLINE bind #-}
bind :: Monad m => (a -> b -> c) -> ParserT st s m a -> (a -> ParserT st s m b) -> ParserT st s m c
bind mk p f = PT $ \st ss -> do
   xs <- runParserT p st ss
   fmap concat $ forM xs $ \(a, st2, ss2) -> do
      ys <- runParserT (f a) st2 ss2
      return [ (mk a b, st3, rest) | (b, st3, rest) <- ys]

------------------------------------------------------------------------------
-- Parser and instances
------------------------------------------------------------------------------

type Parser s = ParserT () s Identity

runParser :: Parser s a -> [s] -> Maybe a
runParser p = fmap fst3 . listToMaybe . runIdentity . runParserT p ()