Commit ed837097 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement functor expression parser for exponentials

parent c41fa7c7
......@@ -66,5 +66,11 @@ checkForFunctor ::
checkForFunctor (Functor a b) = return (Functor a b)
checkForFunctor Variable = fail "Functor expression needs at least one function symbol"
parseFunctorExpression :: [[FunctorParser f]] -> String -> Text -> Either ParseErr (FunctorExpression f Precedence)
parseFunctorExpression = parse . functorsParser . concat
-- FIXME: The double list is unnecessary currently
parseFunctorExpression ::
[[FunctorParser f]]
-> String
-> Text
-> Either ParseErr (FunctorExpression f Precedence)
parseFunctorExpression functors =
parse (functorsParser (concat functors) <* eof)
......@@ -17,6 +17,7 @@ module MA.Functors.Polynomial
, FactorValue(..)
) where
import Data.Foldable
import Control.Monad
import Data.Bifunctor
import Data.List (sort)
......@@ -25,6 +26,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import qualified Data.Vector.Algorithms.Intro as V (sort)
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as V
......@@ -83,12 +85,31 @@ parseProductExpr inner = do
rest <- many (L.symbol "x" *> parseFactorExpr inner)
return $ Product (left :| rest)
parseFactorExpr :: MonadParser f => f a -> f (Factor a)
parseFactorExpr inner = (Const <$> parseConstExpr) <|> (Identity <$> inner)
parseFactorExpr :: MonadParser m => m a -> m (Factor a)
parseFactorExpr inner = (Const <$> parseConstExpr) <|> (parseIdOrExp inner)
parseConstExpr :: MonadParser m => m (Vector Text)
parseConstExpr = V.fromList <$> (L.braces (L.name `sepBy` L.comma))
parseIdOrExp :: MonadParser m => m a -> m (Factor a)
parseIdOrExp inner = do
x <- inner
(Exponential x <$> (try (L.symbol "^") *> parseExponent))
<|> (return (Identity x))
parseExponent :: MonadParser m => m (Vector Text)
parseExponent = L.braces $ do
names <- (V.modify V.sort . V.fromList) <$> L.name `sepBy` L.comma
let iter (unique :: Bool, last :: Maybe Text) (current :: Text) =
let sameAsLast = last == Just current
in (unique && (not sameAsLast), Just current)
allUnique = fst (foldl' iter (True, Nothing) names)
unless allUnique $
fail "exponential: domain must be uniquely defined"
return names
-- Index into coproduct and corresponding product value
data SumValue a = SumValue Int (ProductValue a)
deriving (Eq, Ord, Show, Functor)
......
......@@ -3,6 +3,7 @@ module MA.Functors.PolynomialSpec (spec) where
import Test.Hspec
import Test.Hspec.Megaparsec
import Data.List (isInfixOf)
import Control.Monad.ST
import Data.Either (isRight)
import Data.Functor.Classes
......@@ -10,6 +11,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy
import Type.Reflection
import Text.Megaparsec (parseErrorPretty)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Text (Text)
......@@ -98,6 +100,39 @@ functorExpressionSpec = describe "functorExpression" $ do
,[ Identity (Functor 2 (SomeFunctor (PrefixFunctor Variable))) ]
])))
it "parses an exponential" $ do
p "X^{a,b}"
`shouldParse` (Functor 1 (mkPoly [[Exponential Variable (v ["a", "b"])]]))
it "parses an exponential under a product" $ do
p "X^{a} x X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"]), ident]]))
p "XxX^{a}" `shouldParse`
(Functor 1 (mkPoly [[ident, Exponential Variable (v ["a"])]]))
it "parses an exponential under a coproduct" $ do
p "X^{a} + X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"])], [ident]]))
p "X + X^{a}" `shouldParse`
(Functor 1 (mkPoly [[ident], [Exponential Variable (v ["a"])]]))
it "parses a deply nested exponential" $ do
p "X^{a}xX + X" `shouldParse`
(Functor 1 (mkPoly [[Exponential Variable (v ["a"]), ident], [ident]]))
it "errors if exponential has non-uniquely defined domain" $
p `shouldFailOn` "X^{a, a}"
-- This is a bit of a hack: We need to exclude the following behaviour:
-- 1. The parser tries to parse ^{a, a} and fails because of non-unique keys
-- 2. The parser parses the "X" instead as an identity
-- 3. The whole parser fails with an error saying that you can't just have an
-- "X" as functor.
it "gives a useful error message for non-unique keys" $ do
let Left err = p "X^{a, a}"
parseErrorPretty err `shouldSatisfy` ("unique" `isInfixOf`)
data SomeFunctor a where
SomeFunctor :: (Eq1 f, Typeable f, Show1 f) => f a -> SomeFunctor a
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment