Commit 0ecefd6d authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Add flag to disable sanity checks in parser

Adds a flag to the coalgebra parser that allows individual parsers to
disable all sanity checks on the input.
parent e34d5e0c
......@@ -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 =
......
......@@ -11,6 +11,7 @@ module Copar.Coalgebra.Parser
, morphismsParser
, SymbolTable(..)
, module Copar.Coalgebra.Parser.Class
, noSanityChecks
) where
import Control.Monad (void, forM_)
......@@ -39,6 +40,16 @@ import qualified Copar.Parser.Lexer as L
import Copar.Parser.Types
import Copar.Coalgebra.Parser.Class
-- | 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 :: MorphParser l f1 Bool
noSanityChecks = use disableSanity
newState :: MorphParser l f1 State
newState = nextState <<%= succ
{-# INLINE newState #-}
......@@ -93,13 +104,20 @@ finalizeState state =
, bimap (mkDesortedLabel @f) id (Encoding.new f1Vec edges)
)
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 +137,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)
......
......@@ -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
}
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
......@@ -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]]
......
......@@ -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"
......
......@@ -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
......
......@@ -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)"
......
......@@ -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
......
......@@ -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)
readCoalgebraFromFile Nothing ApplyTransformations EnableSanityChecks file
>>= \case
Left err -> return err
Right (f, (symTab, enc)) -> do
partition <- stToIO (refine f enc)
return $ T.unpack (showPartition enc symTab partition)
Markdown is supported
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