content: {-# LANGUAGE DeriveGeneric, TypeFamilies, DataKinds, RankNTypes #-}
  {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
  module Test.Language.Souffle.MarshalSpec
    ( module Test.Language.Souffle.MarshalSpec
    ) where
  
  import Test.Hspec
  import Test.Hspec.Hedgehog
  import qualified Hedgehog.Gen as Gen
  import qualified Hedgehog.Range as Range
  import GHC.Generics
  import qualified Data.Text as T
  import qualified Data.Text.Lazy as TL
  import Data.Text
  import Data.Int
  import Data.Word
  import Data.Maybe ( fromJust )
  import Control.Monad.IO.Class ( liftIO )
  import Control.Monad
  import Language.Souffle.Marshal
  import qualified Language.Souffle.Marshal as Souffle
  import qualified Language.Souffle.Class as Souffle
  import qualified Language.Souffle.Compiled as Compiled
  import qualified Language.Souffle.Interpreted as Interpreted
  import Data.String (IsString)
  import Data.Void (Void)
  
  
  data Edge = Edge String String
    deriving stock (Eq, Show, Generic)
  
  newtype EdgeUInt = EdgeUInt Word32
    deriving stock (Eq, Show, Generic)
  
  newtype FloatValue = FloatValue Float
    deriving stock (Eq, Show, Generic)
  
  data EdgeStrict = EdgeStrict !String !String
    deriving stock (Eq, Show, Generic)
  
  data EdgeUnpacked
    = EdgeUnpacked {-# UNPACK #-} !Int32 {-# UNPACK #-} !Int32
    deriving stock (Eq, Show, Generic)
  
  type Vertex = Text
  type Vertex' = Text
  
  data EdgeSynonyms = EdgeSynonyms Vertex Vertex
    deriving stock (Eq, Show, Generic)
  
  data EdgeMultipleSynonyms = EdgeMultipleSynonyms Vertex Vertex'
    deriving stock (Eq, Show, Generic)
  
  data EdgeMixed = EdgeMixed Text Vertex
    deriving stock (Eq, Show, Generic)
  
  data EdgeRecord
    = EdgeRecord
    { fromNode :: Text
    , toNode :: Text
    } deriving stock (Eq, Show, Generic)
  
  data IntsAndStrings = IntsAndStrings Text Int32 Text
    deriving stock (Eq, Show, Generic)
  
  data LargeRecord
    = LargeRecord Int32 Int32 Int32 Int32
    deriving stock (Eq, Show, Generic)
  
  newtype NestedNewtype = NestedNewtype LargeRecord
    deriving stock (Eq, Show, Generic)
  
  data Pair = Pair Int32 Int32
    deriving stock (Eq, Show, Generic)
  
  data NestedRecord = NestedRecord Pair Pair
    deriving stock (Eq, Show, Generic)
  
  instance Marshal Edge
  instance Marshal EdgeUInt
  instance Marshal FloatValue
  instance Marshal EdgeStrict
  instance Marshal EdgeUnpacked
  instance Marshal EdgeSynonyms
  instance Marshal EdgeMultipleSynonyms
  instance Marshal EdgeMixed
  instance Marshal EdgeRecord
  instance Marshal IntsAndStrings
  instance Marshal LargeRecord
  instance Marshal Pair
  instance Marshal NestedNewtype
  instance Marshal NestedRecord
  
  data RoundTrip = RoundTrip
  
  newtype StringFact = StringFact String
    deriving stock (Eq, Show, Generic)
  
  newtype TextFact = TextFact T.Text
    deriving stock (Eq, Show, Generic)
  
  newtype LazyTextFact = LazyTextFact TL.Text
    deriving stock (Eq, Show, Generic)
  
  newtype Int32Fact = Int32Fact Int32
    deriving stock (Eq, Show, Generic)
  
  newtype Word32Fact = Word32Fact Word32
    deriving stock (Eq, Show, Generic)
  
  newtype FloatFact = FloatFact Float
    deriving stock (Eq, Show, Generic)
  
  instance Souffle.Fact StringFact where
    type FactDirection StringFact = 'Souffle.InputOutput
    factName = const "string_fact"
  
  instance Souffle.Fact TextFact where
    type FactDirection TextFact = 'Souffle.InputOutput
    factName = const "string_fact"
  
  instance Souffle.Fact LazyTextFact where
    type FactDirection LazyTextFact = 'Souffle.InputOutput
    factName = const "string_fact"
  
  instance Souffle.Fact Int32Fact where
    type FactDirection Int32Fact = 'Souffle.InputOutput
    factName = const "number_fact"
  
  instance Souffle.Fact Word32Fact where
    type FactDirection Word32Fact = 'Souffle.InputOutput
    factName = const "unsigned_fact"
  
  instance Souffle.Fact FloatFact where
    type FactDirection FloatFact = 'Souffle.InputOutput
    factName = const "float_fact"
  
  instance Souffle.Fact NestedNewtype where
    type FactDirection NestedNewtype = 'Souffle.InputOutput
    factName = const "large_record"
  
  instance Souffle.Fact NestedRecord where
    type FactDirection NestedRecord = 'Souffle.InputOutput
    factName = const "large_record"
  
  instance Souffle.Marshal StringFact
  instance Souffle.Marshal TextFact
  instance Souffle.Marshal LazyTextFact
  instance Souffle.Marshal Int32Fact
  instance Souffle.Marshal Word32Fact
  instance Souffle.Marshal FloatFact
  
  instance Souffle.Program RoundTrip where
    type ProgramFacts RoundTrip =
      '[StringFact, TextFact, LazyTextFact, Int32Fact, Word32Fact, FloatFact, NestedNewtype, NestedRecord]
    programName = const "round_trip"
  
  type RoundTripAction
    = forall a. Souffle.Fact a
    => Souffle.ContainsInputFact RoundTrip a
    => Souffle.ContainsOutputFact RoundTrip a
    => Compiled.Submit a
    => a -> PropertyT IO a
  
  
  data EdgeCases = EdgeCases
  
  data EmptyStrings a
    = EmptyStrings a a Int32
    deriving stock (Eq, Show, Generic)
  
  newtype LongStrings a
    = LongStrings a
    deriving stock (Eq, Show, Generic)
  
  newtype Unicode a
    = Unicode a
    deriving stock (Eq, Show, Generic)
  
  data NoStrings a = NoStrings Word32 Int32 Float
    deriving stock (Eq, Show, Generic)
  
  instance Souffle.Program EdgeCases where
    type ProgramFacts EdgeCases =
      '[ EmptyStrings String, EmptyStrings T.Text, EmptyStrings TL.Text
      , LongStrings String, LongStrings T.Text, LongStrings TL.Text
      , Unicode String, Unicode T.Text, Unicode TL.Text
      , NoStrings Void
      ]
    programName = const "edge_cases"
  
  instance Souffle.Fact (EmptyStrings String) where
    type FactDirection (EmptyStrings String) = 'Souffle.InputOutput
    factName = const "empty_strings"
  instance Souffle.Fact (EmptyStrings T.Text) where
    type FactDirection (EmptyStrings T.Text) = 'Souffle.InputOutput
    factName = const "empty_strings"
  instance Souffle.Fact (EmptyStrings TL.Text) where
    type FactDirection (EmptyStrings TL.Text) = 'Souffle.InputOutput
    factName = const "empty_strings"
  
  instance Souffle.Fact (LongStrings String) where
    type FactDirection (LongStrings String) = 'Souffle.InputOutput
    factName = const "long_strings"
  instance Souffle.Fact (LongStrings T.Text) where
    type FactDirection (LongStrings T.Text) = 'Souffle.InputOutput
    factName = const "long_strings"
  instance Souffle.Fact (LongStrings TL.Text) where
    type FactDirection (LongStrings TL.Text) = 'Souffle.InputOutput
    factName = const "long_strings"
  
  instance Souffle.Fact (Unicode String) where
    type FactDirection (Unicode String) = 'Souffle.InputOutput
    factName = const "unicode"
  instance Souffle.Fact (Unicode T.Text) where
    type FactDirection (Unicode T.Text) = 'Souffle.InputOutput
    factName = const "unicode"
  instance Souffle.Fact (Unicode TL.Text) where
    type FactDirection (Unicode TL.Text) = 'Souffle.InputOutput
    factName = const "unicode"
  
  instance Souffle.Fact (NoStrings a) where
    type FactDirection (NoStrings _) = 'Souffle.InputOutput
    factName = const "no_strings"
  
  instance Marshal (EmptyStrings String)
  instance Marshal (EmptyStrings T.Text)
  instance Marshal (EmptyStrings TL.Text)
  instance Marshal (LongStrings String)
  instance Marshal (LongStrings T.Text)
  instance Marshal (LongStrings TL.Text)
  instance Marshal (Unicode String)
  instance Marshal (Unicode T.Text)
  instance Marshal (Unicode TL.Text)
  instance Marshal (NoStrings a)
  
  
  spec :: Spec
  spec = describe "Marshalling" $ parallel $ do
    describe "Auto-deriving marshalling code" $
      it "can generate code for all instances in this file" $
        -- If this file compiles, then the test has already passed
        42 `shouldBe` 42
  
    roundTripSpecs
    edgeCaseSpecs
  
  roundTripSpecs :: Spec
  roundTripSpecs = describe "data transfer between Haskell and Souffle" $ parallel $ do
    let roundTripTests :: RoundTripAction -> Spec
        roundTripTests run = do
          it "can serialize and deserialize String values" $ hedgehog $ do
            str <- forAll $ Gen.string (Range.linear 0 10) Gen.unicode
            let fact = StringFact str
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize lazy Text values" $ hedgehog $ do
            str <- forAll $ Gen.string (Range.linear 0 10) Gen.unicode
            let fact = LazyTextFact (TL.pack str)
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize strict Text values" $ hedgehog $ do
            str <- forAll $ Gen.text (Range.linear 0 10) Gen.unicode
            let fact = TextFact str
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize Int32 values" $ hedgehog $ do
            x <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            let fact = Int32Fact x
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize Word32 values" $ hedgehog $ do
            x <- forAll $ Gen.word32 (Range.linear minBound maxBound)
            let fact = Word32Fact x
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize Float values" $ hedgehog $ do
            let epsilon = 1e-6
                fmin = -1e9
                fmax =  1e9
            x <- forAll $ Gen.float (Range.exponentialFloat fmin fmax)
            let fact = FloatFact x
            FloatFact x' <- run fact
            (abs (x' - x) < epsilon) === True
  
          it "can serialize and deserialize newtypes" $ hedgehog $ do
            a <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            b <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            c <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            d <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            let fact = NestedNewtype $ LargeRecord a b c d
            fact' <- run fact
            fact === fact'
  
          it "can serialize and deserialize nested product types" $ hedgehog $ do
            a <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            b <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            c <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            d <- forAll $ Gen.int32 (Range.linear minBound maxBound)
            let fact = NestedRecord (Pair a b) (Pair c d)
            fact' <- run fact
            fact === fact'
  
  
    describe "interpreted mode" $ parallel $
      roundTripTests $ \fact -> liftIO $ Interpreted.runSouffle RoundTrip $ \handle -> do
        let prog = fromJust handle
        Interpreted.addFact prog fact
        Interpreted.run prog
        Prelude.head <$> Interpreted.getFacts prog
  
    describe "compiled mode" $ parallel $
      roundTripTests $ \fact -> liftIO $ Compiled.runSouffle RoundTrip $ \handle -> do
        let prog = fromJust handle
        Compiled.addFact prog fact
        Compiled.run prog
        Prelude.head <$> Compiled.getFacts prog
  
  edgeCaseSpecs :: Spec
  edgeCaseSpecs = describe "edge cases" $ parallel $ do
    let longString :: IsString a => a
        longString = "long_string_from_DL:...............................................................................................................................................................................................................................................................................................end"
  
        getFactsI :: forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a]
        getFactsI = Interpreted.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Interpreted.run prog
          Interpreted.getFacts prog
        getFactsC :: forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a]
        getFactsC = Compiled.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Compiled.run prog
          Prelude.reverse <$> Compiled.getFacts prog
  
        getUnicodeFactsI :: forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a))
                          => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a))
        getUnicodeFactsI = Interpreted.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Interpreted.run prog
          (,,) <$> Interpreted.getFacts prog
                <*> Interpreted.findFact prog (Unicode "⌀")  -- \x2300 iso \x2200
                <*> Interpreted.findFact prog (Unicode "≂")  -- \x2242 iso \x2200
  
        getUnicodeFactsC :: forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a), Compiled.Submit (Unicode a))
                          => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a))
        getUnicodeFactsC = Compiled.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Compiled.run prog
          (,,) <$> (Prelude.reverse <$> Compiled.getFacts prog)
                <*> Compiled.findFact prog (Unicode "⌀")  -- \x2300 iso \x2200
                <*> Compiled.findFact prog (Unicode "≂")  -- \x2242 iso \x2200
  
        addAndGetFactsI :: Souffle.Fact (f a)
                        => Souffle.ContainsInputFact EdgeCases (f a)
                        => Souffle.ContainsOutputFact EdgeCases (f a)
                        => [f a] -> IO [f a]
        addAndGetFactsI fs = Interpreted.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Interpreted.addFacts prog fs
          Interpreted.run prog
          Interpreted.getFacts prog
        addAndGetFactsC :: Souffle.Fact (f a)
                        => Souffle.ContainsInputFact EdgeCases (f a)
                        => Souffle.ContainsOutputFact EdgeCases (f a)
                        => Compiled.Submit (f a)
                        => [f a] -> IO [f a]
        addAndGetFactsC fs = Compiled.runSouffle EdgeCases $ \handle -> do
          let prog = fromJust handle
          Compiled.addFacts prog fs
          Compiled.run prog
          Prelude.reverse <$> Compiled.getFacts prog
  
  
        runTests :: (forall f a. (Souffle.Fact (f a), Souffle.ContainsOutputFact EdgeCases (f a)) => IO [f a])
                  -> (forall a. (IsString a, Eq a, Souffle.Fact (Unicode a), Souffle.ContainsOutputFact EdgeCases (Unicode a), Compiled.Submit (Unicode a))
                      => IO ([Unicode a], Maybe (Unicode a), Maybe (Unicode a)))
                  -> (forall f a. Souffle.Fact (f a)
                      => Souffle.ContainsInputFact EdgeCases (f a)
                      => Souffle.ContainsOutputFact EdgeCases (f a)
                      => Compiled.Submit (f a)
                      => [f a] -> IO [f a])
                  -> Spec
        runTests getFacts getUnicodeFacts addAndGetFacts = do
          it "correctly marshals facts with number-like types" $ do
            facts <- getFacts
            (facts :: [NoStrings Void])
              `shouldBe` [ NoStrings 42 (-100) 1.5
                         , NoStrings 123 (-456) 3.14
                         ]
  
          it "correctly marshals facts with empty Strings" $ do
            facts <- getFacts
            (facts :: [EmptyStrings String])
              `shouldBe` [ EmptyStrings "" "" 42
                         , EmptyStrings "" "abc" 42
                         , EmptyStrings "abc" "" 42
                         ]
  
          it "correctly marshals facts with empty Texts" $ do
            facts <- getFacts
            (facts :: [EmptyStrings T.Text])
              `shouldBe` [ EmptyStrings "" "" 42
                          , EmptyStrings "" "abc" 42
                          , EmptyStrings "abc" "" 42
                          ]
  
          it "correctly marshals facts with empty lazy Texts" $ do
            facts <- getFacts
            (facts :: [EmptyStrings TL.Text])
              `shouldBe` [ EmptyStrings "" "" 42
                          , EmptyStrings "" "abc" 42
                          , EmptyStrings "abc" "" 42
                          ]
  
          it "correctly marshals facts really with long (>255 chars) String" $ do
            facts <- getFacts
            (facts :: [LongStrings String]) `shouldBe` [ LongStrings longString ]
  
          it "correctly marshals facts really with long (>255 chars) Text" $ do
            facts <- getFacts
            (facts :: [LongStrings T.Text]) `shouldBe` [ LongStrings longString ]
  
          it "correctly marshals facts really with long (>255 chars) lazy Text" $ do
            facts <- getFacts
            (facts :: [LongStrings TL.Text]) `shouldBe` [ LongStrings longString ]
  
          it "correctly marshals facts containing unicode characters (String)" $ do
            results <- getUnicodeFacts
            results `shouldBe`
              ( [ Unicode ("∀" :: String), Unicode "∀∀" ]
              , Nothing :: Maybe (Unicode String)
              , Nothing :: Maybe (Unicode String)
              )
  
          it "correctly marshals facts containing unicode characters (Text)" $ do
            results <- getUnicodeFacts
            results `shouldBe`
              ( [ Unicode ("∀" :: T.Text), Unicode "∀∀" ]
              , Nothing :: Maybe (Unicode T.Text)
              , Nothing :: Maybe (Unicode T.Text)
              )
  
          it "correctly marshals facts containing unicode characters (lazy Text)" $ do
            results <- getUnicodeFacts
            results `shouldBe`
              ( [ Unicode ("∀" :: TL.Text), Unicode "∀∀" ]
              , Nothing :: Maybe (Unicode TL.Text)
              , Nothing :: Maybe (Unicode TL.Text)
              )
  
          it "correctly marshals empty strings back and forth (Strings)" $ do
            let facts :: [EmptyStrings String]
                facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals empty strings back and forth (Text)" $ do
            let facts :: [EmptyStrings T.Text]
                facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals empty strings back and forth (lazy Text)" $ do
            let facts :: [EmptyStrings TL.Text]
                facts = [EmptyStrings "" "" 1, EmptyStrings "" "" 42, EmptyStrings "" "abc" 2, EmptyStrings "" "abc" 42, EmptyStrings "abc" "" 3, EmptyStrings "abc" "" 42]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals unicode back and forth (Strings)" $ do
            let facts :: [Unicode String]
                facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals unicode back and forth (Text)" $ do
            let facts :: [Unicode T.Text]
                facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals unicode back and forth (lazy Text)" $ do
            let facts :: [Unicode TL.Text]
                facts = [Unicode "∀", Unicode "∀∀", Unicode "≂", Unicode "⌀", Unicode "⌀⌀"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals really long strings back and forth (Strings)" $ do
            let facts :: [LongStrings String]
                facts = [LongStrings longString, LongStrings $ join $ Prelude.replicate 10000 "abc"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals really long strings back and forth (Text)" $ do
            let facts :: [LongStrings T.Text]
                facts = [LongStrings longString, LongStrings $ T.pack $ join $ Prelude.replicate 10000 "abc"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals really long strings back and forth (lazy Text)" $ do
            let facts :: [LongStrings TL.Text]
                facts = [LongStrings longString, LongStrings $ TL.pack $ join $ Prelude.replicate 10000 "abc"]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
          it "correctly marshals facts with number-like types" $ do
            let facts :: [NoStrings Void]
                facts = [ NoStrings 42 (-100) 1.5
                        , NoStrings 123 (-456) 3.14
                        , NoStrings 789 (-789) 1000.123
                        , NoStrings 0x12345678 (-1000) 1234.56789
                        ]
            facts' <- addAndGetFacts facts
            facts' `shouldBe` facts
  
    describe "interpreted mode" $ parallel $ do
      runTests getFactsI getUnicodeFactsI addAndGetFactsI
  
    describe "compiled mode" $ parallel $ do
      runTests getFactsC getUnicodeFactsC addAndGetFactsC
  