From 4cb4399006bb97067f38131a7e3ce397b83a4226 Mon Sep 17 00:00:00 2001 From: Tran Ma Date: Tue, 21 Feb 2017 18:11:13 +1100 Subject: [PATCH] Test: convert Icicle type to Zebra schema --- icicle-compiler/icicle.cabal | 26 +- icicle-compiler/src/Icicle/Sea/Eval/Base.hs | 1 + .../test/Icicle/Test/Arbitrary/Core.hs | 17 +- .../test/Icicle/Test/Arbitrary/Program.hs | 21 +- icicle-compiler/test/Icicle/Test/Sea/Zebra.hs | 558 ++++++++++-------- icicle-compiler/test/test.hs | 2 +- lib/anemone | 2 +- lib/x | 2 +- lib/zebra | 2 +- 9 files changed, 341 insertions(+), 290 deletions(-) diff --git a/icicle-compiler/icicle.cabal b/icicle-compiler/icicle.cabal index 010783e0..825f155e 100644 --- a/icicle-compiler/icicle.cabal +++ b/icicle-compiler/icicle.cabal @@ -218,30 +218,10 @@ test-suite test ghc-options: -Wall -threaded -O2 -funbox-strict-fields + ld-options: -Wl,-undefined,dynamic_lookup + hs-source-dirs: test - other-modules: - -- Icicle.Test.Sea.Bindings - - include-dirs: - data/sea - - install-includes: - 00-includes.h - 05-error.h - 06-segv.h - 20-simple.h - 21-time.h - 30-array.h - 31-buffer.h - 40-grisu2-powers.h - 41-grisu2.h - 42-text-conversion.h - 50-chord.h - 51-piano.h - 52-psv.h - 53-zebra-data.h - 54-zebra.h build-depends: base >= 3 && < 5 @@ -261,12 +241,10 @@ test-suite test , ambiata-zebra , ambiata-zebra-test , bifunctors >= 4.2 && < 5.4 - , bindings-DSL >= 1.0.0 && <= 1.0.23 , aeson , bytestring , containers , directory - , exceptions == 0.8.* , filepath == 1.4.* , geniplate-mirror >= 0.7.2 && < 0.8 , megaparsec == 5.0.* diff --git a/icicle-compiler/src/Icicle/Sea/Eval/Base.hs b/icicle-compiler/src/Icicle/Sea/Eval/Base.hs index d202173a..52001ed7 100644 --- a/icicle-compiler/src/Icicle/Sea/Eval/Base.hs +++ b/icicle-compiler/src/Icicle/Sea/Eval/Base.hs @@ -38,6 +38,7 @@ module Icicle.Sea.Eval.Base ( , pokeWordOff , peekWordOff + , peekOutput , peekOutputs , wordOfError , errorOfWord diff --git a/icicle-compiler/test/Icicle/Test/Arbitrary/Core.hs b/icicle-compiler/test/Icicle/Test/Arbitrary/Core.hs index cb6fcba7..d13c906c 100644 --- a/icicle-compiler/test/Icicle/Test/Arbitrary/Core.hs +++ b/icicle-compiler/test/Icicle/Test/Arbitrary/Core.hs @@ -178,19 +178,20 @@ instance Arbitrary ValType where arbitrary = -- Need to be careful about making smaller things. -- It's fine if they're big, but they have to fit in memory. - oneof_sized_vals - [ IntT - , UnitT - , BoolT - , TimeT - , StringT ] + oneof_sized + [ pure IntT + , pure UnitT + , pure BoolT + , pure TimeT + , pure StringT + , StructT <$> arbitrary + , OptionT <$> arbitrary + ] [ ArrayT <$> arbitrary , BufT <$> (getPositive <$> arbitrary) <*> arbitrary , PairT <$> arbitrary <*> arbitrary , SumT <$> arbitrary <*> arbitrary , MapT <$> arbitrary <*> arbitrary - , OptionT <$> arbitrary - , StructT <$> arbitrary ] instance Arbitrary StructType where diff --git a/icicle-compiler/test/Icicle/Test/Arbitrary/Program.hs b/icicle-compiler/test/Icicle/Test/Arbitrary/Program.hs index f71c19a5..cb9162be 100644 --- a/icicle-compiler/test/Icicle/Test/Arbitrary/Program.hs +++ b/icicle-compiler/test/Icicle/Test/Arbitrary/Program.hs @@ -174,8 +174,6 @@ isSupportedInput = \case IntT -> True DoubleT -> True TimeT -> True - FactIdentifierT - -> True StringT -> True UnitT -> False @@ -185,6 +183,8 @@ isSupportedInput = \case PairT{} -> False SumT{} -> False OptionT{} -> False + FactIdentifierT + -> False ArrayT t -> isSupportedInputElem t @@ -201,10 +201,14 @@ isSupportedInputElem = \case IntT -> True DoubleT -> True TimeT -> True - FactIdentifierT - -> True StringT -> True + OptionT BoolT -> True + OptionT IntT -> True + OptionT DoubleT -> True + OptionT TimeT -> True + OptionT StringT -> True + UnitT -> False ErrorT -> False ArrayT{} -> False @@ -213,6 +217,8 @@ isSupportedInputElem = \case PairT{} -> False SumT{} -> False OptionT{} -> False + FactIdentifierT + -> False StructT (StructType fs) -> all isSupportedInputField (Map.elems fs) @@ -223,7 +229,6 @@ isSupportedInputField = \case IntT -> True DoubleT -> True TimeT -> True - FactIdentifierT -> True StringT -> True OptionT BoolT -> True OptionT IntT -> True @@ -239,6 +244,8 @@ isSupportedInputField = \case PairT{} -> False SumT{} -> False OptionT{} -> False + FactIdentifierT + -> False StructT (StructType fs) -> all isSupportedInputField (Map.elems fs) @@ -272,14 +279,14 @@ isSupportedOutputBase = \case IntT -> True DoubleT -> True TimeT -> True - FactIdentifierT - -> True StringT -> True UnitT -> False ErrorT -> False BufT{} -> False StructT{} -> False + FactIdentifierT + -> False _ -> False diff --git a/icicle-compiler/test/Icicle/Test/Sea/Zebra.hs b/icicle-compiler/test/Icicle/Test/Sea/Zebra.hs index ce8520c3..1408b5fa 100644 --- a/icicle-compiler/test/Icicle/Test/Sea/Zebra.hs +++ b/icicle-compiler/test/Icicle/Test/Sea/Zebra.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE PatternGuards #-} module Icicle.Test.Sea.Zebra where @@ -24,13 +25,15 @@ import Foreign.C.String import System.IO +import qualified Prelude as Savage + import P import X.Control.Monad.Trans.Either (hoistEither, firstEitherT, bracketEitherT') import Disorder.Core.IO (testIO) import Disorder.Jack (Property, Jack) -import Disorder.Jack (gamble, arbitrary, (===), justOf, vectorOf) +import Disorder.Jack (gamble, arbitrary, (===), justOf, vectorOf, suchThat) import Jetski @@ -40,8 +43,12 @@ import Anemone.Foreign.Segv (withSegv) import qualified Test.Zebra.Jack as Zebra import qualified Zebra.Foreign.Entity as Zebra import qualified Zebra.Data.Entity as Zebra -import qualified Zebra.Data.Table as Zebra import qualified Zebra.Data.Core as Zebra +import qualified Zebra.Data.Fact as Zebra +import Zebra.Data.Table (Table(..), TableError) +import qualified Zebra.Data.Table as Table +import Zebra.Data.Schema (Schema) +import qualified Zebra.Data.Schema as Schema import qualified Icicle.Internal.Pretty as PP import Icicle.Common.Base @@ -49,6 +56,7 @@ import Icicle.Common.Type import Icicle.Data import qualified Icicle.Data.Time as Icicle import Icicle.Sea.FromAvalanche.Base (seaOfTime) +import Icicle.Sea.FromAvalanche.State import Icicle.Sea.IO import Icicle.Sea.Eval.Base import Icicle.Test.Sea.Utils @@ -61,272 +69,327 @@ import qualified Icicle.Test.Foreign.Utils as Test -- prop_read_entity :: Property prop_read_entity = - gamble zebra $ \(ZebraWellTyped wt ty facts entity) -> + gamble (justOf zebra) $ \(ZebraWellTyped wt ty entity) -> testIO . withSegv (pp wt entity) . bracket Mempool.create Mempool.free $ \pool -> do c_entity <- Zebra.foreignOfEntity pool entity Test.runRight $ do code <- hoistEither $ codeOf wt - src <- firstEitherT SeaJetskiError $ readLibrary code - init <- firstEitherT SeaJetskiError $ function src "zebra_alloc_state" (retPtr retVoid) - end <- firstEitherT SeaJetskiError $ function src "zebra_collect_state" (retPtr retVoid) - test_fleet <- firstEitherT SeaJetskiError $ function src "test_setup_fleet" (retPtr retVoid) - test_read_entity <- firstEitherT SeaJetskiError $ function src "test_zebra_read_entity" (retPtr retWord8) - - withWords 7 $ \config -> do - pokeWordOff config 6 defaultPsvOutputBufferSize - bracketEitherT' - (liftIO (init [ argPtr nullPtr, argPtr config ])) - (\state -> (liftIO (end [ argPtr config, argPtr state ]))) - (\state -> do - fleet_ptr <- peekWordOff state 5 - - _ <- liftIO . withCStringLen (ByteString.unpack . Zebra.unEntityId . Zebra.entityId $ entity) - $ \(id_bytes, id_length) -> do - _ <- test_fleet [ argPtr id_bytes, argInt32 (fromIntegral id_length), argPtr nullPtr, argPtr fleet_ptr ] - _ <- test_read_entity [ argPtr state, argPtr (Zebra.unCEntity c_entity) ] - return () - - -- if no fact was read, we don't want to peek the input struct - if length facts > 0 - then do - programs0_ptr <- peekWordOff fleet_ptr 4 - -- iprogram: { mempool, input, ... } - -- input: { chord_time, fact_count, tombstone, input_start, ... } - input_start <- peekWordOff programs0_ptr 4 - - let - peekInputs xs 0 _ = - return xs - peekInputs xs n offset = do - (offset', xs') <- peekOutputs input_start offset [ty] - peekInputs (xs <> xs') (n - 1) offset' - - inputs <- peekInputs [] (length facts) 0 - return $ facts === inputs - else - return $ length facts === 0 - ) + opts <- getCompilerOptions + bracketEitherT' + (firstEitherT SeaJetskiError $ compileLibrary NoCacheLibrary opts code) + (firstEitherT SeaJetskiError . releaseLibrary) + (\src -> do + init <- firstEitherT SeaJetskiError $ function src "zebra_alloc_state" (retPtr retVoid) + end <- firstEitherT SeaJetskiError $ function src "zebra_collect_state" (retPtr retVoid) + test_fleet <- firstEitherT SeaJetskiError $ function src "test_setup_fleet" (retPtr retVoid) + test_read_entity <- firstEitherT SeaJetskiError $ function src "test_zebra_read_entity" (retPtr retWord8) + + withWords 7 $ \config -> do + pokeWordOff config 6 defaultPsvOutputBufferSize + bracketEitherT' + (liftIO (init [ argPtr nullPtr, argPtr config ])) + (\state -> (liftIO (end [ argPtr config, argPtr state ]))) + (\state -> do + fleet_ptr <- peekWordOff state 5 + + liftIO . withCStringLen (ByteString.unpack . Zebra.unEntityId . Zebra.entityId $ entity) + $ \(id_bytes, id_length) -> do + e1 <- test_fleet + [ argPtr id_bytes + , argInt32 (fromIntegral id_length) + , argPtr nullPtr + , argPtr fleet_ptr ] + + when (e1 /= nullPtr) $ + fail "failed to configure fleet" + + e2 <- test_read_entity + [ argPtr state + , argPtr (Zebra.unCEntity c_entity) ] + + when (e2 /= nullPtr) $ do + err <- peekCString (castPtr e2) + fail $ "failed to read entity: " <> err + + -- iprogram: { *mempool, input, ... } + -- input: { *chord_time, *fact_count, *tombstone, *input_start, ... } + programs0_ptr <- peekWordOff fleet_ptr 4 + tombstones_ptr <- peekWordOff programs0_ptr 3 + + struct_count <- (\x -> x - 2) . length . stateInputVars <$> + hoistEither (stateOfProgram 0 (wtAttribute wt) (wtAvalancheFlat wt)) + + buf <- liftIO $ mallocBytes (struct_count * 8) + + let + input_start + = 4 + + facts + = fmap atFact (wtFacts wt) + + nfacts + = length facts + + -- slice out the input fields at the index (kind of like a transpose) + slice dst fact_i = + forM_ [0 .. struct_count - 1] $ \field_i -> do + ptr_head <- peekWordOff programs0_ptr (input_start + field_i) + let ptr_src = plusPtr ptr_head (fact_i * 8) + ptr_dst = plusPtr dst (field_i * 8) + copyBytes ptr_dst ptr_src 8 + + peekInputs xs 0 = + return xs + + peekInputs xs index = do + let fact_i = nfacts - index + tombstone <- liftIO $ peekElemOff tombstones_ptr fact_i + + x <- case errorOfWord tombstone of + ExceptNotAnError -> do + liftIO $ slice buf fact_i + VRight . snd <$> peekOutput buf 0 ty + e -> + pure (VLeft (VError e)) + + peekInputs (x:xs) (index - 1) + + inputs <- peekInputs [] nfacts + liftIO $ free buf + return $ facts === List.reverse inputs + ) + ) -------------------------------------------------------------------------------- +data TestError + = ZebraError (TableError Schema) + | UnexpectedError ValType [BaseValue] + deriving (Show) + data ZebraWellTyped = ZebraWellTyped { - zWelltyped :: WellTyped - , zFactType :: ValType -- wtFactType = Sum Error FactType - , zFacts :: [BaseValue] -- wtFacts = zFacts + tombstones - , zEntity :: Zebra.Entity () + zWelltyped :: WellTyped + , zFactType :: ValType -- wtFactType = Sum Error FactType + , zEntity :: Zebra.Entity Schema } instance Show ZebraWellTyped where - show (ZebraWellTyped wt _ _ e) = + show (ZebraWellTyped wt _ e) = pp wt e -zebra :: Jack ZebraWellTyped -zebra = justOf (zebraOfWellTyped =<< arbitrary) +zebra :: Jack (Maybe ZebraWellTyped) +zebra = do + let notArray x = case wtFactType x of + SumT _ (ArrayT _) -> False + _ -> True + wt <- arbitrary `suchThat` notArray + zebraOfWellTyped wt zebraOfWellTyped :: WellTyped -> Jack (Maybe ZebraWellTyped) zebraOfWellTyped wt = - case zebraOfFacts (wtFactType wt) (wtFacts wt) of - Nothing -> + case zebraOfFacts (wtFactType wt) (fmap atFact (wtFacts wt)) of + Left e -> + Savage.error (show e) + Right Nothing -> return Nothing - Just (ty, tombstones, facts, table) -> do + Right (Just (ty, tombstones, table)) -> do -- FIXME ignoring fact times for now, but to test it we should convert icicle time to 1600 epoch secs here -- let ts = fmap (Zebra.Time . fromIntegral . Icicle.secondsCountJulian . atTime) (wtFacts wt) let ts = List.replicate (length (wtFacts wt)) 0 ps <- vectorOf (length ts) Zebra.jFactsetId let attribute = Zebra.Attribute (Storable.fromList ts) (Storable.fromList ps) (Storable.fromList tombstones) table entity <- uncurry Zebra.Entity <$> Zebra.jEntityHashId <*> pure (Boxed.singleton attribute) - pure (Just (ZebraWellTyped wt ty facts entity)) - -zebraOfFacts :: ValType -> [AsAt BaseValue] -> Maybe (ValType, [Zebra.Tombstone], [BaseValue], Zebra.Table ()) ---zebraOfFacts x y | trace ("zebra_of_facts: type = " <> show x <> ", facts = " <> show y) False = undefined -zebraOfFacts typ facts = do - let - fromVBool val = - case val of - VBool True -> - pure 1 - VBool False -> - pure 0 - _ -> - Nothing - - fromVTime val = - case val of - VTime t -> - pure (fromIntegral (Icicle.packedOfTime t)) - _ -> - Nothing - - fromVInt val = - case val of - VInt x -> - pure (fromIntegral x) - _ -> - Nothing - - fromVDouble val = - case val of - VDouble x -> - pure x - _ -> - Nothing - - fromVString val = - case val of - VString x -> - pure (ByteString.pack (Text.unpack x)) - _ -> - Nothing - - fromVUnit val = - case val of - VUnit -> - pure 0 - _ -> - Nothing - - --fromVArray f val = - -- case val of - -- VArray vs -> - -- f vs - -- _ -> - -- Nothing - - fromVOption f val = - case val of - VNone -> - (0,) <$> f [] - VSome v -> - (1,) <$> f [v] - _ -> - Nothing - - fromVSumError f val = - case val of - VLeft (VError e) -> - (fromIntegral (wordOfError e),) <$> f [] - VRight v -> - (fromIntegral (wordOfError ExceptNotAnError),) <$> f [v] - _ -> - Nothing - - fromVSum f g val = - case val of - VLeft v -> - (0,,) <$> f [v] <*> g [] - VRight v -> - (1,,) <$> f [] <*> g [v] - _ -> - Nothing - - fromVError val = - case val of - VError _ -> - pure 1 - _ -> - Nothing - - mergeValues t vs - | null vs - = tableOf t [] - | otherwise - = pure (concat vs) - - tableOf :: ValType -> [BaseValue] -> Maybe [Zebra.Column ()] - tableOf ty rows = - case ty of - BoolT -> - pure . Zebra.IntColumn . Storable.fromList <$> mapM fromVBool rows - - TimeT -> - pure . Zebra.IntColumn . Storable.fromList <$> mapM fromVTime rows - - DoubleT -> - pure . Zebra.DoubleColumn . Storable.fromList <$> mapM fromVDouble rows - - IntT -> - pure . Zebra.IntColumn . Storable.fromList <$> mapM fromVInt rows - - UnitT -> - pure . Zebra.IntColumn . Storable.fromList <$> mapM fromVUnit rows - - ErrorT -> - pure . Zebra.IntColumn . Storable.fromList <$> mapM fromVError rows - - StringT -> do - strings <- mapM fromVString rows - - let - string = - ByteString.concat strings - len = - ByteString.length string - lens = - fmap (fromIntegral . ByteString.length) strings - - pure $ [ Zebra.ArrayColumn - (Storable.fromList lens) - (Zebra.Table () len (Boxed.fromList [ Zebra.ByteColumn string ])) - ] - - -- FIXME: we aren't reading nested arrays right now (savages) - --ArrayT t -> do - -- vs <- concat <$> mapM (fromVArray (tableOf t)) rows - -- lens <- mapM (fromVArray (pure . fromIntegral . length)) rows - -- pure [ Zebra.ArrayColumn - -- (Storable.fromList lens) - -- (Zebra.Table () (length vs) (Boxed.fromList vs)) - -- ] - - OptionT t -> do - (bools, vs) <- List.unzip <$> mapM (fromVOption (tableOf t)) rows - cols <- mergeValues t vs - pure $ [ Zebra.IntColumn (Storable.fromList bools) ] <> cols - - SumT ErrorT t -> do - (bools, vs) <- List.unzip <$> mapM (fromVSumError (tableOf t)) rows - pure $ [ Zebra.IntColumn (Storable.fromList bools) ] <> concat vs - - SumT l r -> do - (bools, ls, rs) <- List.unzip3 <$> mapM (fromVSum (tableOf l) (tableOf r)) rows - lcols <- mergeValues l ls - rcols <- mergeValues r rs - pure $ [ Zebra.IntColumn (Storable.fromList bools) ] <> lcols <> rcols - - StructT fields -> do - let - structFieldsOf v = - case v of - VStruct x - -> pure x - _ -> - Nothing - types = - getStructType fields - vs <- fmap (Map.unionsWith (<>) . fmap (fmap pure)) $ mapM structFieldsOf rows - concat <$> mapM (uncurry tableOf) (Map.elems (Map.intersectionWith (,) types vs)) - - _ -> - Nothing - - valuesOf (SumT ErrorT t) vals = do - (ts, vs) <- List.unzip <$> mapM (valueOf (defaultOfType t)) vals - pure (t, ts, vs) - valuesOf _ _ = - Nothing - - valueOf def val = - case val of - VLeft (VError ExceptTombstone) -> - pure (Zebra.Tombstone, def) - VRight v -> - pure (Zebra.NotTombstone, v) - _ -> - Nothing - - (ty, tombstones, values) <- valuesOf typ (fmap atFact facts) - table <- Zebra.Table () (length values) . Boxed.fromList <$> tableOf ty values - pure (ty, tombstones, values, table) + pure . Just $ ZebraWellTyped wt ty entity + +-- we are not reading nested arrays in zebra right now +schemaOfType' :: ValType -> Maybe Schema +schemaOfType' ty = case ty of + ArrayT {} -> + Nothing + BufT {} -> + Nothing + MapT {} -> + Nothing + _ -> + schemaOfType ty + +schemaOfType :: ValType -> Maybe Schema +schemaOfType ty = case ty of + BoolT -> + pure Schema.Bool + + TimeT -> + pure Schema.Int + + DoubleT -> + pure Schema.Double + + IntT -> + pure Schema.Int + + StringT -> + pure $ Schema.Array Schema.Byte + + ErrorT -> + pure Schema.Int + + UnitT -> + pure Schema.Int + + FactIdentifierT -> + pure Schema.Int + + ArrayT t -> + Schema.Array <$> schemaOfType' t + + BufT _ t -> + Schema.Array <$> schemaOfType' t + + OptionT t -> + let + none = + Schema.Variant (Schema.VariantName "none") (Schema.Struct Boxed.empty) + someOf x = + Schema.Variant (Schema.VariantName "some") <$> schemaOfType x + in Schema.Enum none . Boxed.singleton <$> someOf t + + PairT a b -> do + a' <- schemaOfType a + b' <- schemaOfType b + pure . Schema.Struct . Boxed.fromList $ + [ Schema.Field (Schema.FieldName "fst") a' + , Schema.Field (Schema.FieldName "snd") b' ] + + SumT a b -> + let + leftOf x = + Schema.Variant (Schema.VariantName "left") <$> schemaOfType x + rightOf x = + Schema.Variant (Schema.VariantName "right") <$> schemaOfType x + in Schema.Enum <$> leftOf a <*> (Boxed.singleton <$> rightOf b) + + MapT k v -> do + k' <- schemaOfType' k + v' <- schemaOfType' v + pure . Schema.Struct . Boxed.fromList $ + [ Schema.Field (Schema.FieldName "keys") (Schema.Array k') + , Schema.Field (Schema.FieldName "vals") (Schema.Array v') ] + + StructT struct + -- An empty icicle struct is not unit (unlike zebra), it has no input variable. + | fields <- getStructType struct + , not (Map.null fields) -> + let + fieldOf (f, t) = + Schema.Field (Schema.FieldName (nameOfStructField f)) <$> schemaOfType t + in Schema.Struct . Boxed.fromList <$> mapM fieldOf (Map.toList fields) + + _ -> Nothing + +zebraOfValue :: ValType -> BaseValue -> Either TestError Zebra.Value +zebraOfValue ty val = case val of + VInt x -> + pure . Zebra.Int . fromIntegral $ x + + VDouble x -> + pure . Zebra.Double $ x + + VUnit -> + pure . Zebra.Int $ 0 + + VBool x -> + pure . Zebra.Bool $ x + + VTime x -> + pure . Zebra.Int . fromIntegral . Icicle.packedOfTime $ x + + VString x -> + pure . Zebra.ByteArray . ByteString.pack . Text.unpack $ x + + VArray xs + | ArrayT t <- ty + -> Zebra.Array . Boxed.fromList <$> mapM (zebraOfValue t) xs + + VPair a b + | PairT ta tb <- ty + -> do a' <- zebraOfValue ta a + b' <- zebraOfValue tb b + pure . Zebra.Struct . Boxed.fromList $ [a', b'] + + VLeft x + | SumT t _ <- ty + -> Zebra.Enum 0 <$> zebraOfValue t x + + VRight x + | SumT _ t <- ty + -> Zebra.Enum 1 <$> zebraOfValue t x + + VNone + | OptionT _ <- ty + -> pure . Zebra.Enum 0 . Zebra.Struct $ Boxed.empty + + VSome x + | OptionT t <- ty + -> Zebra.Enum 1 <$> zebraOfValue t x + + VMap x + | MapT tk tv <- ty + -> do keys <- mapM (zebraOfValue tk) (Map.keys x) + vals <- mapM (zebraOfValue tv) (Map.elems x) + pure . Zebra.Struct . Boxed.fromList $ + [ Zebra.Array (Boxed.fromList keys), Zebra.Array (Boxed.fromList vals) ] + VStruct xs + | StructT struct <- ty + , types <- getStructType struct + -> do let vs = Map.elems (Map.intersectionWith (,) types xs) + Zebra.Struct . Boxed.fromList <$> mapM (uncurry zebraOfValue) vs + VBuf xs + | BufT _ t <- ty + -> Zebra.Array . Boxed.fromList <$> mapM (zebraOfValue t) xs + + VFactIdentifier x -> + pure . Zebra.Int . fromIntegral . getFactIdentifierIndex $ x + + VError ExceptTombstone -> + Left (UnexpectedError ty [val]) + + VError e -> + pure . Zebra.Int . fromIntegral . wordOfError $ e + + _ -> + Left (UnexpectedError ty [val]) + +zebraOfTopValue :: ValType -> BaseValue -> Either TestError (Zebra.Tombstone, Zebra.Value) +zebraOfTopValue t val + | VRight v <- val + = (Zebra.NotTombstone,) <$> zebraOfValue t v + + | VLeft (VError ExceptTombstone) <- val + = (Zebra.Tombstone,) <$> zebraOfValue t (defaultOfType t) + + | otherwise + = Left (UnexpectedError t [val]) + +zebraOfFacts :: + ValType + -> [BaseValue] + -> Either TestError (Maybe (ValType, [Zebra.Tombstone], Table Schema)) +zebraOfFacts ty facts + | SumT ErrorT t <- ty = + case schemaOfType t of + Nothing -> + pure Nothing + Just schema -> do + (tombstones, rows) <- List.unzip <$> mapM (zebraOfTopValue t) facts + tables <- first ZebraError $ mapM (Table.fromRow schema) rows + table <- first ZebraError + $ if null tables + then pure $ Table.empty schema + else Table.concat . Boxed.fromList $ tables + pure . Just $ (t, tombstones, table) + + | otherwise = Left (UnexpectedError ty facts) testSnapshotTime :: Time testSnapshotTime = Icicle.unsafeTimeOfYMD 9999 1 1 @@ -335,7 +398,8 @@ codeOf :: WellTyped -> Either SeaError SourceCode codeOf wt = do let dummy = HasInput - (FormatZebra (Snapshot testSnapshotTime) (PsvOutputConfig Chords PsvOutputSparse defaultOutputMissing)) + (FormatZebra (Snapshot testSnapshotTime) + (PsvOutputConfig (Snapshot testSnapshotTime) PsvOutputDense defaultOutputMissing)) (InputOpts AllowDupTime Map.empty) ("" :: String) attr = wtAttribute wt @@ -362,7 +426,7 @@ codeOf wt = do ] -pp :: WellTyped -> Zebra.Entity () -> String +pp :: WellTyped -> Zebra.Entity Schema -> String pp wt entity = "Fact type = " <> show (wtFactType wt) <> "\n" <> "Facts = " <> ppShow (wtFacts wt) <> "\n" <> diff --git a/icicle-compiler/test/test.hs b/icicle-compiler/test/test.hs index 67ecc280..a9158bd6 100644 --- a/icicle-compiler/test/test.hs +++ b/icicle-compiler/test/test.hs @@ -66,7 +66,7 @@ main , Icicle.Test.Avalanche.Melt.tests , Icicle.Test.Sea.Psv.tests --- , Icicle.Test.Sea.Zebra.tests + , Icicle.Test.Sea.Zebra.tests , Icicle.Test.Sea.Seaworthy.tests , Icicle.Test.Sea.Text.tests diff --git a/lib/anemone b/lib/anemone index 53698f50..67503dc9 160000 --- a/lib/anemone +++ b/lib/anemone @@ -1 +1 @@ -Subproject commit 53698f50ee768f36206533c192a3e545d89d9b3f +Subproject commit 67503dc98e51f34d1813616f49206ed7622f8dcd diff --git a/lib/x b/lib/x index 29d9c8c1..14136d17 160000 --- a/lib/x +++ b/lib/x @@ -1 +1 @@ -Subproject commit 29d9c8c188f6f02a59228bd7649f13abceb1311a +Subproject commit 14136d17095233cd6ea0d480c608094f12d1d7d9 diff --git a/lib/zebra b/lib/zebra index f772a2b5..c251d664 160000 --- a/lib/zebra +++ b/lib/zebra @@ -1 +1 @@ -Subproject commit f772a2b5d913eab9c9ccaa2a0bb2849e9095c43c +Subproject commit c251d6641afaa57cc7a45b6cf5a21cb539a135cf