{-# LANGUAGE FlexibleContexts #-}
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
skip :: Parse m s => m s
skip = satisfy (const True)
succeed :: Parse m s => a -> m a
succeed = pure
many' :: Parse m s => m a -> m [a]
many' p = (:) <$> p <*> many' p
|> succeed []
many1 :: Parse m s => m a -> m [a]
many1 p = (:) <$> p <*> many p
many1' :: Parse m s => m a -> m [a]
many1' p = (:) <$> p <*> many' p
few :: Parse m s => m a -> m [a]
few p = return [] <|> ((:) <$> p >> few p)
nonEmpty :: Parse m s => m [a] -> m [a]
nonEmpty p = do xs <- p
when (null xs) empty
return xs
choice :: Parse m s => [m a] -> m a
choice = foldl (<|>) empty
choice' :: Parse m s => [m a] -> m a
choice' = foldl (|>) empty
choiceFor :: Parse m s => [a] -> (a -> m b) -> m b
choiceFor as f = foldl (\acc a -> acc <|> f a) empty as
choiceFor' :: Parse m s => [a] -> (a -> m b) -> m b
choiceFor' as f = foldl (\acc a -> acc |> f a) empty as
succeedIf :: Parse m s => (a -> Bool) -> a -> m a
succeedIf p a | p a = return a
| otherwise = empty
withInput :: Parse m s => ([s] -> a) -> m a
withInput f = withInputList (return . f)
getInputSize :: Parse m s => m Int
getInputSize = withInput length
maybeToParse :: Parse m s => Maybe a -> m a
maybeToParse Nothing = empty
maybeToParse (Just a) = succeed a
peek :: Parse m s => m s
peek = do
ms <- safePeek
case ms of
Nothing -> empty
Just s -> return s
peek2 :: Parse m s => m (s, s)
peek2 = do
ss <- withInput id
case ss of
(x:y:_) -> return (x,y)
_ -> empty
pSkipUntil :: Parse m s => m a -> m (a,[s])
pSkipUntil p = ((\a -> (a,[])) <$> p) |> (skip >>= \s -> second (s:) <$> pSkipUntil p)
pFoldAlt' :: (Parse m s, Show a) => (a -> m a) -> a -> m a
pFoldAlt' f a = do
a' <- f a
pFoldAlt' f a' <|> return a'
pFoldAlt :: (Parse m s, Show a) => Bool -> (a -> m a) -> a -> m a
pFoldAlt b f a
| b = pFoldAlt' f a
| otherwise = f a
pSomewhere :: Parse m s => m a -> m a
pSomewhere p = p |> (skip *> pSomewhere p)
pAnywhere :: Parse m s => m a -> m a
pAnywhere p = do
x <- pSomewhere p
_ <- many' skip
return x
pAnyOf :: Parse m s => [m a] -> m [a]
pAnyOf ps = nonEmpty $ catMaybes <$> many' (Just <$> choice' ps |> Nothing <$ skip)
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"
peekExpr :: Parse m Math => m Expr
peekExpr = peek >>= getExpr
peekEq :: Parse m Math => m (Equation Expr)
peekEq = peek >>= getEq
getBinary :: Parse m Math => Expr -> m (Expr, Expr)
getBinary e =
case getFunction e of
Just (_, [x, y]) -> return (x,y)
_ -> empty
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
pRewrite :: Parse m s => a -> m a
pRewrite a = skip >> return a
pAnyExpr :: Parse m Math => m Expr
pAnyExpr = (peek >>= getExpr) <* skip
pExpr :: Parse m Math => Expr -> m ()
pExpr e = () <$ pExprWith (\a -> (a, [])) e
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
pEq :: Parse m Math => Equation Expr -> m ()
pEq e = () <$ pEqWith (\a -> (a, [])) e
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)
pExprCom :: Parse m Math => Expr -> m ()
pExprCom e = () <$ pExprWith (\a -> (nfCom a,[])) e
pEqCom :: Parse m Math => Equation Expr -> m ()
pEqCom e = () <$ pEqWith (\a -> (nfCom a,[])) e
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)
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 [])
(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
]
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')