{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Data.Derivation.Parse (
-- * PARSE CONSTRAINT
parseConstraint, Var ) where
import Control.Applicative (empty, (<|>), many)
import Control.Arrow (second)
import Data.Function ((&))
import Data.Maybe (listToMaybe)
import Data.List (uncons, unfoldr)
import Data.Char (isDigit, isLower)
import Data.Parse (Parse, parse, unparse, (>>!))
import Data.Derivation.Expression (Exp(..), ExpType(..))
import qualified Data.Bool as B (bool)
---------------------------------------------------------------------------
-- * PARSE CONSTRAINT
-- * MEMO
-- * GRAMMAR
-- * PICK AND CHECK
---------------------------------------------------------------------------
-- PARSE CONSTRAINT
---------------------------------------------------------------------------
parseConstraint :: String -> Maybe (Exp Var 'Boolean)
parseConstraint = (fst <$>) . constraint . memo . unfoldr (listToMaybe . lex)
---------------------------------------------------------------------------
-- MEMO
---------------------------------------------------------------------------
data Memo = Memo {
constraint, equal, bool, lessEqual :: M (Exp Var 'Boolean),
polynomial, number :: M (Exp Var 'Number), token :: M String }
type M a = Maybe (a, Memo); type Var = String
memo :: [String] -> Memo
memo ts = m where
m = Memo ct eq bl le pl nm tk
ct = pConstraint `unparse` m
eq = pEqual `unparse` m
bl = pBool `unparse` m
le = pLessEqual `unparse` m
pl = pPolynomial `unparse` m
nm = pNumber `unparse` m
tk = (memo `second`) <$> uncons ts
---------------------------------------------------------------------------
-- GRAMMAR
---------------------------------------------------------------------------
-- Constraint <- Equal / LessEqual
-- Equal <-
-- var "==" var !("+" / "-" / "<=") /
-- var "==" Polynomial !"<=" /
-- var "==" Bool /
-- Polynomial "==" Polynomial /
-- Bool "==" Bool
-- Bool <- LessEqual / "F" / "T" / var
-- LessEqual <- Polynomial "<=" Polynomial
-- Polynomial <- Number ("+" Number / "-" Number)*
-- Number <- <digit string> / var / "(" Polynomial ")"
pConstraint :: Parse Memo (Exp Var 'Boolean)
pConstraint = parse equal <|> parse lessEqual
pEqual :: Parse Memo (Exp Var 'Boolean)
pEqual =
(:==) <$> var <* pick "==" <*> var
>>! (pick "+" <|> pick "-" <|> pick "<=") <|>
(:==) <$> var <* pick "==" <*> parse polynomial >>! pick "<=" <|>
(:==) <$> var <* pick "==" <*> parse bool <|>
(:==) <$> parse polynomial <* pick "==" <*> parse polynomial <|>
(:==) <$> parse bool <* pick "==" <*> parse bool
pBool :: Parse Memo (Exp Var 'Boolean)
pBool = parse lessEqual <|>
Bool False <$ pick "F" <|> Bool True <$ pick "T" <|> var
pLessEqual :: Parse Memo (Exp Var 'Boolean)
pLessEqual = (:<=) <$> parse polynomial <* pick "<=" <*> parse polynomial
pPolynomial :: Parse Memo (Exp Var 'Number)
pPolynomial = foldl (&) <$> parse number <*> many (
flip (:+) <$> (pick "+" *> parse number) <|>
flip (:-) <$> (pick "-" *> parse number) )
pNumber :: Parse Memo (Exp Var 'Number)
pNumber = Const . read <$> check (all isDigit) <|> var <|>
pick "(" *> parse polynomial <* pick ")"
var :: Parse Memo (Exp Var t)
var = Var <$> check (all isLower)
---------------------------------------------------------------------------
-- PICK AND CHECK
---------------------------------------------------------------------------
pick :: String -> Parse Memo String
pick = check . (==)
check :: (String -> Bool) -> Parse Memo String
check p = parse token >>= B.bool empty <$> pure <*> p