diff --git a/bench/Copar/Coalgebra/BenchParser.hs b/bench/Copar/Coalgebra/BenchParser.hs index 28d5a6f6c4dd6dcfc115b01bd7c36a20de039faa..bbd605422dcd380901920a18b611aaba4bb4754e 100644 --- a/bench/Copar/Coalgebra/BenchParser.hs +++ b/bench/Copar/Coalgebra/BenchParser.hs @@ -55,7 +55,7 @@ benchParser :: -> Benchmark benchParser benchmarkName fexpr input = bench benchmarkName (nf parse input) where - parse = parseMorphisms fexpr "" + parse = parseMorphisms fexpr EnableSanityChecks "" mkPoly :: [[Factor a]] -> Polynomial a mkPoly = diff --git a/src/Copar/Coalgebra/Parser.hs b/src/Copar/Coalgebra/Parser.hs index beb512cc0a9a9440e4381ab1a30ba3d5b528f802..8fbc40d885e1ac59c63bd5e7c86cad4943c1b37c 100644 --- a/src/Copar/Coalgebra/Parser.hs +++ b/src/Copar/Coalgebra/Parser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -11,6 +13,8 @@ module Copar.Coalgebra.Parser , morphismsParser , SymbolTable(..) , module Copar.Coalgebra.Parser.Class + , HasSanityChecks(noSanityChecks) + , SanityChecks(..) ) where import Control.Monad (void, forM_) @@ -18,7 +22,7 @@ import Data.Bifunctor import Data.Tuple import Data.Void (Void) -import Control.Monad.State.Strict (execStateT) +import Control.Monad.State.Strict (execStateT, MonadState) import qualified Data.HashMap.Strict as M import Data.Text (Text) import qualified Data.Text as T @@ -39,6 +43,19 @@ import qualified Copar.Parser.Lexer as L import Copar.Parser.Types import Copar.Coalgebra.Parser.Class + +class HasSanityChecks m where + -- | When this returns 'True', morphism parsers are allowed (encouraged) to skip + -- sanity checks on the input. + -- + -- In this case, the user is responsible for providing correct inputs and nasal + -- demons will be set free if the input is incorrect. + noSanityChecks :: m Bool + +instance MonadState (ParserState l f1) m => HasSanityChecks m where + noSanityChecks = use disableSanity + + newState :: MorphParser l f1 State newState = nextState <<%= succ {-# INLINE newState #-} @@ -93,13 +110,21 @@ finalizeState state = , bimap (mkDesortedLabel @f) id (Encoding.new f1Vec edges) ) +-- | Whether or not to do sanity checks on the input. +data SanityChecks = EnableSanityChecks | DisableSanityChecks + morphismsParser :: forall f. (Functor f, ParseMorphism f) => FunctorExpression f Sort + -> SanityChecks -> Parser (SymbolTable, Encoding (Label (Desorted f)) (F1 (Desorted f))) -morphismsParser Variable = error "should not happen: variable" -- FIXME: Useful error message -morphismsParser (Functor sort f) = finalizeState @f <$> (execStateT p initState) +morphismsParser Variable _ = + error "should not happen: variable" -- FIXME: Useful error message +morphismsParser (Functor sort f) sanity = finalizeState @f <$> (execStateT p initial) where + initial = case sanity of + EnableSanityChecks -> initState + DisableSanityChecks -> initState & disableSanity .~ True p = do void (some parsePoint) checkUndefinedRefs @@ -119,11 +144,12 @@ morphismsParser (Functor sort f) = finalizeState @f <$> (execStateT p initState) parseMorphisms :: (Functor f, ParseMorphism f) => FunctorExpression f Sort + -> SanityChecks -> String -> Text -> Either (ParseErrorBundle Text Void) ( SymbolTable , Encoding (Label (Desorted f)) (F1 (Desorted f))) -parseMorphisms = parse . morphismsParser +parseMorphisms expr = parse . morphismsParser expr wrapper :: (Functor f, ParseMorphism f) diff --git a/src/Copar/Coalgebra/Parser/Internal.hs b/src/Copar/Coalgebra/Parser/Internal.hs index 90be16418405b37c25a52fa6370f5e43e42cca8c..a22f3a13e8f5efa05bb034f909845c2af1b349a7 100644 --- a/src/Copar/Coalgebra/Parser/Internal.hs +++ b/src/Copar/Coalgebra/Parser/Internal.hs @@ -7,6 +7,7 @@ module Copar.Coalgebra.Parser.Internal , f1Map , symbolTable , nextState + , disableSanity , Symbol(..) , initState ) where @@ -27,6 +28,8 @@ data ParserState l f1 = ParserState , _f1Map :: M.HashMap State (Sorted f1) , _symbolTable :: M.HashMap Text (State, Symbol) , _nextState :: Int + , _disableSanity :: Bool -- ^ True if parsers are allowed (encouraged) to + -- disable sanity checks on the input } makeLenses ''ParserState @@ -36,4 +39,5 @@ initState = ParserState , _f1Map = M.empty , _symbolTable = M.empty , _nextState = 0 + , _disableSanity = False } diff --git a/src/Copar/Functors/AbsorbingPolynomial.hs b/src/Copar/Functors/AbsorbingPolynomial.hs index 7f57ae5be32541cfa2e8fda00d95fc454c71c3fe..bcfc4743d49cfb520c5fa2f0450e9066ab9383b1 100644 --- a/src/Copar/Functors/AbsorbingPolynomial.hs +++ b/src/Copar/Functors/AbsorbingPolynomial.hs @@ -272,7 +272,8 @@ parseSum f1 (F1 AbsorbingPolynomial, Vector (a, Label AbsorbingPolynomial)) parseSum (Sum summands) i = do - when (i < 0 || i >= length summands) + sanity <- not <$> noSanityChecks + when (sanity && (i < 0 || i >= length summands)) $ fail ("polynomial: injection " ++ show i ++ " is out of bounds") (constants, successors) <- parseProduct1 (summands NonEmpty.!! i) @@ -360,8 +361,9 @@ parseFactor (Const NatSet) = do x <- L.decimal <?> "natural number" return (Left x) parseFactor (Const (FiniteNatSet n)) = do - x <- L.decimal <?> ("natural number small than " ++ show n) - unless (x < n) $ fail + x <- L.decimal <?> ("natural number small than " ++ show n) + sanity <- not <$> noSanityChecks + when (sanity && x >= n) $ fail ( "out of range constant: " ++ show x ++ "(must be between 0 and " @@ -373,23 +375,26 @@ parseFactor (Identity inner) = do successors <- parseInner inner return (Right (V.singleton successors)) parseFactor (Exponential inner exp) = L.braces $ do + sanity <- not <$> noSanityChecks + successors <- - (V.sortOn fst . V.fromList) - <$> (((,) <$> parseExpValue exp <*> (L.colon *> parseInner inner)) - `sepBy` L.comma - ) + (if sanity then V.sortOn fst else id) + . V.fromList + <$> ((,) <$> parseExpValue exp <*> (L.colon *> parseInner inner)) + `sepBy` L.comma - unless (allExpValues exp == (V.map fst successors)) + when (sanity && allExpValues exp /= (V.map fst successors)) $ fail ("exponential: map must be well-defined on " ++ showExp exp) return (Right (V.map snd successors)) -parseExpValue :: MonadParser m => Exponent -> m Int +parseExpValue :: (MonadParser m, HasSanityChecks m) => Exponent -> m Int parseExpValue (ExplicitExp names) = someName names parseExpValue (FiniteNatExp n ) = do - x <- L.decimal - unless (x < n) $ -- L.decimal returns only positive ints - fail + x <- L.decimal + sanity <- not <$> noSanityChecks + -- L.decimal returns only positive ints + when (sanity && x >= n) $ fail ( "Value " ++ show x ++ "is out of bounds. (must be between 0 and " diff --git a/src/Copar/Functors/Distribution.hs b/src/Copar/Functors/Distribution.hs index 8b6f0dd8ed86b1c30c08dce178d58cf01a651005..d39e91dc5615b8c149f0ced89ab021ca5e5d0e64 100644 --- a/src/Copar/Functors/Distribution.hs +++ b/src/Copar/Functors/Distribution.hs @@ -18,6 +18,7 @@ import qualified Data.Text.Prettyprint.Doc as Doc import Data.Text.Prettyprint.Doc ((<+>)) import qualified Data.Text.Prettyprint.Doc.Util as Doc import Data.Text.Prettyprint.Doc.Render.Terminal as Doc +import Control.Monad.Extra (unlessM) import Data.Float.Utils (EqDouble) import Copar.Coalgebra.Parser @@ -69,8 +70,9 @@ instance ParseMorphism Distribution where parseMorphismPoint (Distribution inner) = do (f1, succs) <- parseMorphismPoint (GroupValued @EqDouble inner) - when (f1 /= 1) $ - fail "distribution: Sum of outgoing labels is not 1" + unlessM noSanityChecks $ + when (f1 /= 1) $ + fail "distribution: Sum of outgoing labels is not 1" return (f1, succs) diff --git a/src/Copar/Functors/GroupValued.hs b/src/Copar/Functors/GroupValued.hs index 437b6701e8e26291d12e5a3d96931112da0ff1e2..adc85a41bbfb936fee4a2afe03e9296bc47465f7 100644 --- a/src/Copar/Functors/GroupValued.hs +++ b/src/Copar/Functors/GroupValued.hs @@ -199,12 +199,19 @@ parseMorphismPointHelper :: (Num w, Ord x, MonadParser m) => m x -> m w + -> Bool -> m (w, Vector (x, w)) -parseMorphismPointHelper inner weightParser = do - !successors <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma) +parseMorphismPointHelper inner weightParser sanity = do + !successors <- case sanity of + True -> do + succs <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma) - when (V.hasDuplicates (fmap fst successors)) $ - fail "group valued: Duplicate edges" + when (V.hasDuplicates (fmap fst succs)) $ + fail "group valued: Duplicate edges" + + return succs + + False -> V.fromList <$> L.braces (edge `sepBy` L.comma) let !f1 = V.sum (V.map snd successors) return (f1, successors) @@ -212,22 +219,28 @@ parseMorphismPointHelper inner weightParser = do where edge = (,) <$> inner <*> (L.colon *> weightParser) {-# INLINE parseMorphismPointHelper #-} -{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 Int -> MorphParser l f1 (Int, Vector (Int, Int)) #-} -{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 EqDouble -> MorphParser l f1 (EqDouble, Vector (Int, EqDouble)) #-} +{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 Int -> Bool -> MorphParser l f1 (Int, Vector (Int, Int)) #-} +{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l f1 Int -> MorphParser l f1 EqDouble -> Bool -> MorphParser l f1 (EqDouble, Vector (Int, EqDouble)) #-} instance ParseMorphism (GroupValued Int) where - parseMorphismPoint (GroupValued inner) = parseMorphismPointHelper inner (L.signed L.decimal) + parseMorphismPoint (GroupValued inner) = + parseMorphismPointHelper inner (L.signed L.decimal) + =<< (not <$> noSanityChecks) instance ParseMorphism (GroupValued EqDouble) where - parseMorphismPoint (GroupValued inner) = parseMorphismPointHelper inner (L.signed L.adouble) + parseMorphismPoint (GroupValued inner) = + parseMorphismPointHelper inner (L.signed L.adouble) + =<< (not <$> noSanityChecks) instance ParseMorphism (GroupValued OrderedComplex) where parseMorphismPoint (GroupValued inner) = parseMorphismPointHelper inner (OrderedComplex <$> L.complex L.adouble) + =<< (not <$> noSanityChecks) instance ParseMorphism (GroupValued Rational) where parseMorphismPoint (GroupValued inner) = parseMorphismPointHelper inner (toRational <$> (L.signed L.float)) + =<< (not <$> noSanityChecks) instance (IsGroupF3 m, Ord m, Num m) => RefinementInterface (GroupValued m) where {-# SPECIALIZE instance RefinementInterface (GroupValued Int) #-} diff --git a/src/Copar/Functors/MonoidValued.hs b/src/Copar/Functors/MonoidValued.hs index 9c62839ee7a5ba38383e894460229a4db3097510..7ea786df958681c1fe7b1388825a683b1c64bca3 100644 --- a/src/Copar/Functors/MonoidValued.hs +++ b/src/Copar/Functors/MonoidValued.hs @@ -163,20 +163,30 @@ sumCounts = M.foldlWithKey' (\a x -> (<> a) . multiply x) mempty instance ParseMorphism (SlowMonoidValued (Max Int)) where - parseMorphismPoint (SlowMonoidValued inner) = parseMorphismPointHelper inner (Max <$> (L.signed L.decimal)) + parseMorphismPoint (SlowMonoidValued inner) = + parseMorphismPointHelper inner (Max <$> (L.signed L.decimal)) + =<< (not <$> noSanityChecks) instance ParseMorphism (SlowMonoidValued MaxDouble) where - parseMorphismPoint (SlowMonoidValued inner) = parseMorphismPointHelper inner (MaxDouble <$> L.signed L.float) + parseMorphismPoint (SlowMonoidValued inner) = + parseMorphismPointHelper inner (MaxDouble <$> L.signed L.float) + =<< (not <$> noSanityChecks) -parseMorphismPointHelper :: (MonadParser m, Ord x, Monoid w) => m x -> m w -> m (w, V.Vector (x, w)) -parseMorphismPointHelper inner weightParser = do - !successors <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma) +parseMorphismPointHelper :: (MonadParser m, Ord x, Monoid w) => m x -> m w -> Bool -> m (w, V.Vector (x, w)) +parseMorphismPointHelper inner weightParser sanity = do + !successors <- case sanity of + True -> do + succs <- V.sortOn fst . V.fromList <$> L.braces (edge `sepBy` L.comma) - when (V.hasDuplicates (fmap fst successors)) - $ fail "monoid valued: Duplicate edges" + when (V.hasDuplicates (fmap fst succs)) $ + fail "monoid valued: Duplicate edges" - let !f1 = fold (V.map snd successors) - return (f1, successors) - where edge = (,) <$> inner <*> (L.colon *> weightParser) + return succs + + False -> V.fromList <$> L.braces (edge `sepBy` L.comma) + + let !f1 = fold (V.map snd successors) + return (f1, successors) + where edge = (,) <$> inner <*> (L.colon *> weightParser) diff --git a/src/Copar/Functors/Polynomial.hs b/src/Copar/Functors/Polynomial.hs index 2baeca831060a184ec33affdad849c166e692502..ddafea27605a8ab49a4a109ac33125be3c493591 100644 --- a/src/Copar/Functors/Polynomial.hs +++ b/src/Copar/Functors/Polynomial.hs @@ -266,8 +266,10 @@ instance ParseMorphism Polynomial where -- | Parse either a single product or an injection into the coproduct, depending -- on the number of co-factors. -parseSum1 :: - MonadParser m => Sum (m a) -> m (F1 Polynomial, Vector (a, Label Polynomial)) +parseSum1 + :: (MonadParser m, HasSanityChecks m) + => Sum (m a) + -> m (F1 Polynomial, Vector (a, Label Polynomial)) parseSum1 sum@(Sum (product :| [])) = do -- only a single summand => parse product directly @@ -275,21 +277,27 @@ parseSum1 sum@(Sum (product :| [])) = do -- that fails. -- This avoids strange situations where a constant calle 'inj' exists and the -- input starts with inj. - (try parseSumPrefix >>= parseSum sum) <|> - (first (uncurry (PolyF1 0)) <$> parseProduct1 product) -parseSum1 other = parseSumPrefix >>= parseSum other -- otherwise, require 'inj' - <?> "coproduct injection" + (try parseSumPrefix >>= parseSum sum) + <|> (first (uncurry (PolyF1 0)) <$> parseProduct1 product) +parseSum1 other = + parseSumPrefix + >>= parseSum other -- otherwise, require 'inj' + <?> "coproduct injection" -- | parses @inj i@ where @i@ is a decimal integer parseSumPrefix :: MonadParser m => m Int parseSumPrefix = L.symbol "inj" *> L.decimal -- | Parse an injection into the coproduct with the syntax 'inj i _' -parseSum :: - MonadParser m => Sum (m a) -> Int -> m (F1 Polynomial, Vector (a, Label Polynomial)) +parseSum + :: (MonadParser m, HasSanityChecks m) + => Sum (m a) + -> Int + -> m (F1 Polynomial, Vector (a, Label Polynomial)) parseSum (Sum summands) i = do - when (i < 0 || i >= length summands) $ - fail ("polynomial: injection " ++ show i ++ " is out of bounds") + sanity <- not <$> noSanityChecks + when (sanity && (i < 0 || i >= length summands)) + $ fail ("polynomial: injection " ++ show i ++ " is out of bounds") (f1, successors) <- parseProduct1 (summands NonEmpty.!! i) @@ -298,17 +306,19 @@ parseSum (Sum summands) i = do ----------- Products parser -- | Parse either a single factor without parens or a tuple. -parseProduct1 :: - MonadParser m => Product (m a) -> m ((Int, Vector Int), Vector (a, Label Polynomial)) +parseProduct1 + :: (MonadParser m, HasSanityChecks m) + => Product (m a) + -> m ((Int, Vector Int), Vector (a, Label Polynomial)) parseProduct1 product@(Product (factor :| [])) = let mkProduct = either (\i -> ((0, V.singleton i), V.empty)) (\v -> ((length v, V.empty), v)) - in (mkProduct <$> parseFactor factor) <|> parseProduct product + in (mkProduct <$> parseFactor factor) <|> parseProduct product parseProduct1 other = parseProduct other parseProduct - :: MonadParser m + :: (MonadParser m, HasSanityChecks m) => Product (m a) -> m ((Int, Vector Int), Vector (a, Label Polynomial)) parseProduct (Product l@(f :| fs)) = @@ -330,7 +340,10 @@ parseProduct (Product l@(f :| fs)) = ----------- Factor parser -parseFactor :: MonadParser m => Factor (m a) -> m (Either Int (Vector (a, Int))) +parseFactor + :: (MonadParser m, HasSanityChecks m) + => Factor (m a) + -> m (Either Int (Vector (a, Int))) parseFactor (Const (ExplicitSet names)) = do !f1 <- Left <$> someName names return f1 -- const has no successors @@ -341,30 +354,39 @@ parseFactor (Const NatSet) = do x <- L.decimal <?> "natural number" return (Left x) parseFactor (Const (FiniteNatSet n)) = do - x <- L.decimal <?> ("natural number small than " ++ show n) - unless (x < n) $ - fail ("out of range constant: " ++ show x ++ - "(must be between 0 and " ++ show n ++ ")") + x <- L.decimal <?> ("natural number small than " ++ show n) + sanity <- not <$> noSanityChecks + when (sanity && x >= n) $ fail + ( "out of range constant: " + ++ show x + ++ "(must be between 0 and " + ++ show n + ++ ")" + ) return (Left x) parseFactor (Identity inner) = do successor <- inner return (Right (V.singleton (successor, 0))) parseFactor (Exponential inner exp) = L.braces $ do - successors <- V.sortOn snd . V.fromList <$> - (flip (,) <$> parseExpValue exp - <*> (L.colon *> inner)) + sanity <- not <$> noSanityChecks + + successors <- + (if sanity then V.sortOn snd else id) + . V.fromList + <$> (flip (,) <$> parseExpValue exp <*> (L.colon *> inner)) `sepBy` L.comma - unless (allExpValues exp == (V.map snd successors)) $ - fail ("exponential: map must be well-defined on " ++ showExp exp) + when (sanity && allExpValues exp /= (V.map snd successors)) + $ fail ("exponential: map must be well-defined on " ++ showExp exp) return (Right successors) -parseExpValue :: MonadParser m => Exponent -> m Int +parseExpValue :: (MonadParser m, HasSanityChecks m) => Exponent -> m Int parseExpValue (ExplicitExp names) = someName names parseExpValue (FiniteNatExp n) = do x <- L.decimal - unless (x < n) $ -- L.decimal returns only positive ints + sanity <- not <$> noSanityChecks + when (sanity && x >= n) $ -- L.decimal returns only positive ints fail ("Value " ++ show x ++ "is out of bounds. (must be between 0 and " ++ show n ++ ")") return x diff --git a/src/Copar/Functors/Powerset.hs b/src/Copar/Functors/Powerset.hs index 79b9a1b281a3b8723002cd4f0b47a0ff732ed461..c7f51db0846efe0ea910cda9204a23c3a45820ae 100644 --- a/src/Copar/Functors/Powerset.hs +++ b/src/Copar/Functors/Powerset.hs @@ -85,10 +85,17 @@ type instance F3 Powerset = PowerF3 instance ParseMorphism Powerset where parseMorphismPoint (Powerset inner) = do - successors <- V.sort . V.fromList <$> L.braces (inner `sepBy` L.comma) + successors' <- L.braces (inner `sepBy` L.comma) + sanity <- not <$> noSanityChecks - when (V.hasDuplicates successors) $ - fail "powerset: Duplicate edges" + !successors <- case sanity of + True -> do + let succs = V.sort (V.fromList successors') + when (V.hasDuplicates succs) $ + fail "powerset: Duplicate edges" + return succs + + False -> return (V.fromList successors') let f1 = not (null successors) diff --git a/src/Copar/Parser.hs b/src/Copar/Parser.hs index 55e362c192cdcb7212aa949a9a8f051687ce96bb..83e9c0d79c0e11749d60bfc6092cbf5887c7dab7 100644 --- a/src/Copar/Parser.hs +++ b/src/Copar/Parser.hs @@ -1,14 +1,26 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} +-- | High-level API for the various parsers. +-- +-- This module combines the different parsers (functor, coalgebra) and exposes a +-- high level API to parse the complete input for CoPaR. This is the parser API +-- that should be used in the main function and high-level tests. module Copar.Parser - ( parseCoalgebra + ( -- * IO Parsers + readFile + , readStdin + -- * Pure Parsers + , parseCoalgebra , parseFunctor - , readCoalgebraFromFile - , readCoalgebraFromStdin + -- * Parser Configuration + , Config(..) + , defaultConfig , ApplyFunctorTransformations(..) + , SanityChecks(..) ) where +import Prelude hiding ( readFile ) import Data.Bifunctor import Data.Proxy import qualified Data.List.NonEmpty as E @@ -46,7 +58,9 @@ functorExpressionParser varReplacement functors = do replaceVar other = other --- wether to apply transformations stored in the AST +-- | Whether to apply transformations on the parsed functor expression. These +-- transformations can e.g replace certain functors with more efficient ones or +-- optimize the expression in other ways. data ApplyFunctorTransformations = ApplyTransformations | DontApplyTransformations @@ -55,19 +69,21 @@ coalgebraParser (FunctorExpression SomeFunctor Precedence, [[FunctorParser SomeFunctor]]) (FunctorExpression SomeFunctor Sort) -> ApplyFunctorTransformations + -> SanityChecks -> Parser ( SymbolTable , Encoding (Label (Desorted SomeFunctor)) (F1 (Desorted SomeFunctor)) ) -coalgebraParser functor transPolicy = do +coalgebraParser functor transPolicy sanity = do L.space *> L.newlines f <- case functor of Left (varReplacement, functors) -> functorExpressionParser varReplacement functors <* L.newlines1 Right f' -> return f' - morphismsParser (transformFunctor f) <?> "morphism definition" + morphismsParser (transformFunctor f) sanity + <?> "morphism definition" where transformFunctor = case transPolicy of ApplyTransformations -> applyFunctorRewrites @@ -77,7 +93,17 @@ coalgebraParser functor transPolicy = do -- TODO: Needs better name type TheFunctor = Desorted SomeFunctor -parseFunctor :: String -> Text -> Either String (FunctorExpression SomeFunctor Sort) +-- | Parse functor expression from text. +-- +-- The functor expression contains 'SomeFunctor's, which in turn can wrap any of +-- the registered functors. +-- +-- It returns either an error message or the resulting (sorted) functor +-- expression. +parseFunctor + :: String -- ^ Name of the input (filename, etc) + -> Text -- ^ Input text + -> Either String (FunctorExpression SomeFunctor Sort) parseFunctor name input = let identity = Functor @@ -93,32 +119,81 @@ parseFunctor name input = functorParsers = map (map functorExprParser) registeredFunctors -parseCoalgebra :: - Maybe (FunctorExpression SomeFunctor Sort) - -> ApplyFunctorTransformations - -> String - -> Text - -> Either String ( Proxy TheFunctor - , (SymbolTable, Encoding (Label TheFunctor) (F1 TheFunctor))) -parseCoalgebra functor transPolicy name input = - let identity = - Functor - (Precedence 0) - (SomeFunctor - (Polynomial - (Sum (E.fromList [Product (E.fromList [Identity Variable])])))) - eitherFunctor = maybe (Left (identity, functorParsers)) Right functor - in bimap +-- | Options for coalgebra parsing. +data Config = Config + { -- | Controls whether to apply functor transformations. See + -- 'ApplyTransformations' for details. + functorTransforms :: ApplyFunctorTransformations + -- | Controls sanity checks during parsing. Disabling them can make the + -- parser faster but fail horribly if the input is not correct. + , sanityChecks :: SanityChecks + -- | The functor for the coalgebra. If this is @Nothing@ (the default), the + -- functor expression will be read from the first non-comment line of the + -- input. + , functor :: Maybe (FunctorExpression SomeFunctor Sort) + } + + +-- | Default config: Apply functor transforms, enable sanity checks and read +-- functor from input file. +defaultConfig :: Config +defaultConfig = Config + { functorTransforms = ApplyTransformations + , sanityChecks = EnableSanityChecks + , functor = Nothing + } + + +-- | Parse a coalgebra from text. +-- +-- If the parser configuration specifies a functor expression, this functor is +-- used to parse the coalgebra. Otherwise, a functor expression is read from the +-- first non-comment line in the input. +-- +-- The returned value is either an error message, or as follows: +-- +-- - A proxy for the type of the functor. This is always @Desorted +-- SomeFunctor@ but can be used to conveniently pass the proxy to functions +-- that require the type as input. +-- - A symbol table, mapping the names of all states in sort 1 to their +-- numerical id. +-- - The coalgebra encoding. +parseCoalgebra + :: Config -- ^ Parser configuration + -> String -- ^ Name of the input (filename, etc) + -> Text -- ^ Input text + -> Either + String + ( Proxy TheFunctor + , (SymbolTable, Encoding (Label TheFunctor) (F1 TheFunctor)) + ) +parseCoalgebra config name input = + let identity = Functor + (Precedence 0) + (SomeFunctor + (Polynomial + (Sum (E.fromList [Product (E.fromList [Identity Variable])])) + ) + ) + eitherFunctor = + maybe (Left (identity, functorParsers)) Right (functor config) + in bimap errorBundlePretty (Proxy, ) - (parse (coalgebraParser eitherFunctor transPolicy) name input) - where - functorParsers = map (map functorExprParser) registeredFunctors - - -readCoalgebraFromFile - :: Maybe (FunctorExpression SomeFunctor Sort) - -> ApplyFunctorTransformations + (parse + (coalgebraParser eitherFunctor + (functorTransforms config) + (sanityChecks config) + ) + name + input + ) + where functorParsers = map (map functorExprParser) registeredFunctors + + +-- | Read coalgebra from file. See 'parseCoalgebra' for details. +readFile + :: Config -> FilePath -> IO ( Either @@ -127,14 +202,14 @@ readCoalgebraFromFile , (SymbolTable, Encoding (Label TheFunctor) (F1 TheFunctor)) ) ) -readCoalgebraFromFile functor transPolicy filename = do +readFile config filename = do content <- T.readFile filename - return $ parseCoalgebra functor transPolicy filename content + return $ parseCoalgebra config filename content -readCoalgebraFromStdin - :: Maybe (FunctorExpression SomeFunctor Sort) - -> ApplyFunctorTransformations +-- | Read coalgebra from stdin. See 'parseCoalgebra' for details. +readStdin + :: Config -> IO ( Either String @@ -142,6 +217,6 @@ readCoalgebraFromStdin , (SymbolTable, Encoding (Label TheFunctor) (F1 TheFunctor)) ) ) -readCoalgebraFromStdin functor transPolicy = do +readStdin config = do content <- T.getContents - return $ parseCoalgebra functor transPolicy "(stdin)" content + return $ parseCoalgebra config "(stdin)" content diff --git a/src/main/Main.hs b/src/main/Main.hs index 6e0be15ada43c9882400ac1ef0a8b3b09d010fce..92725aff4b7312abb83cccc04b27e76770d8e268 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -37,7 +37,7 @@ import Text.JSON import Text.Show.Pretty (pPrint) import Copar.Algorithm -import Copar.Parser +import qualified Copar.Parser as P import Copar.PartitionPrinter import Copar.Functors import Copar.FunctorDescription @@ -106,6 +106,7 @@ data RefineOptions = RefineOptions , refineStatsJson :: Bool , refineFunctor :: Maybe (FunctorExpression SomeFunctor Sort) , refineApplyTransformations :: Bool + , refineEnableSanity :: Bool , refineInputFile :: Maybe FilePath , refineOutputFile :: Maybe FilePath } @@ -178,6 +179,13 @@ refineOptions = do "Don't try to optimize functor expression. \ \This flag can drastically *reduce* performace." ) + refineEnableSanity <- not <$> switch + ( long "no-sanity-checks" + <> help + "Disable sanity checks in the parser. Do not use this lightly. It \ + \might speed up the parser but require the input to be absolutely \ + \correct. Otherwise, nasal demons might be created." + ) pure RefineOptions { .. } data GraphOptions = GraphOptions @@ -256,7 +264,7 @@ graphOptions = do pure GraphOptions { .. } functorReader :: ReadM (FunctorExpression SomeFunctor Sort) -functorReader = eitherReader (\input -> parseFunctor input (T.pack input)) +functorReader = eitherReader (\input -> P.parseFunctor input (T.pack input)) data HelpCommand = HelpListFunctors @@ -335,17 +343,10 @@ finalizeStats stats = -- File handling ---------------------------------------------------------------------- -readCoalgebra - :: Maybe (FunctorExpression SomeFunctor Sort) - -> ApplyFunctorTransformations - -> Maybe FilePath - -> IO _ -readCoalgebra functor transPolicy Nothing = - readCoalgebraFromStdin functor transPolicy -readCoalgebra functor transPolicy (Just "-") = - readCoalgebraFromStdin functor transPolicy -readCoalgebra functor transPolicy (Just file) = - readCoalgebraFromFile functor transPolicy file +readCoalgebra :: P.Config -> Maybe FilePath -> IO _ +readCoalgebra config Nothing = P.readStdin config +readCoalgebra config (Just "-" ) = P.readStdin config +readCoalgebra config (Just file) = P.readFile config file outputPartition :: Maybe FilePath -> _ outputPartition Nothing = printPartition @@ -390,10 +391,20 @@ main = do (f, (symbolTable, encoding)) <- withTimeStat stats "parse-duration" $ do let transPolicy = if (refineApplyTransformations r) - then ApplyTransformations - else DontApplyTransformations + then P.ApplyTransformations + else P.DontApplyTransformations + + let sanity = if (refineEnableSanity r) + then P.EnableSanityChecks + else P.DisableSanityChecks - readCoalgebra (refineFunctor r) transPolicy (refineInputFile r) + let parserConfig = P.Config + { functorTransforms = transPolicy + , sanityChecks = sanity + , functor = (refineFunctor r) + } + + readCoalgebra parserConfig (refineInputFile r) >>= \case Left err -> hPutStrLn stderr err >> exitFailure Right res -> evaluate $ res @@ -447,10 +458,15 @@ main = do (GraphCommand r) -> do (f, (symbolTable, encoding)) <- do let transPolicy = if (graphApplyTransformations r) - then ApplyTransformations - else DontApplyTransformations + then P.ApplyTransformations + else P.DontApplyTransformations + + let parserConfig = P.defaultConfig + { P.functorTransforms = transPolicy + , P.functor = graphFunctor r + } - readCoalgebra (graphFunctor r) transPolicy (graphInputFile r) >>= \case + readCoalgebra parserConfig (graphInputFile r) >>= \case Left err -> hPutStrLn stderr err >> exitFailure Right res -> evaluate $ res diff --git a/tests/Copar/Coalgebra/ParserSpec.hs b/tests/Copar/Coalgebra/ParserSpec.hs index 2f42bded8684e988e685aac805a7992110ab7593..12093d273452a9195472308d31ca41c37d46835e 100644 --- a/tests/Copar/Coalgebra/ParserSpec.hs +++ b/tests/Copar/Coalgebra/ParserSpec.hs @@ -91,7 +91,7 @@ parseMorphismsSpec = describe "parseMorphisms" $ do Right [ (Sorted 1 (SomeF1 ("a" :: Text))), (Sorted 2 (SomeF1 ("a" :: Text))) ] context "the symbol table" $ do - let p x = fromSymbolTable . fst <$> parseMorphisms (Functor 1 (P Variable)) "" x + let p x = fromSymbolTable . fst <$> parseMorphisms (Functor 1 (P Variable)) EnableSanityChecks "" x it "contains the defined symbols" $ do (HM.elems <$> p "a: []\nb: []\nc: []") `shouldParse` ["a", "b", "c"] @@ -191,7 +191,7 @@ instance ParseMorphism SomeFunctor where parsing :: (Functor f, ParseMorphism f) => FunctorExpression f Sort -> Text -> Either (ParseErrorBundle Text Void) (Encoding (Sorted (Label f)) (Sorted (F1 f))) -parsing expr = fmap snd . parseMorphisms expr "" +parsing expr = fmap snd . parseMorphisms expr EnableSanityChecks "" encoding :: [f1] -> [(Int, l, Int)] -> Encoding l f1 diff --git a/tests/Copar/Functors/AbsorbingPolynomialSpec.hs b/tests/Copar/Functors/AbsorbingPolynomialSpec.hs index 9fa9c574274e01492b0beac4f0a6d5407de52847..3c2debbf83dfb9607dab7a3d6d80cc1c659cbb94 100644 --- a/tests/Copar/Functors/AbsorbingPolynomialSpec.hs +++ b/tests/Copar/Functors/AbsorbingPolynomialSpec.hs @@ -60,7 +60,7 @@ removeSomeFunctor = bimap (fmap processLabels) (fmap processF1) parseMorphismPointSpec :: Spec parseMorphismPointSpec = describe "parseMorphismPoint" $ do let morphp fexpr input = - (removeSomeFunctor . snd) <$> parseMorphisms (Functor 1 fexpr) "" input + (removeSomeFunctor . snd) <$> parseMorphisms (Functor 1 fexpr) EnableSanityChecks "" input it "parses a constant" $ do morphp (mkPoly [[c ["a", "b", "c"]]]) "x: inj 0 (a)" @@ -223,7 +223,7 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do refineSpec :: Spec refineSpec = describe "refining" $ do - let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input + let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) EnableSanityChecks "" input it "distinguishes constants" $ do let Right enc = diff --git a/tests/Copar/Functors/BagSpec.hs b/tests/Copar/Functors/BagSpec.hs index e76fb2c14a81fcc3cfe293812b0ba9a5b39a108d..09490d01e73b1d6729127ac21ec74f9c189a34d4 100644 --- a/tests/Copar/Functors/BagSpec.hs +++ b/tests/Copar/Functors/BagSpec.hs @@ -36,19 +36,25 @@ functorExpressionSpec = describe "functorExpression" $ do parseMorphismPointSpec :: Spec parseMorphismPointSpec = describe "parseMorphismPoint" $ do - it "works for a simple example" $ - (snd <$> parseMorphisms (Functor 1 (Bag Variable)) "" "x: {x,x}") - `shouldParse` - (encoding [(Sorted 1 2)] [(0, (Sorted 1 1), 0), (0, (Sorted 1 1), 0)]) + it "works for a simple example" + $ (snd <$> parseMorphisms (Functor 1 (Bag Variable)) + EnableSanityChecks + "" + "x: {x,x}" + ) + `shouldParse` (encoding [(Sorted 1 2)] + [(0, (Sorted 1 1), 0), (0, (Sorted 1 1), 0)] + ) refineSpec :: Spec refineSpec = describe "refining" $ do let f = Functor 1 (Bag Variable) - it "distinguishes points with different successor count" $ - let Right (_, enc) = parseMorphisms f "" "x: {x, x, y}\ny: {x, y}" - in stToIO (refine (Proxy @(Desorted Bag)) enc) `shouldReturn` - (Part.fromBlocks [[0], [1]]) + it "distinguishes points with different successor count" + $ let Right (_, enc) = + parseMorphisms f EnableSanityChecks "" "x: {x, x, y}\ny: {x, y}" + in stToIO (refine (Proxy @(Desorted Bag)) enc) + `shouldReturn` (Part.fromBlocks [[0], [1]]) -- FIXME: Remove duplicate definition of this function encoding :: [f1] -> [(Int, l, Int)] -> Encoding l f1 diff --git a/tests/Copar/Functors/DistributionSpec.hs b/tests/Copar/Functors/DistributionSpec.hs index c2c4f17a96339e4a7cc84ff68217df14f19fd2a0..8514d43edebe384d208e241a0569d5789f284227 100644 --- a/tests/Copar/Functors/DistributionSpec.hs +++ b/tests/Copar/Functors/DistributionSpec.hs @@ -41,6 +41,7 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do (snd <$> parseMorphisms (Functor 1 (Distribution Variable)) + EnableSanityChecks "" "x: {x: 0.5, y: 0.5}\ny: {x: 1.0}") `shouldParse` encoding @@ -48,11 +49,12 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do [(1, (Sorted 1 1), 0), (0, (Sorted 1 0.5), 0), (0, (Sorted 1 0.5), 1)] it "errors if edge weight sum isn't 1" $ - parseMorphisms (Functor 1 (Distribution Variable)) "" `shouldFailOn` + parseMorphisms (Functor 1 (Distribution Variable)) EnableSanityChecks "" + `shouldFailOn` "x: {x: 0.5}" it "uses approximate comparison for doubles" $ - parseMorphisms (Functor 1 (Distribution Variable)) "" `shouldSucceedOn` + parseMorphisms (Functor 1 (Distribution Variable)) EnableSanityChecks "" `shouldSucceedOn` "s0: {s0: 0.1, s1: 0.1, s2: 0.1, s3: 0.1, s4: 0.1, s5: 0.1, s6: 0.1, s7: 0.1, s8: 0.1, s9: 0.1}\n\ \s1: {s1: 1.0}\n\ \s2: {s2: 1.0}\n\ @@ -69,7 +71,7 @@ refineSpec = describe "refining" $ do let f = Functor 1 (Distribution Variable) it "handles states with incoming edges greater than 1" $ do - let x = parseMorphisms f "" "x: {z: 1.0}\ny: {z: 1.0}\nz: {y: 1.0}" + let x = parseMorphisms f EnableSanityChecks "" "x: {z: 1.0}\ny: {z: 1.0}\nz: {y: 1.0}" x `shouldSatisfy` isRight let Right (_, enc) = x stToIO (refine (Proxy @(Desorted Distribution)) enc) `shouldReturn` Part.fromBlocks [[0, 1, 2]] diff --git a/tests/Copar/Functors/GroupValuedSpec.hs b/tests/Copar/Functors/GroupValuedSpec.hs index 384235ee8592c081473446c36d934739af446e0e..ac59b2bf3f889db3c55bd9329e78ae91041838af 100644 --- a/tests/Copar/Functors/GroupValuedSpec.hs +++ b/tests/Copar/Functors/GroupValuedSpec.hs @@ -28,7 +28,7 @@ spec = do parseMorphismPointIntSpec :: Spec parseMorphismPointIntSpec = describe "parseMorphismPoint (Int)" $ do - let p = fmap snd . parseMorphisms (Functor 1 (GroupValued @Int Variable)) "" + let p = fmap snd . parseMorphisms (Functor 1 (GroupValued @Int Variable)) EnableSanityChecks "" it "parses an empty successor list" $ p "x: {}" @@ -48,7 +48,7 @@ parseMorphismPointDoubleSpec :: Spec parseMorphismPointDoubleSpec = describe "parseMorphismPoint (Double)" $ do let p = - fmap snd . parseMorphisms (Functor 1 (GroupValued @EqDouble Variable)) "" + fmap snd . parseMorphisms (Functor 1 (GroupValued @EqDouble Variable)) EnableSanityChecks "" it "parses an empty successor list" $ p "x: {}" @@ -68,6 +68,7 @@ parseMorphismPointComplexSpec :: Spec parseMorphismPointComplexSpec = describe "parseMorphismPoint (Complex)" $ do let p = fmap snd . parseMorphisms (Functor 1 (GroupValued @OrderedComplex Variable)) + EnableSanityChecks "" it "parses an empty successor list" diff --git a/tests/Copar/Functors/MonoidValuedSpec.hs b/tests/Copar/Functors/MonoidValuedSpec.hs index 134faaee301a8cadbd467fd203d3323ddf4b1ec0..a95a2cfa056fe62d862cc928dc194348114c32d6 100644 --- a/tests/Copar/Functors/MonoidValuedSpec.hs +++ b/tests/Copar/Functors/MonoidValuedSpec.hs @@ -70,7 +70,7 @@ maxIntParseSpec = describe "maxInt parsing" $ do let p = fmap snd - . parseMorphisms (Functor 1 (SlowMonoidValued @(Max Int) Variable)) "" + . parseMorphisms (Functor 1 (SlowMonoidValued @(Max Int) Variable)) EnableSanityChecks "" it "parses an empty successor list" $ p "x: {}" @@ -89,7 +89,7 @@ maxIntParseSpec = describe "maxInt parsing" $ do maxIntRefineSpec :: Spec maxIntRefineSpec = describe "maxInt refine" $ do let p = fmap snd - . parseMorphisms (Functor 1 (SlowMonoidValued @(Max Int) Variable)) "" + . parseMorphisms (Functor 1 (SlowMonoidValued @(Max Int) Variable)) EnableSanityChecks "" proxy = Proxy @(Desorted (SlowMonoidValued (Max Int))) it "it distinguishes different maximas with equal sums" $ do @@ -130,7 +130,7 @@ maxRealParseSpec = describe "maxReal parsing" $ do let p = fmap snd - . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) "" + . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) EnableSanityChecks "" it "parses an empty successor list" $ p "x: {}" @@ -149,7 +149,7 @@ maxRealParseSpec = describe "maxReal parsing" $ do maxRealRefineSpec :: Spec maxRealRefineSpec = describe "maxReal refine" $ do let p = fmap snd - . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) "" + . parseMorphisms (Functor 1 (SlowMonoidValued @MaxDouble Variable)) EnableSanityChecks "" proxy = Proxy @(Desorted (SlowMonoidValued MaxDouble)) it "it distinguishes different maximas with equal sums" $ do diff --git a/tests/Copar/Functors/PolynomialSpec.hs b/tests/Copar/Functors/PolynomialSpec.hs index 448b05a9fd13d12b09262e26c6c0555861a01f06..40dc602b5220400347c8d106f8774a37616d5bc1 100644 --- a/tests/Copar/Functors/PolynomialSpec.hs +++ b/tests/Copar/Functors/PolynomialSpec.hs @@ -191,7 +191,7 @@ e inner = Exponential inner . ExplicitExp . V.fromList parseMorphismPointSpec :: Spec parseMorphismPointSpec = describe "parseMorphismPoint" $ do - let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input + let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) EnableSanityChecks "" input it "parses a constant" $ do morphp (mkPoly [[c ["a", "b", "c"]]]) "x: inj 0 (a)" `shouldParse` @@ -337,7 +337,7 @@ parseMorphismPointSpec = describe "parseMorphismPoint" $ do refineSpec :: Spec refineSpec = describe "refining" $ do - let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) "" input + let morphp fexpr input = snd <$> parseMorphisms (Functor 1 fexpr) EnableSanityChecks "" input it "distinguishes constants" $ do let Right enc = morphp (mkPoly [[c ["a", "b"]]]) "x: inj 0 (a)\ny: inj 0 (b)" diff --git a/tests/Copar/Functors/PowersetSpec.hs b/tests/Copar/Functors/PowersetSpec.hs index 6d79180eac92a45d4e7c53ca938012d25f84fdeb..1543792a0386240475f23f4f6da3a2a85716fd60 100644 --- a/tests/Copar/Functors/PowersetSpec.hs +++ b/tests/Copar/Functors/PowersetSpec.hs @@ -20,13 +20,13 @@ spec = do parseMorphismPointSpec :: Spec parseMorphismPointSpec = describe "parseMorphismPoint" $ do it "works for a simple example" $ - (snd <$> parseMorphisms (Functor 1 (Powerset Variable)) "" "x: {x, y}\ny: {}") `shouldParse` + (snd <$> parseMorphisms (Functor 1 (Powerset Variable)) EnableSanityChecks "" "x: {x, y}\ny: {}") `shouldParse` (encoding [(Sorted 1 True), (Sorted 1 False)] [(0, (Sorted 1 ()), 0), (0, (Sorted 1 ()), 1)]) it "errors on duplicate edges" $ - parseMorphisms (Functor 1 (Powerset Variable)) "" `shouldFailOn` "x: {x, x}" + parseMorphisms (Functor 1 (Powerset Variable)) EnableSanityChecks "" `shouldFailOn` "x: {x, x}" -- FIXME: Remove duplicate definition of this function encoding :: [f1] -> [(Int, l, Int)] -> Encoding l f1 diff --git a/tests/Examples.hs b/tests/Examples.hs index 904e4584e880d9c8ff24977945621d08d487726f..de13d56f94c988a22e58ff53009a82f41666f1a3 100644 --- a/tests/Examples.hs +++ b/tests/Examples.hs @@ -11,7 +11,7 @@ import System.Directory import Test.Hspec import Copar.Algorithm -import Copar.Parser +import qualified Copar.Parser as P import Copar.PartitionPrinter main :: IO () @@ -39,8 +39,9 @@ testFile outfile = -- | FIXME: Run each example twice, once with and once without transformations. process :: FilePath -> IO String process file = - readCoalgebraFromFile Nothing ApplyTransformations file >>= \case - Left err -> return err - Right (f, (symTab, enc)) -> do - partition <- stToIO (refine f enc) - return $ T.unpack (showPartition enc symTab partition) + P.readFile P.defaultConfig file + >>= \case + Left err -> return err + Right (f, (symTab, enc)) -> do + partition <- stToIO (refine f enc) + return $ T.unpack (showPartition enc symTab partition)