Derived.hs

{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- 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)
--
-- This module exports a set of functions that build upon the primitives from "Recognizer.Common.Parsing.Parse"
-- 
-----------------------------------------------------------------------------

module Recognize.Parsing.Derived
   ( choice, skip, peek, maybeToParse, peek2, choice'
   , choiceFor, choiceFor', succeedIf, pFoldAlt
   , few, satisfyEq, pInOrder, pRepeat, withInput
   , pInOrderAll, getInputSize, getBinary, many1, pSkipUntil
   , many', many1', pAnyExpr, pReplicate, pAnyOf, pSomewhere
   , pAnywhere, nonEmpty, pRewrite, peekExpr, peekEq, pExprWith
   , succeed, pEq, pEqCom, pExprCom, pExpr
   ) where

import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Math.Expr hiding (pExpr)
import Ideas.Common.Rewriting (getFunction)
import Ideas.Common.View
import Recognize.Data.Attribute
import Recognize.Data.Math
import Recognize.Expr.Normalform
import Recognize.Parsing.Parse

-- | Skips a single input
skip :: Parse m s => m s
skip = satisfy (const True)

-- | Synonym for `pure` and `return`
succeed :: Parse m s => a -> m a
succeed = pure

-- | Greedy version of `many`
many' :: Parse m s => m a -> m [a]
many' p = (:) <$> p <*> many' p
                  |> succeed []

-- | Perform one parsing followed by `many`
many1 :: Parse m s => m a -> m [a]
many1 p = (:) <$> p <*> many p

-- | Greedy version of `many1`
many1' :: Parse m s => m a -> m [a]
many1' p = (:) <$> p <*> many' p

-- | Alternative to `many` where the order of the branches is reversed.
--
-- Here the first branch is an always successful parsing, the 2nd branch does one parsing
--
-- The third does two parsings and so on..
--
-- A common usage:
--
-- >>> p >> few skip >> q
--
-- We want to parse @q@ and close as possible to @p@, but we do not mind skipping as much as necessary.
few :: Parse m s => m a -> m [a]
few p = return [] <|> ((:) <$> p >> few p)

-- | Fails if the resulting list is empty
nonEmpty :: Parse m s => m [a] -> m [a]
nonEmpty p = do xs <- p
                when (null xs) empty
                return xs

-- | Fold over <|>
choice :: Parse m s => [m a] -> m a
choice = foldl (<|>) empty

-- | Fold over |>
choice' :: Parse m s => [m a] -> m a
choice' = foldl (|>) empty

-- | Combination of choice and for
choiceFor :: Parse m s => [a] -> (a -> m b) -> m b
choiceFor as f = foldl (\acc a -> acc <|> f a) empty as

-- | Combination of choice' and for
choiceFor' :: Parse m s => [a] -> (a -> m b) -> m b
choiceFor' as f = foldl (\acc a -> acc |> f a) empty as

-- | Fails if predicate doesn't hold
succeedIf :: Parse m s => (a -> Bool) -> a -> m a
succeedIf p a | p a = return a
              | otherwise = empty

-- | Apply a function to the remaining input and return the result
--
-- Does not parse input.
withInput :: Parse m s => ([s] -> a) -> m a
withInput f = withInputList (return . f)

getInputSize :: Parse m s => m Int
getInputSize = withInput length

-- | Fails on Nothing. Succeeds on Just.
maybeToParse :: Parse m s => Maybe a -> m a
maybeToParse Nothing = empty
maybeToParse (Just a) = succeed a

-- | Returns the head of input. Fails if there is none.
peek :: Parse m s => m s
peek = do
  ms <- safePeek
  case ms of
    Nothing -> empty
    Just s -> return s

-- | Returns the top two inputs. Fails if there are less than 2 input remaining.
peek2 :: Parse m s => m (s, s)
peek2 = do
  ss <- withInput id
  case ss of
    (x:y:_) -> return (x,y)
    _ -> empty

-- | Continuously skip input until parsing succeeds.
pSkipUntil :: Parse m s => m a -> m (a,[s])
pSkipUntil p = ((\a -> (a,[])) <$> p) |> (skip >>= \s -> second (s:) <$> pSkipUntil p)

-- | Similar to `pFold`, except that we only return the last computed result
pFoldAlt' :: (Parse m s, Show a) => (a -> m a) -> a -> m a
pFoldAlt' f a = do
  a' <- f a
  pFoldAlt' f a' <|> return a'

-- | Only calls `pFoldAlt'` if the predicate is True. Otherwise parses once.
pFoldAlt :: (Parse m s, Show a) => Bool -> (a -> m a) -> a -> m a
pFoldAlt b f a
  | b = pFoldAlt' f a
  | otherwise = f a

-- | Skip input until a successful parsing
pSomewhere :: Parse m s => m a -> m a
pSomewhere p = p |> (skip *> pSomewhere p)

-- | Skip input until a successful parsing. Skip all remaining input.
pAnywhere :: Parse m s => m a -> m a
pAnywhere p = do
   x <- pSomewhere p
   _ <- many' skip
   return x

-- | Skip input until one of the parsers succeeds. Applies this procedure many times.
pAnyOf :: Parse m s => [m a] -> m [a]
pAnyOf ps = nonEmpty $ catMaybes <$> many' (Just <$> choice' ps |> Nothing <$ skip)

-- | Execute a parser N times.
pReplicate :: Parse m s => Int -> m a -> m [a]
pReplicate 0 _ = succeed []
pReplicate i p | i > 0 = (:) <$> p <*> pReplicate (i-1) p
               | otherwise = fail "Recognize.Parsing.Parse: replicate bounds below zero"

-- | Specialised version of `peek` for `Expr`
peekExpr :: Parse m Math => m Expr
peekExpr = peek >>= getExpr

-- | Specialised version of `peek` for `Equation Expr`
peekEq :: Parse m Math => m (Equation Expr)
peekEq = peek >>= getEq

-- | Parse an expression that has exactly two children
getBinary :: Parse m Math => Expr -> m (Expr, Expr)
getBinary e =
   case getFunction e of
      Just (_, [x, y]) -> return (x,y)
      _ -> empty

-- | Parse an input as an `Equation Expr` whose both sides must satisfy their respective predicates.
satisfyEq :: Parse m Math => (Expr -> Bool) -> (Expr -> Bool) -> m (Equation Expr)
satisfyEq f g = do
  (x :==: y) <- peek >>= getEq
  if f x && g y then skip >> return (x :==: y)
                else empty

-- | Skip an input and return a different value instead
pRewrite :: Parse m s => a -> m a
pRewrite a = skip >> return a

-- | Parses any `Expr`
pAnyExpr :: Parse m Math => m Expr
pAnyExpr = (peek >>= getExpr) <* skip

-- | Parse an `Expr` that is equal to the argument `Expr`
pExpr :: Parse m Math => Expr -> m ()
pExpr e = () <$ pExprWith (\a -> (a, [])) e

-- | Parse an `Expr` that is equal to the argument `Expr`.
--
-- Also takes a function that may be applied to both the argument and input `Expr`.
pExprWith :: Parse m Math => (Expr -> (Expr, [Attribute])) -> Expr -> m (Expr, [Attribute])
pExprWith f x = satisfyWith $ \m ->
    case getExpr m of
      Just y -> do
        let (fx,attr1) = f (toExpr x)
        let (fy,attr2) = f y
        guard $ fx == fy
        return (y, attr1 \\ attr2)
      Nothing -> Nothing

-- | Parse an `Equation` that is equal to the argument `Equation`
pEq :: Parse m Math => Equation Expr -> m ()
pEq e = () <$ pEqWith (\a -> (a, [])) e

-- | Parse an `Equation` that is equal to the argument `Equation`
--
-- Also takes a function that may be applied to both the argument and input `Expr`.
pEqWith :: Parse m Math => (Expr -> (Expr,[Attribute])) -> Equation Expr -> m (Equation Expr,[Attribute])
pEqWith f x = satisfyWith (\m ->
    case getEq m of
      Just y -> do
        let (fxl,_)   = f $ leftHandSide x
            (fxr,_)   = f $ rightHandSide x
            (fyl,ayl) = f $ leftHandSide y
            (fyr,ayr) = f $ rightHandSide y
        guard $ fxl == fyl && fxr == fyr
        return (y,ayl \\ ayr)
      Nothing -> Nothing)

-- | Parse an expression that matches the argument expression modulo commutativity
pExprCom :: Parse m Math => Expr -> m ()
pExprCom e = () <$ pExprWith (\a -> (nfCom a,[])) e

-- | Parse an equation that matches the argument expression modulo commutativity
pEqCom :: Parse m Math => Equation Expr -> m ()
pEqCom e = () <$ pEqWith (\a -> (nfCom a,[])) e

-- | This function is given a list of parsers that must all succeed in the order of the list.
--
-- Input may be skipped as much as necessary. The result of the previous parsing is also available.
pInOrderAll :: Parse m Math => [Maybe (Expr,[r]) -> m (Expr,[r])] -> m (Expr, [r],[Math])
pInOrderAll = rec Nothing 1 []
 where
   rec _ e sk [] = return (e, [], sk)
   rec m _ sk (x:xs) = do
      sk' <- few skip
      (e1, st) <- x m
      (e2, rs, ms) <- rec (Just (e1, st)) e1 (sk ++ sk') xs
      return (e2, st ++ rs, ms)

-- | This function is given a list of parsers that are executed in order of the list.
--
-- Input may be skipped as much as necessary. A parser may fail (none of the remaining input could be parsed) and thus is skipped.
--
-- The result of each previous successful parsing is available.
pInOrder :: (ParseLog m, Parse m Math) => [Maybe (Expr,[r]) -> m (Expr,[r])] -> m (Expr, [r], [Math])
pInOrder = rec Nothing 1 []
 where
   rec _ e sk [] = return (e, [], sk)
   rec m e sk (x:xs) = do
      n <- getInputSize
      pLog $ "I Size: " ++ show n
      choice
         [ do
            pLog "before skip"
            sk' <- return [] <|> (skip >> pLog "skipped" >> return [])
            -- let sk' = []
            -- s <- peek
            -- pLog ("pInOrder: " ++ show s)
            (e',st) <- x m
            pLog "was success"
            (e'',ss,sk'') <- rec (Just (e',st)) e' (sk++sk') xs
            return (e'',st ++ ss,sk'')
         , rec m e sk xs
         ]

-- | Repeatedly execute a parser until we can no longer find any input for a successful parsing.
--
-- Input may be skipped as much as necessary between executions.
--
-- The remaining input is determined by the remaining input after the last successful parsing.
pRepeat :: Parse m Math => m (Expr,[r]) -> m ([Expr],[r],[Math])
pRepeat p = do
  eth <- choice'
    [ do
      sk <- few skip
      (e,r) <- p
      return $ Right (e, r, sk)
    , return $ Left ([],[],[])
    ]

  case eth of
    Left s -> return s
    Right (e,r,sk) -> do
      (e',r',sk') <- pRepeat p
      return (e:e',r++r',sk++sk')