diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright {yyyy} {name of copyright owner} + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/karps.cabal b/karps.cabal new file mode 100644 --- /dev/null +++ b/karps.cabal @@ -0,0 +1,176 @@ +name: karps +version: 0.1.9.0 +cabal-version: >=1.10 +build-type: Simple +license: Apache-2.0 +license-file: LICENSE +copyright: 2016 Karps-Haskell contributors +maintainer: krapsh@yandex.com +homepage: https://github.com/krapsh/kraps-haskell +synopsis: Haskell bindings for Spark Dataframes and Datasets +description: + Karps-Haskell is an exploration vehicle for developing safe, + scalable and reliable data pipelines over Apache Spark, using + the DataFrame API. + In order to use it, you must launch Spark with the + karps-server module installed. +category: Web, Big data +author: krapsh + +source-repository head + type: git + location: https://github.com/krapsh/kraps-haskell + +library + exposed-modules: + Spark.Core + Spark.Core.Context + Spark.Core.Column + Spark.Core.ColumnFunctions + Spark.Core.Dataset + Spark.Core.Functions + Spark.Core.Internal.Arithmetics + Spark.Core.Internal.ArithmeticsImpl + Spark.Core.Internal.Caching + Spark.Core.Internal.CanRename + Spark.Core.Internal.Client + Spark.Core.Internal.ColumnStandard + Spark.Core.Internal.ComputeDag + Spark.Core.Internal.ContextInteractive + Spark.Core.Internal.ContextInternal + Spark.Core.Internal.ContextIOInternal + Spark.Core.Internal.ContextStructures + Spark.Core.Internal.DAGFunctions + Spark.Core.Internal.DAGStructures + Spark.Core.Internal.DatasetFunctions + Spark.Core.Internal.DatasetStructures + Spark.Core.Internal.Groups + Spark.Core.Internal.Joins + Spark.Core.Internal.LocalDataFunctions + Spark.Core.Internal.ObservableStandard + Spark.Core.Internal.OpFunctions + Spark.Core.Internal.OpStructures + Spark.Core.Internal.Paths + Spark.Core.Internal.PathsUntyped + Spark.Core.Internal.Projections + Spark.Core.Internal.Pruning + Spark.Core.Internal.RowGenericsFrom + Spark.Core.Internal.Utilities + Spark.Core.Internal.TypesGenerics + Spark.Core.Internal.TypesStructures + Spark.Core.Internal.TypesStructuresRepr + Spark.Core.Internal.TypesFunctions + Spark.Core.Row + Spark.Core.StructuresInternal + Spark.Core.Try + Spark.Core.Types + Spark.IO.Inputs + build-depends: + aeson >=0.11.2.1 && <0.12, + aeson-pretty >=0.8.2 && <0.9, + base >=4.8.1 && <5, + base16-bytestring >=0.1.1.6 && <0.2, + binary >=0.7 && <0.9, + bytestring >=0.10.8.1 && <0.11, + containers >=0.5.7.1 && <0.6, + cryptohash-sha256 >=0.11.100.1 && <0.12, + deepseq >=1.4.2.0 && <1.5, + either >=4.4.1.1 && <4.5, + exceptions >=0.8.3 && <0.9, + formatting >=6.2.4 && <6.3, + hashable >=1.2.4.0 && <1.3, + lens ==4.14.*, + monad-logger >=0.3.20.1 && <0.4, + QuickCheck >=2.8.2 && <2.9, + random ==1.1.*, + scientific >=0.3.4.9 && <0.4, + semigroups >=0.18.2 && <0.19, + SHA >=1.6.4.2 && <1.7, + mtl >=2.2.1 && <2.3, + text >=1.2.2.1 && <1.3, + text-format >=0.3.1.1 && <0.4, + transformers >=0.5.2.0 && <0.6, + unordered-containers >=0.2.7.1 && <0.3, + vector >=0.11.0.0 && <0.12, + wreq >=0.4.1.0 && <0.5 + default-language: Haskell2010 + hs-source-dirs: src + other-modules: + Spark.Core.Internal.CachingUntyped + Spark.Core.Internal.ColumnFunctions + Spark.Core.Internal.AlgebraStructures + Spark.Core.Internal.ColumnStructures + Spark.Core.Internal.AggregationFunctions + Spark.Core.Internal.FunctionsInternals + Spark.Core.Internal.LocatedBase + Spark.Core.Internal.RowGenerics + Spark.Core.Internal.RowStructures + Spark.Core.Internal.RowUtils + Spark.IO.Internal.InputGeneric + Spark.IO.Internal.Json + Spark.IO.Internal.OutputCommon + ghc-options: -Wall ---fhpc -O0 + +test-suite karps-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + aeson >=0.11.2.1 && <0.12, + base >=4.9.0.0 && <4.10, + bytestring >=0.10.8.1 && <0.11, + containers >=0.5.7.1 && <0.6, + formatting >=6.2.4 && <6.3, + karps >=0.1.9.0 && <0.2, + hspec >=2.0 && <2.3, + text >=1.2.2.1 && <1.3, + raw-strings-qq ==1.1.*, + QuickCheck >=2.8.2 && <2.9, + vector >=0.11.0.0 && <0.12 + default-language: Haskell2010 + hs-source-dirs: test + other-modules: + Spark.Core.ContextSpec + Spark.Core.DatasetSpec + Spark.Core.Internal.CachingSpec + Spark.Core.Internal.LocalDataFunctionsSpec + Spark.Core.Internal.OpFunctionsSpec + Spark.Core.Internal.RowUtilsSpec + Spark.Core.Internal.DAGFunctionsSpec + Spark.Core.Internal.PathsSpec + Spark.Core.Internal.GroupsSpec + Spark.Core.PathSpec + Spark.Core.ProjectionsSpec + Spark.Core.RowToSQLSpec + Spark.Core.TypesSpec + Spark.Core.ColumnSpec + Spark.Core.SimpleExamplesSpec + ghc-options: -- -fhpc -O0 -Wall -prof +test-suite karps-test-integration + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + aeson >=0.11.2.1 && <0.12, + base >=4.9.0.0 && <4.10, + bytestring >=0.10.8.1 && <0.11, + containers >=0.5.7.1 && <0.6, + formatting >=6.2.4 && <6.3, + karps >=0.1.9.0 && <0.2, + hspec ==2.*, + text >=1.2.2.1 && <1.3, + raw-strings-qq ==1.1.*, + QuickCheck >=2.8.2 && <2.9, + vector >=0.11.0.0 && <0.12 + default-language: Haskell2010 + hs-source-dirs: test-integration + other-modules: + Spark.Core.CachingSpec + Spark.Core.CollectSpec + Spark.Core.ColumnSpec + Spark.Core.GroupsSpec + Spark.Core.IntegrationUtilities + Spark.Core.JoinsSpec + Spark.Core.SimpleAddSpec + Spark.Core.PruningSpec + Spark.IO.JsonSpec + Spark.IO.StampSpec + ghc-options: -- -fhpc -O0 -Wall -rtsopts=all -auto-all diff --git a/src/Spark/Core.hs b/src/Spark/Core.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core.hs @@ -0,0 +1,12 @@ +{-| +Module : Spark.Core +Description : Core functions and data structures to communicate with the Karps + server. +Copyright : (c) Karps contributors, 2016 +License : Apache-2.0 +Maintainer : krapsh@yandex.com +Stability : experimental +Portability : POSIX + +-} +module Spark.Core where diff --git a/src/Spark/Core/Column.hs b/src/Spark/Core/Column.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Column.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Spark.Core.Column +Description : Column types and basic operations. + +Operations on columns. +-} +module Spark.Core.Column( + -- * Types + Column, + DynColumn, + GenericColumn, + -- * Extractions and collations + asCol, + asCol', + pack1, + pack, + pack', + struct, + struct', + castCol, + castCol', + colRef, + (//), + (/-), + -- ToStaticProjectable, + StaticColProjection, + DynamicColProjection, + unsafeStaticProjection, + -- * Column type manipulations + dropColType, + -- * Column functions + colType, + untypedCol, + colFromObs, + colFromObs', + applyCol1, + ) where + +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.FunctionsInternals +import Spark.Core.Internal.Projections diff --git a/src/Spark/Core/ColumnFunctions.hs b/src/Spark/Core/ColumnFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/ColumnFunctions.hs @@ -0,0 +1,22 @@ + +{-| +Module : Spark.Core.ColumnFunctions +Description : Column operations + +The standard library of functions that operate on +data columns. +-} +module Spark.Core.ColumnFunctions( + -- * Reductions + sumCol, + sumCol', + countCol, + countCol', + -- * Casting + asDoubleCol +) where + +import Spark.Core.Internal.ArithmeticsImpl() +import Spark.Core.Internal.ColumnStandard +import Spark.Core.Internal.AggregationFunctions +import Spark.Core.Internal.Projections() diff --git a/src/Spark/Core/Context.hs b/src/Spark/Core/Context.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Context.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | This module defines session objects that act as entry points to spark. + +There are two ways to interact with Spark: using an explicit state object, +or using the default state object (interactive session). + +While the interactive session is the most convenient, it should not be +used for more than quick experimentations. Any complex code should use +the SparkSession and SparkState objects. +-} +module Spark.Core.Context( + SparkSessionConf(..), + SparkSession, + SparkState, + SparkInteractiveException, + FromSQL, + defaultConf, + executeCommand1, + executeCommand1', + computationStats, + createSparkSessionDef, + closeSparkSessionDef, + currentSessionDef, + computationStatsDef, + exec1Def, + exec1Def', + execStateDef + ) where + +import Data.Text(pack) + +import Spark.Core.Internal.ContextStructures +import Spark.Core.Internal.ContextIOInternal +import Spark.Core.Internal.ContextInteractive +import Spark.Core.Internal.RowGenericsFrom(FromSQL) + + +-- | The default configuration if the Karps server is being run locally. +defaultConf :: SparkSessionConf +defaultConf = + SparkSessionConf { + confEndPoint = pack "http://127.0.0.1", + confPort = 8081, + confPollingIntervalMillis = 500, + confRequestedSessionName = "", + confUseNodePrunning = False -- Disable graph pruning by default + } diff --git a/src/Spark/Core/Dataset.hs b/src/Spark/Core/Dataset.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Dataset.hs @@ -0,0 +1,48 @@ + +{- | +Module : Spark.Core.Dataset +Description : Dataset types and basic operations. + +This module describes the core data types (Dataset, DataFrame, +Observable and DynObservable), and some basic operations to relate them. +-} +module Spark.Core.Dataset( + -- * Common data structures + -- TODO Should it be hidden? + ComputeNode, + LocLocal, + LocDistributed, + LocUnknown, + UntypedNode, + -- * Distributed data structures + Dataset, + DataFrame, + -- * Local data structures + LocalData, + LocalFrame, + -- * Conversions + asDF, + asDS, + asLocalObservable, + castType, + castType', + -- * Relations + parents, + untyped, + untyped', + depends, + logicalParents, + logicalParents', + -- * Attributes + nodeLogicalParents, + nodeLogicalDependencies, + nodeParents, + nodeOp, + nodeId, + nodeName, + nodeType, + ) where + +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.Projections() diff --git a/src/Spark/Core/Functions.hs b/src/Spark/Core/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Functions.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Spark.Core.Functions( + -- * Creation + dataset, + dataframe, + constant, + -- * Standard conversions + asLocalObservable, + asDouble, + -- * Arithmetic operations + (.+), + (.-), + (./), + div', + -- * Utilities + (@@), + _1, + _2, + -- * Standard library + collect, + collect', + count, + identity, + autocache, + cache, + uncache, + joinInner, + joinInner', + broadcastPair + ) where + + +import Data.Aeson(toJSON) +import qualified Data.Vector as V + +import Spark.Core.Dataset +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Internal.ArithmeticsImpl +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.Joins +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.LocalDataFunctions +import Spark.Core.Internal.ObservableStandard +import Spark.Core.Internal.FunctionsInternals() +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.AggregationFunctions +import Spark.Core.Internal.TypesStructures(SQLType(..)) +import Spark.Core.Internal.Projections +import Spark.Core.Internal.CanRename + +dataset :: (ToSQL a, SQLTypeable a, HasCallStack) => [a] -> Dataset a +dataset l = emptyDataset op tp where + tp = buildType + op = NodeDistributedLit (unSQLType tp) (V.fromList ((toJSON . valueToCell) <$> l)) diff --git a/src/Spark/Core/Internal/AggregationFunctions.hs b/src/Spark/Core/Internal/AggregationFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/AggregationFunctions.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- A number of standard aggregation functions. + +module Spark.Core.Internal.AggregationFunctions( + -- Standard library + collect, + collect', + count, + count', + countCol, + countCol', + sumCol, + sumCol', + -- Developer functions + AggTry, + UniversalAggregator(..), + applyUAOUnsafe, + applyUntypedUniAgg3 +) where + +import Data.Aeson(Value(Null)) +import qualified Data.Text as T +import qualified Data.Vector as V + +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions(colType, untypedCol) +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.RowGenerics(ToSQL) +import Spark.Core.Internal.LocalDataFunctions() +import Spark.Core.Internal.FunctionsInternals +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesFunctions(arrayType') +import Spark.Core.StructuresInternal(emptyFieldPath) +import Spark.Core.Types +import Spark.Core.Try + +{-| The sum of all the elements in a column. + +If the data type is too small to represent the sum, the value being returned is +undefined. +-} +sumCol :: forall ref a. (Num a, SQLTypeable a, ToSQL a) => + Column ref a -> LocalData a +sumCol = applyUAOUnsafe _sumAgg' + +sumCol' :: DynColumn -> LocalFrame +sumCol' = applyUntypedUniAgg3 _sumAgg' + +{-| The number of elements in a column. + +-} +-- TODO use Long for the return data type. +count :: forall a. Dataset a -> LocalData Int +count = countCol . asCol + +count' :: DataFrame -> LocalFrame +count' = countCol' . asCol' + +countCol :: Column ref a -> LocalData Int +countCol = applyUAOUnsafe _countAgg' + +countCol' :: DynColumn -> LocalFrame +countCol' = applyUntypedUniAgg3 _countAgg' + + +{-| Collects all the elements of a column into a list. + +NOTE: +This list is sorted in the canonical ordering of the data type: however the +data may be stored by Spark, the result will always be in the same order. +This is a departure from Spark, which does not guarantee an ordering on +the returned data. +-} +collect :: forall ref a. (SQLTypeable a) => Column ref a -> LocalData [a] +collect = applyUAOUnsafe _collectAgg' + +{-| See the documentation of collect. -} +collect' :: DynColumn -> LocalFrame +collect' = applyUntypedUniAgg3 _collectAgg' + +type AggTry a = Either T.Text a + +{-| +This is the universal aggregator: the invariant aggregator and +some extra laws to combine multiple outputs. +It is useful for combining the results over multiple passes. +A real implementation in Spark has also an inner pass. +-} +data UniversalAggregator a buff = UniversalAggregator { + uaMergeType :: SQLType buff, + -- The result is partioning invariant + uaInitialOuter :: Dataset a -> LocalData buff, + -- This operation is associative and commutative + -- The logical parents of the final observable have to be the 2 inputs + uaMergeBuffer :: LocalData buff -> LocalData buff -> LocalData buff +} + +-- TODO(kps) check the coming type for non-summable types +_sumAgg' :: DataType -> AggTry UniversalAggregatorOp +_sumAgg' dt = pure UniversalAggregatorOp { + uaoMergeType = dt, + uaoInitialOuter = InnerAggOp $ AggFunction "SUM" (V.singleton emptyFieldPath), + uaoMergeBuffer = ColumnSemiGroupLaw "SUM_SL" + } + +_countAgg' :: DataType -> AggTry UniversalAggregatorOp +-- Counting will always succeed. +_countAgg' _ = pure UniversalAggregatorOp { + -- TODO(kps) switch to BigInt + uaoMergeType = StrictType IntType, + uaoInitialOuter = InnerAggOp $ AggFunction "COUNT" (V.singleton emptyFieldPath), + uaoMergeBuffer = ColumnSemiGroupLaw "SUM" + } + +_collectAgg' :: DataType -> AggTry UniversalAggregatorOp +-- Counting will always succeed. +_collectAgg' dt = + let ldt = arrayType' dt + soMerge = StandardOperator { + soName = "org.spark.Collect", + soOutputType = ldt, + soExtra = Null + } + soMono = StandardOperator { + soName = "org.spark.CatSorted", + soOutputType = ldt, + soExtra = Null + } + in pure UniversalAggregatorOp { + -- TODO(kps) switch to BigInt + uaoMergeType = ldt, + uaoInitialOuter = OpaqueAggTransform soMerge, + uaoMergeBuffer = OpaqueSemiGroupLaw soMono + } + +applyUntypedUniAgg3 :: (DataType -> AggTry UniversalAggregatorOp) -> DynColumn -> LocalFrame +applyUntypedUniAgg3 f dc = do + c <- dc + let uaot = f . unSQLType . colType $ c + uao <- tryEither uaot + let no = NodeAggregatorReduction uao + let ds = pack1 c + return $ emptyLocalData no (SQLType (uaoMergeType uao)) `parents` [untyped ds] + +applyUAOUnsafe :: forall a b ref. (SQLTypeable b, HasCallStack) => (DataType -> AggTry UniversalAggregatorOp) -> Column ref a -> LocalData b +applyUAOUnsafe f c = + let lf = applyUntypedUniAgg3 f (untypedCol c) + in forceRight (asObservable lf) + +-- _guardType :: DataType -> (UntypedDataset -> UntypedLocalData) -> (UntypedDataset -> LocalFrame) +-- _guardType dt f ds = +-- if unSQLType (nodeType ds) == dt +-- then +-- pure $ f ds +-- else +-- tryError $ sformat ("Expected type "%sh%" but got type "%sh) dt (nodeType ds) diff --git a/src/Spark/Core/Internal/AlgebraStructures.hs b/src/Spark/Core/Internal/AlgebraStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/AlgebraStructures.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} + +-- TODO remove this file +module Spark.Core.Internal.AlgebraStructures where + +-- | Algebraic structures that are common to columns and observables. + + +data BinaryOpFun in1 in2 to = BinaryOpFun { + bodLift1 :: in1 -> to, + bodLift2 :: in2 -> to, + bodOp :: to -> to -> to +} + + +class HomoBinaryOp2 in1 in2 to | in1 in2 -> to where + _liftFun :: (to -> to -> to) -> BinaryOpFun in1 in2 to + +_applyBinOp0 :: forall in1 in2 to. in1 -> in2 -> BinaryOpFun in1 in2 to -> to +_applyBinOp0 i1 i2 (BinaryOpFun l1 l2 bo) = bo (l1 i1) (l2 i2) + +applyBinOp :: forall in1 in2 to. (HomoBinaryOp2 in1 in2 to) => (to -> to -> to) -> in1 -> in2 -> to +applyBinOp f i1 i2 = + _applyBinOp0 i1 i2 (_liftFun f) + +-- -- | Overloaded operator for operationts that are guaranteed to succeed. +-- (.+) :: (Num out, HomoBinaryOp2 a1 a2 out) => a1 -> a2 -> out +-- (.+) = applyBinOp (+) + +(.-) :: (Num out, HomoBinaryOp2 a1 a2 out) => a1 -> a2 -> out +(.-) = applyBinOp (-) + +(.*) :: (Num out, HomoBinaryOp2 a1 a2 out) => a1 -> a2 -> out +(.*) = applyBinOp (*) + +-- TODO(kps) add here the rest of the Integral operations +div' :: (Integral out, HomoBinaryOp2 a1 a2 out) => a1 -> a2 -> out +div' = applyBinOp div + +-- **** Fractional **** + +(./) :: (Fractional out, HomoBinaryOp2 a1 a2 out) => a1 -> a2 -> out +(./) = applyBinOp (/) diff --git a/src/Spark/Core/Internal/Arithmetics.hs b/src/Spark/Core/Internal/Arithmetics.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Arithmetics.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +-- Required by old versions +{-# LANGUAGE FlexibleContexts #-} + +module Spark.Core.Internal.Arithmetics( + GeneralizedHomoReturn, + GeneralizedHomo2, + HomoColOp2, + -- | Developer API + performOp, + ) where + + +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.FunctionsInternals(projectColFunction2') +import Spark.Core.Internal.Utilities + +{-| All the automatic conversions supported when lifting a -} +type family GeneralizedHomoReturn x1 x2 where + GeneralizedHomoReturn (Column ref x1) (Column ref x1) = Column ref x1 + GeneralizedHomoReturn (Column ref x1) DynColumn = DynColumn + GeneralizedHomoReturn (Column ref x1) (LocalData x1) = Column ref x1 + GeneralizedHomoReturn (Column ref x1) LocalFrame = DynColumn + GeneralizedHomoReturn DynColumn (Column ref x1) = DynColumn + GeneralizedHomoReturn DynColumn DynColumn = DynColumn + GeneralizedHomoReturn DynColumn (LocalData x1) = DynColumn + GeneralizedHomoReturn DynColumn LocalFrame = DynColumn + GeneralizedHomoReturn (LocalData x1) (Column ref x1) = Column ref x1 + GeneralizedHomoReturn (LocalData x1) DynColumn = DynColumn + GeneralizedHomoReturn (LocalData x1) (LocalData x1) = LocalData x1 + GeneralizedHomoReturn (LocalData x1) LocalFrame = LocalFrame + GeneralizedHomoReturn LocalFrame (Column ref x1) = DynColumn + GeneralizedHomoReturn LocalFrame LocalFrame = LocalFrame + +-- The type of an homogeneous operation. +-- TODO it would be nice to enforce this contstraint at the type level, +-- but it is a bit more complex to do. +type HomoColOp2 = UntypedColumnData -> UntypedColumnData -> UntypedColumnData + +{-| The class of types that can be lifted to operations onto Karps types. + +This is the class for operations on homogeneous types (the inputs and the +output have the same underlying type). + +At its core, it takes a broadcasted operation that works on columns, and +makes that operation available on other shapes. +-} +class GeneralizedHomo2 x1 x2 where + _projectHomo :: x1 -> x2 -> HomoColOp2 -> GeneralizedHomoReturn x1 x2 + +{-| Performs an operation, using a reference operation defined on columns. +-} +performOp :: (GeneralizedHomo2 x1 x2) => + HomoColOp2 -> + x1 -> + x2 -> + GeneralizedHomoReturn x1 x2 +performOp f x1 x2 = _projectHomo x1 x2 f + +-- ******* INSTANCES ********* + +instance GeneralizedHomo2 DynColumn DynColumn where + _projectHomo = _performDynDyn + +instance GeneralizedHomo2 (Column ref x) (Column ref x) where + _projectHomo = _performCC + +instance GeneralizedHomo2 DynColumn (Column ref x) where + _projectHomo dc1 c2 = _performDynDyn dc1 (untypedCol c2) + +instance GeneralizedHomo2 (Column ref x) DynColumn where + _projectHomo c1 = _performDynDyn (untypedCol c1) + +instance GeneralizedHomo2 (Column ref x) (LocalData x) where + _projectHomo c1 o2 = _projectHomo c1 (broadcast o2 c1) + +instance GeneralizedHomo2 (LocalData x) (Column ref x) where + _projectHomo o1 c2 = _projectHomo (broadcast o1 c2) c2 + +instance GeneralizedHomo2 (Column ref x) LocalFrame where + _projectHomo c1 o2' = _projectHomo c1 (broadcast' o2' (untypedCol c1)) + +instance GeneralizedHomo2 LocalFrame (Column ref x) where + _projectHomo o1' c2 = _projectHomo (broadcast' o1' (untypedCol c2)) c2 + +instance GeneralizedHomo2 LocalFrame LocalFrame where + _projectHomo o1' o2' f = + let f' x y = f <$> x <*> y + in projectColFunction2' f' o1' o2' + + +_performDynDyn :: + DynColumn -> DynColumn -> HomoColOp2 -> DynColumn +_performDynDyn dc1 dc2 f = do + c1 <- dc1 + c2 <- dc2 + -- TODO: add type guard + let c = f c1 c2 + -- TODO: add dynamic check on the type of the return + return (dropColType c) + +_performCC :: (HasCallStack) => + Column ref x -> Column ref x -> HomoColOp2 -> Column ref x +_performCC c1 c2 f = + let sqlt = colType c1 + c = f (iUntypedColData c1) (iUntypedColData c2) + c' = forceRight $ castCol (colRef c1) sqlt (pure c) + in c' + +_performCO :: (HasCallStack) => + Column ref x -> LocalData x -> HomoColOp2 -> Column ref x +_performCO c1 o2 = _performCC c1 (broadcast o2 c1) diff --git a/src/Spark/Core/Internal/ArithmeticsImpl.hs b/src/Spark/Core/Internal/ArithmeticsImpl.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ArithmeticsImpl.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Disabled for old versions +-- {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +-- Required by old versions +{-# LANGUAGE FlexibleContexts #-} + +{-| This module contains all the class instances and operators related +to arithmetics with Datasets, Dataframes, Columns and Observables. +-} +module Spark.Core.Internal.ArithmeticsImpl( + (.+), + (.-), + (./), + div' + ) where + +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.LocalDataFunctions(constant) +import Spark.Core.Internal.FunctionsInternals(projectColFunction2', projectColFunction') +import Spark.Core.Internal.Arithmetics + + +{-| A generalization of the addition for the Karps types. +-} +(.+) :: forall a1 a2. (Num a1, Num a2, GeneralizedHomo2 a1 a2) => + a1 -> a2 -> GeneralizedHomoReturn a1 a2 +(.+) = performOp (homoColOp2 "+") + +{-| A generalization of the negation for the Karps types. +-} +(.-) :: forall a1 a2. (Num a1, Num a2, GeneralizedHomo2 a1 a2) => + a1 -> a2 -> GeneralizedHomoReturn a1 a2 +(.-) = performOp (homoColOp2 "-") + +(./) :: (Fractional a1, Fractional a2, GeneralizedHomo2 a1 a2) => + a1 -> a2 -> GeneralizedHomoReturn a1 a2 +(./) = performOp (homoColOp2 "/") + +div' :: forall a1 a2. (Num a1, Num a2, GeneralizedHomo2 a1 a2) => + a1 -> a2 -> GeneralizedHomoReturn a1 a2 +div' = performOp (homoColOp2 "/") + +-- All the operations are defined from column operations +-- This adds a little overhead, but it can be optimized by the backend. +instance Num LocalFrame where + (+) = projectColFunction2' (+) + (-) = projectColFunction2' (-) + (*) = projectColFunction2' (*) + abs = projectColFunction' abs + signum = projectColFunction' signum + -- It will choose by default to use the Int type, which may not be + -- what the user wants. + -- In case there is some doubt, user should use typed operations. + fromInteger x = asLocalObservable $ constant (fromInteger x :: Int) + negate = projectColFunction' negate diff --git a/src/Spark/Core/Internal/Caching.hs b/src/Spark/Core/Internal/Caching.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Caching.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- Methods related to checking caching in the graph. +-} + +module Spark.Core.Internal.Caching( + NodeCachingType(..), + CachingFailure(..), + CacheTry, + CacheGraph, + AutocacheGen(..), + checkCaching, + fillAutoCache +) where + +import Control.Monad.Identity +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import Control.Arrow((&&&)) +import Data.Foldable +import Data.Set(Set) +import Data.Maybe(mapMaybe) +import Debug.Trace(trace) +import Data.Text(Text) +import Formatting +-- import Debug.Trace + +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities +-- import Spark.Core.StructuresInternal(NodeId) + +data NodeCachingType = + -- Hinted caching. Will be fullfilled by the algorithm below. + -- The node id is that of the node being cached + AutocacheOp VertexId + -- Unconditional caching + -- The node id is that of the node being cached + | CacheOp VertexId + -- First one is the node id + -- the second is the id of the matching cache or autocache node + | UncacheOp VertexId VertexId + | Through + | Stop deriving (Show, Eq) + +data CachingFailure = CachingFailure { + cachingNode :: !VertexId, + uncachingNode :: !VertexId, + escapingNode :: !VertexId +} deriving (Show, Eq) + +type CacheTry t = Either Text t + +type CacheGraph v = Graph (v, NodeCachingType) StructureEdge + +data AutocacheGen v = AutocacheGen { + -- Generates an uncaching node to insert at the final location of uncaching + deriveUncache :: Vertex v -> Vertex v, + -- A function that given a node, generates an identity node (and a new node + -- id) that can be inserted in place. The generated node id will be used with + -- the identity node newly generated; the previous node will be moved around + -- along with its identity. + deriveIdentity :: Vertex v -> Vertex v +} + +checkCaching :: (Show v) => + Graph v StructureEdge -> + (v -> CacheTry NodeCachingType) -> + CacheTry [CachingFailure] +checkCaching g fun = _cacheGraph g fun >>= _checkCaching + +fillAutoCache :: (Show v) => + (v -> CacheTry NodeCachingType) -> + AutocacheGen v -> + Graph v StructureEdge -> + -- The final graph being constructed. + DagTry (Graph v StructureEdge) +fillAutoCache cacheFun acGen g = do + cg <- graphMapVertices g $ \vx _ -> (const vx &&& id) <$> cacheFun vx + acg <- _fillAutoCache acGen cg + let acg' = graphMapVertices' fst acg + return acg' + + +-- Some internal types to guarantee more correctness +newtype AutocacheVertex v = AutocacheVertex (Vertex v) +newtype StopVertex v = StopVertex { unStopVertex :: Vertex v } +newtype IdentityVertex v = IdentityVertex (Vertex v) +data UncacheVertex v = UncacheVertex (Vertex v) VertexId deriving (Show) +newtype AnyCacheOp = AnyCacheOp { unAnyCacheOp :: VertexId } deriving (Show, Ord, Eq) + +-- The result of creating a vertex +type CreateUncache v = + Either (UncacheVertex v) (UncacheVertex v, Edge StructureEdge) + +-- This performs a graph transform: +-- For each autocache node, it finds the transitive closure of Stop nodes. +-- Then it replaces the sink nodes by a layer of identity nodes and sink nodes +-- and intercalates the uncache node between the two layers, through some +-- logical dependencies. +-- +-- If it does not find the closuure, it leaves these +-- autocache nodes alone and does not attempt to remove them: they will be +-- considered as being unconditional caching without checks. +-- +-- Note that it works on the reverse of the graph (flow instead of dependencies) +_fillAutoCache :: forall v. (Show v) => + AutocacheGen v -> + -- The graph, already annotated with caching information + Graph (v, NodeCachingType) StructureEdge -> + -- The final graph being constructed. + DagTry (Graph (v, NodeCachingType) StructureEdge) +_fillAutoCache acGen cg = + -- Find the auto nodes. + -- Compute the closure for each of them + -- Perform the insertion. + -- TODO: this function is too big, split or build subfunctions. + let + vxMap = M.fromList ((vertexId &&& id) <$> toList (gVertices cg)) + -- TODO: mark if the result was already in the graph + findOrCreateIdentity :: StopVertex v -> IdentityVertex v + findOrCreateIdentity (StopVertex vx) = + let uvx = deriveIdentity acGen vx + in case M.lookup (vertexId uvx) vxMap of + Just vx' -> IdentityVertex $ fst <$> vx' -- Already created + Nothing -> IdentityVertex uvx + acNodesAndScopes = _autoCachingCandidates cg + -- Add the uncaching nodes + findOrCreateUncache' (acv, l) = case _findOrCreateUncache vxMap acGen acv of + Left x -> trace ("findOrCreateUncache: dropping autocache node " ++ show x) Nothing + Right (ucv, ed) -> Just (ed, (acv, ucv, l)) + acWithUncache' = mapMaybe findOrCreateUncache' acNodesAndScopes + acWithUncache = snd <$> acWithUncache' + acEdges = fst <$> acWithUncache' + -- Now group by stop vertex, so that each stop vertex has a list of + -- associated cache and uncache nodes. + -- Not sure if they may be several, but it just sounds like good practice. + tups = myGroupBy [(vertexId (unStopVertex svx), (cvx, uvx, svx)) | (cvx, uvx, l) <- acWithUncache, + svx <- l] + -- Just in this case, it should work because of the construction above + -- TODO: put a lot more documentation here, it is tricky code + group ((_, uvx, svx) : t) = (svx, findOrCreateIdentity svx, uvx : [uvx' | ( _, uvx', _) <- t]) + group [] = failure "_fillAutoCache:group: empty: should not happen" + stopsWithCachingSteps :: [(StopVertex v, IdentityVertex v, [UncacheVertex v])] + stopsWithCachingSteps = (group . snd) <$> M.toList tups + tups2 = [(svx, ivx, uvx) | (svx, ivx, l) <- stopsWithCachingSteps, uvx <- l] + folder eds (svx, ivx, uvx) = _performEdgeTransform svx ivx uvx eds + startEdges = veEdge <$> [ve | (_, v) <- M.toList (gEdges cg), ve <- V.toList v] + edges = acEdges ++ foldl' folder startEdges tups2 + -- Gather all the vertices and edges, and remove duplicates + startVertices = V.toList (gVertices cg) + ucVertices = acWithUncache <&> \(_, UncacheVertex vx cacheVid, _) -> + -- TODO: propagate the cache vertexId with UncacheVertex + let op = UncacheOp (vertexId vx) cacheVid + in (id &&& const op) <$> vx + idVertices = tups2 <&> \(_, IdentityVertex vx, _) -> + (id &&& const Stop) <$> vx + allVertices = startVertices ++ ucVertices ++ idVertices + -- Make a new graph + in buildGraphFromList allVertices edges + +-- TODO: should be a try to perform extra check operations +_findOrCreateUncache :: (HasCallStack, Show v) => + M.Map VertexId (Vertex (v, NodeCachingType)) -> + AutocacheGen v -> + AutocacheVertex v -> CreateUncache v +_findOrCreateUncache vxMap acGen (AutocacheVertex acv) = + let uvx = deriveUncache acGen acv + acVid = vertexId acv + uVid = vertexId uvx + look = vertexData <$> M.lookup uVid vxMap + in case look of + Just (x, UncacheOp _ _) -> + -- That vertex already exists, we will not try to create + -- an uncaching node then + Left $ UncacheVertex (Vertex uVid x) uVid + Just _ -> + -- That vertex already exists, but it is not the proper type. + -- This is a programming error in AutocacheGen: we abort here. + failure $ sformat ("_findOrCreateUncache:"%sh%"->"%sh) acv look + Nothing -> + -- The uncache node does not exist, we are going to create one. + let ed' = Edge uVid acVid ParentEdge + in Right (UncacheVertex uvx uVid, ed') + + +-- FIXME: duplicated work on the stop and identity: pass all the uncache vertexes to process them in one go +_performEdgeTransform :: + StopVertex v -> IdentityVertex v -> UncacheVertex v -> [Edge StructureEdge] -> [Edge StructureEdge] +_performEdgeTransform (StopVertex svx) (IdentityVertex ivx) (UncacheVertex uvx _) eds = + let stopVid = vertexId svx + idenVid = vertexId ivx + ucVid = vertexId uvx + -- Rewrite the edges incoming to the stop node so that they point to the + -- id node instead. + f ed | edgeTo ed == stopVid = ed { edgeTo = idenVid } + f ed = ed + joinEd = Edge { edgeFrom = idenVid, edgeTo = stopVid, edgeData = ParentEdge } + id1Ed = Edge { edgeFrom = idenVid, edgeTo = ucVid, edgeData = LogicalEdge } + id2Ed = Edge { edgeFrom = ucVid, edgeTo = stopVid, edgeData = LogicalEdge } + in id1Ed : id2Ed : joinEd : (f <$> eds) + +-- The list of nodes that do autocaching, and the fringes for each of these +-- nodes. +-- Returns a list of caching node -> [stop node] +_autoCachingCandidates :: forall v. (Show v) => + Graph (v, NodeCachingType) StructureEdge -> + [(AutocacheVertex v, [StopVertex v])] +_autoCachingCandidates cg = + let + cg' = graphMapVertices' snd cg + exps = gVertices $ _expansions cg' + extractAutocache vx = case snd (vertexData vx) of + AutocacheOp _ -> [AutocacheVertex (fst <$> vx)] + _ -> [] + acVxs = concatMap extractAutocache (gVertices cg) + -- All the stop nodes for each caching vertex id + extractFringe vx = case vertexData vx of + (Stop, set) -> (id &&& const (vertexId vx)) <$> toList set + _ -> [] + -- cache vid -> Stop vertex id + acWithFringe = myGroupBy $ concatMap extractFringe (toList exps) + vmap = vertexMap cg + vmap' = vertexMap cg' + -- TODO: should be a try and it should not fail + findStop :: VertexId -> Maybe (StopVertex v) + findStop vid = do + vx <- M.lookup vid vmap + _ <- M.lookup vid vmap' + return $ StopVertex (Vertex vid (fst vx)) + -- TODO: it should be a try, although it is a programming error here + combineWithFringe :: AutocacheVertex v -> (AutocacheVertex v, [StopVertex v]) + combineWithFringe acv @ (AutocacheVertex vx) = + let vids = M.findWithDefault [] (AnyCacheOp (vertexId vx)) acWithFringe + in (acv, mapMaybe findStop vids) + -- Remove the nodes that do not have a fringe. + -- In this case, they are passed through without uncaching operation. + acWithFringeVx = filter (not.null.snd) $ combineWithFringe <$> acVxs + in acWithFringeVx + +_checkCaching :: Graph NodeCachingType StructureEdge -> CacheTry [CachingFailure] +_checkCaching cg = + let + expands = snd <$> vertexMap (_expansions cg) + removals = vertexMap $ _removals cg + f :: NodeCachingType -> [(VertexId, VertexId)] + f (UncacheOp uncacheNid cacheNid) = [(cacheNid, uncacheNid)] + f _ = [] + -- cacheNID -> uncacheNID + removedNodes = M.fromList $ concatMap f (vertexData <$> gVertices cg) + removedNodeSet = S.fromList $ M.keys removedNodes + checkErrors :: VertexId -> [CachingFailure] + checkErrors nid = + let rems = S.intersection + removedNodeSet + (M.findWithDefault S.empty nid removals) + exps = S.intersection + removedNodeSet + (unAnyCacheOp `S.map` M.findWithDefault S.empty nid expands) + bad = S.toList $ S.difference exps rems + badWithUncache = flip mapMaybe bad $ \ cacheNid -> + M.lookup cacheNid removedNodes <&> \uncacheNid -> + CachingFailure cacheNid uncacheNid nid + in badWithUncache + in return $ concatMap checkErrors (vertexId <$> gVertices cg) + +_cacheGraph :: (Show v) => Graph v StructureEdge -> + (v -> CacheTry NodeCachingType) -> + CacheTry (Graph NodeCachingType StructureEdge) +_cacheGraph g f = + graphMapVertices g f' where + f' vx _ = f vx + +-- The set of node caching operations at each step. +-- This includes both regular cache and autocache. +_expansions :: (Show e) => + Graph NodeCachingType e -> + Graph (NodeCachingType, Set AnyCacheOp) e +_expansions g = runIdentity (graphMapVertices g f) where + f x l = return (x, S.union seta parentSet) where + filt ((Stop, _), _) = S.empty + -- Uncaching drops the caching node from the expansions + filt ((UncacheOp _ cacheVid, s), _) = S.delete (AnyCacheOp cacheVid) s + filt ((_, s), _) = s + parentSet :: S.Set AnyCacheOp + parentSet = S.unions (filt <$> l) + seta = case x of + CacheOp nid -> S.singleton (AnyCacheOp nid) + AutocacheOp nid -> S.singleton (AnyCacheOp nid) + _ -> S.empty + +_removals :: (Show e) => + Graph NodeCachingType e -> Graph (Set VertexId) e +_removals g = runIdentity (graphMapVertices (reverseGraph g) f) where + f x l = return $ S.union seta (S.unions (fst <$> l)) where + seta = case x of + UncacheOp _ cacheNid -> S.singleton cacheNid + _ -> S.empty diff --git a/src/Spark/Core/Internal/CachingUntyped.hs b/src/Spark/Core/Internal/CachingUntyped.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/CachingUntyped.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + + +{-| Implementation of the caching interfaces for the compute data structures. +-} +module Spark.Core.Internal.CachingUntyped( + cachingType, + autocacheGen +) where + +import Control.Monad.Except + +import Spark.Core.Internal.Caching +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.PathsUntyped() +import Spark.Core.Internal.DAGStructures +import Spark.Core.StructuresInternal + +cachingType :: UntypedNode -> CacheTry NodeCachingType +cachingType n = case nodeOp n of + NodeLocalOp _ -> pure Stop + NodeAggregatorReduction _ -> pure Stop + NodeAggregatorLocalReduction _ -> pure Stop + NodeOpaqueAggregator _ -> pure Stop + NodeLocalLit _ _ -> pure Stop + NodeStructuredTransform _ -> pure Through + NodeDistributedLit _ _ -> pure Through + NodeDistributedOp so | soName so == opnameCache -> + pure $ CacheOp (vertexToId n) + NodeDistributedOp so | soName so == opnameUnpersist -> + case nodeParents n of + [n'] -> pure $ UncacheOp (vertexToId n) (vertexToId n') + _ -> throwError "Node is not valid uncache node" + NodeDistributedOp so | soName so == opnameAutocache -> + pure $ AutocacheOp (vertexToId n) + NodeDistributedOp _ -> pure Through -- Nothing special for the other operations + NodeBroadcastJoin -> pure Through + NodeGroupedReduction _ -> pure Stop + NodeReduction _ -> pure Stop + NodePointer _ -> pure Stop -- It is supposed to be an observable + +autocacheGen :: AutocacheGen UntypedNode +autocacheGen = AutocacheGen { + deriveUncache = deriveUncache', + deriveIdentity = deriveIdentity' +} where + -- TODO: use path-based identification in the future + -- f :: String -> VertexId -> VertexId + -- f s (VertexId bs) = VertexId . C8.pack . (++s) . C8.unpack $ bs + deriveIdentity' (Vertex _ un) = + let x = identity un + vid' = VertexId . unNodeId . nodeId $ x -- f "_identity" vid + in Vertex vid' x + deriveUncache' (Vertex _ un) = + let x = uncache un + vid' = VertexId . unNodeId . nodeId $ x -- f "_uncache" vid + in Vertex vid' x diff --git a/src/Spark/Core/Internal/CanRename.hs b/src/Spark/Core/Internal/CanRename.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/CanRename.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- TODO(kps): this module stretches my understanding of Haskell. +-- There is probably better than that. + +{-| Defines the notion of renaming something. + +This is closed over a few well-defined types. +-} +module Spark.Core.Internal.CanRename where + +import qualified Data.Text as T +import Formatting + +import Spark.Core.Try +import Spark.Core.StructuresInternal +import Spark.Core.Internal.ColumnFunctions() +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities + +-- | The class of types that can be renamed. +-- It is made generic because it covers 2 notions: +-- - the name of a compute node that will eventually determine its compute path +-- - the name of field (which may become an object path) +-- This syntax tries to be convenient and will fail immediately +-- for basic errors such as illegal characters. +-- +-- This could be revisited in the future, but it is a compromise +-- on readability. +class CanRename a txt where + (@@) :: a -> txt -> a + +infixl 1 @@ + + +instance forall ref a. CanRename (ColumnData ref a) FieldName where + c @@ fn = c { _cReferingPath = Just fn } + + +instance forall ref a s. (s ~ String) => CanRename (Column ref a) s where + c @@ str = case fieldName (T.pack str) of + Right fp -> c @@ fp + Left msg -> + -- The syntax check here is pretty lenient, so it fails, it has + -- some good reasons. We stop here. + failure $ sformat ("Could not make a field path out of string "%shown%" for column "%shown%":"%shown) str c msg + +instance CanRename DynColumn FieldName where + (Right cd) @@ fn = Right (cd @@ fn) + -- TODO better error handling + x @@ _ = x + +instance forall s. (s ~ String) => CanRename DynColumn s where + -- An error could happen when making a path out of a string. + (Right cd) @@ str = case fieldName (T.pack str) of + Right fp -> Right $ cd @@ fp + Left msg -> + -- The syntax check here is pretty lenient, so it fails, it has + -- some good reasons. We stop here. + tryError $ sformat ("Could not make a field path out of string "%shown%" for column "%shown%":"%shown) str cd msg + -- TODO better error handling + x @@ _ = x + + +instance forall loc a s. (s ~ String) => CanRename (ComputeNode loc a) s where + -- There is no need to update the id, as this field is not involved + -- in the calculation of the id. + -- TODO: make this fail immediately? If the name is wrong, it is + -- harder to figure out what is happening. + (@@) cn name = cn { _cnName = Just nn } where + nn = NodeName . T.pack $ name + +instance forall loc a s. (s ~ String) => CanRename (Try (ComputeNode loc a)) s where + (Right n) @@ str = Right (n @@ str) + (Left n) @@ _ = Left n diff --git a/src/Spark/Core/Internal/Client.hs b/src/Spark/Core/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Client.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +-- The communication protocol with the server + +module Spark.Core.Internal.Client where + +import Spark.Core.StructuresInternal +import Spark.Core.Dataset(UntypedNode) +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesStructures(DataType) +import Spark.Core.Internal.TypesFunctions() + +import Data.Text(Text, pack) +import Data.Aeson +import Data.Aeson.Types(Parser) +import GHC.Generics + + +-- Imports for the client + +{-| The ID of an RDD in Spark. +-} +data RDDId = RDDId { + unRDDId :: !Int +} deriving (Eq, Show, Ord) + +data LocalSessionId = LocalSessionId { + unLocalSession :: !Text +} deriving (Eq, Show) + +data Computation = Computation { + cSessionId :: !LocalSessionId, + cId :: !ComputationID, + cNodes :: ![UntypedNode], + -- Non-empty + cTerminalNodes :: ![NodePath], + -- The node at the top of the computation. + -- Must be part of the terminal nodes. + cCollectingNode :: !NodePath, + -- This redundant information is not serialized. + -- It is used internally to track the resulting nodes. + cTerminalNodeIds :: ![NodeId] +} deriving (Show, Generic) + +data BatchComputationKV = BatchComputationKV { + bckvLocalPath :: !NodePath, + bckvDeps :: ![NodePath], + bckvResult :: !PossibleNodeStatus +} deriving (Show, Generic) + +data BatchComputationResult = BatchComputationResult { + bcrTargetLocalPath :: !NodePath, + bcrResults :: ![(NodePath, [NodePath], PossibleNodeStatus)] +} deriving (Show, Generic) + +data RDDInfo = RDDInfo { + rddiId :: !RDDId, + rddiClassName :: !Text, + rddiRepr :: !Text, + rddiParents :: ![RDDId] +} deriving (Show, Generic) + +data SparkComputationItemStats = SparkComputationItemStats { + scisRddInfo :: ![RDDInfo] +} deriving (Show, Generic) + +data PossibleNodeStatus = + NodeQueued + | NodeRunning + | NodeFinishedSuccess !(Maybe NodeComputationSuccess) !(Maybe SparkComputationItemStats) + | NodeFinishedFailure NodeComputationFailure deriving (Show, Generic) + +data NodeComputationSuccess = NodeComputationSuccess { + -- Because Row requires additional information to be deserialized. + ncsData :: Value, + -- The data type is also available, but it is not going to be parsed for now. + ncsDataType :: DataType +} deriving (Show, Generic) + +data NodeComputationFailure = NodeComputationFailure { + ncfMessage :: !Text +} deriving (Show, Generic) + + +-- **** AESON INSTANCES *** + +instance ToJSON LocalSessionId where + toJSON = toJSON . unLocalSession + +instance FromJSON RDDId where + parseJSON x = RDDId <$> parseJSON x + +instance FromJSON RDDInfo where + parseJSON = withObject "RDDInfo" $ \o -> do + _id <- o .: "id" + className <- o .: "className" + repr <- o .: "repr" + parents <- o .: "parents" + return $ RDDInfo _id className repr parents + +instance FromJSON SparkComputationItemStats where + parseJSON = withObject "SparkComputationItemStats" $ \o -> do + rddinfo <- o .: "rddInfo" + return $ SparkComputationItemStats rddinfo + +instance FromJSON BatchComputationKV where + parseJSON = withObject "BatchComputationKV" $ \o -> do + np <- o .: "localPath" + deps <- o .: "pathDependencies" + res <- o .: "result" + return $ BatchComputationKV np deps res + +instance FromJSON BatchComputationResult where + parseJSON = withObject "BatchComputationResult" $ \o -> do + kvs <- o .: "results" + tlp <- o .: "targetLocalPath" + let f (BatchComputationKV k d v) = (k, d, v) + return $ BatchComputationResult tlp (f <$> kvs) + +instance FromJSON NodeComputationSuccess where + parseJSON = withObject "NodeComputationSuccess" $ \o -> NodeComputationSuccess + <$> o .: "content" + <*> o .: "type" + +-- Because we get a row back, we need to supply a SQLType for deserialization. +instance FromJSON PossibleNodeStatus where + parseJSON = + let parseSuccess :: Object -> Parser PossibleNodeStatus + parseSuccess o = NodeFinishedSuccess + <$> o .:? "finalResult" + <*> o .:? "stats" + parseFailure :: Object -> Parser PossibleNodeStatus + parseFailure o = + (NodeFinishedFailure . NodeComputationFailure) <$> o .: pack "finalError" + in + withObject "PossibleNodeStatus" $ \o -> do + status <- o .: pack "status" + case pack status of + "running" -> return NodeRunning + "finished_success" -> parseSuccess o + "finished_failure" -> parseFailure o + "scheduled" -> return NodeQueued + _ -> failure $ pack ("FromJSON PossibleNodeStatus " ++ show status) diff --git a/src/Spark/Core/Internal/ColumnFunctions.hs b/src/Spark/Core/Internal/ColumnFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ColumnFunctions.hs @@ -0,0 +1,358 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- Implements a DSL for extracting some columns from dataframes and datasets. + +module Spark.Core.Internal.ColumnFunctions( + -- Accessors + colType, + colOrigin, + colOp, + colFieldName, + -- Standard functions + broadcast, + broadcast', + -- Internal API + iUntypedColData, + iEmptyCol, + -- Developer API (projections) + -- unsafeStaticProjection, + dropColReference, + dropColType, + extractPathUnsafe, + colExtraction, + unsafeProjectCol, + genColOp, + homoColOp2, + makeColOp1, + -- -- Developer API (projection builders) + -- dynamicProjection, + -- stringToDynColProj, + -- pathToDynColProj, + -- colStaticProjToDynProj, + -- -- Developer API (projection transformers) + -- projectDSDyn, + -- projectDFDyn, + -- projectDsCol, + -- projectColCol, + -- projectColDynCol, + -- projectDColDCol, + -- Public functions + applyCol1, + untypedCol, + colFromObs, + colFromObs', + castTypeCol, + castCol, + castCol', + colRef +) where + +import qualified Data.Text as T +import qualified Data.Text.Format as TF +import qualified Data.Vector as V +import Data.String(IsString(fromString)) +import Data.Text.Lazy(toStrict) +import Data.Maybe(fromMaybe) +import Data.List(find) +import Formatting + +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.TypesStructures +import Spark.Core.StructuresInternal +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.OpFunctions(prettyShowColOp, prettyShowColFun) +import Spark.Core.Internal.AlgebraStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesGenerics(SQLTypeable, buildType) +import Spark.Core.Try + +-- ********** Public methods ******** + + +{-| The type of a column. +-} +colType :: Column ref a -> SQLType a +colType = SQLType . _cType + +{-| Converts a type column to an antyped column. +-} +untypedCol :: Column ref a -> DynColumn +untypedCol = pure . dropColType . dropColReference + +{-| Drops the type information, but kees the reference. +-} +dropColType :: Column ref a -> GenericColumn ref +dropColType = _unsafeCastColData + +{-| Casts a dynamic column to a statically typed column. + +In this case, one must supply the reference (which can be obtained from +another column with colRef, or from a dataset), and a type (which can be +built using the buildType function). +-} +castCol :: ColumnReference ref -> SQLType a -> DynColumn -> Try (Column ref a) +castCol r sqlt dc = + dc >>= castTypeCol sqlt >>= _checkedCastRefColData r + +{-| Casts a dynamic column to a statically typed column, but does not attempt +to enforce a single origin at the type level. + +This is useful when building a dataset from a dataframe: the origin information +cannot be conveyed since it is not available in the first place. +-} +castCol' :: SQLType a -> DynColumn -> Try (Column UnknownReference a) +castCol' = castCol ColumnReference + + +-- | (internal) +castTypeCol :: SQLType b -> ColumnData ref a -> Try (ColumnData ref b) +castTypeCol sqlt cd = + if unSQLType sqlt == unSQLType (colType cd) + then pure (_unsafeCastColData cd) + else tryError $ sformat ("Cannot cast column "%sh%" to type "%sh) cd sqlt + +{-| Takes some local data (contained in an observable) and broadacasts it along +a reference column. +-} +-- TODO: it would be more logical to swap the inputs +broadcast :: LocalData a -> Column ref b -> Column ref a +broadcast ld c = ColumnData { + _cOrigin = colOrigin c, + _cType = unSQLType (nodeType ld), + _cOp = BroadcastColOp (untypedLocalData ld), + _cReferingPath = Nothing + } + +broadcast' :: LocalFrame -> DynColumn -> DynColumn +broadcast' lf dc = do + ld <- lf + c <- dc + return $ broadcast ld c + +-- (internal) +colOrigin :: Column ref a -> UntypedDataset +colOrigin = _cOrigin + +-- (internal) +colOp :: Column ref a -> GeneralizedColOp +colOp = _cOp + +{-| A tag with the reference of a column. + +This is useful when casting dynamic columns to typed columns. +-} +colRef :: Column ref a -> ColumnReference ref +colRef _ = ColumnReference + +-- | Takes an observable and makes it available as a column of the same type. +colFromObs :: (HasCallStack) => LocalData a -> Column (LocalData a) a +colFromObs = missing "colFromObs" + +-- | Takes a dynamic observable and makes it available as a dynamic column. +colFromObs' :: (HasCallStack) => LocalFrame -> DynColumn +colFromObs' = missing "colFromObs'" + +-- | (internal) +colFieldName :: ColumnData ref a -> FieldName +colFieldName c = + fromMaybe (unsafeFieldName . _prettyShowColOp . _cOp $ c) + (_cReferingPath c) + +{-| A converience function for applying one-argument typed functions to +dynamic column. +-} +applyCol1 :: forall x y. (SQLTypeable x) => (forall ref. Column ref x -> Column ref y) -> DynColumn -> DynColumn +applyCol1 f dc = do + c <- dc + let t = buildType :: SQLType x + c1 <- castCol (colRef c) t dc + let c2 = f c1 + untypedCol c2 + + +-- ******** Operations on column operations ******** + +genColOp :: ColOp -> GeneralizedColOp +genColOp (ColExtraction fp) = GenColExtraction fp +genColOp (ColFunction n v) = GenColFunction n (genColOp <$> v) +-- TODO: replace in the ColOp by Cell instead of JSON. +genColOp (ColLit dt _) = GenColLit dt (missing "genColOp (ColLit dt c)") +genColOp (ColStruct v) = GenColStruct (f <$> v) where + f (TransformField n v') = GeneralizedTransField n (genColOp v') + + +-- ********* Projection operations *********** + + +-- ****** Functions that build projections ******* + + +iUntypedColData :: Column ref a -> UntypedColumnData +iUntypedColData = _unsafeCastColData . dropColReference + +-- Recasts the column, trusting the user knows that the type is going to be compatible. +_unsafeCastColData :: Column ref a -> Column ref b +_unsafeCastColData c = c { _cType = _cType c } + +_checkedCastColData :: SQLType b -> ColumnData ref a -> Try (ColumnData ref b) +_checkedCastColData sqlt cd = + if unSQLType sqlt == unSQLType (colType cd) + then pure (_unsafeCastColData cd) + else tryError $ sformat ("Cannot cast column "%sh%" to type "%sh) cd sqlt + +_checkedCastRefColData :: ColumnReference ref2 -> ColumnData ref a -> Try (ColumnData ref2 a) +_checkedCastRefColData _ cd = + -- TODO: do some dynamic checks on the origin. + pure $ cd { _cType = _cType cd } + + + +-- Performs the data projection. This is unsafe, it does not check that the +-- field path is valid in this case, nor that the final type is valid either. +unsafeProjectCol :: ColumnData ref a -> FieldPath -> DataType -> ColumnData ref b +unsafeProjectCol cd (FieldPath p) dtTo = + -- If the column is already a projection, flatten it. + case colOp cd of + -- No previous parent on an extraction -> we can safely append to that one. + GenColExtraction (FieldPath p') -> + cd { _cOp = GenColExtraction . FieldPath $ (p V.++ p'), + _cType = dtTo} + _ -> + -- Extract from the previous column. + cd { _cOp = GenColExtraction . FieldPath $ p, + _cType = dtTo} + + +extractPathUnsafe :: SQLType from -> FieldPath -> Maybe (SQLType to) +extractPathUnsafe sqlt (FieldPath v) = _extractPath0 sqlt (V.toList v) + +_extractPath0 :: SQLType from -> [FieldName] -> Maybe (SQLType to) +_extractPath0 sqlt [] = Just (unsafeCastType sqlt) +_extractPath0 sqlt (field : l) = do + inner <- _extractField sqlt field + _extractPath0 inner l + +_extractField :: SQLType from -> FieldName -> Maybe (SQLType to) +_extractField (SQLType (StrictType (Struct (StructType fields)))) f = + -- There is probably a way to make it shorter... + let z = find (\x -> structFieldName x == f) fields in + SQLType . structFieldType <$> z +_extractField (SQLType (NullableType (Struct (StructType fields)))) f = + -- There is probably a way to make it shorter... + let z = find (\x -> structFieldName x == f) fields in + SQLType . structFieldType <$> z +_extractField _ _ = Nothing + +dropColReference :: ColumnData ref a -> ColumnData UnknownReference a +dropColReference c = c {_cOp = _cOp c} + +-- | (internal) creates a new column with some empty data +iEmptyCol :: Dataset a -> SQLType b -> FieldPath -> Column a b +iEmptyCol = _emptyColData + +-- | (internal) Creates a new column with a dynamic type. +colExtraction :: Dataset a -> DataType -> FieldPath -> DynColumn +colExtraction ds dt fp = pure $ dropColReference $ _emptyColData ds (SQLType dt) fp + +-- | Homogeneous operation betweet 2 columns. +homoColOp2 :: T.Text -> Column ref x -> Column ref x -> Column ref x +homoColOp2 opName c1 c2 = + let co = GenColFunction opName (V.fromList (colOp <$> [c1, c2])) + in ColumnData { + _cOrigin = _cOrigin c1, + _cType = _cType c1, + _cOp = co, + _cReferingPath = Nothing } + +makeColOp1 :: T.Text -> SQLType y -> Column ref x -> Column ref y +makeColOp1 opName sqlt c = + let co = GenColFunction opName (V.fromList (colOp <$> [c])) + in ColumnData { + _cOrigin = _cOrigin c, + _cType = unSQLType sqlt, + _cOp = co, + _cReferingPath = Nothing } + +_prettyShowColOp :: GeneralizedColOp -> T.Text +_prettyShowColOp (GenColExtraction fp) = prettyShowColOp (ColExtraction fp) +_prettyShowColOp (GenColFunction n v) = + prettyShowColFun n (V.toList (_prettyShowColOp <$> v)) +_prettyShowColOp (GenColLit _ c) = show' c +_prettyShowColOp (BroadcastColOp uld) = + "BROADCAST(" <> prettyNodePath (nodePath uld) <> ")" +_prettyShowColOp (GenColStruct v) = + "struct(" <> T.intercalate "," (_prettyShowColOp . gtfValue <$> V.toList v) <> ")" + +-- A new column data structure. +_emptyColData :: Dataset a -> SQLType b -> FieldPath -> ColumnData a b +_emptyColData ds sqlt path = ColumnData { + _cOrigin = untypedDataset ds, + _cType = unSQLType sqlt, + _cOp = GenColExtraction path, + _cReferingPath = Nothing +} + +_homoColOp2' :: T.Text -> DynColumn -> DynColumn -> DynColumn +_homoColOp2' opName c1' c2' = do + c1 <- c1' + c2 <- c2' + -- TODO check same origin + return $ homoColOp2 opName c1 c2 + +-- ******** Displaying and pretty printing ************ + +instance forall ref a. Show (Column ref a) where + show c = + let + name = case _cReferingPath c of + Just fn -> show' fn + Nothing -> _prettyShowColOp . colOp $ c + txt = fromString "{}{{}}->{}" :: TF.Format + -- path = T.pack . show . _cReferingPath $ c + -- no = prettyShowColOp . colOp $ c + fields = T.pack . show . colType $ c + nn = prettyNodePath . nodePath . _cOrigin $ c + in T.unpack $ toStrict $ TF.format txt (name, fields, nn) + +-- *********** Arithmetic operations ********** + + +instance forall a. HomoBinaryOp2 a a a where + _liftFun = BinaryOpFun id id + +instance forall ref a. HomoBinaryOp2 (Column ref a) DynColumn DynColumn where + _liftFun = BinaryOpFun untypedCol id + +instance forall ref a. HomoBinaryOp2 DynColumn (Column ref a) DynColumn where + _liftFun = BinaryOpFun id untypedCol + +instance (Fractional x) => Fractional (Column ref x) where + (/) = homoColOp2 "/" + recip = missing "Fractional (Column ref x): recip" + fromRational = missing "Fractional (Column ref x): fromRational" + +instance (Num x) => Num (Column ref x) where + (+) = homoColOp2 "+" + (*) = homoColOp2 "*" + abs _ = missing "Num (Column x): abs" + signum _ = missing "Num (Column x): signum" + fromInteger _ = missing "Num (Column x): fromInteger" + negate _ = missing "Num (Column x): negate" + +instance Num DynColumn where + (+) = _homoColOp2' "+" + (*) = _homoColOp2' "*" + abs _ = missing "Num (DynColumn x): abs" + signum _ = missing "Num (DynColumn x): signum" + fromInteger _ = missing "Num (DynColumn x): fromInteger" + negate _ = missing "Num (DynColumn x): negate" diff --git a/src/Spark/Core/Internal/ColumnStandard.hs b/src/Spark/Core/Internal/ColumnStandard.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ColumnStandard.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +{-| The standard library of functions operating on columns only. +-} +module Spark.Core.Internal.ColumnStandard( + asDoubleCol +) where + + +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.TypesGenerics(buildType) + +asDoubleCol :: (Num a) => Column ref a -> Column ref Double +asDoubleCol = makeColOp1 "double" buildType diff --git a/src/Spark/Core/Internal/ColumnStructures.hs b/src/Spark/Core/Internal/ColumnStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ColumnStructures.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Spark.Core.Internal.ColumnStructures where + +import Control.Arrow ((&&&)) +import Data.Function(on) +import Data.Vector(Vector) + +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions() +import Spark.Core.Internal.RowStructures +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.OpStructures +import Spark.Core.StructuresInternal +import Spark.Core.Try + +{-| The data structure that implements the notion of data columns. + +The type on this one may either be a Cell or a proper type. + +A column of data from a dataset +The ref is a reference potentially to the originating +dataset, but it may be more general than that to perform +type-safe tricks. + +Unlike Spark, columns are always attached to a reference dataset or dataframe. +One cannot materialize a column out of thin air. In order to broadcast a value +along a given column, the `broadcast` function is provided. + +TODO: try something like this https://www.vidarholen.net/contents/junk/catbag.html +-} +data ColumnData ref a = ColumnData { + _cOrigin :: !UntypedDataset, + _cType :: !DataType, + _cOp :: !GeneralizedColOp, + -- The name in the dataset. + -- If not set, it will be deduced from the operation. + _cReferingPath :: !(Maybe FieldName) +} + +{-| A generalization of the column operation. + +This structure is useful to performn some extra operations not supported by +the Spark engine: + - express joins with an observable + - keep track of DAGs of column operations (not implemented yet) +-} +data GeneralizedColOp = + GenColExtraction !FieldPath + | GenColFunction !SqlFunctionName !(Vector GeneralizedColOp) + | GenColLit !DataType !Cell + -- This is the extra operation that needs to be flattened with a broadcast. + | BroadcastColOp !UntypedLocalData + | GenColStruct !(Vector GeneralizedTransField) + deriving (Eq, Show) + +data GeneralizedTransField = GeneralizedTransField { + gtfName :: !FieldName, + gtfValue :: !GeneralizedColOp +} deriving (Eq, Show) + +{-| A column of data from a dataset or a dataframe. + +This column is typed: the operations on this column will be +validdated by Haskell' type inferenc. +-} +type Column ref a = ColumnData ref a + +{-| An untyped column of data from a dataset or a dataframe. + +This column is untyped and may not be properly constructed. Any error +will be found during the analysis phase at runtime. +-} +type DynColumn = Try (ColumnData UnknownReference Cell) + + +-- | (dev) +-- The type of untyped column data. +type UntypedColumnData = ColumnData UnknownReference Cell + +{-| (dev) +A column for which the type of the cells is unavailable (at the type level), + but for which the origin is available at the type level. +-} +type GenericColumn ref = Column ref Cell + +{-| A dummy data type that indicates the data referenc is missing. +-} +data UnknownReference + +{-| A tag that carries the reference information of a column at a +type level. This is useful when creating column. + +See ref and colRef. +-} +data ColumnReference a = ColumnReference + +instance forall ref a. Eq (ColumnData ref a) where + (==) = (==) `on` (_cOrigin &&& _cType &&& _cOp &&& _cReferingPath) diff --git a/src/Spark/Core/Internal/ComputeDag.hs b/src/Spark/Core/Internal/ComputeDag.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ComputeDag.hs @@ -0,0 +1,82 @@ + + +module Spark.Core.Internal.ComputeDag where + +import Data.Foldable(toList) +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import Data.Vector(Vector) + +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DAGFunctions + +{-| A DAG of computation nodes. + +At a high level, it is a total function with a number of inputs and a number +of outputs. + +Note about the edges: the edges flow along the path of dependencies: +the inputs are the start points, and the outputs are the end points of the +graph. + +-} +data ComputeDag v e = ComputeDag { + -- The edges that make up the DAG + cdEdges :: !(AdjacencyMap v e), + -- All the vertices of the graph + -- Sorted by lexicographic order + node id for uniqueness + cdVertices :: !(Vector (Vertex v)), + -- The inputs of the computation graph. These correspond to the + -- sinks of the dependency graph. + cdInputs :: !(Vector (Vertex v)), + -- The outputs of the computation graph. These correspond to the + -- sources of the dependency graph. + cdOutputs :: !(Vector (Vertex v)) +} deriving (Show) + + +-- | Conversion +computeGraphToGraph :: ComputeDag v e -> Graph v e +computeGraphToGraph cg = + Graph (cdEdges cg) (cdVertices cg) + +-- | Conversion +graphToComputeGraph :: Graph v e -> ComputeDag v e +graphToComputeGraph g = + ComputeDag { + cdEdges = gEdges g, + cdVertices = gVertices g, + -- We work on the graph of dependencies (not flows) + -- The sources correspond to the outputs. + cdInputs = V.fromList $ graphSinks g, + cdOutputs = V.fromList $ graphSources g + } + +_mapVerticesAdj :: (Vertex v -> v') -> AdjacencyMap v e -> AdjacencyMap v' e +_mapVerticesAdj f m = + let f1 ve = + let vx = veEndVertex ve + d' = f vx in + ve { veEndVertex = vx { vertexData = d' } } + f' v = f1 <$> v + in M.map f' m + +mapVertices :: (Vertex v -> v') -> ComputeDag v e -> ComputeDag v' e +mapVertices f cd = + let f' vx = vx { vertexData = f vx } + in ComputeDag { + cdEdges = _mapVerticesAdj f (cdEdges cd), + cdVertices = f' <$> cdVertices cd, + cdInputs = f' <$> cdInputs cd, + cdOutputs = f' <$> cdOutputs cd + } + +mapVertexData :: (v -> v') -> ComputeDag v e -> ComputeDag v' e +mapVertexData f = mapVertices (f . vertexData) + +buildCGraph :: (GraphOperations v e, Show v) => + v -> DagTry (ComputeDag v e) +buildCGraph n = graphToComputeGraph <$> buildGraph n + +graphDataLexico :: ComputeDag v e -> [v] +graphDataLexico cd = vertexData <$> toList (cdVertices cd) diff --git a/src/Spark/Core/Internal/ContextIOInternal.hs b/src/Spark/Core/Internal/ContextIOInternal.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ContextIOInternal.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} + +module Spark.Core.Internal.ContextIOInternal( + returnPure, + createSparkSession, + createSparkSession', + executeCommand1, + executeCommand1', + checkDataStamps, + updateSourceInfo, + createComputation, + computationStats +) where + +import Control.Concurrent(threadDelay) +import Control.Lens((^.)) +import Control.Monad.State(mapStateT, get) +import Control.Monad(forM, forM_) +import Data.Aeson(toJSON, FromJSON) +import Data.Functor.Identity(runIdentity) +import Data.Text(Text, pack) +import qualified Data.Text as T +import qualified Network.Wreq as W +import Network.Wreq(responseBody) +import Control.Monad.Trans(lift) +import Control.Monad.Logger(runStdoutLoggingT, LoggingT, logDebugN, logInfoN, MonadLoggerIO) +import System.Random(randomIO) +import Data.Word(Word8) +import Data.Maybe(mapMaybe) +import Control.Monad.IO.Class +import GHC.Generics +-- import Formatting +import Network.Wreq.Types(Postable) +import Data.ByteString.Lazy(ByteString) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS + +import Spark.Core.Dataset +import Spark.Core.Internal.Client +import Spark.Core.Internal.ContextInternal +import Spark.Core.Internal.ContextStructures +import Spark.Core.Internal.DatasetFunctions(untypedLocalData, nodePath) +import Spark.Core.Internal.DatasetStructures(UntypedLocalData) +import Spark.Core.Internal.OpStructures(DataInputStamp(..)) +import Spark.Core.Row +import Spark.Core.StructuresInternal +import Spark.Core.Try +import Spark.Core.Types +import Spark.Core.Internal.Utilities + +returnPure :: forall a. SparkStatePure a -> SparkState a +returnPure p = lift $ mapStateT (return . runIdentity) p + +{- | Creates a new Spark session. + +This session is unique, and it will not try to reconnect to an existing +session. +-} +createSparkSession :: (MonadLoggerIO m) => SparkSessionConf -> m SparkSession +createSparkSession conf = do + sessionName <- case confRequestedSessionName conf of + "" -> liftIO _randomSessionName + x -> pure x + let session = _createSparkSession conf sessionName 0 + let url = _sessionEndPoint session + logDebugN $ "Creating spark session at url: " <> url + -- TODO get the current counter from remote + _ <- _ensureSession session + return session + +{-| Convenience function for simple cases that do not require monad stacks. +-} +createSparkSession' :: SparkSessionConf -> IO SparkSession +createSparkSession' = _runLogger . createSparkSession + +{- | +Executes a command: +- performs the transforms and the optimizations in the pure state +- sends the computation to the backend +- waits for the terminal nodes to reach a final state +- commits the final results to the state + +If any failure is detected that is internal to Karps, it returns an error. +If the error comes from an underlying library (http stack, programming failure), +an exception may be thrown instead. +-} +executeCommand1 :: forall a. (FromSQL a) => + LocalData a -> SparkState (Try a) +executeCommand1 ld = do + tcell <- executeCommand1' (untypedLocalData ld) + return $ tcell >>= (tryEither . cellToValue) + +-- The main function to launch computations. +executeCommand1' :: UntypedLocalData -> SparkState (Try Cell) +executeCommand1' ld = do + logDebugN $ "executeCommand1': computing observable " <> show' ld + -- Retrieve the computation graph + let cgt = buildComputationGraph ld + _ret cgt $ \cg -> do + cgWithSourceT <- updateSourceInfo cg + _ret cgWithSourceT $ \cgWithSource -> do + -- Update the computations with the stamps, and build the computation. + compt <- createComputation cgWithSource + _ret compt $ \comp -> do + -- Run the computation. + session <- get + _ <- _sendComputation session comp + waitForCompletion comp + +waitForCompletion :: Computation -> SparkState (Try Cell) +waitForCompletion comp = do + -- We track all the observables, instead of simply the targets. + let obss = getObservables comp + let trackedNodes = obss <&> \n -> + (nodeId n, nodePath n, + unSQLType (nodeType n), nodePath n) + nrs' <- _computationMultiStatus (cId comp) HS.empty trackedNodes + -- Find the main result again in the list of everything. + -- TODO: we actually do not need all the results, just target nodes. + let targetNid = case cTerminalNodeIds comp of + [nid] -> nid + -- TODO: handle the case of multiple terminal targets + l -> missing $ "waitForCompletion: missing multilist case with " <> show' l + case filter (\z -> fst z == targetNid) nrs' of + [(_, tc)] -> return tc + l -> return $ tryError $ "Expected single result, got " <> show' l + +{-| Exposed for debugging -} +computationStats :: + ComputationID -> SparkState BatchComputationResult +computationStats cid = do + logDebugN $ "computationStats: stats for " <> show' cid + session <- get + _computationStats session cid + +{-| Exposed for debugging -} +createComputation :: ComputeGraph -> SparkState (Try Computation) +createComputation cg = returnPure $ prepareComputation cg + +{-| Exposed for debugging -} +updateSourceInfo :: ComputeGraph -> SparkState (Try ComputeGraph) +updateSourceInfo cg = do + let sources = inputSourcesRead cg + if null sources + then return (pure cg) + else do + logDebugN $ "updateSourceInfo: found sources " <> show' sources + -- Get the source stamps. Any error at this point is considered fatal. + stampsRet <- checkDataStamps sources + logDebugN $ "updateSourceInfo: retrieved stamps " <> show' stampsRet + let stampst = sequence $ _f <$> stampsRet + let cgt = insertSourceInfo cg =<< stampst + return cgt + + +_ret :: Try a -> (a -> SparkState (Try b)) -> SparkState (Try b) +_ret (Left x) _ = return (Left x) +_ret (Right x) f = f x + +_f :: (a, Try b) -> Try (a, b) +_f (x, t) = case t of + Right u -> Right (x, u) + Left e -> Left e + +data StampReturn = StampReturn { + stampReturnPath :: !Text, + stampReturnError :: !(Maybe Text), + stampReturn :: !(Maybe Text) +} deriving (Eq, Show, Generic) + +instance FromJSON StampReturn + +{-| Given a list of paths, checks each of these paths on the file system of the +given Spark cluster to infer the status of these resources. + +The primary role of this function is to check how recent these resources are +compared to some previous usage. +-} +checkDataStamps :: [HdfsPath] -> SparkState [(HdfsPath, Try DataInputStamp)] +checkDataStamps l = do + session <- get + let url = _sessionResourceCheck session + status <- liftIO (W.asJSON =<< W.post (T.unpack url) (toJSON l) :: IO (W.Response [StampReturn])) + let s = status ^. responseBody + return $ mapMaybe _parseStamp s + + +_parseStamp :: StampReturn -> Maybe (HdfsPath, Try DataInputStamp) +_parseStamp sr = case (stampReturn sr, stampReturnError sr) of + (Just s, _) -> pure (HdfsPath (stampReturnPath sr), pure (DataInputStamp s)) + (Nothing, Just err) -> pure (HdfsPath (stampReturnPath sr), tryError err) + _ -> Nothing -- No error being returned for now, we just discard it. + +_randomSessionName :: IO Text +_randomSessionName = do + ws <- forM [1..10] (\(_::Int) -> randomIO :: IO Word8) + let ints = (`mod` 10) <$> ws + return . T.pack $ "session" ++ concat (show <$> ints) + +type DefLogger a = LoggingT IO a + +_runLogger :: DefLogger a -> IO a +_runLogger = runStdoutLoggingT + +_post :: (MonadIO m, Postable a) => + Text -> a -> m (W.Response ByteString) +_post url = liftIO . W.post (T.unpack url) + +_get :: (MonadIO m) => + Text -> m (W.Response ByteString) +_get url = liftIO $ W.get (T.unpack url) + +-- TODO move to more general utilities +-- Performs repeated polling until the result can be converted +-- to a certain other type. +-- Int controls the delay in milliseconds between each poll. +_pollMonad :: (MonadIO m) => m a -> Int -> (a -> Maybe b) -> m b +_pollMonad rec delayMillis check = do + curr <- rec + case check curr of + Just res -> return res + Nothing -> do + _ <- liftIO $ threadDelay (delayMillis * 1000) + _pollMonad rec delayMillis check + + +-- Creates a new session from a string containing a session ID. +_createSparkSession :: SparkSessionConf -> Text -> Integer -> SparkSession +_createSparkSession conf sessionId idx = + SparkSession conf sid idx HM.empty where + sid = LocalSessionId sessionId + +_port :: SparkSession -> Text +_port = pack . show . confPort . ssConf + +-- The URL of the end point +_sessionEndPoint :: SparkSession -> Text +_sessionEndPoint sess = + let port = _port sess + sid = (unLocalSession . ssId) sess + in + T.concat [ + (confEndPoint . ssConf) sess, ":", port, + "/sessions/", sid] + +_sessionResourceCheck :: SparkSession -> Text +_sessionResourceCheck sess = + let port = _port sess + sid = (unLocalSession . ssId) sess + in + T.concat [ + (confEndPoint . ssConf) sess, ":", port, + "/resources_status/", sid] + +_sessionPortText :: SparkSession -> Text +_sessionPortText = pack . show . confPort . ssConf + +-- The URL of the computation end point +_compEndPoint :: SparkSession -> ComputationID -> Text +_compEndPoint sess compId = + let port = _sessionPortText sess + sid = (unLocalSession . ssId) sess + cid = unComputationID compId + in + T.concat [ + (confEndPoint . ssConf) sess, ":", port, + "/computations/", sid, "/", cid] + +-- The URL of the status of a computation +_compEndPointStatus :: SparkSession -> ComputationID -> Text +_compEndPointStatus sess compId = + let port = _sessionPortText sess + sid = (unLocalSession . ssId) sess + cid = unComputationID compId + in + T.concat [ + (confEndPoint . ssConf) sess, ":", port, + "/computations_status/", sid, "/", cid] + +-- Ensures that the server has instantiated a session with the given ID. +_ensureSession :: (MonadLoggerIO m) => SparkSession -> m () +_ensureSession session = do + let url = _sessionEndPoint session <> "/create" + _ <- _post url (toJSON 'a') + return () + + +_sendComputation :: (MonadLoggerIO m) => SparkSession -> Computation -> m () +_sendComputation session comp = do + let base' = _compEndPoint session (cId comp) + let url = base' <> "/create" + logInfoN $ "Sending computations at url: " <> url <> "with nodes: " <> show' (cNodes comp) + _ <- _post url (toJSON (cNodes comp)) + return () + +_computationStatus :: (MonadLoggerIO m) => + SparkSession -> ComputationID -> NodePath -> m PossibleNodeStatus +_computationStatus session compId npath = do + let base' = _compEndPointStatus session compId + let rest = prettyNodePath npath + let url = base' <> rest + _ <- _get url + status <- liftIO (W.asJSON =<< W.get (T.unpack url) :: IO (W.Response PossibleNodeStatus)) + let s = status ^. responseBody + return s + +-- TODO: not sure how this works when trying to make a fix point: is it going to +-- blow up the 'stack'? +_computationMultiStatus :: + -- The computation being run + ComputationID -> + -- The set of nodes that have been processed in this computation, and ended + -- with a success. + -- TODO: should we do all the nodes processed in this computation? + HS.HashSet NodeId -> + -- The list of nodes for which we have not had completion information so far. + [(NodeId, NodePath, DataType, NodePath)] -> + SparkState [(NodeId, Try Cell)] +_computationMultiStatus _ _ [] = return [] +_computationMultiStatus cid done l = do + session <- get + -- Find the nodes that still need processing (i.e. that have not previously + -- finished with a success) + let f (nid, _, _, _) = not $ HS.member nid done + let needsProcessing = filter f l + -- Poll a bunch of nodes to try to get a status update. + let statusl = _try (_computationStatus session cid) <$> needsProcessing :: [SparkState (NodeId, NodePath, DataType, PossibleNodeStatus)] + status <- sequence statusl + -- Update the state with the new data + (updated, statusUpdate) <- returnPure $ updateCache cid status + forM_ statusUpdate $ \(p, s) -> case s of + NodeCacheSuccess -> + logInfoN $ "_computationMultiStatus: " <> prettyNodePath p <> " finished" + NodeCacheError -> + logInfoN $ "_computationMultiStatus: " <> prettyNodePath p <> " finished (ERROR)" + NodeCacheRunning -> + logInfoN $ "_computationMultiStatus: " <> prettyNodePath p <> " running" + -- Filter out the updated nodes, so that we do not ask for them again. + let updatedNids = HS.union done (HS.fromList (fst <$> updated)) + let g (nid, _, _, _) = not $ HS.member nid updatedNids + let stillNeedsProcessing = filter g needsProcessing + -- Do not block uselessly if we have nothing else to do + if null stillNeedsProcessing + then return updated + else do + let delayMillis = confPollingIntervalMillis $ ssConf session + _ <- liftIO $ threadDelay (delayMillis * 1000) + -- TODO: this chaining is certainly not tail-recursive + -- How much of a memory leak is it? + reminder <- _computationMultiStatus cid updatedNids stillNeedsProcessing + return $ updated ++ reminder + +_try :: (Monad m) => (y -> m z) -> (x, x', x'', y) -> m (x, x', x'', z) +_try f (x, x', x'', y) = f y <&> \z -> (x, x', x'', z) + +_computationStats :: (MonadLoggerIO m) => + SparkSession -> ComputationID -> m BatchComputationResult +_computationStats session compId = do + let url = _compEndPointStatus session compId <> "/" -- The final / is mandatory + logDebugN $ "Sending computations stats request at url: " <> url + stats <- liftIO (W.asJSON =<< W.get (T.unpack url) :: IO (W.Response BatchComputationResult)) + let s = stats ^. responseBody + return s + + +_waitSingleComputation :: (MonadLoggerIO m) => + SparkSession -> Computation -> NodePath -> m FinalResult +_waitSingleComputation session comp npath = + let + extract :: PossibleNodeStatus -> Maybe FinalResult + extract (NodeFinishedSuccess (Just s) _) = Just $ Right s + extract (NodeFinishedFailure f) = Just $ Left f + extract _ = Nothing + getStatus = _computationStatus session (cId comp) npath + i = confPollingIntervalMillis $ ssConf session + in + _pollMonad getStatus i extract diff --git a/src/Spark/Core/Internal/ContextInteractive.hs b/src/Spark/Core/Internal/ContextInteractive.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ContextInteractive.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Functions to create and manipulate one default context. +-- +-- This is most appropriate when working in an interactive session, +-- during which it is usually clear that there is a single +-- Spark context in use. +-- +-- This module uses unsafe Haskell code that should not be used +-- outside prototyping in an interactive REPL. In any good case, +-- you should use the SparkState monad. +module Spark.Core.Internal.ContextInteractive( + SparkInteractiveException, + createSparkSessionDef, + exec1Def, + exec1Def', + closeSparkSessionDef, + execStateDef, + computationStatsDef, + currentSessionDef +) where + +import qualified Data.Vector as V +import Control.Exception +import Control.Monad.Catch(throwM) +import Data.IORef +import Data.Typeable +import Control.Monad.State(runStateT) +import Data.Text +import System.IO.Unsafe(unsafePerformIO) +import Control.Monad.Logger(runStdoutLoggingT) + + +import Spark.Core.Internal.Client(BatchComputationResult) +import Spark.Core.Internal.ContextStructures +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions(untypedLocalData) +import Spark.Core.Internal.ContextIOInternal +import Spark.Core.Internal.RowGenericsFrom(FromSQL, cellToValue) +import Spark.Core.Internal.RowStructures(Cell) +import Spark.Core.StructuresInternal +import Spark.Core.Try + +-- The global session reference. Should not be accessed outside +-- this file. +_globalSessionRef :: IORef (Maybe SparkSession) +{-# NOINLINE _globalSessionRef #-} +_globalSessionRef = unsafePerformIO (newIORef Nothing) + +-- | The exception thrown when a request cannot be completed +-- in an interactive session. +data SparkInteractiveException = SparkInteractiveException { + _sieInner :: NodeError +} deriving Typeable + +instance Show SparkInteractiveException where + show (SparkInteractiveException inner) = + show inner + +instance Exception SparkInteractiveException + +{- | Creates a spark session that will be used as the default session. + +If a session already exists, an exception will be thrown. + -} +createSparkSessionDef :: SparkSessionConf -> IO () +createSparkSessionDef conf = do + current <- _currentSession + case current of + Nothing -> + return () + Just _ -> + -- TODO let users change the state + _throw "A default context already exist. If you wish to modify the exsting context, you must use modifySparkConfDef" + new <- createSparkSession' conf + _setSession new + return () + +{- | Executes a command using the default spark session. + +This is the most unsafe way of running a command: +it executes a command using the default spark session, and +throws an exception if any error happens. + -} +exec1Def :: (FromSQL a) => LocalData a -> IO a +exec1Def ld = do + c <- exec1Def' (pure (untypedLocalData ld)) + _forceEither $ cellToValue c + +exec1Def' :: LocalFrame -> IO Cell +exec1Def' lf = do + ld <- _getOrThrow lf + res <- execStateDef (executeCommand1' ld) + _getOrThrow res + +{-| Runs the computation described in the state transform, using the default +Spark session. + +Will throw an exception if no session currently exists. +-} +execStateDef :: SparkState a -> IO a +execStateDef s = do + ctx <- _currentSessionOrThrow + (res, newSt) <- (runStateT . runStdoutLoggingT) s ctx + _setSession newSt + return res + +{-| Closes the default session. The default session is empty after this call +completes. + +NOTE: This does not currently clear up the resources! It is a stub implementation +used in testing. +-} +closeSparkSessionDef :: IO () +closeSparkSessionDef = do + _ <- _removeSession + return () + +computationStatsDef :: ComputationID -> IO BatchComputationResult +computationStatsDef compId = execStateDef (computationStats compId) + +currentSessionDef :: IO (Maybe SparkSession) +currentSessionDef = _currentSession + +_currentSession :: IO (Maybe SparkSession) +_currentSession = readIORef _globalSessionRef + +_setSession :: SparkSession -> IO () +_setSession st = writeIORef _globalSessionRef (Just st) + +_removeSession :: IO (Maybe SparkSession) +_removeSession = do + current <- _currentSession + _ <- writeIORef _globalSessionRef Nothing + return current + +_currentSessionOrThrow :: IO SparkSession +_currentSessionOrThrow = do + mCtx <- _currentSession + case mCtx of + Nothing -> + _throw "No default context found. You must first create a default spark context with createSparkSessionDef" + Just ctx -> return ctx + + +_getOrThrow :: Try a -> IO a +_getOrThrow (Right x) = return x +_getOrThrow (Left err) = throwM (SparkInteractiveException err) + +_forceEither :: Either Text a -> IO a +_forceEither = _getOrThrow . tryEither + +_throw :: Text -> IO a +_throw txt = throwM $ + SparkInteractiveException Error { + ePath = NodePath V.empty, + eMessage = txt + } diff --git a/src/Spark/Core/Internal/ContextInternal.hs b/src/Spark/Core/Internal/ContextInternal.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ContextInternal.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +-- Functions to build the graph of computations. +-- The following steps are performed: +-- - typing checking +-- - caching checks +-- - building the final json +-- +-- All the functions in this module are pure and use SparkStatePure for transforms. + +module Spark.Core.Internal.ContextInternal( + FinalResult, + inputSourcesRead, + prepareComputation, + buildComputationGraph, + performGraphTransforms, + getTargetNodes, + getObservables, + insertSourceInfo, + updateCache +) where + +import Control.Monad.State(get, put) +import Control.Monad(when) +import Data.Text(pack) +import Data.Maybe(mapMaybe, catMaybes) +import Data.Either(isRight) +import Data.Foldable(toList) +import Control.Arrow((&&&)) +import Formatting +import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as HM + +import Spark.Core.Dataset +import Spark.Core.Try +import Spark.Core.Row +import Spark.Core.Types +import Spark.Core.StructuresInternal(NodeId, NodePath, ComputationID(..)) +import Spark.Core.Internal.Caching +import Spark.Core.Internal.CachingUntyped +import Spark.Core.Internal.ContextStructures +import Spark.Core.Internal.Client +import Spark.Core.Internal.ComputeDag +import Spark.Core.Internal.PathsUntyped +import Spark.Core.Internal.Pruning +import Spark.Core.Internal.OpFunctions(hdfsPath, updateSourceStamp) +import Spark.Core.Internal.OpStructures(HdfsPath(..), DataInputStamp) +-- Required to import the instances. +import Spark.Core.Internal.Paths() +import Spark.Core.Internal.DAGFunctions(buildVertexList, graphMapVertices) +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities + +-- The result from querying the status of a computation +type FinalResult = Either NodeComputationFailure NodeComputationSuccess + +{-| Given a context for the computation and a graph of computation, builds a +computation object. +-} +prepareComputation :: + ComputeGraph -> + SparkStatePure (Try Computation) +prepareComputation cg = do + session <- get + let compt = do + cg2 <- performGraphTransforms session cg + _buildComputation session cg2 + when (isRight compt) _increaseCompCounter + return compt + +{-| Exposed for debugging + +Inserts the source information into the graph. + +Note: after that, the node IDs may be different. The names and the paths +will be kept though. +-} +insertSourceInfo :: ComputeGraph -> [(HdfsPath, DataInputStamp)] -> Try ComputeGraph +insertSourceInfo cg l = do + let m = M.fromList l + let g = computeGraphToGraph cg + g2 <- graphMapVertices g (_updateVertex2 m) + let cg2 = graphToComputeGraph g2 + return cg2 + +{-| A list of file sources that are being requested by the compute graph -} +inputSourcesRead :: ComputeGraph -> [HdfsPath] +inputSourcesRead cg = + -- TODO: make unique elements + mapMaybe (hdfsPath.nodeOp.vertexData) (toList (cdVertices cg)) + +-- Here are the steps being run +-- - node collection + cycle detection +-- - naming: +-- -> everything after that can be done with names, and on server +-- -> for convenience, the vertex ids will be still the hash ids +-- - verification of cache/uncache +-- - deconstruction of unions and aggregations +-- - caching swap +-- +-- There is a lot more that could be done (merging the aggregations, etc.) +-- but it is outside the scope of this MVP. +-- TODO: should graph pruning be moved before naming? + +{-| Builds the computation graph by expanding a single node until a transitive +closure is reached. + +It performs the naming, node deduplication and cycle detection. + +TODO(kps) use the caching information to have a correct fringe +-} +buildComputationGraph :: ComputeNode loc a -> Try ComputeGraph +buildComputationGraph ld = do + cg <- tryEither $ buildCGraph (untyped ld) + assignPathsUntyped cg + +{-| Performs all the operations that are done on the compute graph: + +- fullfilling autocache requests +- checking the cache/uncache pairs +- pruning of observed successful computations +- deconstructions of the unions (in the future) + +This could all be done on the server side at this point. +-} +performGraphTransforms :: SparkSession -> ComputeGraph -> Try ComputeGraph +performGraphTransforms session cg = do + -- Tie the nodes to ensure that the node IDs match the topology and + -- content of the graph. + -- TODO: make a special function for tying + pruning, it is easy to forget. + let tiedCg = tieNodes cg + let g = computeGraphToGraph tiedCg + let conf = ssConf session + let pruned = if confUseNodePrunning conf + then pruneGraphDefault (ssNodeCache session) g + else g + -- Autocache + caching pass pass + -- TODO: separate in a function + let acg = fillAutoCache cachingType autocacheGen pruned + g' <- tryEither acg + failures <- tryEither $ checkCaching g' cachingType + case failures of + [] -> return (graphToComputeGraph g') + _ -> tryError $ sformat ("Found some caching errors: "%sh) failures + -- TODO: we could add an extra pruning pass here + +_buildComputation :: SparkSession -> ComputeGraph -> Try Computation +_buildComputation session cg = + let sid = ssId session + cid = (ComputationID . pack . show . ssCommandCounter) session + allNodes = vertexData <$> toList (cdVertices cg) + terminalNodes = vertexData <$> toList (cdOutputs cg) + terminalNodePaths = nodePath <$> terminalNodes + terminalNodeIds = nodeId <$> terminalNodes + -- TODO it is missing the first node here, hoping it is the first one. + in case terminalNodePaths of + [p] -> + return $ Computation sid cid allNodes [p] p terminalNodeIds + _ -> tryError $ sformat ("Programming error in _build1: cg="%sh) cg + +_updateVertex :: M.Map HdfsPath DataInputStamp -> UntypedNode -> Try UntypedNode +_updateVertex m un = + let no = nodeOp un in case hdfsPath no of + Just p -> case M.lookup p m of + Just dis -> updateSourceStamp no dis <&> updateNodeOp un + -- TODO: this is for debugging, but it could be eventually relaxed. + Nothing -> tryError $ "_updateVertex: Expected to find path " <> show' p + Nothing -> pure un + +_updateVertex2 :: + M.Map HdfsPath DataInputStamp -> + UntypedNode -> + [(UntypedNode, StructureEdge)] -> + Try UntypedNode +_updateVertex2 m un _ = + _updateVertex m un + +_increaseCompCounter :: SparkStatePure () +_increaseCompCounter = get >>= \session -> + let + curr = ssCommandCounter session + session2 = session { ssCommandCounter = curr + 1 } + in put session2 + +-- Given an end point, gathers all the nodes reachable from there. +_gatherNodes :: LocalData a -> Try [UntypedNode] +_gatherNodes = tryEither . buildVertexList . untyped + +-- Given a result, tries to build the corresponding object out of it +_extract1 :: FinalResult -> DataType -> Try Cell +_extract1 (Left nf) _ = tryError $ sformat ("got an error "%shown) nf +_extract1 (Right ncs) dt = tryEither $ jsonToCell dt (ncsData ncs) + +-- Gets the relevant nodes for this computation from this spark session. +-- The computation is assumed to be correct and to contain all the nodes +-- already. +-- TODO: make it a total function +-- TODO: this is probably not needed anymore +getTargetNodes :: (HasCallStack) => Computation -> [UntypedLocalData] +getTargetNodes comp = + let + fun2 :: (HasCallStack) => UntypedNode -> UntypedLocalData + fun2 n = case asLocalObservable <$> castLocality n of + Right (Right x) -> x + err -> failure $ sformat ("_getNodes:fun2: err="%shown%" n="%shown) err n + finalNodeNames = cTerminalNodes comp + dct = M.fromList $ (nodePath &&& id) <$> cNodes comp + untyped2 = finalNodeNames <&> \n -> + let err = failure $ sformat ("Could not find "%sh%" in "%sh) n dct + in M.findWithDefault err n dct + in fun2 <$> untyped2 + +{-| Retrieves all the observables from a computation. +-} +getObservables :: Computation -> [UntypedLocalData] +getObservables comp = + let fun n = case asLocalObservable <$> castLocality n of + Right (Right x) -> return x + _ -> Nothing + in catMaybes $ fun <$> cNodes comp + +{-| Updates the cache, and returns the updates if there are any. + +The updates are split into final results, and general update status (scheduled, +running, etc.) +-} +updateCache :: ComputationID -> [(NodeId, NodePath, DataType, PossibleNodeStatus)] -> SparkStatePure ([(NodeId, Try Cell)], [(NodePath, NodeCacheStatus)]) +updateCache c l = do + l' <- sequence $ _updateCache1 c <$> l + return (catMaybes (fst <$> l'), catMaybes (snd <$> l')) + +_updateCache1 :: ComputationID -> (NodeId, NodePath, DataType, PossibleNodeStatus) -> SparkStatePure (Maybe (NodeId, Try Cell), Maybe (NodePath, NodeCacheStatus)) +_updateCache1 cid (nid, p, dt, status) = + case status of + (NodeFinishedSuccess (Just s) _) -> do + updated <- _insertCacheUpdate cid nid p NodeCacheSuccess + let res2 = _extract1 (pure s) dt + return (Just (nid, res2), (p, ) <$> updated) + (NodeFinishedFailure e) -> do + updated <- _insertCacheUpdate cid nid p NodeCacheError + let res2 = _extract1 (Left e) dt + return (Just (nid, res2), (p, ) <$> updated) + NodeRunning -> do + updated <- _insertCacheUpdate cid nid p NodeCacheRunning + return (Nothing, (p, ) <$> updated) + _ -> return (Nothing, Nothing) + +-- Returns true if the cache is updated +_insertCacheUpdate :: ComputationID -> NodeId -> NodePath -> NodeCacheStatus -> SparkStatePure (Maybe NodeCacheStatus) +_insertCacheUpdate cid nid p s = do + session <- get + let m = ssNodeCache session + let currentStatus = nciStatus <$> HM.lookup nid m + if currentStatus == Just s + then return Nothing + else do + let v = NodeCacheInfo { + nciStatus = s, + nciComputation = cid, + nciPath = p } + let m' = HM.insert nid v m + let session' = session { ssNodeCache = m' } + put session' + return $ Just s diff --git a/src/Spark/Core/Internal/ContextStructures.hs b/src/Spark/Core/Internal/ContextStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ContextStructures.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.Internal.ContextStructures( + SparkSessionConf(..), + SparkSession(..), + SparkState, + SparkStatePure, + ComputeGraph, + HdfsPath(..), + NodeCacheInfo(..), + NodeCacheStatus(..), + SparkStateT, + SparkStatePureT +) where + +import Data.Text(Text) +import Control.Monad.State(StateT, State) +import Control.Monad.Logger(LoggingT) + +import Spark.Core.Internal.Client(LocalSessionId) +import Spark.Core.Internal.ComputeDag(ComputeDag) +import Spark.Core.Internal.OpStructures(HdfsPath(..)) +import Spark.Core.Internal.Pruning +import Spark.Core.Internal.DatasetStructures(UntypedNode, StructureEdge) + +-- | The configuration of a remote spark session in Karps. +data SparkSessionConf = SparkSessionConf { + -- | The URL of the end point. + confEndPoint :: !Text, + -- | The port used to configure the end point. + confPort :: !Int, + -- | (internal) the polling interval + confPollingIntervalMillis :: !Int, + -- | (optional) the requested name of the session. + -- This name must obey a number of rules: + -- - it must consist in alphanumerical and -,_: [a-zA-Z0-9\-_] + -- - if it already exists on the server, it will be reconnected to + -- + -- The default value is "" (a new random context name will be chosen). + confRequestedSessionName :: !Text, + {-| If enabled, attempts to prune the computation graph as much as possible. + + This option is useful in interactive sessions when long chains of computations + are extracted. This forces the execution of only the missing parts. + The algorithm is experimental, so disabling it is a safe option. + + Disabled by default. + -} + confUseNodePrunning :: !Bool +} deriving (Show) + +-- | A session in Spark. +-- Encapsualates all the state needed to communicate with Spark +-- and to perfor some simple optimizations on the code. +data SparkSession = SparkSession { + ssConf :: !SparkSessionConf, + ssId :: !LocalSessionId, + ssCommandCounter :: !Integer, + ssNodeCache :: !NodeCache +} deriving (Show) + + + +-- | Represents the state of a session and accounts for the communication +-- with the server. +type SparkState a = SparkStateT IO a + +-- More minimalistic state transforms when doing pure evaluation. +-- (internal type) +-- TODO: use the transformer +type SparkStatePure x = State SparkSession x + +type SparkStatePureT m = StateT SparkSession m +type SparkStateT m = LoggingT (SparkStatePureT m) + +{-| internal + +A graph of computations. This graph is a direct acyclic graph. Each node is +associated to a global path. +-} +type ComputeGraph = ComputeDag UntypedNode StructureEdge diff --git a/src/Spark/Core/Internal/DAGFunctions.hs b/src/Spark/Core/Internal/DAGFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/DAGFunctions.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +{-| A set of utility functions to build and transform DAGs. + +Because I could not find a public library for such transforms. + +Most Karps manipulations are converted into graph manipulations. +-} +module Spark.Core.Internal.DAGFunctions( + DagTry, + FilterOp(..), + -- Building + buildGraph, + buildVertexList, + buildGraphFromList, + -- Queries + graphSinks, + graphSources, + -- Transforms + graphMapVertices, + graphMapVertices', + vertexMap, + graphFlatMapEdges, + graphMapEdges, + reverseGraph, + verticesAndEdges, + graphFilterVertices, + pruneLexicographic +) where + +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import Data.List(sortBy) +import Data.Maybe +import Data.Foldable(toList) +import Data.Text(Text) +import Control.Arrow((&&&)) +import Control.Monad.Except +import Formatting +import Control.Monad.Identity + +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.Utilities + +-- | Separate type of error to make it more general and easier +-- to test. +type DagTry a = Either Text a + +{-| The different filter modes when pruning a graph. + +Keep: keep the current node. +CutChildren: keep the current node, but do not consider the children. +Remove: remove the current node, do not consider the children. +-} +data FilterOp = Keep | Remove | CutChildren + +{-| Starts from a vertex and expands the vertex to reach all the transitive +closure of the vertex. + +Returns a list in lexicographic order of dependencies: the graph corresponding +to this list of elements has one sink (the start element) and potentially +multiple sources. The nodes are ordered so that all the parents are visited +before the node itself. +-} +buildVertexList :: (GraphVertexOperations v, Show v) => v -> DagTry [v] +buildVertexList x = buildVertexListBounded x [] + +{-| Builds the list of vertices, up to a boundary. +-} +buildVertexListBounded :: (GraphVertexOperations v, Show v) => + v -> [v] -> DagTry [v] +buildVertexListBounded x boundary = + let + boundaryIds = S.fromList $ vertexToId <$> boundary + traversals = toList $ _buildList boundaryIds [x] M.empty + lexico = _lexicographic vertexToId traversals in lexico + +-- | Builds a graph by expanding a start vertex. +buildGraph :: forall v e. (GraphOperations v e, Show v) => + v -> DagTry (Graph v e) +buildGraph start = buildVertexList start <&> \vxData -> + let vertices = [Vertex (vertexToId vx) vx | vx <- vxData] + -- The edges and vertices are already in the right order, no need + -- to do further checks + f :: v -> (VertexId, V.Vector (VertexEdge e v)) + f x = + let vid = vertexToId x + g :: (e, v) -> VertexEdge e v + g (ed, x') = + let toId = vertexToId x' + v' = Vertex toId x' + e = Edge vid toId ed + in VertexEdge v' e + vedges = g <$> expandVertex x + in (vid, V.fromList vedges) + vxs = V.fromList vertices + edges = f <$> vxData + adj = M.fromList edges + in Graph adj vxs + +{-| Attempts to build a graph from a collection of vertices and edges. + +This collection may be invalid (cycles, etc.) and the vertices need not +be in topological order. + +All the vertices referred by edges must be present in the list of vertices. +-} +buildGraphFromList :: forall v e. (Show v) => + [Vertex v] -> [Edge e] -> DagTry (Graph v e) +buildGraphFromList vxs eds = do + -- 1. Group the edges by start point + -- 2. Find the lexicgraphic order (if possible) + vxById <- _vertexById vxs + -- The topological information + let edTopo = myGroupBy $ (edgeFrom &&& edgeTo) <$> eds + let vertexById :: VertexId -> DagTry (Vertex v) + vertexById vid = case M.lookup vid vxById of + Nothing -> throwError $ sformat ("buildGraphFromList: vertex id found in edge but not in vertices: "%sh) vid + Just vx -> pure vx + let f :: Vertex v -> DagTry (Vertex v, [Vertex v]) + f vx = + let links = M.findWithDefault [] (vertexId vx) edTopo + in sequence (vertexById <$> links) <&> \l -> (vx, l) + verticesWithEnds <- sequence $ f <$> vxs + let indexedVertices = zip [1..] verticesWithEnds <&> \(idx, (vx, l)) -> (idx, vx, l) + -- The nodes in lexicographic order. + lexico <- _lexicographic vertexId indexedVertices + -- Build the edge map: + -- vertexFromId -> vertexEdge + let vertexEdge :: Edge e -> DagTry (VertexId, VertexEdge e v) + vertexEdge e = do + vxTo <- vertexById (edgeTo e) + -- Used to confirm that the start vertex is here + _ <- vertexById (edgeFrom e) + return (edgeFrom e, VertexEdge vxTo e) + vEdges <- sequence $ vertexEdge <$> eds + let edgeMap = M.map V.fromList (myGroupBy vEdges) + return $ Graph edgeMap (V.fromList lexico) + +_vertexById :: (Show v) => [Vertex v] -> DagTry (M.Map VertexId (Vertex v)) +_vertexById vxs = + -- This is probably not the most pretty, but it works. + let vxById = myGroupBy $ (vertexId &&& id) <$> vxs + f (vid, [vx]) = pure (vid, vx) + f (vid, l) = throwError $ sformat ("_VertexById: Multiple vertices with the same id: "%sh%" in "%sh) vid l + in M.fromList <$> sequence (f <$> M.toList vxById) + +-- This implementation is not very efficient and is probably a performance +-- bottleneck. +-- Int is the traversal order. It is just used to break the ties. +-- VertexId is the node id of the vertex. +_lexicographic :: (v -> VertexId) -> [(Int, v, [v])] -> DagTry [v] +_lexicographic _ [] = return [] +_lexicographic f m = + -- We use the traversal ordering to separate the ties. + -- The first nodes traversed get priority. + let fcmp (idx, _, []) (idx', _, []) = compare idx idx' + fcmp (_, _, []) (_, _, _) = LT + fcmp (_, _, _) (_, _, []) = GT + fcmp (_, _, _) (_, _, _) = EQ -- This one does not matter + in case sortBy fcmp m of + [] -> throwError "_lexicographic: there is a cycle" + ((_, v, _) : t) -> + let currentId = f v + removeCurrentId l = [v' | v' <- l, f v' /= currentId] + m' = t <&> \(idx, v', l) -> (idx, v', removeCurrentId l) + tl = _lexicographic f m' + in (v :) <$> tl + + +_buildList :: (Show v, GraphVertexOperations v) => + S.Set VertexId -> -- boundary ids, they will not be traversed + [v] -> -- fringe ids + M.Map VertexId (Int, v, [v]) -> -- all seen ids so far (the intermediate result) + M.Map VertexId (Int, v, [v]) +_buildList boundary fringe = + _buildListGeneral boundary fringe expandVertexAsVertices + +-- (internal) +-- Gathers the list of all the nodes connected through this graph +-- +-- The expansion function in that case can be controlled. +-- +-- The expansion is done in a DFS manner (the order of the node is unique). +_buildListGeneral :: (Show v, GraphVertexOperations v) => + S.Set VertexId -> -- boundary ids, they will not be traversed + [v] -> -- fringe ids: the nodes that have been touched but not expanded. + (v -> [v]) -> -- The expansion function. They will be the next nodes to expand. + -- all seen ids so far (the intermediate result) + -- along with the index of the node during the traversal, and the + -- node itself. + M.Map VertexId (Int, v, [v]) -> + M.Map VertexId (Int, v, [v]) +_buildListGeneral _ [] _ allSeen = allSeen +_buildListGeneral boundaryIds (x : t) expand allSeen = + let vid = vertexToId x in + if M.member vid allSeen || S.member vid boundaryIds then + _buildListGeneral boundaryIds t expand allSeen + else + let nextVertices = expand x + currIdx = M.size allSeen + allSeen2 = M.insert vid (currIdx, x, nextVertices) allSeen + filterFun y = not $ M.member (vertexToId y) allSeen2 + nextVertices2 = filter filterFun nextVertices + in _buildListGeneral boundaryIds (nextVertices2 ++ t) expand allSeen2 + +{-| The sources of a DAG (nodes with no parent). +-} +graphSources :: Graph v e -> [Vertex v] +graphSources g = + let hasParent = do + vedges <- toList (gEdges g) + edge <- toList vedges + return . vertexId . veEndVertex $ edge + hasPSet = S.fromList hasParent + -- false iff the vertex has an incoming edge + filt vx = not (S.member (vertexId vx) hasPSet) + in filter filt (toList (gVertices g)) + +{-| The sinks of a graph (nodes with no descendant). +-} +graphSinks :: Graph v e -> [Vertex v] +graphSinks g = + let f vx = V.null (M.findWithDefault V.empty (vertexId vx) (gEdges g)) + in filter f (toList (gVertices g)) + +-- | Flips the edges of this graph (it is also a DAG) +reverseGraph :: forall v e. Graph v e -> Graph v e +reverseGraph g = + let + vxMap = M.fromList ((vertexId &&& id) <$> toList (gVertices g)) + flipVEdge :: (VertexId, V.Vector (VertexEdge e v)) -> [(VertexId, VertexEdge e v)] + flipVEdge (fromNid, vec) = case M.lookup fromNid vxMap of + Nothing -> [] -- Should be a programming error + Just endVx -> + toList vec <&> \ve -> + let ed = veEdge ve + oldEndVx = veEndVertex ve + oldEndVid = vertexId oldEndVx + ed' = Edge { + edgeFrom = oldEndVid, + edgeTo = fromNid, + edgeData = edgeData ed } + in (oldEndVid, VertexEdge { veEdge = ed', veEndVertex = endVx }) + edges = myGroupBy $ concat $ flipVEdge <$> M.toList (gEdges g) + in Graph (V.fromList <$> edges) (V.reverse (gVertices g)) + +-- | A generic transform over the graph that may account for potential failures +-- in the process. +graphMapVertices :: forall m v e v2. (HasCallStack, Show v2, Monad m) => + Graph v e -> -- The start graph + (v -> [(v2,e)] -> m v2) -> -- The transform + m (Graph v2 e) +graphMapVertices g f = + let + fun :: M.Map VertexId v2 -> [Vertex v] -> m [Vertex v2] + fun _ [] = return [] + fun done (vx : t) = + let + vid = vertexId vx + parents = V.toList $ fromMaybe V.empty $ M.lookup vid (gEdges g) + parentEdges = veEdge <$> parents + getPairs :: Edge e -> (v2, e) + getPairs ed = + let vidTo = edgeTo ed + msg = sformat ("graphMapVertices: Could not locate "%shown%" in "%shown)vidTo done + -- The edges are flowing from child -> parent so + -- to == parent + vert = fromMaybe (failure msg) (M.lookup vidTo done) + in (vert, edgeData ed) + parents2 = [getPairs ed | ed <- parentEdges] + -- parents2 = [fromJust $ M.lookup vidFrom done | vidFrom <- parentVids] + merge0 :: v2 -> m [Vertex v2] + merge0 vx2Data = + let done2 = M.insert vid vx2Data done + vx2 = vx { vertexData = vx2Data } + rest = fun done2 t in + (vx2 : ) <$> rest + in + f (vertexData vx) parents2 >>= merge0 + in do + verts2 <- fun M.empty (toList (gVertices g)) + let + idxs2 = M.fromList [(vertexId vx2, vx2) | vx2 <- verts2] + trans :: Vertex v -> Vertex v2 + trans vx = fromJust $ M.lookup (vertexId vx) idxs2 + conv :: VertexEdge e v -> VertexEdge e v2 + conv (VertexEdge vx1 e1) = VertexEdge (trans vx1) e1 + adj2 = M.map (conv <$>) (gEdges g) + return Graph { gEdges = adj2, gVertices = V.fromList verts2 } + +-- | (internal) Maps the edges +graphMapEdges :: Graph v e -> (e -> e') -> Graph v e' +graphMapEdges g f = graphFlatMapEdges g ((:[]) . f) + +-- | (internal) Maps and the edges, and may create more or less. +graphFlatMapEdges :: Graph v e -> (e -> [e']) -> Graph v e' +graphFlatMapEdges g f = g { gEdges = edges } where + fun (VertexEdge vx ed) = + f (edgeData ed) <&> \ed' -> VertexEdge vx (ed { edgeData = ed' }) + edges = (V.fromList . concatMap fun) <$> gEdges g + +-- | (internal) Maps the vertices. +graphMapVertices' :: (Show v, Show e, Show v') => (v -> v') -> Graph v e -> Graph v' e +graphMapVertices' f g = + runIdentity (graphMapVertices g f') where + f' v _ = return $ f v + +{-| Given a graph, prunes out a subset of vertices. + +All the corresponding edges and the unreachable chunks of the graph are removed. +-} +graphFilterVertices :: (Show v, Show e) => + (v -> FilterOp) -> Graph v e -> Graph v e +graphFilterVertices f g = + -- Tag all the vertices that we are going to remove first. + let f' v l = return $ _transFilter f v l + g' = runIdentity (graphMapVertices g f') + -- In a second step, directly remove all these elements from the graph. + -- TODO: use more recent version of Vector. + vxs = V.fromList $ mapMaybe _filt (V.toList (gVertices g')) + keptIds = S.fromList $ V.toList (vertexId <$> vxs) + eds = M.mapMaybeWithKey (_filtEdge keptIds) (gEdges g) + -- We are guaranteed that the result is still a DAG. + in Graph eds vxs + + +-- | The map of vertices, by vertex id. +vertexMap :: Graph v e -> M.Map VertexId v +vertexMap g = + M.fromList . toList $ gVertices g <&> (vertexId &&& vertexData) + +-- (internal) +-- The vertices in lexicographic order, and the originating edges for these +-- vertices. +verticesAndEdges :: Graph v e -> [([(v, e)],v)] +verticesAndEdges g = + toList (gVertices g) <&> \vx -> + let n = vertexData vx + l = V.toList $ M.findWithDefault V.empty (vertexId vx) (gEdges g) + lres = [(vertexData vx', edgeData e') | (VertexEdge vx' e') <- l] + in (lres, n) + +{-| Given a list of elements with vertex/edge information and a start vertex, +builds the graph from all the reachable vertices in the list. + +It returns the vertices in a DAG traversal order. + +Note that this function is robust and silently drops the missing vertices. +-} +pruneLexicographic :: VertexId -> [(VertexId, [VertexId], a)] -> [a] +pruneLexicographic hvid l = + let f (vid, l', a) = (vid, (l', a)) + allVertices = myGroupBy (f <$> l) + allVertices' = M.map head allVertices + in reverse $ _pruneLexicographic allVertices' S.empty [hvid] + +-- Recursive traversal of the graph, dropping everything that looks suspiscious. +_pruneLexicographic :: + M.Map VertexId ([VertexId], a) -> + S.Set VertexId -> + [VertexId] -> + [a] +_pruneLexicographic _ _ [] = [] +_pruneLexicographic vertices visited (hvid : t) = + if S.member hvid visited + then _pruneLexicographic vertices visited t + else case M.lookup hvid vertices of + Just (l, x) -> + x : _pruneLexicographic vertices (S.insert hvid visited) (l ++ t) + Nothing -> + _pruneLexicographic vertices visited t + +_transFilter :: (v -> FilterOp) -> v -> [(FilterVertex v, e)] -> FilterVertex v +_transFilter filt vx l = + let f (KeepVertex _, _) = True + f (DropChildren _, _) = False + f (RemoveVertex _, _) = False + -- If the current node is reachable: + -- If the node has no child, we do not make checks on the parents. + -- (it is considered to be reachable) + reachableChildren = null l || or (f <$> l) + in if reachableChildren + then case filt vx of + Keep -> KeepVertex vx + CutChildren -> DropChildren vx + Remove -> RemoveVertex vx + -- The node is unreachable, just drop + else RemoveVertex vx + +_filt :: Vertex (FilterVertex v) -> Maybe (Vertex v) +_filt (Vertex vid (KeepVertex v)) = Just (Vertex vid v) +_filt (Vertex vid (DropChildren v)) = Just (Vertex vid v) +_filt (Vertex _ (RemoveVertex _)) = Nothing + + +_filtEdge :: S.Set VertexId -> VertexId -> V.Vector (VertexEdge e v) -> Maybe (V.Vector (VertexEdge e v)) +-- The start vertex has been pruned out. +_filtEdge s vid _ | not (S.member vid s) = Nothing +_filtEdge s _ v = + let f ve = S.member (vertexId . veEndVertex $ ve) s + v' = V.filter f v + in if V.null v' + then Nothing + else Just v' + +data FilterVertex v = KeepVertex !v | DropChildren !v | RemoveVertex !v deriving (Show) diff --git a/src/Spark/Core/Internal/DAGStructures.hs b/src/Spark/Core/Internal/DAGStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/DAGStructures.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| Data structures to represent Directed Acyclic Graphs (DAGs). + +-} +module Spark.Core.Internal.DAGStructures where + +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.ByteString(ByteString) +import Data.Vector(Vector) +import Data.Foldable(toList) +import Data.Hashable(Hashable) +import GHC.Generics(Generic) +import Formatting + +import Spark.Core.Internal.Utilities + +-- | The unique ID of a vertex. +newtype VertexId = VertexId { unVertexId :: ByteString } deriving (Eq, Ord, Generic) + + +-- | An edge in a graph, parametrized by some payload. +data Edge e = Edge { + edgeFrom :: !VertexId, + edgeTo :: !VertexId, + edgeData :: !e +} + +-- | A vertex in a graph, parametrized by some payload. +data Vertex v = Vertex { + vertexId :: !VertexId, + vertexData :: !v +} + +{-| An edge, along with its end node. +-} +data VertexEdge e v = VertexEdge { + veEndVertex :: !(Vertex v), + veEdge :: !(Edge e) } + +{-| The adjacency map of a graph. + +The node Id corresponds to the start node, the pairs are the end node and +and the edge to reach to the node. There may be multiple edges leading to the +same node. +-} +type AdjacencyMap v e = M.Map VertexId (Vector (VertexEdge e v)) + +-- | The representation of a graph. +-- +-- In all the project, it is considered as a DAG. +data Graph v e = Graph { + gEdges :: !(AdjacencyMap v e), + gVertices :: !(Vector (Vertex v)) +} + +-- | Graph operations on types that are supposed to +-- represent vertices. +class GraphVertexOperations v where + vertexToId :: v -> VertexId + expandVertexAsVertices :: v -> [v] + +-- | Graph operations on types that are supposed to represent +-- edges. +class (GraphVertexOperations v) => GraphOperations v e where + expandVertex :: v -> [(e,v)] + +instance Functor Vertex where + fmap f vx = vx { vertexData = f (vertexData vx) } + +instance Functor Edge where + fmap f ed = ed { edgeData = f (edgeData ed) } + +instance (Show v) => Show (Vertex v) where + show vx = "Vertex(vId=" ++ show (vertexId vx) ++ " v=" ++ show (vertexData vx) ++ ")" + +instance (Show e) => Show (Edge e) where + show ed = "Edge(from=" ++ show (edgeFrom ed) ++ " to=" ++ show (edgeTo ed) ++ " e=" ++ show (edgeData ed) ++ ")" + +instance (Show v, Show e) => Show (VertexEdge e v) where + show (VertexEdge v e) = "(" ++ show v ++ ", " ++ show e ++ ")" + +instance (Show v, Show e) => Show (Graph v e) where + show g = + let vxs = toList $ gVertices g <&> \(Vertex vid x) -> + sformat (sh%":"%sh) vid x + vedges = foldMap toList (M.elems (gEdges g)) + edges = (veEdge <$> vedges) <&> \(Edge efrom eto x) -> + sformat (sh%"->"%sh%"->"%sh) efrom x eto + -- eds = (M.elems (gEdges g)) `foldMap` \v -> + -- (toList v) <&> + vxs' = T.intercalate "," vxs + eds' = T.intercalate " " edges + str = T.concat ["Graph{", vxs', ", ", eds', "}"] + in T.unpack str + +instance Hashable VertexId + +instance Show VertexId where + show (VertexId bs) = let s = show bs in + if length s > 9 then + (drop 1 . take 6) s ++ ".." + else + s diff --git a/src/Spark/Core/Internal/DatasetFunctions.hs b/src/Spark/Core/Internal/DatasetFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/DatasetFunctions.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Spark.Core.Internal.DatasetFunctions( + parents, + untyped, + untyped', + logicalParents, + logicalParents', + depends, + dataframe, + asDF, + asDS, + asLocalObservable, + asObservable, + -- Standard functions + identity, + autocache, + cache, + uncache, + union, + -- Developer + castLocality, + emptyDataset, + emptyLocalData, + emptyNodeStandard, + nodeId, + nodeLogicalDependencies, + nodeLogicalParents, + nodeLocality, + nodeName, + nodePath, + nodeOp, + nodeParents, + nodeType, + untypedDataset, + untypedLocalData, + updateNode, + updateNodeOp, + broadcastPair, + -- Developer conversions + -- TODO: remove all that + fun1ToOpTyped, + fun2ToOpTyped, + nodeOpToFun1, + nodeOpToFun1Typed, + nodeOpToFun1Untyped, + nodeOpToFun2, + nodeOpToFun2Typed, + nodeOpToFun2Untyped, + unsafeCastDataset, + placeholder, + castType, + castType', + -- Internal + opnameCache, + opnameUnpersist, + opnameAutocache, + +) where + +import qualified Crypto.Hash.SHA256 as SHA +import qualified Data.Aeson as A +import qualified Data.Text as T +import qualified Data.Text.Format as TF +import qualified Data.Vector as V +import Data.Aeson((.=), toJSON) +import Data.Text.Encoding(decodeUtf8) +import Data.ByteString.Base16(encode) +import Data.Maybe(fromMaybe, listToMaybe) +import Data.Text.Lazy(toStrict) +import Data.String(IsString(fromString)) +import Formatting + +import Spark.Core.StructuresInternal +import Spark.Core.Try +import Spark.Core.Row +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.OpFunctions +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.RowUtils +import Spark.Core.Internal.TypesGenerics +import Spark.Core.Internal.TypesFunctions + +-- | (developer) The operation performed by this node. +nodeOp :: ComputeNode loc a -> NodeOp +nodeOp = _cnOp + +-- | The nodes this node depends on directly. +nodeParents :: ComputeNode loc a -> [UntypedNode] +nodeParents = V.toList . _cnParents + +-- | (developer) Returns the logical parenst of a node. +nodeLogicalParents :: ComputeNode loc a -> Maybe [UntypedNode] +nodeLogicalParents = (V.toList <$>) . _cnLogicalParents + +-- | Returns the logical dependencies of a node. +nodeLogicalDependencies :: ComputeNode loc a -> [UntypedNode] +nodeLogicalDependencies = V.toList . _cnLogicalDeps + +-- | The name of a node. +-- TODO: should be a NodePath +nodeName :: ComputeNode loc a -> NodeName +nodeName node = fromMaybe (_defaultNodeName node) (_cnName node) + +{-| The path of a node, as resolved. + +This path includes information about the logical parents (after resolution). +-} +nodePath :: ComputeNode loc a -> NodePath +nodePath node = + if V.null . unNodePath . _cnPath $ node + then NodePath . V.singleton . nodeName $ node + else _cnPath node + +-- | The type of the node +-- TODO have nodeType' for dynamic types as well +nodeType :: ComputeNode loc a -> SQLType a +nodeType = SQLType . _cnType + +{-| The identity function. + +Returns a compute node with the same datatype and the same content as the +previous node. If the operation of the input has a side effect, this side +side effect is *not* reevaluated. + +This operation is typically used when establishing an ordering between some +operations such as caching or side effects, along with `logicalDependencies`. +-} +identity :: ComputeNode loc a -> ComputeNode loc a +identity n = n2 `parents` [untyped n] + where n2 = emptyNodeStandard (nodeLocality n) (nodeType n) name + name = if _cnLocality n == Local + then "org.spark.LocalIdentity" + else "org.spark.Identity" + +{-| Caches the dataset. + +This function instructs Spark to cache a dataset with the default persistence +level in Spark (MEMORY_AND_DISK). + +Note that the dataset will have to be evaluated first for the caching to take +effect, so it is usual to call `count` or other aggregrators to force +the caching to occur. +-} +cache :: Dataset a -> Dataset a +cache n = n2 `parents` [untyped n] + where n2 = emptyNodeStandard (nodeLocality n) (nodeType n) opnameCache + +-- (internal) +opnameCache :: T.Text +opnameCache = "org.spark.Cache" + +{-| Uncaches the dataset. + +This function instructs Spark to unmark the dataset as cached. The disk and the +memory used by Spark in the future. + +Unlike Spark, Karps is stricter with the uncaching operation: + - the argument of cache must be a cached dataset + - once a dataset is uncached, its cached version cannot be used again (i.e. it + must be recomputed). + +Karps performs escape analysis and will refuse to run programs with caching +issues. +-} +uncache :: ComputeNode loc a -> ComputeNode loc a +uncache n = n2 `parents` [untyped n] + where n2 = emptyNodeStandard (nodeLocality n) (nodeType n) opnameUnpersist + +-- (internal) +opnameUnpersist :: T.Text +opnameUnpersist = "org.spark.Unpersist" + +{-| Automatically caches the dataset on a need basis, and performs deallocation +when the dataset is not required. + +This function marks a dataset as eligible for the default caching level in +Spark. The current implementation performs caching only if it can be established +that the dataset is going to be involved in more than one shuffling or +aggregation operation. + +If the dataset has no observable child, no uncaching operation is added: the +autocache operation is equivalent to unconditional caching. +-} +autocache :: Dataset a -> Dataset a +autocache n = n2 `parents` [untyped n] + where n2 = emptyNodeStandard (nodeLocality n) (nodeType n) opnameAutocache + +opnameAutocache :: T.Text +opnameAutocache = "org.spark.Autocache" + +{-| Returns the union of two datasets. + +In the context of streaming and differentiation, this union is biased towards +the left: the left argument expresses the stream and the right element expresses +the increment. +-} +union :: Dataset a -> Dataset a -> Dataset a +union n1 n2 = n `parents` [untyped n1, untyped n2] + where n = emptyNodeStandard (nodeLocality n1) (nodeType n1) _opnameUnion + +_opnameUnion :: T.Text +_opnameUnion = "org.spark.Union" + +-- | Converts to a dataframe and drops the type info. +-- This always works. +asDF :: ComputeNode LocDistributed a -> DataFrame +asDF = pure . _unsafeCastNode + +-- | Attempts to convert a dataframe into a (typed) dataset. +-- +-- This will fail if the dataframe itself is a failure, of if the casting +-- operation is not correct. +-- This operation assumes that both field names and types are correct. +asDS :: forall a. (SQLTypeable a) => DataFrame -> Try (Dataset a) +asDS = _asTyped + + +-- | Converts a local node to a local frame. +-- This always works. +asLocalObservable :: ComputeNode LocLocal a -> LocalFrame +asLocalObservable = pure . _unsafeCastNode + +asObservable :: forall a. (SQLTypeable a) => LocalFrame -> Try (LocalData a) +asObservable = _asTyped + +-- | Converts any node to an untyped node +untyped :: ComputeNode loc a -> UntypedNode +untyped = _unsafeCastNode + +untyped' :: Try (ComputeNode loc a) -> UntypedNode' +untyped' = fmap untyped + + +untypedDataset :: ComputeNode LocDistributed a -> UntypedDataset +untypedDataset = _unsafeCastNode + +{-| Removes type informatino from an observable. -} +untypedLocalData :: ComputeNode LocLocal a -> UntypedLocalData +untypedLocalData = _unsafeCastNode + +{-| Adds parents to the node. +It is assumed the parents are the unique set of nodes required +by the operation defined in this node. +If you want to set parents for the sake of organizing computation +use logicalParents. +If you want to add some timing dependencies between nodes, +use depends. +-} +parents :: ComputeNode loc a -> [UntypedNode] -> ComputeNode loc a +parents node l = updateNode node $ \n -> + n { _cnParents = V.fromList l V.++ _cnParents n } + +{-| Establishes a naming convention on this node: the path of this node will be +determined as if the parents of this node were the list provided (and without +any effect from the direct parents of this node). + +For this to work, the logical parents should split the nodes between internal +nodes, logical parents, and the rest. In other words, for any ancestor of this node, +and for any valid path to reach this ancestor, this path should include at least one +node from the logical dependencies. + +This set can be a super set of the actual logical parents. + +The check is lazy (done during the analysis phase). An error (if any) will +only be reported during analysis. +-} +logicalParents :: ComputeNode loc a -> [UntypedNode] -> ComputeNode loc a +logicalParents node l = updateNode node $ \n -> + n { _cnLogicalParents = pure . V.fromList $ l } + +logicalParents' :: Try (ComputeNode loc a) -> [UntypedNode'] -> Try (ComputeNode loc a) +logicalParents' n' l' = do + n <- n' + l <- sequence l' + return (logicalParents n l) + +{-| Sets the logical dependencies on this node. + +All the nodes given will be guaranteed to be executed before the current node. + +If there are any failures, this node will also be treated as a failure (even +if the parents are all successes). +-} +depends :: ComputeNode loc a -> [UntypedNode] -> ComputeNode loc a +depends node l = updateNode node $ \n -> + n { _cnLogicalDeps = V.fromList l } + + +-- (internal) +-- Tries to update the locality of a node. This is a checked cast. +-- TODO: remove, it is only used to cast to local frame +castLocality :: forall a loc loc'. (CheckedLocalityCast loc') => + ComputeNode loc a -> Try (ComputeNode loc' a) +castLocality node = + let + loc2 = _cnLocality node + locs = unTypedLocality <$> (_validLocalityValues :: [TypedLocality loc']) + in if locs == [loc2] then + pure $ node { _cnLocality = loc2 } + else + tryError $ sformat ("Wrong locality :"%shown%", expected: "%shown) loc2 locs + +-- (internal) +-- The id of a node. If it is not set in the node, it will be +-- computed from scratch. +-- This is a potentially long operation. +nodeId :: ComputeNode loc a -> NodeId +nodeId = _cnNodeId + +-- (internal) +-- This operation should always be used to make sure that the +-- various caches inside the compute node are maintained. +updateNode :: ComputeNode loc a -> (ComputeNode loc a -> ComputeNode loc' b) -> ComputeNode loc' b +updateNode ds f = ds2 { _cnNodeId = id2 } where + ds2 = f ds + id2 = _nodeId ds2 + + +updateNodeOp :: ComputeNode loc a -> NodeOp -> ComputeNode loc a +updateNodeOp n no = updateNode n (\n' -> n' { _cnOp = no }) + +-- (internal) +-- The locality of the node +nodeLocality :: ComputeNode loc a -> TypedLocality loc +nodeLocality = TypedLocality . _cnLocality + +-- (internal) +emptyDataset :: NodeOp -> SQLType a -> Dataset a +emptyDataset = _emptyNode + +-- (internal) +emptyLocalData :: NodeOp -> SQLType a -> LocalData a +emptyLocalData = _emptyNode + +{-| Creates a dataframe from a list of cells and a datatype. + +Wil fail if the content of the cells is not compatible with the +data type. +-} +dataframe :: DataType -> [Cell] -> DataFrame +dataframe dt cells' = do + validCells <- tryEither $ sequence (checkCell dt <$> cells') + let jData = V.fromList (toJSON <$> validCells) + let op = NodeDistributedLit dt jData + return $ _emptyNode op (SQLType dt) + + +-- *********** function / object conversions ******* + +-- | (internal) +placeholderTyped :: forall a loc. (IsLocality loc) => + SQLType a -> ComputeNode loc a +placeholderTyped tp = _unsafeCastNode n where + n = placeholder (unSQLType tp) :: ComputeNode loc Cell + +placeholder :: forall loc. (IsLocality loc) => DataType -> ComputeNode loc Cell +placeholder tp = + let + t = SQLType tp + so = makeOperator "org.spark.Placeholder" t + (TypedLocality l) = _getTypedLocality :: TypedLocality loc + op = case l of + Local -> NodeLocalOp so + Distributed -> NodeDistributedOp so + in _emptyNode op t + +-- | (internal) conversion +fun1ToOpTyped :: forall a loc a' loc'. (IsLocality loc) => + SQLType a -> (ComputeNode loc a -> ComputeNode loc' a') -> NodeOp +fun1ToOpTyped sqlt f = nodeOp $ f (placeholderTyped sqlt) + +-- | (internal) conversion +fun2ToOpTyped :: forall a1 a2 a loc1 loc2 loc. (IsLocality loc1, IsLocality loc2) => + SQLType a1 -> SQLType a2 -> (ComputeNode loc1 a1 -> ComputeNode loc2 a2 -> ComputeNode loc a) -> NodeOp +fun2ToOpTyped sqlt1 sqlt2 f = nodeOp $ f (placeholderTyped sqlt1) (placeholderTyped sqlt2) + +-- | (internal) conversion +nodeOpToFun1 :: forall a1 a2 loc1 loc2. (SQLTypeable a2, IsLocality loc2) => + NodeOp -> ComputeNode loc1 a1 -> ComputeNode loc2 a2 +nodeOpToFun1 = nodeOpToFun1Typed (buildType :: SQLType a2) + +-- | (internal) conversion +nodeOpToFun1Typed :: forall a1 a2 loc1 loc2. (IsLocality loc2) => + SQLType a2 -> NodeOp -> ComputeNode loc1 a1 -> ComputeNode loc2 a2 +nodeOpToFun1Typed sqlt no node = + let n2 = _emptyNode no sqlt :: ComputeNode loc2 a2 + in n2 `parents` [untyped node] + +-- | (internal) conversion +nodeOpToFun1Untyped :: forall loc1 loc2. (IsLocality loc2) => + DataType -> NodeOp -> ComputeNode loc1 Cell -> ComputeNode loc2 Cell +nodeOpToFun1Untyped dt no node = + let n2 = _emptyNode no (SQLType dt) :: ComputeNode loc2 Cell + in n2 `parents` [untyped node] + +-- | (internal) conversion +nodeOpToFun2 :: forall a a1 a2 loc loc1 loc2. (SQLTypeable a, IsLocality loc) => + NodeOp -> ComputeNode loc1 a1 -> ComputeNode loc2 a2 -> ComputeNode loc a +nodeOpToFun2 = nodeOpToFun2Typed (buildType :: SQLType a) + +-- | (internal) conversion +nodeOpToFun2Typed :: forall a a1 a2 loc loc1 loc2. (IsLocality loc) => + SQLType a -> NodeOp -> ComputeNode loc1 a1 -> ComputeNode loc2 a2 -> ComputeNode loc a +nodeOpToFun2Typed sqlt no node1 node2 = + let n2 = _emptyNode no sqlt :: ComputeNode loc a + in n2 `parents` [untyped node1, untyped node2] + +-- | (internal) conversion +nodeOpToFun2Untyped :: forall loc1 loc2 loc3. (IsLocality loc3) => + DataType -> NodeOp -> ComputeNode loc1 Cell -> ComputeNode loc2 Cell -> ComputeNode loc3 Cell +nodeOpToFun2Untyped dt no node1 node2 = + let n2 = _emptyNode no (SQLType dt) :: ComputeNode loc3 Cell + in n2 `parents` [untyped node1, untyped node2] + + +{-| Low-level operator that takes an observable and propagates it along the +content of an existing dataset. + +Users are advised to use the Column-based `broadcast` function instead. +-} +broadcastPair :: Dataset a -> LocalData b -> Dataset (a, b) +broadcastPair ds ld = n `parents` [untyped ds, untyped ld] + where n = emptyNodeStandard (nodeLocality ds) sqlt name + sqlt = tupleType (nodeType ds) (nodeType ld) + name = "org.spark.BroadcastPair" + +-- ******* INSTANCES ********* + +-- Put here because it depends on some private functions. +instance forall loc a. Show (ComputeNode loc a) where + show ld = let + txt = fromString "{}@{}{}{}" :: TF.Format + loc :: T.Text + loc = case nodeLocality ld of + TypedLocality Local -> "!" + TypedLocality Distributed -> ":" + np = prettyNodePath . nodePath $ ld + no = prettyShowOp . nodeOp $ ld + fields = T.pack . show . nodeType $ ld in + T.unpack $ toStrict $ TF.format txt (np, no, loc, fields) + +instance forall loc a. A.ToJSON (ComputeNode loc a) where + toJSON node = A.object [ + "locality" .= nodeLocality node, + "path" .= nodePath node, + "op" .= (simpleShowOp . nodeOp $ node), + "extra" .= (extraNodeOpData . nodeOp $ node), + "parents" .= (nodePath <$> nodeParents node), + "logicalDependencies" .= (nodePath <$> nodeLogicalDependencies node), + "_type" .= (unSQLType . nodeType) node] + +instance forall loc. A.ToJSON (TypedLocality loc) where + toJSON (TypedLocality Local) = A.String "local" + toJSON (TypedLocality Distributed) = A.String "distributed" + +unsafeCastDataset :: ComputeNode LocDistributed a -> ComputeNode LocDistributed b +unsafeCastDataset ds = ds { _cnType = _cnType ds } + +-- TODO: figure out the story around haskell types vs datatypes +-- Should we have equivalence classes for haskell, so that a tuple has the +-- same type as a structure? +-- Probably not, it breaks the correspondence. +-- Probably, it makes the metadata story easier. +castType :: SQLType a -> ComputeNode loc b -> Try (ComputeNode loc a) +castType sqlt n = do + let dt = unSQLType sqlt + let dt' = unSQLType (nodeType n) + if dt `compatibleTypes` dt' + then let n' = updateNode n (\node -> node { _cnType = dt }) in + pure (_unsafeCastNode n') + else tryError $ sformat ("castType: Casting error: dataframe has type "%sh%" incompatible with type "%sh) dt' dt + +castType' :: SQLType a -> Try (ComputeNode loc Cell) -> Try (ComputeNode loc a) +castType' sqlt df = df >>= castType sqlt + +_asTyped :: forall loc a. (SQLTypeable a) => Try (ComputeNode loc Cell) -> Try (ComputeNode loc a) +_asTyped = castType' (buildType :: SQLType a) + +-- Performs an unsafe type recast. +-- This is useful for internal code that knows whether +-- this operation is legal or not through some other means. +-- This may still throw an error if the cast is illegal. +_unsafeCastNode :: ComputeNode loc1 a -> ComputeNode loc2 b +_unsafeCastNode x = x { + _cnType = _cnType x, + _cnLocality = _cnLocality x + } + +_unsafeCastNodeTyped :: TypedLocality loc2 -> ComputeNode loc1 a -> ComputeNode loc2 b +_unsafeCastNodeTyped l x = x { + _cnType = _cnType x, + _cnLocality = unTypedLocality l + } + +-- +_unsafeCastLoc :: CheckedLocalityCast loc' => + TypedLocality loc -> TypedLocality loc' +_unsafeCastLoc (TypedLocality Local) = + checkLocalityValidity (TypedLocality Local) +_unsafeCastLoc (TypedLocality Distributed) = + checkLocalityValidity (TypedLocality Distributed) + + +-- This should be a programming error +checkLocalityValidity :: forall loc. (HasCallStack, CheckedLocalityCast loc) => + TypedLocality loc -> TypedLocality loc +checkLocalityValidity x = + if x `notElem` _validLocalityValues + then + let msg = sformat ("CheckedLocalityCast: element "%shown%" not in the list of accepted values: "%shown) + x (_validLocalityValues :: [TypedLocality loc]) + in failure msg x + else x + + +-- Computes the ID of a node. +-- Since this is a complex operation, it should be cached by each node. +_nodeId :: ComputeNode loc a -> NodeId +_nodeId node = + let c1 = SHA.init + f2 = unNodeId . nodeId + c2 = hashUpdateNodeOp c1 (nodeOp node) + c3 = SHA.updates c2 $ f2 <$> nodeParents node + c4 = SHA.updates c3 $ f2 <$> nodeLogicalDependencies node + -- c6 = SHA.update c4 $ (BS.concat . LBS.toChunks) b + in + -- Using base16 encoding to make sure it is readable. + -- Not sure if it is a good idea in general. + (NodeId . encode . SHA.finalize) c4 + +_defaultNodeName :: ComputeNode loc a -> NodeName +_defaultNodeName node = + let opName = (prettyShowOp . nodeOp) node + namePieces = T.splitOn (T.pack ".") opName + lastOpt = (listToMaybe . reverse) namePieces + l = fromMaybe (T.pack "???") lastOpt + idbs = nodeId node + idt = (T.take 6 . decodeUtf8 . unNodeId) idbs + n = T.concat [T.toLower l, T.pack "_", idt] + in NodeName n + +-- Create a new empty node. Also performs a locality check to +-- make sure the info being provided is correct. +_emptyNode :: forall loc a. (IsLocality loc) => + NodeOp -> SQLType a -> ComputeNode loc a +_emptyNode op sqlt = _emptyNodeTyped (_getTypedLocality :: TypedLocality loc) sqlt op + +_emptyNodeTyped :: forall loc a. + TypedLocality loc -> SQLType a -> NodeOp -> ComputeNode loc a +_emptyNodeTyped tloc (SQLType dt) op = updateNode (_unsafeCastNodeTyped tloc ds) id where + ds :: ComputeNode loc a + ds = ComputeNode { + _cnName = Nothing, + _cnOp = op, + _cnType = dt, + _cnParents = V.empty, + _cnLogicalParents = Nothing, + _cnLogicalDeps = V.empty, + _cnLocality = unTypedLocality tloc, + _cnNodeId = error "_emptyNode: _cnNodeId", + _cnPath = NodePath V.empty + } + +emptyNodeStandard :: forall loc a. + TypedLocality loc -> SQLType a -> T.Text -> ComputeNode loc a +emptyNodeStandard tloc sqlt name = _emptyNodeTyped tloc sqlt op where + so = StandardOperator { + soName = name, + soOutputType = unSQLType sqlt, + soExtra = A.Null + } + op = if unTypedLocality tloc == Local + then NodeLocalOp so + else NodeDistributedOp so diff --git a/src/Spark/Core/Internal/DatasetStructures.hs b/src/Spark/Core/Internal/DatasetStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/DatasetStructures.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Spark.Core.Internal.DatasetStructures where + +import Data.Vector(Vector) + +import Spark.Core.StructuresInternal +import Spark.Core.Try +import Spark.Core.Row +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.TypesStructures + +{-| (internal) The main data structure that represents a data node in the +computation graph. + +This data structure forms the backbone of computation graphs expressed +with spark operations. + +loc is a typed locality tag. +a is the type of the data, as seen by the Haskell compiler. If erased, it +will be a Cell type. +-} +-- TODO: separate the topology info from the node info. It will help when +-- building the graphs. +data ComputeNode loc a = ComputeNode { + -- | The id of the node. + -- + -- Non strict because it may be expensive. + _cnNodeId :: NodeId, + -- The following fields are used to build a unique ID to + -- a compute node: + + -- | The operation associated to this node. + _cnOp :: !NodeOp, + -- | The type of the node + _cnType :: !DataType, + -- | The direct parents of the node. The order of the parents is important + -- for the semantics of the operation. + _cnParents :: !(Vector UntypedNode), + -- | A set of extra dependencies that can be added to force an order between + -- the nodes. + -- + -- The order is not important, they are sorted by ID. + -- + -- TODO(kps) add this one to the id + _cnLogicalDeps :: !(Vector UntypedNode), + -- | The locality of this node. + -- + -- TODO(kps) add this one to the id + _cnLocality :: !Locality, + -- Attributes that are not included in the id + -- These attributes are mostly for the user to relate to the nodes. + -- They are not necessary for the computation. + -- + -- | The name + _cnName :: !(Maybe NodeName), + -- | A set of nodes considered as the logical input for this node. + -- This has no influence on the calculation of the id and is used + -- for organization purposes only. + _cnLogicalParents :: !(Maybe (Vector UntypedNode)), + -- | The path of this oned in a computation flow. + -- + -- This path includes the node name. + -- Not strict because it may be expensive to compute. + -- By default it only contains the name of the node (i.e. the node is + -- attached to the root) + _cnPath :: NodePath +} deriving (Eq) + +-- (internal) Phantom type tags for the locality +data TypedLocality loc = TypedLocality { unTypedLocality :: !Locality } deriving (Eq, Show) +data LocLocal +data LocDistributed +data LocUnknown + +-- (developer) The type for which we drop all the information expressed in +-- types. +-- +-- This is useful to express parent dependencies (pending a more type-safe +-- interface) +type UntypedNode = ComputeNode LocUnknown Cell + +-- (internal) A dataset for which we have dropped type information. +-- Used internally by columns. +type UntypedDataset = Dataset Cell + +type UntypedLocalData = LocalData Cell + +{-| A typed collection of distributed data. + +Most operations on datasets are type-checked by the Haskell +compiler: the type tag associated to this dataset is guaranteed +to be convertible to a proper Haskell type. In particular, building +a Dataset of dynamic cells is guaranteed to never happen. + +If you want to do untyped operations and gain +some flexibility, consider using UDataFrames instead. + +Computations with Datasets and observables are generally checked for +correctness using the type system of Haskell. +-} +type Dataset a = ComputeNode LocDistributed a + +{-| +A unit of data that can be accessed by the user. + +This is a typed unit of data. The type is guaranteed to be a proper +type accessible by the Haskell compiler (instead of simply a Cell +type, which represents types only accessible at runtime). + +TODO(kps) rename to Observable +-} +type LocalData a = ComputeNode LocLocal a + + +{-| +The dataframe type. Any dataset can be converted to a dataframe. + +For the Spark users: this is different than the definition of the +dataframe in Spark, which is a dataset of rows. Because the support +for single columns is more akward in the case of rows, it is more +natural to generalize datasets to contain cells. +When communicating with Spark, though, single cells are wrapped +into rows with single field, as Spark does. +-} +type DataFrame = Try UntypedDataset + +{-| Observable, whose type can only be infered at runtime and +that can fail to be computed at runtime. + +Any observable can be converted to an untyped +observable. + +Untyped observables are more flexible and can be combined in +arbitrary manner, but they will fail during the validation of +the Spark computation graph. + +TODO(kps) rename to DynObservable +-} +type LocalFrame = Try UntypedLocalData + +type UntypedNode' = Try UntypedNode + +{-| The different paths of edges in the compute DAG of nodes, at the +start of computations. + + - scope edges specify the scope of a node for naming. They are not included in + the id. + +-} +data NodeEdge = ScopeEdge | DataStructureEdge StructureEdge deriving (Show, Eq) + +{-| The edges in a compute DAG, after name resolution (which is where most of +the checks and computations are being done) + +- parent edges are the direct parents of a node, the only ones required for + defining computations. They are included in the id. +- logical edges define logical dependencies between nodes to force a specific + ordering of the nodes. They are included in the id. +-} +data StructureEdge = ParentEdge | LogicalEdge deriving (Show, Eq) + + +class CheckedLocalityCast loc where + _validLocalityValues :: [TypedLocality loc] + +-- Class to retrieve the locality associated to a type. +-- Is it better to use type classes? +class (CheckedLocalityCast loc) => IsLocality loc where + _getTypedLocality :: TypedLocality loc + +instance CheckedLocalityCast LocLocal where + _validLocalityValues = [TypedLocality Local] + +instance CheckedLocalityCast LocDistributed where + _validLocalityValues = [TypedLocality Distributed] + +-- LocLocal is a locality associated to Local +instance IsLocality LocLocal where + _getTypedLocality = TypedLocality Local + +-- LocDistributed is a locality associated to Distributed +instance IsLocality LocDistributed where + _getTypedLocality = TypedLocality Distributed + +instance CheckedLocalityCast LocUnknown where + _validLocalityValues = [TypedLocality Distributed, TypedLocality Local] diff --git a/src/Spark/Core/Internal/FunctionsInternals.hs b/src/Spark/Core/Internal/FunctionsInternals.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/FunctionsInternals.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- A number of utilities related to data sets and dataframes. + +module Spark.Core.Internal.FunctionsInternals( + DynColPackable, + StaticColPackable2, + NameTuple(..), + TupleEquivalence(..), + asCol, + asCol', + pack1, + pack, + pack', + struct', + struct, + -- Developer tools + checkOrigin, + projectColFunction, + projectColFunction', + projectColFunction2', + colOpNoBroadcast +) where + +import Control.Arrow +import Data.Aeson(toJSON) +import qualified Data.Vector as V +import qualified Data.Map.Strict as M +import qualified Data.List.NonEmpty as N +import qualified Data.Text as T +import Formatting + +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.LocalDataFunctions +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.Projections +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.TypesGenerics(SQLTypeable, buildType) +import Spark.Core.StructuresInternal +import Spark.Core.Try + +{-| The class of pairs of types that express the fact that some type a can +be converted to a dataset of type b. + +This class is only inhabited by some internal types: lists, tuples, etc. +-} +class DynColPackable a where + -- Returns (possibly) some form of the type a packed into a single column. + -- This implementation must make sure that the final column is either a + -- failure or is well-formed (no name duplicates, etc.) + _packAsColumn :: a -> DynColumn + +{-| The class of pairs of types that express the fact that some type a can +be converted to a dataset of type b. + +This class is meant to be extended by users to create converters associated +to their data types. +-} +class StaticColPackable2 ref a b | a -> ref where + _staticPackAsColumn2 :: a -> Column ref b + +data NameTuple to = NameTuple [String] + +{-| A class that expresses the fact that a certain type (that is well-formed) +is equivalent to a tuple of points. + +Useful for auto conversions between tuples of columns and data structures. +-} +class TupleEquivalence to tup | to -> tup where + tupleFieldNames :: NameTuple to + +-- Here is the basic algorithm: +-- - datasets can only contain rows of things +-- - columns and observables contain cells (which may be empty) +-- - a strict struct cell is equivalent to a row +-- - a non-strict or non-struct cell is equivalent to a row with a single item +-- - as a consequence, there is no "row with a unique field". This is equivalent +-- to the element inside the field + +-- Invariants to respect in terms of types (not in terms of values) +-- untypedCol . asCol == asCol' +-- pack1 . asCol == asCol . pack1 +-- for single columns, pack = Right . pack1 + +-- The typed function +-- This only works for inner types that are known to the Haskell type system +-- fun :: (SQLTypeable a, HasCallStack) => Column a -> Column a -> Column a +-- fun = undefined + +-- The untyped equivalent +-- Each of the inputs can be either a column or a try, and the final outcome is always a try +-- When both types are known to the type system, the 2 calls are equivalent +-- fun' :: (ColumnLike a1, ColumnLike a2, HasCallStack) => a1 -> a2 -> Try DynColumn +-- fun' = undefined + +-- | Represents a dataframe as a single column. +asCol :: Dataset a -> Column a a +asCol ds = + -- Simply recast the dataset as a column. + -- The empty path indicates that we are wrapping the whole thing. + iEmptyCol ds (unsafeCastType $ nodeType ds) (FieldPath V.empty) + +asCol' :: DataFrame -> DynColumn +asCol' = ((iUntypedColData . asCol) <$>) + +-- | Packs a single column into a dataframe. +pack1 :: Column ref a -> Dataset a +pack1 = _pack1 + +{-| Packs a number of columns into a single dataframe. + +This operation is checked for same origin and no duplication of columns. + +This function accepts columns, list of columns and tuples of columns (both +typed and untyped). +-} +pack' :: (DynColPackable a) => a -> DataFrame +-- Pack the columns and check that they have the same origin. +pack' z = pack1 <$> _packAsColumn z + +{-| Packs a number of columns with the same references into a single dataset. + +The type of the dataset must be provided in order to have proper type inference. + +TODO: example. +-} +pack :: forall ref a b. (StaticColPackable2 ref a b) => a -> Dataset b +pack z = + let c = _staticPackAsColumn2 z :: ColumnData ref b + in pack1 c + +{-| Packs a number of columns into a single column (the struct construct). + +Columns must have different names, or an error is returned. +-} +struct' :: [DynColumn] -> DynColumn +struct' cols = do + l <- sequence cols + let fields = (colFieldName &&& id) <$> l + _buildStruct fields + +{-| Packs a number of columns into a single structure, given a return type. + +The field names of the columns are discarded, and replaced by the field names +of the structure. +-} +struct :: forall ref a b. (StaticColPackable2 ref a b) => a -> Column ref b +struct = _staticPackAsColumn2 + + +checkOrigin :: [DynColumn] -> Try [UntypedColumnData] +checkOrigin x = _checkOrigin =<< sequence x + +{-| Takes a typed function that operates on columns and projects this function +onto a similar operation for type observables. + +This function is not very smart and may throw an error for complex cases such +as broadcasting, joins, etc. +-} +-- TODO: we do not need technically the typeable constraint. +-- It is an additional check. +projectColFunction :: forall x y. + (HasCallStack, SQLTypeable y, SQLTypeable x) => + (forall ref. Column ref x -> Column ref y) -> LocalData x -> LocalData y +projectColFunction f o = + let o' = untypedLocalData o + sqltx = buildType :: SQLType x + sqlty = buildType :: SQLType y + f' :: UntypedColumnData -> Try UntypedColumnData + f' x = dropColType . f <$> castTypeCol sqltx x + o2 = projectColFunctionUntyped (f' =<<) o' + o3 = castType sqlty =<< o2 + in forceRight o3 + +projectColFunctionUntyped :: + (DynColumn -> DynColumn) -> UntypedLocalData -> LocalFrame +projectColFunctionUntyped f obs = do + -- Create a placeholder dataset and a corresponding column. + let dt = unSQLType (nodeType obs) + -- Pass them to the function. + let no = NodeDistributedLit dt V.empty + let ds = emptyDataset no (SQLType dt) + let c = asCol ds + colRes <- f (pure (dropColType c)) + let dtOut = unSQLType $ colType colRes + -- This will fail if there is a broadcast. + co <- _replaceObservables M.empty (colOp colRes) + let op = NodeStructuredTransform co + return $ emptyLocalData op (SQLType dtOut) + `parents` [untyped obs] + +{-| Takes a function that operates on columns, and projects this +function onto the same operations for observables. + +This is not very smart at the moment and will miss the more +complex operations such as broadcasting, etc. +-} +-- TODO: use for the numerical transforms instead of special stuff. +projectColFunction' :: + (DynColumn -> DynColumn) -> + LocalFrame -> LocalFrame +projectColFunction' f obs = projectColFunctionUntyped f =<< obs + +projectColFunction2' :: + (DynColumn -> DynColumn -> DynColumn) -> + LocalFrame -> + LocalFrame -> + LocalFrame +projectColFunction2' f o1' o2' = do + let f2 :: DynColumn -> DynColumn + f2 dc = f (dc /- "_1") (dc /- "_2") + o1 <- o1' + o2 <- o2' + let o = iPackTupleObs $ o1 N.:| [o2] + projectColFunctionUntyped f2 o + +colOpNoBroadcast :: GeneralizedColOp -> Try ColOp +colOpNoBroadcast = _replaceObservables M.empty + + +_checkOrigin :: [UntypedColumnData] -> Try [UntypedColumnData] +_checkOrigin [] = pure [] +_checkOrigin l = + case _columnOrigin l of + [_] -> pure l + l' -> tryError $ sformat ("Too many distinct origins: "%sh) l' + + +instance forall x. (DynColPackable x) => DynColPackable [x] where + _packAsColumn = struct' . (_packAsColumn <$>) + +instance DynColPackable DynColumn where + _packAsColumn = id + +instance forall ref a. DynColPackable (Column ref a) where + _packAsColumn = pure . iUntypedColData + +instance forall z1 z2. (DynColPackable z1, DynColPackable z2) => DynColPackable (z1, z2) where + _packAsColumn (c1, c2) = struct' [_packAsColumn c1, _packAsColumn c2] + +-- ******** Experimental ************ +instance forall ref a. StaticColPackable2 ref (Column ref a) a where + _staticPackAsColumn2 = id + +-- Tuples are equivalent to tuples +instance forall a1 a2. TupleEquivalence (a1, a2) (a1, a2) where + tupleFieldNames = NameTuple ["_1", "_2"] + + +-- The equations that bind column packable stuff through their tuple equivalents +instance forall ref b a1 a2 z1 z2. ( + TupleEquivalence b (a1, a2), + StaticColPackable2 ref z1 a1, + StaticColPackable2 ref z2 a2) => + StaticColPackable2 ref (z1, z2) b where + _staticPackAsColumn2 (c1, c2) = + let + x1 = iUntypedColData (_staticPackAsColumn2 c1 :: Column ref a1) + x2 = iUntypedColData (_staticPackAsColumn2 c2 :: Column ref a2) + names = tupleFieldNames :: NameTuple b + in _unsafeBuildStruct [x1, x2] names + +instance forall ref b a1 a2 a3 z1 z2 z3. ( + TupleEquivalence b (a1, a2, a3), + StaticColPackable2 ref z1 a1, + StaticColPackable2 ref z2 a2, + StaticColPackable2 ref z3 a3) => + StaticColPackable2 ref (z1, z2, z3) b where + _staticPackAsColumn2 (c1, c2, c3) = + let + x1 = iUntypedColData (_staticPackAsColumn2 c1 :: Column ref a1) + x2 = iUntypedColData (_staticPackAsColumn2 c2 :: Column ref a2) + x3 = iUntypedColData (_staticPackAsColumn2 c3 :: Column ref a3) + names = tupleFieldNames :: NameTuple b + in _unsafeBuildStruct [x1, x2, x3] names + + + +_unsafeBuildStruct :: [UntypedColumnData] -> NameTuple x -> Column ref x +_unsafeBuildStruct cols (NameTuple names) = + if length cols /= length names + then failure $ sformat ("The number of columns and names differs:"%sh%" and "%sh) cols names + else + let fnames = unsafeFieldName . T.pack <$> names + uc = _buildStruct (fnames `zip` cols) + z = forceRight uc + in z { _cOp = _cOp z } + +_buildTuple :: [UntypedColumnData] -> Try UntypedColumnData +_buildTuple l = _buildStruct (zip names l) where + names = (:[]) . unsafeFieldName . ("_" <> ) . show' $ [0..(length l)] + +_buildStruct :: [(FieldName, UntypedColumnData)] -> Try UntypedColumnData +_buildStruct cols = do + let fields = GenColStruct $ (uncurry GeneralizedTransField . (fst &&& colOp . snd)) <$> V.fromList cols + st <- structTypeFromFields $ (fst &&& unSQLType . colType . snd) <$> cols + let name = structName st + case _columnOrigin (snd <$> cols) of + [ds] -> + pure ColumnData { + _cOrigin = ds, + _cType = StrictType (Struct st), + _cOp = fields, + _cReferingPath = Just $ unsafeFieldName name + } + l -> tryError $ sformat ("_buildStruct: Too many distinct origins: "%sh) l + +_columnOrigin :: [UntypedColumnData] -> [UntypedDataset] +_columnOrigin l = + let + groups = myGroupBy' (nodeId . colOrigin) l + in (colOrigin . head . snd) <$> groups + +-- The packing algorithm +-- It eliminates the broadcast variables into joins and then wraps the +-- remaining transform into structured transform. +-- TODO: the data structure and the algorithms use unsafe operations +-- It should be transfromed to safe operations eventually. +_pack1 :: (HasCallStack) => Column ref a -> Dataset a +_pack1 ucd = + let gco = colOp ucd + ulds = _collectObs gco + in case ulds of + [] -> let co = forceRight $ colOpNoBroadcast gco in + _packCol1 ucd co + (h : t) -> forceRight $ _packCol1WithObs ucd (h N.:| t) + +_packCol1WithObs :: Column ref a -> N.NonEmpty UntypedLocalData -> Try (Dataset a) +_packCol1WithObs c ulds = do + let packedObs = iPackTupleObs ulds + -- Retrieve the field names in the pack structure. + let st = structTypeTuple (unSQLType . nodeType <$> ulds) + let names = V.toList $ structFieldName <$> structFields st + let paths = FieldPath . V.fromList . (unsafeFieldName "_2" : ) . (:[]) <$> names + let m = M.fromList ((nodeId <$> N.toList ulds) `zip` paths) + let joined = broadcastPair (colOrigin c) packedObs + co <- _replaceObservables m (colOp c) + let no = NodeStructuredTransform co + let f = emptyDataset no (colType c) `parents` [untyped joined] + return f + + +_replaceObservables :: M.Map NodeId FieldPath -> GeneralizedColOp -> Try ColOp +-- Special case for when there is nothing in the dictionary +_replaceObservables m (GenColExtraction fp) | M.null m = pure $ ColExtraction fp +_replaceObservables _ (GenColExtraction (FieldPath v)) = + -- It is a normal extraction, prepend the suffix of the data structure. + pure (ColExtraction (FieldPath v')) where + v' = V.cons (unsafeFieldName "_1") v +_replaceObservables _ (GenColLit dt c) = pure (ColLit dt (toJSON c)) +_replaceObservables m (GenColFunction n v) = + ColFunction n <$> sequence (_replaceObservables m <$> v) +_replaceObservables m (GenColStruct v) = ColStruct <$> sequence (_replaceField m <$> v) +_replaceObservables m (BroadcastColOp uld) = + case M.lookup (nodeId uld) m of + Just p -> pure $ ColExtraction p + Nothing -> tryError $ "_replaceObservables: error: missing key " <> show' uld <> " in " <> show' m + +_replaceField :: M.Map NodeId FieldPath -> GeneralizedTransField -> Try TransformField +_replaceField m (GeneralizedTransField n v) = TransformField n <$> _replaceObservables m v + +-- Unconditionally packs the column into a dataset. +_packCol1 :: Column ref a -> ColOp -> Dataset a +-- Special case for column operations that are no-ops: return the dataset itself. +_packCol1 c (ColExtraction (FieldPath v)) | V.null v = + -- TODO: we should not need to force this operation. + forceRight $ castType (colType c) (colOrigin c) +_packCol1 c op = + emptyDataset (NodeStructuredTransform op) (colType c) + `parents` [untyped (colOrigin c)] + +_collectObs :: GeneralizedColOp -> [UntypedLocalData] +_collectObs (GenColFunction _ v) = concat (_collectObs <$> V.toList v) +_collectObs (BroadcastColOp uld) = [uld] +_collectObs (GenColStruct v) = concat (_collectObs . gtfValue <$> V.toList v) +_collectObs _ = [] -- Anything else has no broadcast info. diff --git a/src/Spark/Core/Internal/Groups.hs b/src/Spark/Core/Internal/Groups.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Groups.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +-- A number of standard aggregation functions. + +module Spark.Core.Internal.Groups( + GroupData, + LogicalGroupData, + -- Typed functions + groupByKey, + mapGroup, + aggKey, + groupAsDS + -- Developer + +) where + +import qualified Data.Text as T +import qualified Data.Vector as V +import Formatting +import Debug.Trace(trace) + +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions(untypedCol, colType, colOp, iUntypedColData, colOrigin, castTypeCol, dropColReference, genColOp) +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.LocalDataFunctions() +import Spark.Core.Internal.FunctionsInternals +import Spark.Core.Internal.TypesFunctions(tupleType, structTypeFromFields) +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.Projections +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.RowStructures(Cell) +import Spark.Core.Try +import Spark.Core.StructuresInternal +import Spark.Core.Internal.CanRename + +{-| A dataset that has been partitioned according to some given field. +-} +data GroupData key val = GroupData { + -- The dataset of reference for this group + _gdRef :: !UntypedDataset, + -- The columns used to partition the data by keys. + _gdKey :: !GroupColumn, + -- The columns that contain the values. + _gdValue :: !GroupColumn +} + +type LogicalGroupData = Try UntypedGroupData + +-- A column in a group, that can be used either for key or for values. +-- It is different from the column data, because it does not include +-- broadcast data. +data GroupColumn = GroupColumn { + _gcType :: !DataType, + _gcOp :: !ColOp, + _gcRefName :: !(Maybe FieldName) +} deriving (Eq, Show) + + +{-| (developper) + +A group data type with no typing information. +-} +type UntypedGroupData = GroupData Cell Cell + +-- type GroupTry a = Either T.Text a + +-- A useful type when chaining operations withing groups. +data PipedTrans = + PipedError !T.Text + | PipedDataset !UntypedDataset + | PipedGroup !UntypedGroupData + deriving (Show) + + +{-| Performs a logical group of data based on a key. +-} +groupByKey :: (HasCallStack) => Column ref key -> Column ref val -> GroupData key val +groupByKey keys vals = forceRight $ _castGroup (colType keys) (colType vals) =<< _groupByKey (iUntypedColData keys) (iUntypedColData vals) + +{-| Transforms the values in a group. +-} +-- This only allows direct transforms, so it is probably valid in all cases. +mapGroup :: GroupData key val -> (forall ref. Column ref val -> Column ref val') -> GroupData key val' +mapGroup g f = + let c = _valueCol g + c' = f (_unsafeCastColData c) + -- Assume for now that there is no broadcast. + -- TODO: deal with broadcast eventually + gVals = forceRight $ _groupCol c' + in g { _gdValue = gVals } + +{-| The generalized value transform. + +This generalizes mapGroup to allow more complex transforms involving joins, +groups, etc. +-} +-- TODO: this can fail +-- magGroupGen :: (forall ref. Column ref val -> Dataset val') -> GroupData key val -> GroupData key val' +-- magGroupGen _ _ = undefined + +{-| Given a group and an aggregation function, aggregates the data. + +Note: not all the reduction functions may be used in this case. The analyzer +will fail if the function is not universal. +-} +-- TODO: it should be a try, this can fail +aggKey :: (HasCallStack) => GroupData key val -> (forall ref. Column ref val -> LocalData val') -> Dataset (key, val') +aggKey gd f = trace "aggKey" $ + let ugd = _untypedGroup gd + keyt = traceHint "aggKey: keyt: " $ mapGroupKeys gd colType + valt = traceHint "aggKey: valt: " $ mapGroupValues gd colType + -- We call the function twice: the first one to recover the type info, + -- and the second time to perform the unrolling. + -- TODO we should be able to do it in one pass instead. + fOut = traceHint "aggKey: fOut: " $ f (mapGroupValues gd dropColReference) + valt' = traceHint "aggKey: valt': " $ nodeType fOut + t = traceHint "aggKey: t: " $ tupleType keyt valt' + f' c = untypedLocalData . f <$> castTypeCol valt c + tud = traceHint "aggKey: tud: " $ _aggKey ugd f' + res = castType' t tud + in forceRight res + +{-| Creates a group by 'expanding' a value into a potentially large collection. + +Note on performance: this function is optimized to work at any scale and may not +be the most efficient when the generated collections are small (a few elements). +-} +-- TODO: it should be a try, this can fail +-- expand :: Column ref key -> Column ref val -> (LocalData val -> Dataset val') -> GroupData key val' +-- expand = undefined + +{-| Builds groups within groups. + +This function allows groups to be constructed from each collections inside a +group. + +This function is usually not used directly by the user, but rather as part of +more complex pipelines that may involve multiple levels of nesting. +-} +-- groupInGroup :: GroupData key val -> (forall ref. Column ref val -> GroupData key' val') -> GroupData (key', key) val' +-- groupInGroup _ _ = undefined + +{-| Reduces a group in group into a single group. +-} +-- aggGroup :: GroupData (key, key') val -> (forall ref. LocalData key -> Column ref val -> LocalData val') -> GroupData key val +-- aggGroup _ _ = undefined + +{-| Returns the collapsed representation of a grouped dataset, discarding group +information. +-} +groupAsDS :: forall key val. GroupData key val -> Dataset (key, val) +groupAsDS g = pack s where + c1 = _unsafeCastColData (_keyCol g) :: Column UnknownReference key + c2 = _unsafeCastColData (_valueCol g) :: Column UnknownReference val + s = struct (c1, c2) :: Column UnknownReference (key, val) + +mapGroupKeys :: GroupData key val -> (forall ref. Column ref key -> a) -> a +mapGroupKeys gd f = + f (_unsafeCastColData (_keyCol gd)) + +mapGroupValues :: GroupData key val -> (forall ref. Column ref val -> a) -> a +mapGroupValues gd f = + f (_unsafeCastColData (_valueCol gd)) + +-- ******** INSTANCES *********** + + +instance Show (GroupData key val) where + show gd = T.unpack s where + s = sformat ("GroupData[key="%sh%", val="%sh%"]") (_gdKey gd) (_gdValue gd) + +-- ******** PRIVATE METHODS ******** + +_keyCol :: GroupData key val -> UntypedColumnData +_keyCol gd = ColumnData { + _cOrigin = _gdRef gd, + _cType = _gcType (_gdKey gd), + _cOp = genColOp . _gcOp . _gdKey $ gd, + _cReferingPath = _gcRefName . _gdKey $ gd + } + +_valueCol :: GroupData key val -> UntypedColumnData +_valueCol gd = ColumnData { + _cOrigin = _gdRef gd, + _cType = _gcType (_gdValue gd), + _cOp = genColOp . _gcOp . _gdValue $ gd, + _cReferingPath = _gcRefName . _gdValue $ gd + } + + +_pError :: T.Text -> PipedTrans +_pError = PipedError + +_unrollTransform :: PipedTrans -> NodeId -> UntypedNode -> PipedTrans +_unrollTransform start nid un | nodeId un == nid = start +_unrollTransform start nid un = case nodeParents un of + [p] -> + let pt' = _unrollTransform start nid p in _unrollStep pt' un + _ -> + _pError $ sformat (sh%": operations with multiple parents cannot be used in groups yet.") un + +_unrollStep :: PipedTrans -> UntypedNode -> PipedTrans +_unrollStep pt un = traceHint ("_unrollStep: pt=" <> show' pt <> " un=" <> show' un <> " res=") $ + let op = nodeOp un + dt = unSQLType (nodeType un) in case nodeParents un of + [p] -> + case (pt, op) of + (PipedError e, _) -> PipedError e + (PipedDataset ds, NodeStructuredTransform _) -> + -- This is simply dointg a DS -> DS transform. + -- TODO: this breaks the encapsulation of ComputeNode + let ds' = updateNode un (\un' -> un' { _cnParents = V.singleton (untyped ds)}) + in PipedDataset ds' + (PipedGroup g, NodeStructuredTransform co) -> + _unrollGroupTrans g co + (PipedGroup g, NodeAggregatorReduction uao) -> + case uaoInitialOuter uao of + OpaqueAggTransform x -> _pError $ sformat ("Cannot apply opaque transform in the context of an aggregation: "%sh) x + InnerAggOp ao -> + PipedDataset $ _applyAggOp dt ao g + _ -> _pError $ sformat (sh%": Operation not supported with trans="%sh%" and parents="%sh) op pt p + l -> _pError $ sformat (sh%": expected one parent but got "%sh) un l + +-- dt: output type of the aggregation op +_applyAggOp :: (HasCallStack) => DataType -> AggOp -> UntypedGroupData -> UntypedDataset +_applyAggOp dt ao ugd = traceHint ("_applyAggOp dt=" <> show' dt <> " ao=" <> show' ao <> " ugd=" <> show' ugd <> " res=") $ + -- Reset the names to make sure there are no collision. + let c1 = untypedCol (_keyCol ugd) @@ T.unpack "_1" + c2 = untypedCol (_valueCol ugd) @@ T.unpack "_2" + s = struct' [c1, c2] + p = pack1 <$> s + ds = forceRight p + -- The structure of the result dataframe + keyDt = unSQLType (colType (_keyCol ugd)) + st' = structTypeFromFields [(unsafeFieldName "key", keyDt), (unsafeFieldName "agg", dt)] + -- The keys are different, so we know we this operation is legit: + st = forceRight st' + resDt = SQLType . StrictType . Struct $ st + ds2 = emptyDataset (NodeGroupedReduction ao) resDt `parents` [untyped ds] + in ds2 + +_unrollGroupTrans :: UntypedGroupData -> ColOp -> PipedTrans +_unrollGroupTrans ugd co = + let gco = colOp (_valueCol ugd) in case colOpNoBroadcast gco of + Left x -> _pError $ "_unrollGroupTrans (1): using unimplemented feature:" <> show' x + Right co' -> case _combineColOp co' co of + -- TODO: this is ugly, we are loosing the error structure. + Left x -> _pError $ "_unrollGroupTrans (2): failure with " <> show' x + Right co'' -> case _groupCol $ _transformCol co'' (_valueCol ugd) of + Left x -> _pError $ "_unrollGroupTrans (3): failure with " <> show' x + Right g -> PipedGroup $ ugd { _gdValue = g } + +-- TODO: this should be moved to ColumnFunctions +_transformCol :: ColOp -> UntypedColumnData -> UntypedColumnData +-- TODO: at this point, it should be checked for correctness (the fields +-- being extracted should exist) +_transformCol co ucd = ucd { _cOp = genColOp co } + +-- Takes a column operation and chain it with another column operation. +_combineColOp :: ColOp -> ColOp -> Try ColOp +_combineColOp _ (x @ (ColLit _ _)) = pure x +_combineColOp x (ColFunction fn v) = + ColFunction fn <$> sequence (_combineColOp x <$> v) +_combineColOp x (ColExtraction fp) = _extractColOp x (V.toList (unFieldPath fp)) +_combineColOp x (ColStruct v) = + ColStruct <$> sequence (f <$> v) where + f (TransformField n val) = TransformField n <$> _combineColOp x val + +_extractColOp :: ColOp -> [FieldName] -> Try ColOp +_extractColOp x [] = pure x +_extractColOp (ColStruct s) (fn : t) = + case V.find (\x -> tfName x == fn) s of + Just (TransformField _ co) -> + _extractColOp co t + Nothing -> + tryError $ sformat ("Expected to find field "%sh%" in structure "%sh) fn s +_extractColOp x y = + tryError $ sformat ("Cannot perform extraction "%sh%" on column operation "%sh) y x + +_aggKey :: UntypedGroupData -> (UntypedColumnData -> Try UntypedLocalData) -> Try UntypedDataset +_aggKey ugd f = + let inputDt = unSQLType . colType . _valueCol $ ugd + p = placeholder inputDt :: UntypedDataset + startNid = nodeId p in do + uld <- f (_unsafeCastColData (asCol p)) + case _unrollTransform (PipedGroup ugd) startNid (untyped uld) of + PipedError t -> tryError t + PipedGroup g -> + -- This is a programming error + tryError $ sformat ("Expected a dataframe at the output but got a group: "%sh) g + PipedDataset ds -> pure ds + +_unsafeCastColData :: Column ref a -> Column ref' a' +_unsafeCastColData c = c { _cType = _cType c } + +{-| Checks that the group can be cast. +-} +_castGroup :: + SQLType key -> SQLType val -> UntypedGroupData -> Try (GroupData key val) +_castGroup (SQLType keyType) (SQLType valType) ugd = + let keyType' = unSQLType . colType . _keyCol $ ugd + valType' = unSQLType . colType . _valueCol $ ugd in + if keyType == keyType' + then if valType == valType' + then + pure ugd { _gdRef = _gdRef ugd } + else + tryError $ sformat ("The value column (of type "%sh%") cannot be cast to type "%sh) valType' valType + else + tryError $ sformat ("The value column (of type "%sh%") cannot be cast to type "%sh) keyType' keyType + +_untypedGroup :: GroupData key val -> UntypedGroupData +_untypedGroup gd = gd { _gdRef = _gdRef gd } + +_groupByKey :: UntypedColumnData -> UntypedColumnData -> LogicalGroupData +_groupByKey keys vals = + if nodeId (colOrigin keys) == nodeId (colOrigin vals) + then + -- Get the latest data (packed) + -- TODO: put a scoping + let s = struct (keys, vals) :: Column UnknownReference (Cell, Cell) + ds = pack1 s + keys' = ds // _1 + vals' = ds // _2 + in do + gKeys <- _groupCol keys' + gVals <- _groupCol vals' + return GroupData { + _gdRef = colOrigin keys', + _gdKey = gKeys, + _gdValue = gVals + } + else + tryError $ sformat ("The columns have different origin: "%sh%" and "%sh) keys vals + +_groupCol :: Column ref a -> Try GroupColumn +_groupCol c = do + co <- colOpNoBroadcast (colOp c) + return GroupColumn { + _gcType = unSQLType $ colType c, + _gcOp = co, + _gcRefName = Nothing + } diff --git a/src/Spark/Core/Internal/Joins.hs b/src/Spark/Core/Internal/Joins.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Joins.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-| Exposes some of Spark's joining algorithms. +-} +module Spark.Core.Internal.Joins( + join, + join', + joinInner, + joinInner', + joinObs, + joinObs' +) where + +import qualified Data.Aeson as A +import qualified Data.Vector as V +import Control.Arrow + +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.FunctionsInternals +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesFunctions(structTypeFromFields) +import Spark.Core.Try +import Spark.Core.StructuresInternal(unsafeFieldName) + +{-| Standard (inner) join on two sets of data. +-} +join :: Column ref1 key -> Column ref1 value1 -> Column ref2 key -> Column ref2 value2 -> Dataset (key, value1, value2) +join = joinInner + +{-| Untyped version of the standard join. +-} +join' :: DynColumn -> DynColumn -> DynColumn -> DynColumn -> DataFrame +join' = joinInner' + +{-| Explicit inner join. +-} +joinInner :: Column ref1 key -> Column ref1 value1 -> Column ref2 key -> Column ref2 value2 -> Dataset (key, value1, value2) +joinInner key1 val1 key2 val2 = unsafeCastDataset (forceRight df) where + df = joinInner' (untypedCol key1) (untypedCol val1) (untypedCol key2) (untypedCol val2) + +{-| Untyped version of the inner join. +-} +joinInner' :: DynColumn -> DynColumn -> DynColumn -> DynColumn -> DataFrame +joinInner' key1 val1 key2 val2 = do + df1 <- pack' (struct' [key1, val1]) + df2 <- pack' (struct' [key2, val2]) + dt <- _joinTypeInner key1 val1 val2 + let so = StandardOperator { soName = "org.spark.Join", soOutputType = dt, soExtra = A.String "inner" } + let ds = emptyDataset (NodeDistributedOp so) (SQLType dt) + let f ds' = ds' { _cnParents = V.fromList [untyped df1, untyped df2] } + return $ updateNode ds f + +{-| Broadcasts an observable alongside a dataset to make it available as an +extra column. +-} +-- This is the low-level operation that is used to implement the other +-- broadcast operations. +joinObs :: (HasCallStack) => Column ref val -> LocalData val' -> Dataset (val, val') +joinObs c ld = + -- TODO: has a forcing at the last moment so that we can at least + -- have stronger guarantees in the type coercion. + unsafeCastDataset $ forceRight $ joinObs' (untypedCol c) (pure (untypedLocalData ld)) + +{-| Broadcasts an observable along side a dataset to make it available as +an extra column. + +The resulting dataframe has 2 columns: + - one column called 'values' + - one column called 'broadcast' + + Note: this is a low-level operation. Users may want to use broadcastObs instead. +-} +-- TODO: what is the difference with broadcastPair??? +joinObs' :: DynColumn -> LocalFrame -> DataFrame +joinObs' dc lf = do + let df = pack' dc + dc' <- df + c <- asCol' df + o <- lf + st <- structTypeFromFields [(unsafeFieldName "values", unSQLType (colType c)), (unsafeFieldName "broadcast", unSQLType (nodeType o))] + let sqlt = SQLType (StrictType (Struct st)) + return $ emptyDataset NodeBroadcastJoin sqlt `parents` [untyped dc', untyped o] + +_joinTypeInner :: DynColumn -> DynColumn -> DynColumn -> Try DataType +_joinTypeInner kcol col1 col2 = do + cs <- sequence [kcol, col1, col2] + st <- structTypeFromFields $ (colFieldName &&& unSQLType . colType) <$> cs + return $ StrictType (Struct st) diff --git a/src/Spark/Core/Internal/LocalDataFunctions.hs b/src/Spark/Core/Internal/LocalDataFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/LocalDataFunctions.hs @@ -0,0 +1,120 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- A number of functions related to local data. + +module Spark.Core.Internal.LocalDataFunctions( + constant, + iPackTupleObs +) where + +import Data.Aeson(toJSON, Value(Null)) +import qualified Data.Text as T +import qualified Data.List.NonEmpty as N +import Control.Exception.Base(assert) + +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesGenerics(SQLTypeable, buildType) +import Spark.Core.Row + +constant :: (ToSQL a, SQLTypeable a) => a -> LocalData a +constant cst = + let + sqlt = buildType + dt = unSQLType sqlt + in emptyLocalData (NodeLocalLit dt (toJSON (valueToCell cst))) sqlt + +{-| (developer API) + +This function takes a non-empty list of observables and puts them +into a structure. The names of each element is _0 ... _(n-1) +-} +iPackTupleObs :: N.NonEmpty UntypedLocalData -> UntypedLocalData +iPackTupleObs ulds = + let dt = structTypeTuple' (unSQLType . nodeType <$> ulds) + so = StandardOperator { + soName = "org.spark.LocalPack", + soOutputType = dt, + soExtra = Null } + op = NodeLocalOp so + in emptyLocalData op (SQLType dt) + `parents` (untyped <$> N.toList ulds) + +instance (Num a, ToSQL a, SQLTypeable a) => Num (LocalData a) where + -- TODO: convert all that to use column operations + (+) = _binOp "org.spark.LocalPlus" + (-) = _binOp "org.spark.LocalMinus" + (*) = _binOp "org.spark.LocalMult" + abs = _unaryOp "org.spark.LocalAbs" + signum = _unaryOp "org.spark.LocalSignum" + fromInteger x = constant (fromInteger x :: a) + negate = _unaryOp "org.spark.LocalNegate" + +instance forall a. (ToSQL a, Enum a, SQLTypeable a) => Enum (LocalData a) where + toEnum x = constant (toEnum x :: a) + fromEnum = failure "Cannot use fromEnum against a local data object" + -- TODO(kps) some of the others are still available for implementation + +instance (Num a, Ord a) => Ord (LocalData a) where + compare = failure "You cannot compare instances of LocalData. (yet)." + min = _binOp "org.spark.LocalMin" + max = _binOp "org.spark.LocalMax" + +instance forall a. (Real a, ToSQL a, SQLTypeable a) => Real (LocalData a) where + toRational = failure "Cannot convert LocalData to rational" + +instance (ToSQL a, Integral a, SQLTypeable a) => Integral (LocalData a) where + quot = _binOp "org.spark.LocalQuotient" + rem = _binOp "org.spark.LocalReminder" + div = _binOp "org.spark.LocalDiv" + mod = _binOp "org.spark.LocalMod" + quotRem = failure "quotRem is not implemented (yet). Use quot and rem." + divMod = failure "divMod is not implemented (yet). Use div and mod." + toInteger = failure "Cannot convert LocalData to integer" + +instance (ToSQL a, SQLTypeable a, Fractional a) => Fractional (LocalData a) where + fromRational x = constant (fromRational x :: a) + (/) = _binOp "org.spark.LocalDiv" + + +_unaryOp :: T.Text -> LocalData a -> LocalData a +_unaryOp optxt ld = + let so = StandardOperator { + soName = optxt, + soOutputType = unSQLType $ nodeType ld, + soExtra = Null } + op = NodeLocalOp so in + emptyLocalData op (nodeType ld) + `parents` [untyped ld] + +_binOp :: T.Text -> LocalData a -> LocalData a -> LocalData a +_binOp optxt ld1 ld2 = assert (nodeType ld1 == nodeType ld2) $ + let so = StandardOperator { + soName = optxt, + soOutputType = unSQLType $ nodeType ld1, + soExtra = Null } + op = NodeLocalOp so in + emptyLocalData op (nodeType ld1) + `parents` [untyped ld1, untyped ld2] + +-- TODO(kps) more input tests +_binOp' :: StandardOperator -> LocalData a -> LocalData a -> LocalData a +_binOp' so ld1 ld2 = assert (nodeType ld1 == nodeType ld2) $ + let op = NodeLocalOp so in + emptyLocalData op (nodeType ld1) + `parents` [untyped ld1, untyped ld2] + +_intOperator :: T.Text -> StandardOperator +_intOperator optxt = StandardOperator { + soName = optxt, + soOutputType = intType, + soExtra = Null +} diff --git a/src/Spark/Core/Internal/LocatedBase.hs b/src/Spark/Core/Internal/LocatedBase.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/LocatedBase.hs @@ -0,0 +1,51 @@ +-- Taken from https://hackage.haskell.org/package/located-base-0.1.1.0/docs/src/GHC-Err-Located.html + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +module Spark.Core.Internal.LocatedBase (error, undefined, HasCallStack, showCallStack) where + +#if __GLASGOW_HASKELL__ < 800 + +import GHC.SrcLoc +import GHC.Stack (CallStack, getCallStack) +import Prelude hiding (error, undefined) +import qualified Prelude +import Text.Printf +import Data.Text(Text, unpack) + +type HasCallStack = (?callStack :: CallStack) + +error :: HasCallStack => Text -> a +error msg = Prelude.error (unpack msg ++ "\n" ++ showCallStack ?callStack) + +undefined :: HasCallStack => a +undefined = error "Prelude.undefined" + +showCallStack :: CallStack -> String +showCallStack stk = case getCallStack stk of + _:locs -> unlines $ "Callstack:" : map format locs + _ -> Prelude.error "showCallStack: empty call-stack" + where + format (fn, loc) = printf " %s, called at %s" fn (showSrcLoc loc) + +#else + +import GHC.Stack(HasCallStack, CallStack, prettyCallStack) +import qualified GHC.Stack() +import Data.Text(Text, unpack) +import qualified Prelude +import Prelude((.)) + +{-# DEPRECATED showCallStack "use GHC.Stack.prettyCallStack instead" #-} +showCallStack :: CallStack -> Prelude.String +showCallStack = prettyCallStack + +error :: HasCallStack => Text -> a +error = Prelude.error . unpack + +undefined :: HasCallStack => a +undefined = error "Prelude.undefined" + +#endif diff --git a/src/Spark/Core/Internal/ObservableStandard.hs b/src/Spark/Core/Internal/ObservableStandard.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/ObservableStandard.hs @@ -0,0 +1,13 @@ + +module Spark.Core.Internal.ObservableStandard( + asDouble) where + +import Spark.Core.Internal.ColumnStandard +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.FunctionsInternals +import Spark.Core.Internal.TypesGenerics(SQLTypeable) + +{-| Casts a local data as a double. +-} +asDouble :: (Num a, SQLTypeable a) => LocalData a -> LocalData Double +asDouble = projectColFunction asDoubleCol diff --git a/src/Spark/Core/Internal/OpFunctions.hs b/src/Spark/Core/Internal/OpFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/OpFunctions.hs @@ -0,0 +1,235 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + + +module Spark.Core.Internal.OpFunctions( + simpleShowOp, + prettyShowOp, + extraNodeOpData, + hashUpdateNodeOp, + prettyShowColOp, + hdfsPath, + updateSourceStamp, + prettyShowColFun +) where + +import qualified Data.Text as T +import qualified Data.Aeson as A +import qualified Data.Vector as V +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import Data.Text(Text) +import Data.Aeson((.=), toJSON) +import Data.Char(isSymbol) +import qualified Crypto.Hash.SHA256 as SHA + +import Spark.Core.Internal.OpStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Try + +-- (internal) +-- The serialized type of a node operation, as written in +-- the JSON description. +simpleShowOp :: NodeOp -> T.Text +simpleShowOp (NodeLocalOp op) = soName op +simpleShowOp (NodeDistributedOp op) = soName op +simpleShowOp (NodeLocalLit _ _) = "org.spark.LocalLiteral" +simpleShowOp (NodeOpaqueAggregator op) = soName op +simpleShowOp (NodeAggregatorReduction ua) = + _jsonShowAggTrans . uaoInitialOuter $ ua +simpleShowOp (NodeAggregatorLocalReduction ua) = _jsonShowSGO . uaoMergeBuffer $ ua +simpleShowOp (NodeStructuredTransform _) = "org.spark.Select" +simpleShowOp (NodeDistributedLit _ _) = "org.spark.DistributedLiteral" +simpleShowOp (NodeGroupedReduction _) = "org.spark.GroupedReduction" +simpleShowOp (NodeReduction _) = "org.spark.Reduction" +simpleShowOp NodeBroadcastJoin = "org.spark.BroadcastJoin" +simpleShowOp (NodePointer _) = "org.spark.PlaceholderCache" + +{-| A text representation of the operation that is appealing for humans. +-} +prettyShowOp :: NodeOp -> T.Text +prettyShowOp (NodeAggregatorReduction uao) = + case uaoInitialOuter uao of + OpaqueAggTransform so -> soName so + -- Try to have a pretty name for the simple reductions + InnerAggOp (AggFunction n _) -> n + _ -> simpleShowOp (NodeAggregatorReduction uao) +prettyShowOp x = simpleShowOp x + + +-- A human-readable string that represents column operations. +prettyShowColOp :: ColOp -> T.Text +prettyShowColOp (ColExtraction fpath) = T.pack (show fpath) +prettyShowColOp (ColFunction txt cols) = + prettyShowColFun txt (V.toList (prettyShowColOp <$> cols)) +prettyShowColOp (ColLit _ cell) = show' cell +prettyShowColOp (ColStruct s) = + "struct(" <> T.intercalate "," (prettyShowColOp . tfValue <$> V.toList s) <> ")" + +{-| If the node is a reading operation, returns the HdfsPath of the source +that is going to be read. +-} +hdfsPath :: NodeOp -> Maybe HdfsPath +hdfsPath (NodeDistributedOp so) = + if soName so == "org.spark.GenericDatasource" + then case soExtra so of + A.Object o -> case HM.lookup "inputPath" o of + Just (A.String x) -> Just . HdfsPath $ x + _ -> Nothing + _ -> Nothing + else Nothing +hdfsPath _ = Nothing + +{-| Updates the input stamp if possible. + +If the node cannot be updated, it is most likely a programming error: an error +is returned. +-} +updateSourceStamp :: NodeOp -> DataInputStamp -> Try NodeOp +updateSourceStamp (NodeDistributedOp so) (DataInputStamp dis) | soName so == "org.spark.GenericDatasource" = + case soExtra so of + A.Object o -> + let extra' = A.Object $ HM.insert "inputStamp" (A.toJSON dis) o + so' = so { soExtra = extra' } + in pure $ NodeDistributedOp so' + x -> tryError $ "updateSourceStamp: Expected dict, got " <> show' x +updateSourceStamp x _ = + tryError $ "updateSourceStamp: Expected NodeDistributedOp, got " <> show' x + +_jsonShowAggTrans :: AggTransform -> Text +_jsonShowAggTrans (OpaqueAggTransform op) = soName op +_jsonShowAggTrans (InnerAggOp _) = "org.spark.StructuredReduction" + + +_jsonShowSGO :: SemiGroupOperator -> Text +_jsonShowSGO (OpaqueSemiGroupLaw so) = soName so +_jsonShowSGO (UdafSemiGroupOperator ucn) = ucn +_jsonShowSGO (ColumnSemiGroupLaw sfn) = sfn + + +_prettyShowAggOp :: AggOp -> T.Text +_prettyShowAggOp (AggUdaf _ ucn fp) = ucn <> "(" <> show' fp <> ")" +_prettyShowAggOp (AggFunction sfn v) = prettyShowColFun sfn r where + r = V.toList (show' <$> v) +_prettyShowAggOp (AggStruct v) = + "struct(" <> T.intercalate "," (_prettyShowAggOp . afValue <$> V.toList v) <> ")" + +_prettyShowAggTrans :: AggTransform -> Text +_prettyShowAggTrans (OpaqueAggTransform op) = soName op +_prettyShowAggTrans (InnerAggOp ao) = _prettyShowAggOp ao + +_prettyShowSGO :: SemiGroupOperator -> Text +_prettyShowSGO (OpaqueSemiGroupLaw so) = soName so +_prettyShowSGO (UdafSemiGroupOperator ucn) = ucn +_prettyShowSGO (ColumnSemiGroupLaw sfn) = sfn + +-- (internal) +-- The extra data associated with the operation, and that is required +-- by the backend to successfully perform the operation. +-- We pass the type as seen by Karps (along with some extra information about +-- nullability). This information is required by spark to analyze the exact +-- type of some operations. +extraNodeOpData :: NodeOp -> A.Value +extraNodeOpData (NodeLocalLit dt cell) = + A.object [ "type" .= toJSON dt, + "content" .= toJSON cell] +extraNodeOpData (NodeStructuredTransform st) = toJSON st +extraNodeOpData (NodeDistributedLit dt lst) = + -- The backend deals with all the details translating the augmented type + -- as a SQL datatype. + A.object [ "cellType" .= toJSON dt, + "content" .= toJSON lst] +extraNodeOpData (NodeDistributedOp so) = soExtra so +extraNodeOpData (NodeGroupedReduction ao) = toJSON ao +extraNodeOpData (NodeAggregatorReduction ua) = + case uaoInitialOuter ua of + OpaqueAggTransform so -> toJSON (soExtra so) + InnerAggOp ao -> toJSON ao +extraNodeOpData (NodeOpaqueAggregator so) = soExtra so +extraNodeOpData (NodeLocalOp so) = soExtra so +extraNodeOpData NodeBroadcastJoin = A.Null +extraNodeOpData (NodeReduction _) = A.Null -- TODO: should it send something? +extraNodeOpData (NodeAggregatorLocalReduction _) = A.Null -- TODO: should it send something? +extraNodeOpData (NodePointer p) = + A.object [ + "computation" .= toJSON (pointerComputation p), + "path" .= toJSON (pointerPath p) + ] + +-- Adds the content of a node op to a hash. +-- Right now, this builds the json representation and passes it +-- to the hash function, which simplifies the verification on +-- on the server side. +-- TODO: this depends on some implementation details such as the hashing +-- function used by Aeson. +hashUpdateNodeOp :: SHA.Ctx -> NodeOp -> SHA.Ctx +hashUpdateNodeOp ctx op = _hashUpdateJson ctx $ A.object [ + "op" .= simpleShowOp op, + "extra" .= extraNodeOpData op] + + +prettyShowColFun :: T.Text -> [Text] -> T.Text +prettyShowColFun txt [col] | _isSym txt = + T.concat [txt, " ", col] +prettyShowColFun txt [col1, col2] | _isSym txt = + -- This is not perfect for complex operations, but it should get the job done + -- for now. + -- TODO eventually use operator priority here + T.concat [col1, " ", txt, " ", col2] +prettyShowColFun txt cols = + let vals = T.intercalate ", " cols in + T.concat [txt, "(", vals, ")"] + +_isSym :: T.Text -> Bool +_isSym txt = all isSymbol (T.unpack txt) + +-- This schema is not great because there is some ambiguity about the final +-- nodes. +-- Someone could craft a JSON that would confuse the object detection. +-- Not sure if this is much of a security risk anyway. +instance A.ToJSON ColOp where + toJSON (ColExtraction fp) = A.object [ + "colOp" .= T.pack "extraction", + "field" .= toJSON fp] + toJSON (ColFunction txt cols) = A.object [ + "colOp" .= T.pack "fun", + "function" .= txt, + "args" .= (toJSON <$> cols)] + toJSON (ColLit _ cell) = A.object [ + "colOp" .= T.pack "literal", + "lit" .= toJSON cell] + toJSON (ColStruct v) = + let fun (TransformField fn colOp) = + A.object ["name" .= T.pack (show fn), "op" .= toJSON colOp] + in A.Array $ fun <$> v + +-- instance A.ToJSON AggTransform where +-- toJSON (OpaqueAggTransform so) = A.object [ +-- "aggOpaqueTrans" .= toJSON so +-- ] + +instance A.ToJSON UdafApplication where + toJSON Algebraic = toJSON (T.pack "algebraic") + toJSON Complete = toJSON (T.pack "complete") + +instance A.ToJSON AggField where + toJSON (AggField fn aggOp) = + A.object ["name" .= show' fn, "op" .= toJSON aggOp] + +instance A.ToJSON AggOp where + toJSON (AggUdaf ua ucn fp) = A.object [ + "aggOp" .= T.pack "udaf", + "udafApplication" .= toJSON ua, + "className" .= ucn, + "field" .= toJSON fp] + toJSON (AggFunction sfn v) = A.object [ + "aggOp" .= toJSON (T.pack "function"), + "functionName" .= toJSON sfn, + "fields" .= toJSON (V.toList v)] + toJSON (AggStruct v) = toJSON (V.toList v) + +_hashUpdateJson :: SHA.Ctx -> A.Value -> SHA.Ctx +_hashUpdateJson ctx val = SHA.update ctx bs where + bs = BS.concat . LBS.toChunks . encodeDeterministicPretty $ val diff --git a/src/Spark/Core/Internal/OpStructures.hs b/src/Spark/Core/Internal/OpStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/OpStructures.hs @@ -0,0 +1,296 @@ +{-| +A description of the operations that can be performed on +nodes and columns. +-} +module Spark.Core.Internal.OpStructures where + +import Data.Text as T +import Data.Aeson(Value, Value(Null), FromJSON, ToJSON, toJSON) +import Data.Aeson.Types(typeMismatch) +import qualified Data.Aeson as A +import Data.Vector(Vector) + +import Spark.Core.StructuresInternal +import Spark.Core.Internal.TypesStructures(DataType, SQLType, SQLType(unSQLType)) + +{-| The name of a SQL function. + +It is one of the predefined SQL functions available in Spark. +-} +type SqlFunctionName = T.Text + +{-| The classpath of a UDAF. +-} +type UdafClassName = T.Text + +{-| The name of an operator defined in Karps. +-} +type OperatorName = T.Text + +{-| A path in the Hadoop File System (HDFS). + +These paths are usually not created by the user directly. +-} +data HdfsPath = HdfsPath Text deriving (Eq, Show, Ord) + +{-| A stamp that defines some notion of uniqueness of the data source. + +The general contract is that: + - stamps can be extracted fast (no need to scan the whole dataset) + - if the data gets changed, the stamp will change. + +Stamps are used for performing aggressing operation caching, so it is better +to conservatively update stamps if one is unsure about the freshness of the +dataset. For regular files, stamps are computed using the file system time +stamps. +-} +data DataInputStamp = DataInputStamp Text deriving (Eq, Show) + + +{-| The invariant respected by a transform. + +Depending on the value of the invariant, different optimizations +may be available. +-} +data TransformInvariant = + -- | This operator has no special property. It may depend on + -- the partitioning layout, the number of partitions, the order + -- of elements in the partitions, etc. + -- This sort of operator is unwelcome in Karps... + Opaque + -- | This operator respects the canonical partition order, but may + -- not have the same number of elements. + -- For example, this could be a flatMap on an RDD (filter, etc.). + -- This operator can be used locally with the signature a -> [a] + | PartitioningInvariant + -- | The strongest invariant. It respects the canonical partition order + -- and it outputs the same number of elements. + -- This is typically a map. + -- This operator can be used locally with the signature a -> a + | DirectPartitioningInvariant + + +-- | The dynamic value of locality. +-- There is still a tag on it, but it can be easily dropped. +data Locality = + -- | The data associated to this node is local. It can be materialized + -- and accessed by the user. + Local + -- | The data associated to this node is distributed or not accessible + -- locally. It cannot be accessed by the user. + | Distributed deriving (Show, Eq) + +-- ********* PHYSICAL OPERATORS *********** +-- These structures declare some operations that correspond to operations found +-- in Spark itself, or in the surrounding libraries. + +-- | An operator defined by default in the release of Karps. +-- All other physical operators can be converted to a standard operators. +data StandardOperator = StandardOperator { + soName :: !OperatorName, + soOutputType :: !DataType, + soExtra :: !Value +} deriving (Eq, Show) + +-- | A scala method of a singleton object. +data ScalaStaticFunctionApplication = ScalaStaticFunctionApplication { + sfaObjectName :: !T.Text, + sfaMethodName :: !T.Text + -- TODO add the input and output types? +} + + +-- | The different kinds of column operations that are understood by the +-- backend. +-- +-- These operations describe the physical operations on columns as supported +-- by Spark SQL. They can operate on column -> column, column -> row, row->row. +-- Of course, not all operators are valid for each configuration. +data ColOp = + -- | A projection onto a single column + -- An extraction is always direct. + ColExtraction !FieldPath + -- | A function of other columns. + -- In this case, the other columns may matter + -- TODO(kps) add if this function is partition invariant. + -- It should be the case most of the time. + | ColFunction !SqlFunctionName !(Vector ColOp) + -- | A constant defined for each element. + -- The type should be the same as for the column + -- A literal is always direct + | ColLit !DataType !Value + -- | A structure. + | ColStruct !(Vector TransformField) + deriving (Eq, Show) + +-- | A field in a structure. +data TransformField = TransformField { + tfName :: !FieldName, + tfValue :: !ColOp +} deriving (Eq, Show) + +-- | The content of a structured transform. +data StructuredTransform = + InnerOp !ColOp + | InnerStruct !(Vector TransformField) + deriving (Eq, Show) + +{-| When applying a UDAF, determines if it should only perform the algebraic +portion of the UDAF (initialize+update+merge), or if it also performs the final, +non-algebraic step. +-} +data UdafApplication = Algebraic | Complete deriving (Eq, Show) + +data AggOp = + -- The name of the UDAF and the field path to apply it onto. + AggUdaf !UdafApplication !UdafClassName !FieldPath + -- A column function that can be applied (sum, max, etc.) + | AggFunction !SqlFunctionName !(Vector FieldPath) + | AggStruct !(Vector AggField) + deriving (Eq, Show) + +{-| A field in the resulting aggregation transform. +-} +data AggField = AggField { + afName :: !FieldName, + afValue :: !AggOp +} deriving (Eq, Show) + +{-| +-} +data AggTransform = + OpaqueAggTransform !StandardOperator + | InnerAggOp !AggOp deriving (Eq, Show) + +{-| The representation of a semi-group law in Spark. + +This is the basic law used in universal aggregators. It is a function on +observables that must respect the following laws: + +f :: X -> X -> X +commutative +associative + +A neutral element is not required for the semi-group laws. However, if used in +the context of a universal aggregator, such an element implicitly exists and +corresponds to the empty dataset. +-} +data SemiGroupOperator = + -- | A standard operator that happens to respect the semi-group laws. + OpaqueSemiGroupLaw !StandardOperator + -- | The merging portion of a UDAF + | UdafSemiGroupOperator !UdafClassName + -- | A SQL operator that happens to respect the semi-group laws. + | ColumnSemiGroupLaw !SqlFunctionName deriving (Eq, Show) + +-- ********* DATASET OPERATORS ************ +-- These describe Dataset -> Dataset transforms. + + +data DatasetTransformDesc = + DSScalaStaticFunction !ScalaStaticFunctionApplication + | DSStructuredTransform !ColOp + | DSOperator !StandardOperator + + +-- ****** OBSERVABLE OPERATORS ******* +-- These operators describe Observable -> Observable transforms + +-- **** AGGREGATION OPERATORS ***** +-- The different types of aggregators + +-- The low-level description of a +-- The name of the aggregator is the name of the +-- Dataset -> Local data transform +data UniversalAggregatorOp = UniversalAggregatorOp { + uaoMergeType :: !DataType, + uaoInitialOuter :: !AggTransform, + uaoMergeBuffer :: !SemiGroupOperator +} deriving (Eq, Show) + + +data NodeOp2 = + -- empty -> local + NodeLocalLiteral !DataType !Value + -- empty -> distributed + | NodeDistributedLiteral !DataType !(Vector Value) + -- distributed -> local + | NodeStructuredAggregation !AggOp !(Maybe UniversalAggregatorOp) + -- distributed -> distributed or local -> local + | NodeStructuredTransform2 !Locality !ColOp + -- [distributed, local] -> [local, distributed] opaque + | NodeOpaqueTransform !Locality StandardOperator + deriving (Eq, Show) + +{-| A pointer to a node that is assumed to be already computed. +-} +data Pointer = Pointer { + pointerComputation :: !ComputationID, + pointerPath :: !NodePath +} deriving (Eq, Show) + +{- +A node operation. +A description of all the operations between nodes. +These are the low-level, physical operations that Spark implements. + +Each node operation is associated with: + - a locality + - an operation name (implicit or explicit) + - a data type + - a representation in JSON + +Additionally, some operations are associated with algebraic invariants +to enable programmatic transformations. +-} +-- TODO: way too many different ops. Restructure into a few fundamental ops with +-- options. +data NodeOp = + -- | An operation between local nodes: [Observable] -> Observable + NodeLocalOp StandardOperator + -- | An observable literal + | NodeLocalLit !DataType !Value + -- | A special join that broadcasts a value along a dataset. + | NodeBroadcastJoin + -- | Some aggregator that does not respect any particular invariant. + | NodeOpaqueAggregator StandardOperator + -- It implicicty expects a dataframe with 2 fields: + -- - the first field is used as a key + -- - the second field is passed to the reducer + | NodeGroupedReduction !AggOp + | NodeReduction !AggTransform + -- TODO: remove these + -- | A universal aggregator. + | NodeAggregatorReduction UniversalAggregatorOp + | NodeAggregatorLocalReduction UniversalAggregatorOp + -- | A structured transform, performed either on a local node or a + -- distributed node. + | NodeStructuredTransform !ColOp + -- | A distributed dataset (with no partition information) + | NodeDistributedLit !DataType !(Vector Value) + -- | An opaque distributed operator. + | NodeDistributedOp StandardOperator + | NodePointer Pointer + deriving (Eq, Show) + +-- | Makes a standard operator with no extra value +makeOperator :: T.Text -> SQLType a -> StandardOperator +makeOperator txt sqlt = + StandardOperator { + soName = txt, + soOutputType = unSQLType sqlt, + soExtra = Null } + +instance ToJSON HdfsPath where + toJSON (HdfsPath p) = toJSON p + +instance ToJSON DataInputStamp where + toJSON (DataInputStamp p) = toJSON p + +instance FromJSON HdfsPath where + parseJSON (A.String p) = return (HdfsPath p) + parseJSON x = typeMismatch "HdfsPath" x + +instance FromJSON DataInputStamp where + parseJSON (A.String p) = return (DataInputStamp p) + parseJSON x = typeMismatch "DataInputStamp" x diff --git a/src/Spark/Core/Internal/Paths.hs b/src/Spark/Core/Internal/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Paths.hs @@ -0,0 +1,184 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Spark.Core.Internal.Paths( + HasNodeName(..), + PathEdge(..), + computePaths, + assignPaths', + -- For testing: + Scopes, + ParentSplit(..), + mergeScopes, + gatherPaths, + iGetScopes0, +) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Vector as V +import Data.List(sort) +import Data.Maybe(fromMaybe, catMaybes) +import Data.Foldable(foldr', foldl', toList) +import Formatting + +import Spark.Core.Try +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.ComputeDag +import Spark.Core.StructuresInternal + +class HasNodeName v where + -- Retrieves the name of the node + getNodeName :: v -> NodeName + -- Assigns a path to the node + assignPath :: v -> NodePath -> v + +{-| The types of edges for the calculation of paths. + - same level parent -> the node should have the same prefix as its parents + - inner edge -> the parent defines the scope of this node + -} +data PathEdge = SameLevelEdge | InnerEdge deriving (Show, Eq) + +-- Assigns paths in a graph. +-- +computePaths :: (HasNodeName v) => + ComputeDag v PathEdge -> Try (M.Map VertexId NodePath) +computePaths cd = + let nodecg = mapVertexData getNodeName cd + in _computePaths nodecg + +assignPaths' :: (HasNodeName v) => + M.Map VertexId NodePath -> ComputeDag v e -> ComputeDag v e +assignPaths' m cd = + let f vx = + let old = NodePath . V.singleton $ getNodeName (vertexData vx) + new = M.findWithDefault old (vertexId vx) m + in assignPath (vertexData vx) new + in mapVertices f cd + +-- The main function to perform the pass assignments. +-- It starts from the graph of dependencies and from the local name info, +-- and computes the complete paths (if possible), starting from the fringe. +_computePaths :: ComputeDag NodeName PathEdge -> Try (M.Map VertexId NodePath) +_computePaths cg = + let + scopes = iGetScopes0 (toList . cdOutputs $ cg) (_splitParents' (cdEdges cg)) + paths = gatherPaths scopes + nodeNames = M.fromList [(vertexId vx, vertexData vx)| vx <- toList . cdVertices $ cg] + lookup' nid = M.lookup nid nodeNames + f :: VertexId -> [[VertexId]] -> Try NodePath + f nid ls = case ls of + [l] -> + return . NodePath . V.fromList . catMaybes $ lookup' <$> (l ++ [nid]) + x -> + tryError $ sformat ("Node has too many paths: node="%shown%" discovered paths ="%shown) nid x + nodePaths = M.traverseWithKey f paths + in nodePaths + +-- (private) +-- The top-level scope may not have an ID associated to it +type Scopes = M.Map (Maybe VertexId) (S.Set VertexId) + + +-- (internal) +-- The separation of parents into logical and inner parents +data ParentSplit a = ParentSplit { + psLogical :: ![Vertex a], + psInner :: ![Vertex a] +} deriving (Show) + +_lookupOrEmpty :: Scopes -> Maybe VertexId -> [VertexId] +_lookupOrEmpty scopes mnid = + S.toList $ fromMaybe S.empty (M.lookup mnid scopes) + +mergeScopes :: Scopes -> Scopes -> Scopes +mergeScopes = M.unionWith S.union + +_singleScope :: Maybe VertexId -> VertexId -> Scopes +_singleScope mKey nid = M.singleton mKey (S.singleton nid) + +-- For each node, finds the one, or more than one if possible, path(s) +-- from the root to the node (which is itself not included at the end) +-- The gathering of paths may not be exaustive. +gatherPaths :: Scopes -> M.Map VertexId [[VertexId]] +gatherPaths scopes = M.map sort $ _gatherPaths0 scopes start where + start = _lookupOrEmpty scopes Nothing + +_gatherPaths0 :: Scopes -> [VertexId] -> M.Map VertexId [[VertexId]] +_gatherPaths0 _ [] = M.empty +_gatherPaths0 scopes (nid : t) = + let + inner = _lookupOrEmpty scopes (Just nid) + innerPaths = _gatherPaths0 scopes inner + innerWithHead = M.map (\l -> (nid : ) <$> l) innerPaths + thisPaths = M.singleton nid [[]] + innerPaths2 = M.unionWith (++) innerWithHead thisPaths + in M.unionWith (++) innerPaths2 (_gatherPaths0 scopes t) + + +iGetScopes0 :: forall a. (Show a) => + [Vertex a] -> + (Vertex a -> ParentSplit a) -> + Scopes +iGetScopes0 [] _splitter = M.empty +iGetScopes0 (h : t) splitter = + let + startScope = _singleScope Nothing (vertexId h) + folder :: Scopes -> Vertex a -> Scopes + folder current un = + if M.member (Just (vertexId un)) current then + current + else + let split = _getScopes' splitter Nothing S.empty un current + in mergeScopes split current + -- Important here to use a left folder, as we want to start with the head + -- and move down the list. + in foldl' folder startScope (h : t) + +_splitParents' :: AdjacencyMap v PathEdge -> Vertex v -> ParentSplit v +_splitParents' m vx = + let ves = V.toList $ M.findWithDefault V.empty (vertexId vx) m + scope = [veEndVertex ve | ve <- ves, edgeData (veEdge ve) == SameLevelEdge] + parents' = [veEndVertex ve | ve <- ves, edgeData (veEdge ve) == InnerEdge] + in ParentSplit { psLogical = scope, psInner = parents' } + + +-- TODO(kps) this recursive code is most probably going to explode for deep stacks +_getScopes' :: forall a. (Show a) => + (Vertex a -> ParentSplit a) -> -- The expansion of a node into logical and inner nodes + Maybe VertexId -> -- the current parent (if any) + S.Set VertexId -> -- the current boundary to respect + Vertex a -> -- the current node to expand + Scopes -> -- the scopes seen so far + Scopes +_getScopes' splitter mScopeId boundary un scopes = + if S.member (vertexId un) boundary then + scopes + else + let + split = splitter un + logParents = psLogical split + innerParents = psInner split + -- A fold on the parents + parF :: Vertex a -> Scopes -> Scopes + parF = + -- Same boundary and parent, but update the scopes + _getScopes' splitter mScopeId boundary + scopesPar = foldr' parF scopes logParents + -- Now work on the inner nodes: + vid = vertexId un + boundary' = S.fromList (vertexId <$> logParents) + inF :: Vertex a -> Scopes -> Scopes + inF = + -- parent is current, boundary is current logical + _getScopes' splitter (Just vid) boundary' + scopesIn = foldr' inF scopesPar innerParents + scopesFinal = scopesIn + `mergeScopes` _singleScope mScopeId vid + `mergeScopes` M.singleton (Just vid) S.empty + in scopesFinal diff --git a/src/Spark/Core/Internal/PathsUntyped.hs b/src/Spark/Core/Internal/PathsUntyped.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/PathsUntyped.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.Internal.PathsUntyped( + assignPathsUntyped, + tieNodes +) where + +import qualified Data.Vector as V +import qualified Data.Map.Strict as M +import Data.Maybe(fromMaybe) +import Data.Foldable(toList) +import Data.List(nub) +import Control.Arrow((&&&)) +import Formatting +import Control.Monad.Identity + +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.ComputeDag +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.Paths +import Spark.Core.Internal.Utilities +import Spark.Core.Try +import Spark.Core.StructuresInternal(unNodeId) + +instance GraphVertexOperations UntypedNode where + vertexToId = VertexId . unNodeId . nodeId + expandVertexAsVertices n = + nodeParents n + ++ fromMaybe [] (nodeLogicalParents n) + ++ nodeLogicalDependencies n + +instance GraphOperations UntypedNode NodeEdge where + expandVertex n = + -- The logical parents are more important than the parents + let + -- If the logical parents are not specified, the logical parents are the + -- direct parents. + scopeNodes = fromMaybe (nodeParents n) (nodeLogicalParents n) + loParents = [(ScopeEdge, v) | v <- scopeNodes] + -- The direct parents. They may overload with the scoping parents, but + -- this will be checked during the name analysis. + parents' = (const (DataStructureEdge ParentEdge) &&& id) <$> nodeParents n + loDeps = (const (DataStructureEdge LogicalEdge) &&& id) <$> nodeLogicalDependencies n + in loParents ++ parents' ++ loDeps + +instance HasNodeName UntypedNode where + getNodeName = nodeName + assignPath n p = updateNode n $ \n' -> n' { _cnPath = p } + + +-- Stitches the nodes together to make sure that the edges in the graph also +-- correspond to the dependencies in the nodes themselves. +-- This does not update the nodeIds +-- This must happen before the pruning is performed, otherwise the node IDs will +-- not match. +tieNodes :: ComputeDag UntypedNode StructureEdge -> ComputeDag UntypedNode StructureEdge +tieNodes cd = + let g = computeGraphToGraph cd + f :: UntypedNode -> [(UntypedNode, StructureEdge)] -> Identity UntypedNode + f v l = + let parents' = V.fromList [n | (n, e) <- l, e == ParentEdge] + logDeps = V.fromList [n | (n, e) <- l, e == LogicalEdge] + res = updateNode v $ \n -> n { + _cnParents = parents', + _cnLogicalDeps = logDeps, + _cnLogicalParents = Nothing } + in return res + g2 = runIdentity $ graphMapVertices g f + in graphToComputeGraph g2 + +-- Assigs the paths, and drops the scoping edges. +assignPathsUntyped :: (HasCallStack) => + ComputeDag UntypedNode NodeEdge -> Try (ComputeDag UntypedNode StructureEdge) +assignPathsUntyped cd = do + let pathCGraph = _getPathCDag cd + paths <- computePaths pathCGraph + let g = computeGraphToGraph $ assignPaths' paths cd + let f ScopeEdge = [] + f (DataStructureEdge x) = [x] + let g' = graphFlatMapEdges g f + return $ graphToComputeGraph g' + + +-- transforms node edges into path edges +_cleanEdges :: (HasCallStack) => [VertexEdge NodeEdge v] -> [VertexEdge PathEdge v] +_cleanEdges [] = [] +_cleanEdges (h : t) = + let vid = vertexId (veEndVertex h) + others = [ve | ve <- t, (vertexId . veEndVertex $ ve) /= vid] + sames = [ve | ve <- t, (vertexId . veEndVertex $ ve) == vid] + rest = _cleanEdges others + e = veEdge h + -- If there multiple edges between nodes, they are dropped. + -- This distinction is not required for names. + eData = nub $ edgeData . veEdge <$> (h : sames) + eData' = case eData of + [DataStructureEdge ParentEdge] -> Just InnerEdge + [DataStructureEdge ParentEdge, ScopeEdge] -> Just SameLevelEdge + [ScopeEdge, DataStructureEdge ParentEdge] -> Just SameLevelEdge + [ScopeEdge] -> Just SameLevelEdge + [DataStructureEdge LogicalEdge] -> Nothing + l -> failure (sformat ("Could not understand combination "%shown) l) + res = case eData' of + Just v -> (h { veEdge = e { edgeData = v } }) : rest + Nothing -> rest + in res + + +_getPathCDag :: (HasCallStack) => ComputeDag v NodeEdge -> ComputeDag v PathEdge +_getPathCDag cd = + let adj' = M.map (V.fromList . _cleanEdges . toList) (cdEdges cd) + in cd { cdEdges = adj' } diff --git a/src/Spark/Core/Internal/Projections.hs b/src/Spark/Core/Internal/Projections.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Projections.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +-- {-# LANGUAGE UndecidableInstances #-} + +-- TODO(kps): this module stretches my understanding of Haskell. +-- There is probably better than that. + +{-| Defines some projections operations over dataframes, observables, and +columns. This allows users for a fairly natural manipulation of +data. + +-} +module Spark.Core.Internal.Projections( + ProjectReturn, + Project, + (//), + (/-), + _1, + _2, + -- * Developer functions + StaticColProjection(..), + DynamicColProjection, + unsafeStaticProjection, + dynamicProjection, +) where + +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Maybe(fromMaybe) +import Formatting +import Data.Text(Text) + +import Spark.Core.Try +import Spark.Core.StructuresInternal +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.ColumnFunctions +import Spark.Core.Internal.ColumnStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities + + +{-| The class of static projections that are guaranteed to succeed +by using the type system. + +from is the type of the dataset (which is also a typed dataset) +to is the type of the final column. +-} +data StaticColProjection from to = StaticColProjection { + _staticProj :: SQLType from -> Try (FieldPath, SQLType to) +} + +{-| The class of projections that require some runtime introspection +to confirm that the projection is valid. +-} +data DynamicColProjection = DynamicColProjection { + -- The start type is irrelevant. + _dynProjTry :: DataType -> Try (FieldPath, DataType) +} + +-- TODO: use type literal +data FixedProjection1 = FixedProjection1 +data FixedProjection2 = FixedProjection2 + +{-| The operation of extraction from a Spark object to another +object. +-} +class Projection from proj to | from proj -> to where + _performProjection :: from -> proj -> to + +{-| The projector operation. + +This is the general projection operation in Spark. It lets you extract columns +from datasets or dataframes, or sub-observables from observables. + +TODO(kps) put an example here. +-} +(//) :: forall from proj. Project from proj => from -> proj -> ProjectReturn from proj +(//) = _performProject +-- (//) :: forall from proj to. Projection from proj to => from -> proj -> to +-- (//) = _performProjection + +{-| The projector operation for string. + +This is the general projection operation in Spark. It lets you extract columns +from datasets or dataframes, or sub-observables from observables. + +Because of a Haskell limitation, this operator is different for strings. + +TODO(kps) put an example here. +-} +(/-) :: forall from. Project from Text => from -> Text -> ProjectReturn from Text +(/-) = _performProject + + +type family ProjectReturn from proj where + ProjectReturn DataFrame DynamicColProjection = DynColumn + ProjectReturn DataFrame (StaticColProjection from to) = DynColumn + ProjectReturn DataFrame Text = DynColumn + ProjectReturn DynColumn DynamicColProjection = DynColumn + ProjectReturn DynColumn Text = DynColumn + ProjectReturn (Dataset (x1, x2)) FixedProjection1 = Column (x1, x2) x1 + ProjectReturn (Dataset (x1, x2)) FixedProjection2 = Column (x1, x2) x2 + ProjectReturn (Dataset x) DynamicColProjection = DynColumn + -- TODO: not sure how to force x ~ x' + ProjectReturn (Dataset x) (StaticColProjection x y) = Column x y + ProjectReturn (Dataset x) Text = DynColumn + + +class MyString x where + convertToText :: x -> Text + +instance (a ~ Text) => MyString a where + convertToText = id + +class Project from proj where + _performProject :: from -> proj -> ProjectReturn from proj + +instance Project DynColumn DynamicColProjection where + _performProject = projectDColDCol + +instance Project DataFrame DynamicColProjection where + _performProject = projectDFDyn + +instance forall a b. Project DataFrame (StaticColProjection a b) where + _performProject df proj = projectDFDyn df (colStaticProjToDynProj proj) + +instance forall a b. Project (Dataset a) (StaticColProjection a b) where + _performProject = projectDsCol + +instance forall a. Project (Dataset a) DynamicColProjection where + _performProject = projectDSDyn + +instance Project DynColumn Text where + _performProject dc s = + let s' = T.unpack $ convertToText s + in _performProjection dc (stringToDynColProj s') + +instance Project DataFrame Text where + _performProject df s = + let s' = T.unpack $ convertToText s + in projectDFDyn df (stringToDynColProj s') + +instance Project (Dataset a) Text where + _performProject ds s = + let s' = T.unpack $ convertToText s + in projectDSDyn ds (stringToDynColProj s') + +instance forall x1 x2. Project (Dataset (x1, x2)) FixedProjection1 where + _performProject ds _ = projectDsCol ds (StaticColProjection (_projectNthField 1)) + +instance forall x1 x2. Project (Dataset (x1, x2)) FixedProjection2 where + _performProject ds _ = projectDsCol ds (StaticColProjection (_projectNthField 2)) + +-- data Foo +-- data Bar +-- +-- test = +-- let dyn1 = undefined :: DynColumn +-- pdyn1 = undefined :: DynamicColProjection +-- p = undefined :: StaticColProjection Foo Bar +-- ds1 = undefined :: Dataset Foo +-- foo = undefined :: Foo +-- df1 = undefined :: DataFrame +-- dyn2 = dyn1 // pdyn1 +-- dyn3 = dyn1/-"ab"/-"cd" +-- dyn4 = dyn1 // pdyn1 // pdyn1 +-- cdyn1 = df1/-"ab"//pdyn1 +-- ds2 = ds1 // p +-- -- dyn4 = dyn1 /// foo +-- in ds2 + +-- instance Project + +-- dataset -> static projection -> column +instance forall a to. Projection (Dataset a) (StaticColProjection a to) (Column a to) where + _performProjection = projectDsCol + +-- dataset -> dynamic projection -> DynColumn +instance forall a. Projection (Dataset a) DynamicColProjection DynColumn where + _performProjection = projectDSDyn + +-- dataset -> string -> DynColumn +instance forall a . Projection (Dataset a) String DynColumn where + _performProjection ds s = projectDSDyn ds (stringToDynColProj s) + +-- dataframe -> dynamic projection -> dyncolumn +instance Projection DataFrame DynamicColProjection DynColumn where + _performProjection = projectDFDyn + +-- dataframe -> static projection -> dyncolumn +-- This is a relaxation as we could return Try (Column to) intead. +-- It makes more sense from an API perspective to just return a dynamic result. +instance forall a to. Projection DataFrame (StaticColProjection a to) DynColumn where + _performProjection df proj = projectDFDyn df (colStaticProjToDynProj proj) + +-- dataframe -> string -> dyncolumn +instance Projection DataFrame String DynColumn where + _performProjection df s = projectDFDyn df (stringToDynColProj s) + +-- column -> static projection -> column +instance forall ref a to. Projection (Column ref a) (StaticColProjection a to) (Column ref to) where + _performProjection = projectColCol + + +-- dyncolumn -> dynamic projection -> dyncolumn +instance Projection DynColumn DynamicColProjection DynColumn where + _performProjection = projectDColDCol + +instance forall a to. Projection DynColumn (StaticColProjection a to) DynColumn where + _performProjection dc proj = projectDColDCol dc (colStaticProjToDynProj proj) + +-- dyncolumn -> string -> dyncolumn +instance Projection DynColumn String DynColumn where + _performProjection dc s = _performProjection dc (stringToDynColProj s) + + +-- Tuples + +_2 :: FixedProjection2 +_2 = FixedProjection2 + +_1 :: FixedProjection1 +_1 = FixedProjection1 + + +{-| Lets the users define their own static projections. + +Throws an error if the type cannot be found, so should be used with caution. + +String has to be used because of type inferrence issues +-} +unsafeStaticProjection :: forall from to. (HasCallStack) => + SQLType from -- ^ The start type + -> String -- ^ The name of a field assumed to be found in the start type. + -- This only has to be valid for Spark purposes, not + -- internal Haskell representation. + -> StaticColProjection from to +unsafeStaticProjection sqlt field = + let + f = forceRight . fieldPath . T.pack $ field + sqlt' = fromMaybe + (failure $ sformat ("unsafeStaticProjection: Cannot find the field "%sh%" in type "%sh) field sqlt) + (extractPathUnsafe sqlt f) + f2 inSqlt = if inSqlt == sqlt + then pure (f, sqlt') + else tryError $ "Expected type " <> show' sqlt <> " but received type " <> show' inSqlt + in StaticColProjection f2 + + +-- Returns a projection from a path (even if invalid data) +-- TODO: what is the difference with the function below?? +dynamicProjection :: String -> DynamicColProjection +dynamicProjection txt = case fieldPath (T.pack txt) of + Left msg -> DynamicColProjection $ \_ -> + tryError $ sformat ("dynamicProjection: invalid syntax for path "%shown%": "%shown) txt msg + Right fpath -> pathToDynColProj fpath + +{-| Given a string that contains a name or a path, builds a dynamic column +projection. +-} +stringToDynColProj :: String -> DynamicColProjection +stringToDynColProj s = + let + fun dt = + case fieldPath (T.pack s) of + Right fp -> _dynProjTry (pathToDynColProj fp) dt + Left msg -> tryError (T.pack msg) + in DynamicColProjection fun + +pathToDynColProj :: FieldPath -> DynamicColProjection +pathToDynColProj fpath = + let + fun dt = case extractPathUnsafe (SQLType dt) fpath of + Just (SQLType dt') -> pure (fpath, dt') -- TODO(kps) I have a doubt + Nothing -> + tryError $ sformat ("unsafeStaticProjection: Cannot find the field "%shown%" in type "%shown) fpath dt + in DynamicColProjection fun + + +-- | Converts a static project to a dynamic projector. +colStaticProjToDynProj :: forall from to. StaticColProjection from to -> DynamicColProjection +colStaticProjToDynProj (StaticColProjection fProj) = + DynamicColProjection $ \dt -> do + (fp, sqlt) <- fProj (SQLType dt) + let dt' = unSQLType sqlt + return (fp, dt') + +-- ****** Functions that perform projections ******* + +-- TODO: take a compute node instead +projectDSDyn :: Dataset from -> DynamicColProjection -> DynColumn +projectDSDyn ds proj = do + (p, dt) <- _dynProjTry proj (unSQLType . nodeType $ ds) + colExtraction ds dt p + +projectDFDyn :: DataFrame -> DynamicColProjection -> DynColumn +projectDFDyn df proj = do + node <- df + projectDSDyn node proj + +projectDsCol :: (HasCallStack) => Dataset from -> StaticColProjection from to -> Column from to +projectDsCol ds proj = let (p, sqlt) = forceRight $ _staticProj proj (nodeType ds) in + iEmptyCol ds sqlt p + +projectColCol :: Column ref from -> StaticColProjection from to -> Column ref to +projectColCol c (StaticColProjection fProj) = + let (fp, SQLType dt) = forceRight $ fProj (colType c) + in unsafeProjectCol c fp dt + + +projectColDynCol :: ColumnData ref a -> DynamicColProjection -> DynColumn +projectColDynCol cd proj = + _dynProjTry proj (_cType cd) <&> uncurry (unsafeProjectCol . dropColReference $ cd) + +projectDColDCol :: DynColumn -> DynamicColProjection -> DynColumn +projectDColDCol c proj = do + cd <- c + projectColDynCol cd proj + +_projectNthField :: Int -> SQLType a -> Try (FieldPath, SQLType b) +_projectNthField n (SQLType (StrictType (Struct (StructType v)))) = + let extractNth :: Int -> [StructField] -> Try (FieldPath, SQLType b) + extractNth 1 (f1 : _) = + pure (FieldPath . V.singleton . structFieldName $ f1, SQLType . structFieldType $ f1) + extractNth n' (_ : t) | n > 1 = extractNth (n'-1) t + extractNth n' l = tryError $ "_projectNthField: n = "<>show' n'<>" l="<>show' l + in extractNth n (V.toList v) +_projectNthField _ sqlt = tryError $ "_1: Expected a struct, got " <> show' sqlt diff --git a/src/Spark/Core/Internal/Pruning.hs b/src/Spark/Core/Internal/Pruning.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Pruning.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| Methods to prune the computation graph. +-} +module Spark.Core.Internal.Pruning( + NodeCacheStatus(..), + NodeCacheInfo(..), + NodeCache, + pruneGraph, + pruneGraphDefault, + emptyNodeCache +) where + +import Data.HashMap.Strict as HM + +import Spark.Core.StructuresInternal(NodeId, NodePath, ComputationID) +import Spark.Core.Internal.DatasetStructures(UntypedNode, StructureEdge) +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.OpStructures + + +{-| The status of a node being computed. + +On purpose, it does not store data. This is meant to be +only the control plane of the compuations. +-} +data NodeCacheStatus = + NodeCacheRunning + | NodeCacheError + | NodeCacheSuccess + deriving (Eq, Show) + +{-| This structure describes the last time a node was observed by the +controller, and the state it was in. + +This information is used to do smart computation pruning, by assuming +that the observables are kept by the Spark processes. +-} +data NodeCacheInfo = NodeCacheInfo { + nciStatus :: !NodeCacheStatus, + nciComputation :: !ComputationID, + nciPath :: !NodePath +} deriving (Eq, Show) + +type NodeCache = HM.HashMap NodeId NodeCacheInfo + +emptyNodeCache :: NodeCache +emptyNodeCache = HM.empty + +{-| It assumes a compute graph, NOT a dependency dag. +-} +pruneGraph :: (Show v) => + -- The current cache + NodeCache -> + (v -> NodeId) -> + -- A function to create a node replacement + (v -> NodeCacheInfo -> v) -> + -- The graph + Graph v StructureEdge -> + Graph v StructureEdge +pruneGraph c getNodeId f g = + -- Prune the node that we do not want + let depGraph = reverseGraph g + fop v = if HM.member (getNodeId v) c + then CutChildren + else Keep + filtered = graphFilterVertices fop depGraph + -- Bring back to normal flow. + comFiltered = reverseGraph filtered + -- Replace the nodes in the cache by place holders. + -- This is done on the compute graph. + repOp v = case HM.lookup (getNodeId v) c of + Just nci -> f v nci + Nothing -> v + g' = graphMapVertices' repOp comFiltered + in g' + +pruneGraphDefault :: + NodeCache -> Graph UntypedNode StructureEdge -> Graph UntypedNode StructureEdge +pruneGraphDefault c = pruneGraph c nodeId _createNodeCache + +_createNodeCache :: UntypedNode -> NodeCacheInfo -> UntypedNode +_createNodeCache n nci = + let name = "org.spark.PlaceholderCache" + no = NodePointer (Pointer (nciComputation nci) (nciPath nci)) + n2 = emptyNodeStandard (nodeLocality n) (nodeType n) name + `updateNodeOp` no + in n2 diff --git a/src/Spark/Core/Internal/RowGenerics.hs b/src/Spark/Core/Internal/RowGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/RowGenerics.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} + + +-- The generic implementation for the protocol that converts to +-- and from SQL cells. +-- Going through JSON is not recommended because of precision loss +-- for the numbers, and other issues related to numbers. +module Spark.Core.Internal.RowGenerics( + ToSQL, + valueToCell, +) where + +import GHC.Generics +import qualified Data.Vector as V +import Data.Text(pack, Text) + +import Spark.Core.Internal.RowStructures +import Spark.Core.Internal.Utilities + +-- We need to differentiate between the list built for the +-- constructor and an inner object. +data CurrentBuffer = + ConsData ![Cell] + | BuiltCell !Cell deriving (Show) + +_cellOrError :: CurrentBuffer -> Cell +_cellOrError (BuiltCell cell) = cell +_cellOrError x = let msg = "Expected built cell, received " ++ show x in + failure (pack msg) + +-- All the types that can be converted to a SQL value. +class ToSQL a where + _valueToCell :: a -> Cell + + default _valueToCell :: (Generic a, GToSQL (Rep a)) => a -> Cell + _valueToCell !x = _g2cell (from x) + +valueToCell :: (ToSQL a) => a -> Cell +valueToCell = _valueToCell + +-- class FromSQL a where +-- _cellToValue :: Cell -> Try a + +instance ToSQL a => ToSQL (Maybe a) where + _valueToCell (Just x) = _valueToCell x + _valueToCell Nothing = Empty + +instance (ToSQL a, ToSQL b) => ToSQL (a, b) where + _valueToCell (x, y) = RowArray (V.fromList [valueToCell x, valueToCell y]) + +instance ToSQL Int where + _valueToCell = IntElement + +instance ToSQL Double where + _valueToCell = DoubleElement + +instance ToSQL Text where + _valueToCell = StringElement + + +class GToSQL r where + _g2buffer :: r a -> CurrentBuffer + _g2cell :: r a -> Cell + _g2cell = _cellOrError . _g2buffer + +instance GToSQL U1 where + _g2buffer U1 = failure $ pack "GToSQL UI called" + +-- | Constants, additional parameters and recursion of kind * +instance (GToSQL a, GToSQL b) => GToSQL (a :*: b) where + _g2buffer (a :*: b) = case (_g2buffer a, _g2buffer b) of + (ConsData l1, ConsData l2) -> ConsData (l1 ++ l2) + (y1, y2) -> failure $ pack $ "GToSQL (a :*: b): Expected buffers, received " ++ show y1 ++ " and " ++ show y2 + +instance (GToSQL a, GToSQL b) => GToSQL (a :+: b) where + _g2buffer (L1 x) = _g2buffer x + _g2buffer (R1 x) = let !y = _g2buffer x in y + +-- -- | Sums: encode choice between constructors +-- instance (GToSQL a) => GToSQL (M1 i c a) where +-- _g2cell !(M1 x) = let !y = _g2cell x in +-- trace ("GToSQL M1: y = " ++ show y) y + +instance (GToSQL a) => GToSQL (M1 C c a) where + _g2buffer (M1 x) = let !y = _g2buffer x in y + +instance (GToSQL a) => GToSQL (M1 S c a) where + _g2buffer (M1 x) = let !y = ConsData [_g2cell x] in y + +instance (GToSQL a) => GToSQL (M1 D c a) where + _g2buffer (M1 x) = + case _g2buffer x of + ConsData cs -> BuiltCell $ RowArray (V.fromList cs) + BuiltCell cell -> BuiltCell cell + +-- | Products: encode multiple arguments to constructors +instance (ToSQL a) => GToSQL (K1 i a) where + _g2buffer (K1 x) = let !y = _valueToCell x in BuiltCell y diff --git a/src/Spark/Core/Internal/RowGenericsFrom.hs b/src/Spark/Core/Internal/RowGenericsFrom.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/RowGenericsFrom.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + + +-- The generic implementation for the protocol that converts to +-- and from SQL cells. +-- Going through JSON is not recommended because of precision loss +-- for the numbers, and other issues related to numbers. +module Spark.Core.Internal.RowGenericsFrom( + FromSQL(_cellToValue), + TryS, + cellToValue, +) where + +import GHC.Generics +import Data.Text(Text, pack) +import Control.Applicative(liftA2) +import Control.Monad.Except +import Formatting +import qualified Data.Vector as V + +import Spark.Core.Internal.RowStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesStructuresRepr(DataTypeRepr, DataTypeElementRepr) + +-- Convert a cell to a value (if possible) +cellToValue :: (FromSQL a) => Cell -> Either Text a +cellToValue = _cellToValue + +type TryS = Either Text + +-- Because of the way the generic decoders work, +-- an array of cell needs special treatment when it is +-- decoded as the constructor of an object. Then it should +-- be interpreted as a stateful tape, for which we read a +-- few cells (number unknown) and return some value from the +-- cells that have been consumed. +data Decode2 = + -- A tape with some potentially remaining cells + D2Cons ![Cell] + -- Just a normal cell. + | D2Normal !Cell + deriving (Eq, Show) + + +-- All the types that can be converted to a SQL value. +class FromSQL a where + _cellToValue :: Cell -> TryS a + + default _cellToValue :: (Generic a, GFromSQL (Rep a)) => Cell -> TryS a + _cellToValue cell = let + x = undefined :: a + x1r = _gFcell (from x) (D2Normal cell) :: InterResult (Decode2, Rep a a) + x2r = snd <$> x1r + x1t = to <$> x2r + in _toTry x1t + +-- ******** Basic instance ******** + +instance FromSQL a => FromSQL (Maybe a) where + _cellToValue Empty = pure Nothing + _cellToValue x = pure <$> _cellToValue x + +instance FromSQL Int where + _cellToValue (IntElement x) = pure x + _cellToValue x = throwError $ sformat ("FromSQL: Decoding an int from "%shown) x + +instance FromSQL Double where + _cellToValue (DoubleElement x) = pure x + _cellToValue x = throwError $ sformat ("FromSQL: Decoding a double from "%shown) x + +instance FromSQL Text where + _cellToValue (StringElement txt) = pure txt + _cellToValue x = throwError $ sformat ("FromSQL: Decoding a unicode text from "%shown) x + +instance FromSQL Cell where + _cellToValue = pure + +instance FromSQL Bool where + _cellToValue (BoolElement b) = pure b + _cellToValue x = throwError $ sformat ("FromSQL: Decoding a boolean from "%shown) x + +instance FromSQL DataTypeRepr +instance FromSQL DataTypeElementRepr + +instance FromSQL a => FromSQL [a] where + _cellToValue (RowArray xs) = + sequence (_cellToValue <$> V.toList xs) + _cellToValue x = throwError $ sformat ("FromSQL[]: Decoding array from "%shown) x + +instance (FromSQL a1, FromSQL a2) => FromSQL (a1, a2) where + _cellToValue (RowArray xs) = case V.toList xs of + [x1, x2] -> + liftA2 (,) (_cellToValue x1) (_cellToValue x2) + l -> throwError $ sformat ("FromSQL: Expected 2 elements but got "%sh) l + _cellToValue x = throwError $ sformat ("FromSQL(,): Decoding array from "%shown) x + +-- ******* GENERIC ******** + +-- A final message at the bottom +-- A path in the elements to get there +data FailureInfo = FailureInfo !Text ![Text] deriving (Eq, Show) + +type InterResult a = Either FailureInfo a + + +class GFromSQL r where + -- An evidence about the type (in order to have info about the field names) + -- The current stuff that has been decoded + _gFcell :: r a -> Decode2 -> InterResult (Decode2, r a) + +_toTry :: InterResult a -> TryS a +_toTry (Right x) = pure x +_toTry (Left (FailureInfo msg p)) = Left $ show' (reverse p) <> " : " <> msg + +_fromTry :: TryS a -> InterResult a +_fromTry (Right x) = Right x +_fromTry (Left x) = Left $ FailureInfo x [] + +instance GFromSQL U1 where + _gFcell x = failure $ pack $ "GFromSQL UI called" ++ show x + +instance (GFromSQL a, GFromSQL b) => GFromSQL (a :*: b) where + -- Switching to tape-reading mode + _gFcell ev (D2Normal (RowArray arr)) = _gFcell ev (D2Cons (V.toList arr)) + -- Advancing into the reader + _gFcell ev (D2Cons l) = do + let (ev1 :*: ev2) = ev + (d1, x1) <- _gFcell ev1 (D2Cons l) + (d2, x2) <- _gFcell ev2 d1 + return (d2, x1 :*: x2) + _gFcell _ x = failure $ pack ("GFromSQL (a :*: b) " ++ show x) + + +instance (GFromSQL a, GFromSQL b) => GFromSQL (a :+: b) where + _gFcell _ x = failure $ pack $ "GFromSQL (a :+: b)" ++ show x + +instance (GFromSQL a, Constructor c) => GFromSQL (M1 C c a) where + _gFcell _ (D2Cons x) = failure $ pack ("GFromSQL (M1 C c a)" ++ " FAILED CONS: " ++ show x) + _gFcell ev (D2Normal cell) = do + let ev' = unM1 ev + (d, x) <- _withHint (pack (conName ev)) $ _gFcell ev' (D2Normal cell) + return (d, M1 x) + +instance (GFromSQL a, Selector c) => GFromSQL (M1 S c a) where + _gFcell ev (D2Normal (RowArray arr)) = do + let ev' = unM1 ev + let l = V.toList arr + (d, x) <- _withHint ("(1)" <> pack (selName ev)) $ _gFcell ev' (D2Cons l) + return (d, M1 x) + _gFcell ev d = do + let ev' = unM1 ev + (d', x) <- _withHint ("(2)" <> pack (selName ev)) $ _gFcell ev' d + return (d', M1 x) + +instance (GFromSQL a, Datatype c) => GFromSQL (M1 D c a) where + _gFcell ev (z @ (D2Normal (RowArray _))) = do + let ev' = unM1 ev + (d, x) <- _gFcell ev' z + return (d, M1 x) + _gFcell _ x = failure $ pack $ "FAIL GFromSQL (M1 D c a)" ++ show x + +-- | Products: encode multiple arguments to constructors +instance (FromSQL a) => GFromSQL (K1 i a) where + -- It is just a normal cell. + -- Read one element and move on. + _gFcell _ (D2Cons (cell : r)) = do + x <- _fromTry $ _cellToValue cell + return (D2Cons r, K1 x) + -- Just reading a normal cell, return no tape. + _gFcell _ (D2Normal cell) = do + x <- _fromTry $ _cellToValue cell + return (D2Cons [], K1 x) + _gFcell _ x = failure $ pack ("GFromSQLK FAIL " ++ show x) + +_withHint :: Text -> InterResult a -> InterResult a +_withHint extra (Left (FailureInfo msg l)) = Left (FailureInfo msg (extra : l)) +_withHint _ (Right x) = Right x diff --git a/src/Spark/Core/Internal/RowStructures.hs b/src/Spark/Core/Internal/RowStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/RowStructures.hs @@ -0,0 +1,50 @@ +module Spark.Core.Internal.RowStructures where + +import Data.Aeson +import Data.Vector(Vector) +import qualified Data.Text as T + +-- | The basic representation of one row of data. This is a standard type that comes out of the +-- SQL engine in Spark. + +-- | An element in a Row object. +-- All objects manipulated by the Spark framework are assumed to +-- be convertible to cells. +-- +-- This is usually handled by generic transforms. +data Cell = + Empty -- To represent maybe + | IntElement !Int + | DoubleElement !Double + | StringElement !T.Text + | BoolElement !Bool + | RowArray !(Vector Cell) deriving (Show, Eq) + +-- | A Row of data: the basic data structure to transport information +-- TODO rename to rowCells +data Row = Row { + cells :: !(Vector Cell) + } deriving (Show, Eq) + + +-- AESON INSTANCES + +-- TODO(kps) add some workaround to account for the restriction of +-- JSON types: +-- int32 -> int32 +-- double -> double +-- weird double -> string? +-- long/bigint -> string? + +-- | Cell +instance ToJSON Cell where + toJSON Empty = Null + toJSON (DoubleElement d) = toJSON d + toJSON (IntElement i) = toJSON i + toJSON (BoolElement b) = toJSON b + toJSON (StringElement s) = toJSON s + toJSON (RowArray arr) = toJSON arr + +-- | Row +instance ToJSON Row where + toJSON (Row x) = toJSON x diff --git a/src/Spark/Core/Internal/RowUtils.hs b/src/Spark/Core/Internal/RowUtils.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/RowUtils.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.Internal.RowUtils( + jsonToCell, + checkCell, + rowArray +) where + +import Data.Aeson +import Data.Text(Text) +import Data.Maybe(catMaybes, listToMaybe) +import Formatting +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM +import Data.Scientific(floatingOrInteger, toRealFloat) +import Control.Monad.Except + +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.RowStructures +import Spark.Core.StructuresInternal(FieldName(..)) +import Spark.Core.Internal.Utilities + +type TryCell = Either Text Cell + +-- | Decodes a JSON into a row. +-- This operation requires a SQL type that describes + -- the schema. +jsonToCell :: DataType -> Value -> Either Text Cell +jsonToCell dt v = withContext ("jsonToCell: dt="<>show' dt<>" v="<>show' v) $ + _j2Cell v dt + +{-| Given a datatype, ensures that the cell has the corresponding type. +-} +checkCell :: DataType -> Cell -> Either Text Cell +checkCell dt c = case _checkCell dt c of + Nothing -> pure c + Just txt -> throwError txt + +{-| Convenience constructor for an array of cells. +-} +rowArray :: [Cell] -> Cell +rowArray = RowArray . V.fromList + + +-- Returns an error message if something wrong is found +_checkCell :: DataType -> Cell -> Maybe Text +_checkCell dt c = case (dt, c) of + (NullableType _, Empty) -> Nothing + (StrictType _, Empty) -> + pure $ sformat ("Expected a strict value of type "%sh%" but no value") dt + (StrictType sdt, x) -> _checkCell' sdt x + (NullableType sdt, x) -> _checkCell' sdt x + +-- Returns an error message if something wrong is found +_checkCell' :: StrictDataType -> Cell -> Maybe Text +_checkCell' sdt c = case (sdt, c) of + (_, Empty) -> + pure $ sformat ("Expected a strict value of type "%sh%" but no value") sdt + (IntType, IntElement _) -> Nothing + (StringType, StringElement _) -> Nothing + (Struct (StructType fields), RowArray cells') -> + if V.length fields == V.length cells' + then + let types = V.toList $ structFieldType <$> fields + res = uncurry _checkCell <$> (types `zip` V.toList cells') + in listToMaybe (catMaybes res) + else + pure $ sformat ("Struct "%sh%" has "%sh%" fields, asked to be matched with "%sh%" cells") sdt (V.length fields) (V.length cells') + (ArrayType dt, RowArray cells') -> + let res = uncurry _checkCell <$> (repeat dt `zip` V.toList cells') + in listToMaybe (catMaybes res) + (_, _) -> + pure $ sformat ("Type "%sh%" is incompatible with cell content "%sh) sdt c + + +_j2Cell :: Value -> DataType -> TryCell +_j2Cell Null (StrictType t) = + throwError $ sformat ("_j2Cell: Expected "%shown%", got null") t +_j2Cell Null (NullableType _) = pure Empty +_j2Cell x (StrictType t) = _j2CellS x t +-- We do not express optional types at cell level. They have to be +-- encoded in the data type. +_j2Cell x (NullableType t) = _j2CellS x t +--_j2Cell x t = throwError $ sformat ("_j2Cell: Could not match value "%shown%" with type "%shown) x t + +_j2CellS :: Value -> StrictDataType -> TryCell +_j2CellS (String t) StringType = pure . StringElement $ t +_j2CellS (Bool t) BoolType = pure . BoolElement $ t +_j2CellS (Array v) (ArrayType t) = + let trys = flip _j2Cell t <$> v in + RowArray <$> sequence trys +_j2CellS (Number s) IntType = case floatingOrInteger s :: Either Double Int of + Left _ -> throwError $ sformat ("_j2CellS: Could not cast as int "%shown) s + Right i -> pure (IntElement i) +_j2CellS (Number s) DoubleType = pure . DoubleElement . toRealFloat $ s +-- Normal representation as object. +_j2CellS (Object o) (Struct struct) = + let + o2f :: StructField -> TryCell + o2f field = + let nullable = isNullable $ structFieldType field + val = HM.lookup (unFieldName $ structFieldName field) o in + case val of + Nothing -> + if nullable then + pure Empty + else throwError $ sformat ("_j2CellS: Could not find key "%shown%" in object "%shown) field o + Just x -> _j2Cell x (structFieldType field) + fields = o2f <$> structFields struct + in RowArray <$> sequence fields +-- Compact array-based representation. +_j2CellS (Array v) (Struct (StructType fields)) = + if V.length v == V.length fields + then + let dts = structFieldType <$> fields + inner = uncurry _j2Cell <$> V.zip v dts + in RowArray <$> sequence inner + else throwError $ sformat ("_j2CellS: Compact object format a different number of fields '"%shown%"' compared "%shown) v fields +_j2CellS x t = throwError $ sformat ("_j2CellS: Could not match value '"%shown%"' with type "%shown) x t diff --git a/src/Spark/Core/Internal/TypesFunctions.hs b/src/Spark/Core/Internal/TypesFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/TypesFunctions.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Spark.Core.Internal.TypesFunctions( + isNullable, + iInnerStrictType, + columnType, + unsafeCastType, + intType, + arrayType, + compatibleTypes, + arrayType', + frameTypeFromCol, + colTypeFromFrame, + canNull, + structField, + structType, + structTypeFromFields, + structTypeTuple, + structTypeTuple', + tupleType, + structName, + iSingleField, + -- cellType, +) where + +import Control.Monad.Except +import qualified Data.List.NonEmpty as N +import Control.Arrow(second) +import Data.Function(on) +import Data.List(sort, nub, sortBy) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Text(Text, intercalate) +import qualified Data.Vector as V +import Formatting + + +import Spark.Core.Internal.TypesStructures +import Spark.Core.StructuresInternal +import Spark.Core.Internal.RowGenericsFrom(FromSQL(..), TryS) +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesStructuresRepr(DataTypeRepr, DataTypeElementRepr) +import qualified Spark.Core.Internal.TypesStructuresRepr as DTR +import Spark.Core.Try + +-- Performs a cast of the type. +-- This may throw an error if the required type b is not +-- compatible with the type embedded in a. +unsafeCastType :: SQLType a -> SQLType b +-- TODO add more error checking here. +unsafeCastType (SQLType dt) = SQLType dt + + +-- Given a sql type tag, returns the equivalent data type for a column or a blob +-- (internal) +columnType :: SQLType a -> DataType +columnType (SQLType dt) = dt + +-- (internal) +isNullable :: DataType -> Bool +isNullable (StrictType _) = False +isNullable (NullableType _) = True + +-- *** Creation of data types *** + + +-- Takes a data type (assumed to be that of a column or cell) and returns the +-- corresponding dataset type. +-- This should only be used when talking to Spark. +-- All visible operations in Karps use Cell types instead. +-- TODO should it use value or _1? Both seem to be used in Spark. +frameTypeFromCol :: DataType -> StructType +frameTypeFromCol (StrictType (Struct struct)) = struct +frameTypeFromCol dt = _structFromUnfields [("value", dt)] + +-- Given the structural type for a dataframe or a dataset, returns the +-- equivalent column type. +colTypeFromFrame :: StructType -> DataType +colTypeFromFrame st @ (StructType fs) = case V.toList fs of + [StructField { + structFieldName = fname, + structFieldType = (StrictType dt)}] | fname == "value" -> + StrictType dt + _ -> StrictType (Struct st) + + +-- The strict int type + +compatibleTypes :: DataType -> DataType -> Bool +compatibleTypes (StrictType sdt) (StrictType sdt') = _compatibleTypesStrict sdt sdt' +compatibleTypes (NullableType sdt) (NullableType sdt') = _compatibleTypesStrict sdt sdt' +compatibleTypes _ _ = False + +-- ***** INSTANCES ***** + +-- In the case of source introspection, datatypes may be returned. +instance FromSQL DataType where + _cellToValue = _cellToValue >=> _sDataTypeFromRepr + +_sDataTypeFromRepr :: DataTypeRepr -> TryS DataType +_sDataTypeFromRepr (DTR.DataTypeRepr l) = snd <$> _sToTreeRepr l + +_sToTreeRepr :: [DataTypeElementRepr] -> TryS (Int, DataType) +_sToTreeRepr [] = throwError $ sformat "_sToTreeRepr: empty list" +_sToTreeRepr [dtr] | null (DTR.fieldPath dtr) = + -- We are at a leaf, decode the leaf + _decodeLeaf dtr [] +_sToTreeRepr l = do + let f dtr = case DTR.fieldPath dtr of + [] -> [] + (h : t) -> [(h, dtr')] where dtr' = dtr { DTR.fieldPath = t } + let hDtrt = case filter (null . DTR.fieldPath) l of + [dtr] -> pure dtr + _ -> + throwError $ sformat ("_decodeList: invalid top with "%sh) l + let withHeads = concatMap f l + let g = myGroupBy withHeads + let groupst = M.toList g <&> \(h, l') -> + _sToTreeRepr l' <&> second (StructField (FieldName h)) + groups <- sequence groupst + checkedGroups <- _packWithIndex groups + hDtr <- hDtrt + _decodeLeaf hDtr checkedGroups + +_packWithIndex :: (Show t) => [(Int, t)] -> TryS [t] +_packWithIndex l = _check 0 $ sortBy (compare `on` fst) l + +-- Checks that all the elements are indexed in order by their value. +-- It works by running a counter along each element and seeing that it is here. +_check :: (Show t) => Int -> [(Int, t)] -> TryS [t] +_check _ [] = pure [] +_check n ((n', x):t) = + if n == n' + then (x : ) <$> _check (n+1) t + else + throwError $ sformat ("_check: could not match arguments at index "%sh%" for argument "%sh) n ((n', x):t) + + +_decodeLeaf :: DataTypeElementRepr -> [StructField] -> TryS (Int, DataType) +_decodeLeaf dtr l = _decodeLeafStrict dtr l <&> \sdt -> + if DTR.isNullable dtr + then (DTR.fieldIndex dtr, NullableType sdt) + else (DTR.fieldIndex dtr, StrictType sdt) + +_decodeLeafStrict :: DataTypeElementRepr -> [StructField] -> TryS StrictDataType +-- The array type +_decodeLeafStrict dtr [sf] | DTR.typeId dtr == 11 = + pure $ ArrayType (structFieldType sf) +-- Structure types +_decodeLeafStrict dtr l | DTR.typeId dtr == 10 = + pure . Struct . StructType . V.fromList $ l +_decodeLeafStrict dtr [] = case DTR.typeId dtr of + 0 -> pure IntType + 1 -> pure StringType + 2 -> pure BoolType + n -> throwError $ sformat ("_decodeLeafStrict: unknown type magic id "%sh) n +_decodeLeafStrict dtr l = + throwError $ sformat ("_decodeLeafStrict: cannot interpret dtr="%sh%" and fields="%sh) dtr l + +_compatibleTypesStrict :: StrictDataType -> StrictDataType -> Bool +_compatibleTypesStrict IntType IntType = True +_compatibleTypesStrict DoubleType DoubleType = True +_compatibleTypesStrict StringType StringType = True +_compatibleTypesStrict (ArrayType et) (ArrayType et') = compatibleTypes et et' +_compatibleTypesStrict (Struct (StructType v)) (Struct (StructType v')) = + (length v == length v') && + and (V.zipWith compatibleTypes (structFieldType <$> v) (structFieldType <$> v')) +_compatibleTypesStrict _ _ = False + +tupleType :: SQLType a -> SQLType b -> SQLType (a, b) +tupleType (SQLType dt1) (SQLType dt2) = + SQLType $ structType [structField "_1" dt1, structField "_2" dt2] + +intType :: DataType +intType = StrictType IntType + +-- a string +structField :: T.Text -> DataType -> StructField +structField txt = StructField (FieldName txt) + +-- The strict structure type +structType :: [StructField] -> DataType +structType = StrictType . Struct . StructType . V.fromList + +-- The strict array type +arrayType' :: DataType -> DataType +arrayType' = StrictType . ArrayType + +-- Returns the equivalent data type that may be nulled. +canNull :: DataType -> DataType +canNull = NullableType . iInnerStrictType + +-- Given a type, returns the corresponding array type. +-- This is preferred to using directly buildType, as it may encounter some +-- overlapping instances. +arrayType :: SQLType a -> SQLType [a] +arrayType (SQLType dt) = SQLType (arrayType' dt) + +iInnerStrictType :: DataType -> StrictDataType +iInnerStrictType (StrictType st) = st +iInnerStrictType (NullableType st) = st + +iSingleField :: DataType -> Maybe DataType +iSingleField (StrictType (Struct (StructType fields))) = case V.toList fields of + [StructField _ dt] -> Just dt + _ -> Nothing +iSingleField _ = Nothing + + +structName :: StructType -> Text +structName (StructType fields) = + "struct(" <> intercalate "," (unFieldName . structFieldName <$> V.toList fields) <> ")" + +{-| Builds a type that is a tuple of all the given types. + +Following the Spark and SQL convention, the indexing starts at 1. +-} +structTypeTuple :: N.NonEmpty DataType -> StructType +structTypeTuple dts = + let numFields = length dts + rawFieldNames = ("_" <> ) . show' <$> (1 N.:| [2..numFields]) + fieldNames = N.toList $ unsafeFieldName <$> rawFieldNames + fieldTypes = N.toList dts + -- Unsafe call, but we know it is going to be all different fields + in forceRight $ structTypeFromFields (zip fieldNames fieldTypes) + +{-| Returns a data type instead (the most common use case) + +Note that unlike Spark and SQL, the indexing starts from 0. + -} +structTypeTuple' :: N.NonEmpty DataType -> DataType +structTypeTuple' = StrictType . Struct . structTypeTuple + +structTypeFromFields :: [(FieldName, DataType)] -> Try StructType +structTypeFromFields [] = tryError "You cannot build an empty structure" +structTypeFromFields ((hfn, hdt):t) = + let fs = (hfn, hdt) : t + ct = StructType $ uncurry StructField <$> V.fromList fs + names = fst <$> fs + numNames = length names + numDistincts = length . nub $ names + in if numNames == numDistincts + then return ct + else tryError $ sformat ("Duplicate field names when building the struct: "%sh) (sort names) + +_structFromUnfields :: [(T.Text, DataType)] -> StructType +_structFromUnfields l = StructType . V.fromList $ x where + x = [StructField (FieldName name) dt | (name, dt) <- l] diff --git a/src/Spark/Core/Internal/TypesGenerics.hs b/src/Spark/Core/Internal/TypesGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/TypesGenerics.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Spark.Core.Internal.TypesGenerics where + +import qualified Data.Vector as V +import qualified Data.Text as T +import GHC.Generics +import Formatting + +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.Utilities +import Spark.Core.StructuresInternal(FieldName(..), unsafeFieldName) +import Spark.Core.Internal.TypesStructuresRepr(DataTypeRepr, DataTypeElementRepr) + +-- The 3rd attempt to get generics conversions. + +-- Given a tag on a type, returns the equivalent SQL type. +-- This is the type for a cell, not for a row. +-- TODO(kps) more documentation +buildType :: (HasCallStack, SQLTypeable a) => SQLType a +buildType = _buildType + + +-- The class of all the types for which the SQL type can be inferred +-- from the Haskell type only. +-- Two notable exceptions are Row and Cell, which are the dynamic types +-- used by Spark. +-- See also buildType on how to use it. +class SQLTypeable a where + _genericTypeFromValue :: (HasCallStack) => a -> GenericType + default _genericTypeFromValue :: (HasCallStack, Generic a, GenSQLTypeable (Rep a)) => a -> GenericType + _genericTypeFromValue x = genTypeFromProxy (from x) + +-- Generic SQLTypeable +class GenSQLTypeable f where + genTypeFromProxy :: (HasCallStack) => f a -> GenericType + + +-- | The only function that should matter for users in this file. +-- Given a type, returns the SQL representation of this type. +_buildType :: forall a. (HasCallStack, SQLTypeable a) => SQLType a +_buildType = + let dt = _genericTypeFromValue (undefined :: a) + in SQLType dt + +type GenericType = DataType + +instance SQLTypeable Int where + _genericTypeFromValue _ = StrictType IntType + +instance SQLTypeable Double where + _genericTypeFromValue _ = StrictType DoubleType + +instance SQLTypeable T.Text where + _genericTypeFromValue _ = StrictType StringType + +instance SQLTypeable Bool where + _genericTypeFromValue _ = StrictType BoolType + +instance SQLTypeable DataTypeRepr +instance SQLTypeable DataTypeElementRepr + +instance SQLTypeable DataType where + _genericTypeFromValue _ = _genericTypeFromValue (undefined :: DataTypeRepr) + + +-- instance {-# INCOHERENT #-} SQLTypeable String where +-- _genericTypeFromValue _ = StrictType StringType + +instance SQLTypeable a => SQLTypeable (Maybe a) where + _genericTypeFromValue _ = let SQLType dt = buildType :: (SQLType a) in + (NullableType . iInnerStrictType) dt + +instance {-# OVERLAPPABLE #-} SQLTypeable a => SQLTypeable [a] where + _genericTypeFromValue _ = + let SQLType dt = buildType :: (SQLType a) in + (StrictType . ArrayType) dt + + +instance forall a1 a2. ( + SQLTypeable a2, + SQLTypeable a1) => SQLTypeable (a1, a2) where + _genericTypeFromValue _ = + let + SQLType t1 = buildType :: SQLType a1 + SQLType t2 = buildType :: SQLType a2 + in _buildTupleStruct [t1, t2] + +_buildTupleStruct :: [GenericType] -> GenericType +_buildTupleStruct dts = + let fnames = unsafeFieldName . T.pack. ("_" ++) . show <$> ([1..] :: [Int]) + fs = uncurry StructField <$> zip fnames dts + in StrictType . Struct . StructType $ V.fromList fs + +-- instance (SQLTypeable a, SQLTypeable b) => SQLTypeable (a,b) where +-- _genericTypeFromValue _ = _genericTypeFromValue (undefined :: a) ++ _genericTypeFromValue (undefined :: b) + +instance (GenSQLTypeable f) => GenSQLTypeable (M1 D c f) where + genTypeFromProxy m = genTypeFromProxy (unM1 m) + +instance (GenSQLTypeable f, Constructor c) => GenSQLTypeable (M1 C c f) where + genTypeFromProxy m + | conIsRecord m = + let x = unM1 m + dt = genTypeFromProxy x in + dt + | otherwise = + -- It is assumed to be a newtype and we are going to unwrap it + let !dt1 = genTypeFromProxy (unM1 m) + in case iSingleField dt1 of + Just dt -> dt + Nothing -> + failure $ sformat ("M1 C "%sh%" dt1="%sh) n dt1 + where n = conName m + +-- Selector Metadata +instance (GenSQLTypeable f, Selector c) => GenSQLTypeable (M1 S c f) where + genTypeFromProxy m = + let st = genTypeFromProxy (unM1 m) + n = selName m + field = StructField { structFieldName = FieldName $ T.pack n, structFieldType = st } + st2 = StructType (V.singleton field) in + StrictType $ Struct st2 + +instance (SQLTypeable a) => GenSQLTypeable (K1 R a) where + genTypeFromProxy m = _genericTypeFromValue (unK1 m) + +-- Sum branch +instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :+: b) where + genTypeFromProxy (L1 x) = genTypeFromProxy x + genTypeFromProxy (R1 x) = genTypeFromProxy x + +-- Product branch +instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :*: b) where + genTypeFromProxy z = + -- Due to optimizations that I do not understand, the decomposition has to + -- be done inside the function. + -- Otherwise, the value (which is undefined) gets to be evaluated, and breaks + -- the code. + let (x1 :*: x2) = z + y1 = genTypeFromProxy x1 + y2 = genTypeFromProxy x2 in case (y1, y2) of + (StrictType (Struct s1), StrictType (Struct s2)) -> + (StrictType . Struct) s where + fs = structFields s1 V.++ structFields s2 + s = StructType fs + _ -> failure $ sformat ("should not happen: left="%sh%" right="%sh) y1 y2 + +-- Void branch +instance GenSQLTypeable U1 where + genTypeFromProxy _ = failure "U1" diff --git a/src/Spark/Core/Internal/TypesStructures.hs b/src/Spark/Core/Internal/TypesStructures.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/TypesStructures.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| The structures of data types in Karps. + +For a detailed description of the supported types, see +http://spark.apache.org/docs/latest/sql-programming-guide.html#data-types + +At a high-level, Spark DataFrames and Datasets are equivalent to lists of +objects whose type can be mapped to the same StructType: +Dataset a ~ ArrayType StructType (...) +Columns of a dataset are equivalent to lists of object whose type can be +mapped to the same DataType (either Strict or Nullable) +Local data (or "blobs") are single elements whose type can be mapped to a +DataType (either strict or nullable) +-} +module Spark.Core.Internal.TypesStructures where + +import Data.Aeson +import Data.Vector(Vector) +import Control.Monad(guard) +import qualified Data.Vector as V +import qualified Data.Aeson as A +import qualified Data.Text as T +import GHC.Generics(Generic) +import Test.QuickCheck + +import Spark.Core.StructuresInternal(FieldName(..)) +import Spark.Core.Internal.Utilities + +-- The core type algebra + +-- | The data types that are guaranteed to not be null: evaluating them will return a value. +data StrictDataType = + IntType + | DoubleType + | StringType + | BoolType + | Struct !StructType + | ArrayType !DataType + deriving (Eq) + +-- | All the data types supported by the Spark engine. +-- The data types can either be nullable (they may contain null values) or strict (all the values are present). +-- There are a couple of differences with the algebraic data types in Haskell: +-- Maybe (Maybe a) ~ Maybe a which implies that arbitrary nesting of values will be flattened to a top-level Nullable +-- Similarly, [[]] ~ [] +data DataType = + StrictType !StrictDataType + | NullableType !StrictDataType deriving (Eq) + +-- | A field in a structure +data StructField = StructField { + structFieldName :: !FieldName, + structFieldType :: !DataType +} deriving (Eq) + +-- | The main structure of a dataframe or a dataset +data StructType = StructType { + structFields :: !(Vector StructField) +} deriving (Eq) + + +-- Convenience types + +-- | Represents the choice between a strict and a nullable field +data Nullable = CanNull | NoNull deriving (Show, Eq) + +-- | Encodes the type of all the nullable data types +data NullableDataType = NullableDataType !StrictDataType deriving (Eq) + +-- | A tagged datatype that encodes the sql types +-- This is the main type information that should be used by users. +data SQLType a = SQLType { + -- | The underlying data type. + unSQLType :: !DataType +} deriving (Eq, Generic) + + +instance Show DataType where + show (StrictType x) = show x + show (NullableType x) = show x ++ "?" + +instance Show StrictDataType where + show StringType = "string" + show DoubleType = "double" + show IntType = "int" + show BoolType = "bool" + show (Struct struct) = show struct + show (ArrayType at) = "[" ++ show at ++ "]" + +instance Show StructField where + show field = (T.unpack . unFieldName . structFieldName) field ++ ":" ++ s where + s = show $ structFieldType field + +instance Show StructType where + show struct = "{" ++ unwords (map show (V.toList . structFields $ struct)) ++ "}" + +instance Show (SQLType a) where + show (SQLType dt) = show dt + + +-- QUICKCHECK INSTANCES + + +instance Arbitrary StructField where + arbitrary = do + name <- elements ["_1", "a", "b", "abc"] + dt <- arbitrary :: Gen DataType + return $ StructField (FieldName $ T.pack name) dt + +instance Arbitrary StructType where + arbitrary = do + fields <- listOf arbitrary + return . StructType . V.fromList $ fields + +instance Arbitrary StrictDataType where + arbitrary = do + idx <- elements [1,2] :: Gen Int + return $ case idx of + 1 -> StringType + 2 -> IntType + _ -> failure "Arbitrary StrictDataType" + +instance Arbitrary DataType where + arbitrary = do + x <- arbitrary + u <- arbitrary + return $ if x then + StrictType u + else + NullableType u + +-- AESON INSTANCES + +-- This follows the same structure as the JSON generated by Spark. +instance ToJSON StrictDataType where + toJSON IntType = "integer" + toJSON DoubleType = "double" + toJSON StringType = "string" + toJSON BoolType = "bool" + toJSON (Struct struct) = toJSON struct + toJSON (ArrayType (StrictType dt)) = + object [ "type" .= A.String "array" + , "elementType" .= toJSON dt + , "containsNull" .= A.Bool False ] + toJSON (ArrayType (NullableType dt)) = + object [ "type" .= A.String "array" + , "elementType" .= toJSON dt + , "containsNull" .= A.Bool True ] + +instance ToJSON StructType where + toJSON (StructType fields) = + let + fs = (snd . _fieldToJson) <$> V.toList fields + in object [ "type" .= A.String "struct" + , "fields" .= fs ] + +-- Spark drops the info at the highest level. +instance ToJSON DataType where + toJSON (StrictType dt) = object [ + "nullable" .= A.Bool False, + "dt" .= toJSON dt] + toJSON (NullableType dt) = object [ + "nullable" .= A.Bool True, + "dt" .= toJSON dt] + +instance FromJSON DataType where + parseJSON = withObject "DataType" $ \o -> do + nullable <- o .: "nullable" + dt <- o .: "dt" + let c = if nullable then NullableType else StrictType + return (c dt) + +instance FromJSON StructField where + parseJSON = withObject "StructField" $ \o -> do + n <- o .: "name" + dt <- o .: "type" + nullable <- o .: "nullable" + let c = if nullable then NullableType else StrictType + return $ StructField (FieldName n) (c dt) + +instance FromJSON StructType where + parseJSON = withObject "StructType" $ \o -> do + tp <- o .: "type" + guard (tp == T.pack "struct") + fs <- o .: "fields" + return (StructType fs) + +instance FromJSON StrictDataType where + parseJSON (A.String s) = case s of + "integer" -> return IntType + "double" -> return DoubleType + "string" -> return StringType + "bool" -> return BoolType + -- TODO: figure out which one is correct + "boolean" -> return BoolType + _ -> fail ("StrictDataType: unknown type " ++ T.unpack s) + parseJSON (Object o) = do + tp <- o .: "type" + case T.pack tp of + "struct" -> Struct <$> parseJSON (Object o) + "array" -> do + dt <- o .: "elementType" + containsNull <- o .: "containsNull" + let c = if containsNull then NullableType else StrictType + return $ ArrayType (c dt) + s -> fail ("StrictDataType: unknown type " ++ T.unpack s) + + parseJSON x = fail ("StrictDataType: cannot parse " ++ show x) + + +_fieldToJson :: StructField -> (T.Text, A.Value) +_fieldToJson (StructField (FieldName n) (StrictType dt)) = + (n, object [ "name" .= A.String n + , "type" .= toJSON dt + , "nullable" .= A.Bool False]) +_fieldToJson (StructField (FieldName n) (NullableType dt)) = + (n, object [ "name" .= A.String n + , "type" .= toJSON dt + , "nullable" .= A.Bool True]) diff --git a/src/Spark/Core/Internal/TypesStructuresRepr.hs b/src/Spark/Core/Internal/TypesStructuresRepr.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/TypesStructuresRepr.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Spark.Core.Internal.TypesStructuresRepr( + DataTypeElementRepr(..), + DataTypeRepr(..) +) where + +import qualified Data.Text as T +import GHC.Generics(Generic) + +-- The inner representation of a dataype as a Row object. +-- This representation is meant to be internal. +-- Because the Spark data types do not support recursive types (trees), +-- This is a flattened representation of types. +data DataTypeElementRepr = DataTypeElementRepr { + fieldPath :: ![T.Text], + isNullable :: !Bool, + typeId :: !Int, + fieldIndex :: !Int +} deriving (Eq, Show, Generic) + +data DataTypeRepr = DataTypeRepr { + rows :: [DataTypeElementRepr] +} deriving (Eq, Show, Generic) diff --git a/src/Spark/Core/Internal/Utilities.hs b/src/Spark/Core/Internal/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Internal/Utilities.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + + +{-| A collection of small utility functions. +-} +module Spark.Core.Internal.Utilities( + LB.HasCallStack, + UnknownType, + pretty, + myGroupBy, + myGroupBy', + missing, + failure, + failure', + forceRight, + show', + encodeDeterministicPretty, + withContext, + strictList, + traceHint, + SF.sh, + (<&>), + (<>) + ) where + +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy.Char8 as Char8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Formatting.ShortFormatters as SF +import Control.Arrow ((&&&)) +import Data.List +import Data.Function +import Data.Text(Text) +import Formatting +import Debug.Trace(trace) +import qualified Data.Map.Strict as M +import Data.Monoid((<>)) + +import qualified Spark.Core.Internal.LocatedBase as LB + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap + +-- | A type that is is not known and that is not meant to be exposed to the +-- user. +data UnknownType + +{-| Pretty printing for Aeson values (and deterministic output) +-} +pretty :: Value -> Text +pretty = T.pack . Char8.unpack . encodeDeterministicPretty + +-- | Produces a bytestring output of a JSON value that is deterministic +-- and that is invariant to the insertion order of the keys. +-- (i.e the keys are stored in alphabetic order) +-- This is to ensure that all id computations are stable and reproducible +-- on the server part. +-- TODO(kps) use everywhere JSON is converted +encodeDeterministicPretty :: Value -> LBS.ByteString +encodeDeterministicPretty = + encodePretty' (defConfig { confIndent = Spaces 0, confCompare = compare }) + +-- | group by +-- TODO: have a non-empty list instead +myGroupBy' :: (Ord b) => (a -> b) -> [a] -> [(b, [a])] +myGroupBy' f = map (f . head &&& id) + . groupBy ((==) `on` f) + . sortBy (compare `on` f) + +-- | group by +-- TODO: have a non-empty list instead +myGroupBy :: (Ord a) => [(a, b)] -> M.Map a [b] +myGroupBy l = let + l2 = myGroupBy' fst l in + M.map (snd <$>) $ M.fromList l2 + + +-- | Missing implementations in the code base. +missing :: (LB.HasCallStack) => Text -> a +missing msg = LB.error $ T.concat ["MISSING IMPLEMENTATION: ", msg] + +{-| The function that is used to trigger exception due to internal programming +errors. + +Currently, all programming errors simply trigger an exception. All these +impure functions are tagged with an implicit call stack argument. +-} +failure :: (LB.HasCallStack) => Text -> a +failure msg = LB.error (T.concat ["FAILURE in Spark. Hint: ", msg]) + +failure' :: (LB.HasCallStack) => Format Text (a -> Text) -> a -> c +failure' x = failure . sformat x + + +{-| Given a DataFrame or a LocalFrame, attempts to get the value, +or throws the error. + +This function is not total. +-} +forceRight :: (LB.HasCallStack, Show a) => Either a b -> b +forceRight (Right b) = b +forceRight (Left a) = LB.error $ + sformat ("Failure from either, got instead a left: "%shown) a + +-- | Force the complete evaluation of a list to WNF. +strictList :: (Show a) => [a] -> [a] +strictList [] = [] +strictList (h : t) = let !t' = strictList t in (h : t') + +-- | (internal) prints a hint with a value +traceHint :: (Show a) => Text -> a -> a +traceHint hint x = trace (T.unpack hint ++ show x) x + +-- | show with Text +show' :: (Show a) => a -> Text +show' x = T.pack (show x) + +withContext :: Text -> Either Text a -> Either Text a +withContext _ (Right x) = Right x +withContext msg (Left other) = Left (msg <> "\n>>" <> other) diff --git a/src/Spark/Core/Row.hs b/src/Spark/Core/Row.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Row.hs @@ -0,0 +1,14 @@ +module Spark.Core.Row( + module Spark.Core.Internal.RowStructures, + ToSQL, + FromSQL, + valueToCell, + cellToValue, + jsonToCell, + rowArray + ) where + +import Spark.Core.Internal.RowStructures +import Spark.Core.Internal.RowGenerics +import Spark.Core.Internal.RowGenericsFrom +import Spark.Core.Internal.RowUtils diff --git a/src/Spark/Core/StructuresInternal.hs b/src/Spark/Core/StructuresInternal.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/StructuresInternal.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Some basic structures about nodes in a graph, etc. + +module Spark.Core.StructuresInternal( + NodeName(..), + NodePath(..), + NodeId(..), + FieldName(..), + FieldPath(..), + ComputationID(..), + catNodePath, + fieldName, + unsafeFieldName, + emptyFieldPath, + nullFieldPath, + headFieldPath, + fieldPath, + prettyNodePath, +) where + +import qualified Data.Text as T +import Data.ByteString(ByteString) +import GHC.Generics (Generic) +import Data.Hashable(Hashable) +import Data.List(intercalate) +import qualified Data.Aeson as A +import Data.String(IsString(..)) +import Data.Vector(Vector) +import qualified Data.Vector as V + +import Spark.Core.Internal.Utilities + +-- | The name of a node (without path information) +newtype NodeName = NodeName { unNodeName :: T.Text } deriving (Eq, Ord) + +-- | The user-defined path of the node in the hierarchical representation of the graph. +newtype NodePath = NodePath { unNodePath :: Vector NodeName } deriving (Eq, Ord) + +-- | The unique ID of a node. It is based on the parents of the node +-- and all the relevant intrinsic values of the node. +newtype NodeId = NodeId { unNodeId :: ByteString } deriving (Eq, Ord, Generic) + +-- | The name of a field in a sql structure +-- This structure ensures that proper escaping happens if required. +-- TODO: prevent the constructor from being used, it should be checked first. +newtype FieldName = FieldName { unFieldName :: T.Text } deriving (Eq) + +-- | A path to a nested field an a sql structure. +-- This structure ensures that proper escaping happens if required. +newtype FieldPath = FieldPath { unFieldPath :: Vector FieldName } deriving (Eq) + +{-| A unique identifier for a computation (a batch of nodes sent for execution +to Spark). +-} +data ComputationID = ComputationID { + unComputationID :: !T.Text +} deriving (Eq, Show, Generic) + + + +-- | A safe constructor for field names that fixes all the issues relevant to +-- SQL escaping +-- TODO: proper implementation +fieldName :: T.Text -> Either String FieldName +fieldName = Right . FieldName + +-- | Constructs the field name, but will fail if the content is not correct. +unsafeFieldName :: (HasCallStack) => T.Text -> FieldName +unsafeFieldName = forceRight . fieldName + +-- | A safe constructor for field names that fixes all the issues relevant to SQL escaping +-- TODO: proper implementation +fieldPath :: T.Text -> Either String FieldPath +fieldPath x = Right . FieldPath . V.singleton $ FieldName x + +emptyFieldPath :: FieldPath +emptyFieldPath = FieldPath V.empty + +nullFieldPath :: FieldPath -> Bool +nullFieldPath = V.null . unFieldPath + +headFieldPath :: FieldPath -> Maybe FieldName +headFieldPath (FieldPath v) | V.null v = Nothing +headFieldPath (FieldPath v) = Just $ V.head v + +-- | The concatenated path. This is the inverse function of fieldPath. +-- | TODO: this one should be hidden? +catNodePath :: NodePath -> T.Text +catNodePath (NodePath np) = + T.intercalate "/" (unNodeName <$> V.toList np) + +prettyNodePath :: NodePath -> T.Text +-- Only a single slash, double slashes are reserved for the case +-- of global paths (including session and computation) +prettyNodePath np = "/" <> catNodePath np + +instance Show NodeId where + show (NodeId bs) = let s = show bs in + if length s > 9 then + (drop 1 . take 6) s ++ ".." + else + s + +instance Show NodeName where + show (NodeName nn) = T.unpack nn + +instance Show NodePath where + show np = T.unpack $ T.concat ["NPath(", catNodePath np, ")" ] + +instance Show FieldPath where + show (FieldPath l) = + intercalate "." (show <$> V.toList l) + +instance Show FieldName where + -- TODO(kps) escape the '.' characters in the field name + show (FieldName fn) = T.unpack fn + +instance Hashable NodeId + +instance IsString FieldName where + fromString = FieldName . T.pack + +instance A.ToJSON NodeName where + toJSON = A.toJSON . unNodeName + +instance A.FromJSON NodeName where + -- TODO: more parse checks + parseJSON x = NodeName <$> A.parseJSON x + +instance A.ToJSON NodePath where + toJSON = A.toJSON . unNodePath + +instance A.FromJSON NodePath where + parseJSON x = NodePath <$> A.parseJSON x + +instance A.ToJSON FieldName where + toJSON = A.toJSON . unFieldName + +instance A.ToJSON FieldPath where + toJSON = A.toJSON . unFieldPath + +instance Ord FieldName where + compare f1 f2 = compare (unFieldName f1) (unFieldName f2) + +instance A.ToJSON ComputationID where + toJSON = A.toJSON . unComputationID diff --git a/src/Spark/Core/Try.hs b/src/Spark/Core/Try.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Try.hs @@ -0,0 +1,51 @@ + +{-| +Useful classes and functions to deal with failures +within the Karps framework. + +This is a developer API. Users should not have to invoke functions +from this module. +-} +module Spark.Core.Try( + NodeError(..), + Try, + tryError, + tryEither + ) where + +import qualified Data.Text as T +import qualified Data.Vector as V + +import Spark.Core.StructuresInternal + +-- | An error associated to a particular node (an observable or a dataset). +data NodeError = Error { + ePath :: NodePath, + eMessage :: T.Text +} deriving (Eq, Show) + +-- | The common result of attempting to build something. +type Try = Either NodeError + + +-- TODO: rename to tryError +_error :: T.Text -> Try a +_error txt = Left Error { + ePath = NodePath V.empty, + eMessage = txt + } + +-- | Returns an error object given a text clue. +tryError :: T.Text -> Try a +tryError = _error + +-- | Returns an error object given a string clue. +--Remove this method +--tryError' :: String -> Try a +--tryError' = _error . T.pack + +-- | (internal) +-- Given a potentially errored object, converts it to a Try. +tryEither :: Either T.Text a -> Try a +tryEither (Left msg) = tryError msg +tryEither (Right x) = Right x diff --git a/src/Spark/Core/Types.hs b/src/Spark/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Spark/Core/Types.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Spark.Core.Types( + DataType, + Nullable(..), + TupleEquivalence(..), + NameTuple(..), + -- intType, + -- canNull, + -- noNull, + -- stringType, + -- arrayType', + -- cellType, + -- structField, + -- structType, + -- arrayType, + SQLType, + columnType, + SQLTypeable, + buildType, + StructField, + StructType, + -- castType, + catNodePath, + unSQLType +) where + +import Spark.Core.Internal.TypesStructures +import Spark.Core.Internal.TypesGenerics +import Spark.Core.Internal.TypesFunctions +import Spark.Core.StructuresInternal +import Spark.Core.Internal.FunctionsInternals(TupleEquivalence(..), NameTuple(..)) + +-- | Description of types supported in DataSets +-- Karps supports a restrictive subset of Algebraic Datatypes that is amenable to SQL +-- transformations. This file contains the description of all the supported types, and some +-- conversion tools. diff --git a/src/Spark/IO/Inputs.hs b/src/Spark/IO/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Spark/IO/Inputs.hs @@ -0,0 +1,14 @@ + +module Spark.IO.Inputs( + SparkPath, + JsonMode, + DataSchema, + JsonOptions, + SourceDescription, + json', + json, + jsonInfer +) where + +import Spark.IO.Internal.Json +import Spark.IO.Internal.InputGeneric diff --git a/src/Spark/IO/Internal/InputGeneric.hs b/src/Spark/IO/Internal/InputGeneric.hs new file mode 100644 --- /dev/null +++ b/src/Spark/IO/Internal/InputGeneric.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.IO.Internal.InputGeneric( + SparkPath(..), + DataSchema(..), + InputOptionValue(..), + InputOptionKey(..), + DataFormat(..), + SourceDescription(..), + generic', + genericWithSchema', + genericWithSchema +) where + +import Data.Text(Text) +import Data.String(IsString(..)) +import qualified Data.Map.Strict as M +import qualified Data.Aeson as A +import qualified Data.Text as T +import Data.Aeson(toJSON, (.=)) +-- import Debug.Trace + +import Spark.Core.Types +import Spark.Core.Context +import Spark.Core.Try +import Spark.Core.Dataset + +import Spark.Core.Internal.Utilities(forceRight) +import Spark.Core.Internal.DatasetFunctions(asDF, emptyDataset, emptyLocalData) +import Spark.Core.Internal.TypesStructures(SQLType(..)) +import Spark.Core.Internal.OpStructures + +{-| A path to some data that can be read by Spark. +-} +newtype SparkPath = SparkPath Text deriving (Show, Eq) + +{-| The schema policty with respect to a data source. It should either +request Spark to infer the schema from the source, or it should try to +match the source against a schema provided by the user. +-} +data DataSchema = InferSchema | UseSchema DataType deriving (Show, Eq) + +{-| The low-level option values accepted by the Spark reader API. +-} +data InputOptionValue = + InputIntOption Int + | InputDoubleOption Double + | InputStringOption Text + | InputBooleanOption Bool + deriving (Eq, Show) + +instance A.ToJSON InputOptionValue where + toJSON (InputIntOption i) = toJSON i + toJSON (InputDoubleOption d) = toJSON d + toJSON (InputStringOption s) = toJSON s + toJSON (InputBooleanOption b) = toJSON b + +newtype InputOptionKey = InputOptionKey { unInputOptionKey :: Text } deriving (Eq, Show, Ord) + +{-| The type of the source. + +This enumeration contains all the data formats that are natively supported by +Spark, either for input or for output, and allows the users to express their +own format if requested. +-} +data DataFormat = + JsonFormat + | TextFormat + | CsvFormat + | CustomSourceFormat !Text + deriving (Eq, Show) +-- data InputSource = JsonSource | TextSource | CsvSource | InputSource SparkPath + +{-| A description of a data source, following Spark's reader API version 2. + +Eeach source constists in an input source (json, xml, etc.), an optional schema +for this source, and a number of options specific to this source. + +Since this descriptions is rather low-level, a number of wrappers of provided +for each of the most popular sources that are already built into Spark. +-} +data SourceDescription = SourceDescription { + inputPath :: !SparkPath, + inputSource :: !DataFormat, + inputSchema :: !DataSchema, + sdOptions :: !(M.Map InputOptionKey InputOptionValue), + inputStamp :: !(Maybe DataInputStamp) +} deriving (Eq, Show) + +instance IsString SparkPath where + fromString = SparkPath . T.pack + +{-| Generates a dataframe from a source description. + +This may trigger some calculations on the Spark side if schema inference is +required. +-} +generic' :: SourceDescription -> SparkState DataFrame +generic' sd = do + dtt <- _inferSchema sd + return $ dtt >>= \dt -> genericWithSchema' dt sd + +{-| Generates a dataframe from a source description, and assumes a given schema. + +This schema overrides whatever may have been given in the source description. If +the source description specified that the schema must be checked or inferred, +this instruction is overriden. + +While this is convenient, it may lead to runtime errors that are hard to +understand if the data does not follow the given schema. +-} +genericWithSchema' :: DataType -> SourceDescription -> DataFrame +genericWithSchema' dt sd = asDF $ emptyDataset no (SQLType dt) where + sd' = sd { inputSchema = UseSchema dt } + so = StandardOperator { + soName = "org.spark.GenericDatasource", + soOutputType = dt, + soExtra = A.toJSON sd' + } + no = NodeDistributedOp so + +{-| Generates a dataframe from a source description, and assumes a certain +schema on the source. +-} +genericWithSchema :: forall a. (SQLTypeable a) => SourceDescription -> Dataset a +genericWithSchema sd = + let sqlt = buildType :: SQLType a + dt = unSQLType sqlt in + forceRight $ castType sqlt =<< genericWithSchema' dt sd + +-- Wraps the action of inferring the schema. +-- This is not particularly efficient here: it does a first pass to get the +-- schema, and then will do a second pass in order to read the data. +_inferSchema :: SourceDescription -> SparkState (Try DataType) +_inferSchema = executeCommand1 . _inferSchemaCmd + +-- TODO: this is a monoidal operation, it could be turned into a universal +-- aggregator. +_inferSchemaCmd :: SourceDescription -> LocalData DataType +_inferSchemaCmd sd = emptyLocalData no sqlt where + sqlt = buildType :: SQLType DataType + dt = unSQLType sqlt + so = StandardOperator { + soName = "org.spark.InferSchema", + soOutputType = dt, + soExtra = A.toJSON sd + } + no = NodeOpaqueAggregator so + +instance A.ToJSON SparkPath where + toJSON (SparkPath p) = toJSON p + +instance A.ToJSON DataSchema where + toJSON InferSchema = "infer_schema" + toJSON (UseSchema dt) = toJSON dt + +instance A.ToJSON DataFormat where + toJSON JsonFormat = "json" + toJSON TextFormat = "text" + toJSON CsvFormat = "csv" + toJSON (CustomSourceFormat s) = toJSON s + +instance A.ToJSON SourceDescription where + toJSON sd = A.object [ + "inputPath" .= toJSON (inputPath sd), + "inputSource" .= toJSON (inputSource sd), + "inputSchema" .= toJSON (inputSchema sd), + "inputStamp" .= A.Null, + "options" .= A.object (f <$> M.toList (sdOptions sd)) + ] where + f (k, v) = unInputOptionKey k .= toJSON v diff --git a/src/Spark/IO/Internal/Json.hs b/src/Spark/IO/Internal/Json.hs new file mode 100644 --- /dev/null +++ b/src/Spark/IO/Internal/Json.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Spark.IO.Internal.Json( + JsonMode, + JsonOptions(..), + json', + json, + jsonInfer, + jsonOpt', + jsonOpt, + defaultJsonOptions +) where + +import qualified Data.Map.Strict as M +import Data.Text(pack) + + +import Spark.Core.Types +import Spark.Core.Dataset(DataFrame, Dataset, castType') +import Spark.Core.Context +import Spark.Core.Try + +import Spark.IO.Internal.InputGeneric + +{-| +-} +data JsonMode = Permissive | DropMalformed | FailFast + +{-| The options for the json input. +-} +data JsonOptions = JsonOptions { + mode :: !JsonMode, + jsonSchema :: !DataSchema +} + + +{-| Declares a source of data of the given data type. + +The source is not read at this point, it is just declared. It may be found to be +invalid in subsequent computations. +-} +json' :: DataType -> String -> DataFrame +json' dt p = genericWithSchema' dt (_jsonSourceDescription (SparkPath (pack p)) defaultJsonOptions) + +{-| Declares a source of data of the given data type. + +The source is not read at this point, it is just declared. +-} +json :: (SQLTypeable a) => String -> Dataset a +json p = genericWithSchema (_jsonSourceDescription (SparkPath (pack p)) defaultJsonOptions) + +{-| Reads a source of data expected to be in the JSON format. + +The schema is not required and Spark will infer the schema of the source. +However, all the data contained in the source may end up being read in the +process. +-} +jsonInfer :: SparkPath -> SparkState DataFrame +jsonInfer = jsonOpt' defaultJsonOptions + +{-| Reads a source of data expected to be in the JSON format. + +The schema is not required and Spark will infer the schema of the source. +However, all the data contained in the source may end up being read in the +process. +-} +jsonOpt' :: JsonOptions -> SparkPath -> SparkState DataFrame +jsonOpt' jo sp = generic' (_jsonSourceDescription sp jo) + +{-| Reads a source of data expected to be in the JSON format. + +The schema is not required and Spark will infer the schema of the source. +However, all the data contained in the source may end up being read in the +process. +-} +jsonOpt :: forall a. (SQLTypeable a) => JsonOptions -> SparkPath -> SparkState (Try (Dataset a)) +jsonOpt jo sp = + let sqlt = buildType :: SQLType a + dt = unSQLType sqlt + jo' = jo { jsonSchema = UseSchema dt } + in castType' sqlt <$> jsonOpt' jo' sp + +defaultJsonOptions :: JsonOptions +defaultJsonOptions = JsonOptions { + -- Fail fast by default, to be conservative about errors, + -- and respect the strictness arguments. + mode = FailFast, + jsonSchema = InferSchema +} + +_jsonSourceDescription :: SparkPath -> JsonOptions -> SourceDescription +_jsonSourceDescription sp jo = SourceDescription { + inputSource = JsonFormat, + inputPath = sp, + inputSchema = jsonSchema jo, + sdOptions = _jsonOptions jo, + inputStamp = Nothing +} + +_jsonOptions :: JsonOptions -> M.Map InputOptionKey InputOptionValue +_jsonOptions jo = M.fromList [(InputOptionKey "mode", _mode (mode jo))] + +_mode :: JsonMode -> InputOptionValue +_mode Permissive = InputStringOption "PERMISSIVE" +_mode DropMalformed = InputStringOption "DROPMALFORMED" +_mode FailFast = InputStringOption "FAILFAST" diff --git a/src/Spark/IO/Internal/OutputCommon.hs b/src/Spark/IO/Internal/OutputCommon.hs new file mode 100644 --- /dev/null +++ b/src/Spark/IO/Internal/OutputCommon.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Spark.IO.Internal.OutputCommon( + SaveMode(..), + OutputBucket, + DynOutputBucket, + OutputPartition, + DynOutputPartition, + SavingDescription(..), + partition, + partition', + bucket, + bucket', + saveDefaults, + saveCol +) where + +-- import Data.Text(Text) +-- import qualified Data.Map.Strict as M +-- import qualified Data.Aeson as A +-- import Data.Aeson(toJSON, (.=)) + +-- import Spark.Core.Types +-- import Spark.Core.Context +import Spark.Core.Try +import Spark.Core.Column +-- import Spark.Core.ColumnFunctions +-- import Spark.Core.Row +import Spark.Core.Dataset + +import Spark.Core.Internal.ColumnStructures(UnknownReference, UntypedColumnData) +import Spark.Core.Internal.ColumnFunctions(dropColReference) +import Spark.Core.Internal.Utilities +import Spark.IO.Internal.InputGeneric + +{-| The mode when saving the data. +-} +data SaveMode = + Overwrite + | Append + | Ignore + | ErrorIfExists deriving(Eq, Show) + +data OutputPartition ref = OutputPartition UntypedColumnData + +type DynOutputPartition = Try (OutputPartition UnknownReference) + +data OutputBucket ref = OutputBucket UntypedColumnData + +type DynOutputBucket = Try (OutputBucket UnknownReference) + +partition :: Column ref a -> OutputPartition ref +partition = OutputPartition . dropColType . dropColReference + +partition' :: DynColumn -> DynOutputPartition +partition' = fmap partition + +bucket :: Column ref a -> OutputBucket ref +bucket = OutputBucket . dropColType . dropColReference + +bucket' :: DynColumn -> DynOutputBucket +bucket' = fmap bucket + + +data SavingDescription ref a = SavingDescription { + partitions :: ![OutputPartition ref], + buckets :: ![OutputBucket ref], + savedCol :: !(Column ref a), + saveFormat :: !DataFormat, + savePath :: !SparkPath +} + +saveDefaults :: SparkPath -> DataFormat -> Column ref a -> SavingDescription ref a +saveDefaults sp f c = SavingDescription { + partitions = [], + buckets = [], + savedCol = c, + saveFormat = f, + savePath = sp +} + +{-| Inserts an action to store the given dataframe in the graph of computations. + +NOTE: Because of some limitations in Spark, all the columns used when forming +the buckets and the parttions must be present inside the column being written. +These columns will be appended to the column being written if they happen to be +missing. The consequence is that more data may be written than expected. + +It returns true if the update was successful. The return type is subject to + change. +-} +saveCol :: SavingDescription ref a -> LocalData Bool +saveCol _ = missing "saveCol" + +-- test :: Int +-- test = +-- let c = undefined :: Column Int Int +-- ld = saveCol (saveDefaults undefined JsonFormat c) { partitions = [partition c, partition c] } +-- in 3 +-- +-- repeatDS :: Column ref Int -> Column ref a -> Dataset a +-- +-- repeatFast :: Column ref Int -> Column ref a -> Dataset a +-- +-- repeatScatter :: Int -> Column ref Int -> Column ref a -> Dataset a diff --git a/test-integration/Spark/Core/CachingSpec.hs b/test-integration/Spark/Core/CachingSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/CachingSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.CachingSpec where + +import Test.Hspec +import qualified Data.Text + +import Spark.Core.Context +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.ColumnFunctions +import Spark.Core.StructuresInternal(ComputationID(..)) + + +-- Collecting a dataset made from a list should yield the same list (modulo +-- some reordering) +collectIdempotent :: [Int] -> IO () +collectIdempotent l = do + -- stats <- computationStatsDef (ComputationID "0") + -- print "STATS" + -- print (show stats) + let ds = dataset l + let ds' = autocache ds + let c1 = asCol ds' + let s1 = sumCol c1 + let s2 = count ds' + let x = s1 + s2 + l2 <- exec1Def x + l2 `shouldBe` (sum l + length l) + +run :: String -> IO () -> SpecWith (Arg (IO ())) +run s f = it s $ do + createSparkSessionDef $ defaultConf { confRequestedSessionName = Data.Text.pack s } + f + -- This is horribly not robust to any sort of failure, but it will do for now + -- TODO(kps) make more robust + closeSparkSessionDef + return () + +spec :: Spec +spec = do + describe "Integration test - caching on ints" $ do + run "cache_sum1" $ + collectIdempotent ([1,2,3] :: [Int]) diff --git a/test-integration/Spark/Core/CollectSpec.hs b/test-integration/Spark/Core/CollectSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/CollectSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.CollectSpec where + +import Test.Hspec +import qualified Data.Text +import Data.List(sort) + +import Spark.Core.Context +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.IntegrationUtilities +import Spark.Core.Internal.Utilities + + +-- Collecting a dataset made from a list should yield the same list (modulo +-- some reordering) +-- TODO: replace the ordering by the canonical ordering over the data +collectIdempotent :: (Ord a, Eq a, Show a, SQLTypeable a, ToSQL a, FromSQL a) => [a] -> IO () +collectIdempotent l = do + let ds = dataset l + l2 <- exec1Def $ collect (asCol ds) + l2 `shouldBe` sort l + +run :: String -> IO () -> SpecWith (Arg (IO ())) +run s f = it s $ do + createSparkSessionDef $ defaultConf { confRequestedSessionName = Data.Text.pack s } + f + -- This is horribly not robust to any sort of failure, but it will do for now + -- TODO(kps) make more robust + closeSparkSessionDef + return () + +spec :: Spec +spec = do + describe "Integration test - collect on ints" $ do + run "running_twice" $ do + let ds = dataset [1::Int,2] + let c = traceHint "c=" $ collect (asCol ds) + l2 <- exec1Def $ c + l2' <- exec1Def $ collect (asCol ds) + l2 `shouldBe` l2' + run "empty_ints1" $ + collectIdempotent ([] :: [Int]) + run "ints1" $ + collectIdempotent ([4,5,1,2,3] :: [Int]) + run "ints1_opt" $ + collectIdempotent ([Just 1, Nothing] :: [Maybe Int]) + run "nothing_ints_opt" $ + collectIdempotent ([Nothing] :: [Maybe Int]) + run "ints1_opt" $ + collectIdempotent ([Just 1, Just 2] :: [Maybe Int]) + run "empty_ints_opt" $ + collectIdempotent ([] :: [Maybe Int]) + describe "Integration test - collect on TestStruct5" $ do + run "empty_TestStruct5" $ + collectIdempotent ([] :: [TestStruct5]) + run "single_TestStruct5" $ + collectIdempotent ([TestStruct5 1 2] :: [TestStruct5]) diff --git a/test-integration/Spark/Core/ColumnSpec.hs b/test-integration/Spark/Core/ColumnSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/ColumnSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.ColumnSpec where + +import Test.Hspec +import Data.List.NonEmpty(NonEmpty( (:|) )) + +import Spark.Core.Context +import Spark.Core.Dataset +import Spark.Core.Column +import Spark.Core.Row +import Spark.Core.Functions +import Spark.Core.ColumnFunctions +import Spark.Core.SimpleAddSpec(run) +import Spark.Core.Internal.LocalDataFunctions(iPackTupleObs) +import Spark.Core.Internal.DatasetFunctions(untypedLocalData) + +myScaler :: Column ref Double -> Column ref Double +myScaler col = + let cnt = asDouble (countCol col) + m = sumCol col / cnt + centered = col .- m + stdDev = sumCol (centered * centered) / cnt + in centered ./ stdDev + + +spec :: Spec +spec = do + describe "local data operations" $ do + run "broadcastPair_struct" $ do + let ds = dataset [1] :: Dataset Int + let cnt = countCol (asCol ds) + let c = collect (asCol ds .+ cnt) + res <- exec1Def c + res `shouldBe` [2] + run "LocalPack (doubles)" $ do + let x = untypedLocalData (1 :: LocalData Double) + let x2 = iPackTupleObs (x :| [x]) + res <- exec1Def x2 + res `shouldBe` rowArray [DoubleElement 1, DoubleElement 1] + run "LocalPack" $ do + let x = untypedLocalData (1 :: LocalData Int) + let x2 = iPackTupleObs (x :| [x]) + res <- exec1Def x2 + res `shouldBe` rowArray [IntElement 1, IntElement 1] + run "BroadcastPair" $ do + let x = 1 :: LocalData Int + let ds = dataset [2, 3] :: Dataset Int + let ds2 = broadcastPair ds x + res <- exec1Def (collect (asCol ds2)) + res `shouldBe` [(2, 1), (3, 1)] + -- TODO: this combines a lot of elements together. + describe "columns - integration" $ do + run "mean" $ do + let ds = dataset [-1, 1] :: Dataset Double + let c = myScaler (asCol ds) + res <- exec1Def (collect c) + res `shouldBe` [-1, 1] diff --git a/test-integration/Spark/Core/GroupsSpec.hs b/test-integration/Spark/Core/GroupsSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/GroupsSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.GroupsSpec where + +import Test.Hspec +import Data.Text(Text) + +import Spark.Core.Context +import Spark.Core.Functions +import Spark.Core.ColumnFunctions +import Spark.Core.Column +import Spark.Core.IntegrationUtilities +import Spark.Core.CollectSpec(run) +import Spark.Core.Internal.Groups + +sumGroup :: [MyPair] -> [(Text, Int)] -> IO () +sumGroup l lexp = do + let ds = dataset l + let keys = ds // myKey' + let values = ds // myVal' + let g = groupByKey keys values + let ds2 = g `aggKey` sumCol + l2 <- exec1Def $ collect (asCol ds2) + l2 `shouldBe` lexp + +spec :: Spec +spec = do + describe "Integration test - groups on (text, int)" $ do + run "empty" $ + sumGroup [] [] + run "one" $ + sumGroup [MyPair "x" 1] [("x", 1)] + run "two" $ + sumGroup [MyPair "x" 1, MyPair "x" 2, MyPair "y" 1] [("x", 3), ("y", 1)] diff --git a/test-integration/Spark/Core/IntegrationUtilities.hs b/test-integration/Spark/Core/IntegrationUtilities.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/IntegrationUtilities.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Spark.Core.IntegrationUtilities where + +import GHC.Generics (Generic) +import Data.Text(Text) +import Data.Aeson(ToJSON) + +import Spark.Core.Context +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Column + +data TestStruct1 = TestStruct1 { + ts1f1 :: Int, + ts1f2 :: Maybe Int } deriving (Show, Eq, Generic) +instance ToSQL TestStruct1 +instance FromSQL TestStruct1 +instance SQLTypeable TestStruct1 + +data TestStruct2 = TestStruct2 { + ts2f1 :: [Int] +} deriving (Show, Generic) +instance SQLTypeable TestStruct2 + +data TestStruct3 = TestStruct3 { + ts3f1 :: Int +} deriving (Show, Eq, Generic) +instance ToSQL TestStruct3 +instance SQLTypeable TestStruct3 + +data TestStruct4 = TestStruct4 { + ts4f1 :: TestStruct3 +} deriving (Show, Eq, Generic) + +data TestStruct5 = TestStruct5 { + ts5f1 :: Int, + ts5f2 :: Int +} deriving (Show, Eq, Generic, Ord) +-- instance ToJSON TestStruct5 +instance SQLTypeable TestStruct5 +instance FromSQL TestStruct5 +instance ToSQL TestStruct5 + +data TestStruct6 = TestStruct6 { + ts6f1 :: Int, + ts6f2 :: Int, + ts6f3 :: TestStruct3 +} deriving (Show, Eq, Generic) + +data TestStruct7 = TestStruct7 { + ts7f1 :: Text +} deriving (Show, Eq, Generic) +instance ToSQL TestStruct7 +instance SQLTypeable TestStruct7 +instance ToJSON TestStruct7 + +newtype TestT1 = TestT1 { + unTestT1 :: Int +} deriving (Eq, Show, Generic, Num) + +data MyPair = MyPair { + myKey :: Text, + myVal :: Int } deriving (Generic, Show) + +myKey' :: StaticColProjection MyPair Text +myKey' = unsafeStaticProjection buildType "myKey" +myVal' :: StaticColProjection MyPair Int +myVal' = unsafeStaticProjection buildType "myVal" +instance SQLTypeable MyPair +instance ToSQL MyPair diff --git a/test-integration/Spark/Core/JoinsSpec.hs b/test-integration/Spark/Core/JoinsSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/JoinsSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.JoinsSpec where + +import Test.Hspec + +import Spark.Core.Context +import Spark.Core.Dataset +import Spark.Core.Column +import Spark.Core.ColumnFunctions +import Spark.Core.Row +import Spark.Core.Functions +import Spark.Core.SimpleAddSpec(run) + +spec :: Spec +spec = do + describe "Path test" $ do + run "test_path1" $ do + let ds1 = dataset [1] :: Dataset Int + let x1 = sumCol (asCol ds1) @@ "x1" + let x2 = ((x1 + 1) @@ "x2") `logicalParents` [untyped ds1] + res <- exec1Def x2 + res `shouldBe` 2 + -- describe "Join test - join on ints" $ do + -- run "empty_ints1" $ do + -- let ds1 = dataset [(1,2)] :: Dataset (Int, Int) + -- let ds2 = dataset [(1,3)] :: Dataset (Int, Int) + -- let df1 = asDF ds1 + -- let df2 = asDF ds2 + -- let df = joinInner' (df1/-"_1") (df1/-"_2") (df2/-"_1") (df2/-"_2" @@ "_3") + -- res <- exec1Def' (collect' (asCol' df)) + -- res `shouldBe` rowArray [rowArray [IntElement 1, IntElement 2, IntElement 3]] diff --git a/test-integration/Spark/Core/PruningSpec.hs b/test-integration/Spark/Core/PruningSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/PruningSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.PruningSpec where + +import Test.Hspec +import qualified Data.Text as T +import Data.List(sort) + +import Spark.Core.Context +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.IntegrationUtilities +import Spark.Core.CollectSpec(run) + +run2 :: T.Text -> IO () -> SpecWith (Arg (IO ())) +run2 s f = it (T.unpack s) $ do + createSparkSessionDef $ defaultConf { + confRequestedSessionName = s, + confUseNodePrunning = True } + f + -- This is horribly not robust to any sort of failure, but it will do for now + -- TODO(kps) make more robust + closeSparkSessionDef + return () + + +spec :: Spec +spec = do + describe "Integration test - pruning" $ do + run2 "running_twice" $ do + let ds = dataset [1::Int,2] + l2 <- exec1Def $ collect (asCol ds) + l2' <- exec1Def $ collect (asCol ds) + l2 `shouldBe` l2' diff --git a/test-integration/Spark/Core/SimpleAddSpec.hs b/test-integration/Spark/Core/SimpleAddSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/Core/SimpleAddSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.SimpleAddSpec where + +import Test.Hspec +import qualified Data.Text + +import Spark.Core.Context +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Functions + + +smallSum :: (Eq a, Show a, SQLTypeable a, ToSQL a, FromSQL a, Num a) => a -> a -> IO () +smallSum x y = do + let x' = constant x + let y' = constant y + let z1' = x' + y' + z1 <- exec1Def z1' + z1 `shouldBe` (x + y) + let z2' = y' + x' + z2 <- exec1Def z2' + z2 `shouldBe` (x + y) + +negation :: (Eq a, Show a, SQLTypeable a, ToSQL a, FromSQL a, Num a) => a -> a -> IO () +negation x y = do + let x' = constant x + let y' = constant y + let z1' = x' - y' + z1 <- exec1Def z1' + z1 `shouldBe` (x - y) + let z2' = y' - x' + z2 <- exec1Def z2' + z2 `shouldBe` (y - x) + +checkNegate :: (Eq a, Show a, SQLTypeable a, ToSQL a, FromSQL a, Num a) => a -> IO () +checkNegate x = do + let x' = constant x + let z1' = negate x' + z1 <- exec1Def z1' + z1 `shouldBe` negate x + +run :: String -> IO () -> SpecWith (Arg (IO ())) +run s f = it s $ do + createSparkSessionDef $ defaultConf { + confRequestedSessionName = Data.Text.pack s, + confPollingIntervalMillis = 100, + confUseNodePrunning = False } -- Disabling caching for now, it causes issues. + f + -- This is horribly not robust to any sort of failure, but it will do for now + -- TODO(kps) make more robust + closeSparkSessionDef + return () + +spec :: Spec +spec = do + describe "Integration test - sum on ints" $ do + run "empty_ints1" $ + smallSum (1 :: Int) (2 :: Int) + run "zero_ints1" $ + smallSum (0 :: Int) (2 :: Int) + run "negation_ints1" $ + negation (1 :: Int) (2 :: Int) + run "negate_ints1" $ + checkNegate (1 :: Int) diff --git a/test-integration/Spark/IO/JsonSpec.hs b/test-integration/Spark/IO/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/IO/JsonSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.IO.JsonSpec where + +import Test.Hspec +import Data.Aeson(encode) +import qualified Data.ByteString.Lazy +-- import System.IO + +import Spark.Core.Context +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Functions +import Spark.Core.Column +import Spark.IO.Inputs +import Spark.Core.IntegrationUtilities +import Spark.Core.SimpleAddSpec(run) + +spec :: Spec +spec = do + describe "Read a json file" $ do + run "simple read" $ do + let xs = [TestStruct7 "x"] + let js = encode xs + _ <- Data.ByteString.Lazy.writeFile "/tmp/x.json" js + let dt = unSQLType (buildType :: SQLType TestStruct7) + let df = json' dt "/tmp/x.json" + let c = collect' (asCol' df) + c1 <- exec1Def' c + c1 `shouldBe` rowArray [rowArray [StringElement "x"]] + c2 <- exec1Def' c + c2 `shouldBe` rowArray [rowArray [StringElement "x"]] + run "simple inference" $ do + let xs = [TestStruct7 "x"] + let js = encode xs + _ <- Data.ByteString.Lazy.writeFile "/tmp/x.json" js + df <- execStateDef $ jsonInfer "/tmp/x.json" + let c = collect' (asCol' df) + c1 <- exec1Def' c + c1 `shouldBe` rowArray [rowArray [StringElement "x"]] diff --git a/test-integration/Spark/IO/StampSpec.hs b/test-integration/Spark/IO/StampSpec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spark/IO/StampSpec.hs @@ -0,0 +1,28 @@ +{- +let s = "s" + +createSparkSessionDef $ defaultConf { confRequestedSessionName = Data.Text.pack s } + +execStateDef (checkDataStamps [HdfsPath (Data.Text.pack "/tmp/")]) + +-} + +module Spark.IO.StampSpec where + +import Test.Hspec + +-- import Spark.Core.Context +-- import Spark.Core.Types +-- import Spark.Core.Row +-- import Spark.Core.Functions +-- import Spark.Core.Column +-- import Spark.IO.Inputs +-- import Spark.Core.IntegrationUtilities +import Spark.Core.SimpleAddSpec(run) + +spec :: Spec +spec = do + describe "Read a json file" $ do + run "simple read" $ do + let x = 1 :: Int + x `shouldBe` x diff --git a/test-integration/Spec.hs b/test-integration/Spec.hs new file mode 100644 --- /dev/null +++ b/test-integration/Spec.hs @@ -0,0 +1,2 @@ +-- Not working??? +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Spark/Core/ColumnSpec.hs b/test/Spark/Core/ColumnSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/ColumnSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.ColumnSpec where + +import Test.Hspec + +import Spark.Core.Column +import Spark.Core.Dataset +import Spark.Core.Functions +import Spark.Core.Types +import Spark.Core.ColumnFunctions +import Spark.Core.Internal.Utilities + +data Z +data Y + +myScaler :: Column ref Double -> Column ref Double +myScaler col = + let cnt = asDouble (countCol col) + m = sumCol col / cnt + centered = col .- m + stdDev = sumCol (centered * centered) / cnt + in centered ./ stdDev + + +spec :: Spec +spec = do + describe "ColumnSpec: ensure rules compile correctly" $ do + let ds = dataset [(1,2)] :: Dataset (Int, Int) + let c1 = ds // _1 + let c2 = ds // _2 + let c1' = untypedCol c1 + let c2' = untypedCol c2 + let i1 = 3 :: Int + let o1 = constant 4 :: LocalData Int + let o2 = 5 :: LocalData Int + let o1' = asLocalObservable o1 + let o2' = asLocalObservable o2 + it "+ should not blow up" $ do + let z1 = c1 + c2 + let z2 = c1' + c2' + let z3 = c1 + 1 + let z4 = 1 + c1 + 'a' `shouldBe` 'a' + it ".+ should not blow up with colums" $ do + let z1 = c1 .+ c2 + let z2 = c1' .+ c2' + let z3 = c1 .+ c2' + let z4 = c1' .+ c2 + let z5 = c1 .+ o1 + let z6 = c1 .+ o1' + 'a' `shouldBe` 'a' + it "simple aggregations" $ do + let c3 = c1 + (c2 .+ sumCol c2) + let ds2 = pack1 c3 + nodeType ds2 `shouldBe` (buildType :: SQLType Int) + it "mean" $ do + let ds' = dataset [1, 2] :: Dataset Double + let c = asCol ds' + let cnt = asDouble (countCol c) + let m = traceHint "m=" $ sumCol c / cnt + let centered = c .- m + let stdDev = sumCol (centered * centered) / cnt + let scaled = traceHint "scaled=" $ centered ./ stdDev + let ds2 = pack1 scaled + nodeType ds2 `shouldBe` (buildType :: SQLType Double) diff --git a/test/Spark/Core/ContextSpec.hs b/test/Spark/Core/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/ContextSpec.hs @@ -0,0 +1,17 @@ + + +module Spark.Core.ContextSpec where + +import Test.Hspec + +import Spark.Core.Functions + +spec :: Spec +spec = do + describe "Basic routines to get something out" $ do + it "should print a node" $ do + let x = dataset ([1 ,2, 3, 4]::[Int]) + x `shouldBe` x + -- b = nodeToBundle (untyped x) in + -- trace (pretty b) $ + -- 1 `shouldBe` 1 diff --git a/test/Spark/Core/DatasetSpec.hs b/test/Spark/Core/DatasetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/DatasetSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.DatasetSpec where + +import qualified Data.Text as T +import Test.Hspec +import qualified Data.Vector as V + +import Spark.Core.Dataset +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.StructuresInternal +import Spark.Core.Internal.ContextInternal +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.ComputeDag + +nName :: String -> NodeName +nName = NodeName . T.pack + +spec :: Spec +spec = do + describe "create a dataframe" $ do + it "should not explode" $ + let x = dataset ([1 ,2, 3, 4]::[Int]) in + nodeName x `shouldBe` nName "distributedliteral_c87697" + + it "renaming should work" $ + let x = dataset ([1 ,2, 3]::[Int]) @@ "ds1" in + nodeName x `shouldBe` nName "ds1" + + describe "check localset" $ do + it "should not explode" $ + let x = dataset ([1 ,2, 3]::[Int]) in + nodeName x `shouldBe` nName "distributedliteral_1ba31e" + + it "renaming should work" $ + let x = dataset ([1 ,2, 3]::[Int]) @@ "ds1" in + nodeName x `shouldBe` nName "ds1" + + describe "column syntax" $ + it "should not explode" $ do + let ds = dataset ([1 ,2, 3]::[Int]) + let c1 = ds/-"c1" + c1 `shouldBe` c1 + + describe "Logical dependencies" $ do + it "should work" $ do + let ds = dataset ([1 ,2, 3, 4]::[Int]) + let ds1 = dataset ([1]::[Int]) `depends` [untyped ds] + let g = traceHint (T.pack "g=") $ computeGraphToGraph $ forceRight $ buildComputationGraph ds1 + V.length (gVertices g) `shouldBe` 2 + + +-- describe "simple test" $ do +-- it "the type should match" $ do +-- let +-- n1 = constant "xxx" +-- n = NodeType $ T.pack "org.spark.Constant" in +-- (nodeOp n1) `shouldBe` n + +-- it "no name" $ do +-- let n1 = constant "xxx" +-- t = NodeName $ T.pack "org.spark.Constant" in +-- (nodeName n1) `shouldBe` t + +-- it "some name" $ do +-- let n1 = constant "xxx" @@ "name" +-- t = NodeName $ T.pack "name" in +-- (nodeName n1) `shouldBe` t diff --git a/test/Spark/Core/Internal/CachingSpec.hs b/test/Spark/Core/Internal/CachingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/CachingSpec.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.Internal.CachingSpec where + +import Test.Hspec + +import qualified Data.ByteString.Char8 as C8 +import Data.Either(isLeft, isRight) +import Control.Arrow((&&&)) +import Data.Text(Text) +import Data.Foldable(toList) +import Formatting + +import Spark.Core.Try +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.ColumnFunctions +import Spark.Core.Internal.Caching +-- Required for instance resolution +import Spark.Core.StructuresInternal() +import Spark.Core.Internal.Client(LocalSessionId(..)) +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.ContextStructures +import Spark.Core.Internal.ContextInternal +import Spark.Core.Internal.Pruning(emptyNodeCache) + +data TestType = AutocacheNode | CacheNode | UncacheNode | Dataset | Row deriving (Eq, Show) + +data TestNode = TestNode { tnId :: VertexId, tnType :: TestType, tnParents :: [(StructureEdge, TestNode)] } deriving (Eq) + +instance Show TestNode where + show v = "TestNode(" ++ (C8.unpack . unVertexId. tnId $ v) ++ ")" + +nid :: String -> VertexId +nid = VertexId . C8.pack + +node :: String -> TestType -> [TestNode] -> TestNode +node s tp p = TestNode (VertexId (C8.pack s)) tp ((const ParentEdge &&& id) <$> p) + +instance GraphVertexOperations TestNode where + vertexToId = tnId + expandVertexAsVertices x = snd <$> tnParents x + +instance GraphOperations TestNode StructureEdge where + expandVertex tn = tnParents tn + +acGen :: AutocacheGen TestNode +acGen = + let deriveUncache' (Vertex (VertexId x) (TestNode _ AutocacheNode _)) = + let vid' = VertexId $ C8.pack . (++ "_uncache") . C8.unpack $ x + in Vertex vid' (TestNode vid' UncacheNode []) + deriveUncache' x = error (show x) + deriveIdentity' (Vertex (VertexId x) (TestNode _ r _)) = + let vid' = VertexId $ C8.pack . (++ "_identity") . C8.unpack $ x + in Vertex vid' (TestNode vid' r []) + in AutocacheGen { + deriveUncache = deriveUncache', + deriveIdentity = deriveIdentity' + } + +expandFun :: TestNode -> CacheTry NodeCachingType +expandFun n = case (tnType n, tnParents n) of + (AutocacheNode, [_]) -> pure $ AutocacheOp (tnId n) + (AutocacheNode, x) -> Left $ sformat ("Node: "%shown%": expected one parent for autocaching, got "%shown) n x + (CacheNode, [_]) -> pure $ CacheOp (tnId n) + (CacheNode, x) -> Left $ sformat ("Node: "%shown%": expected one parent for caching, got "%shown) n x + (UncacheNode, [(ParentEdge, x)]) -> pure $ UncacheOp (tnId n) (tnId x) + (UncacheNode, x) -> Left $ sformat ("Node: "%shown%": Expected one parent for uncaching, got "%shown) n x + (Dataset, _) -> Right Through + (Row, _) -> Right Stop + +errors :: TestNode -> CacheTry [CachingFailure] +errors tn = do + g <- buildGraph tn :: Either Text (Graph TestNode StructureEdge) + checkCaching (graphMapEdges g (const ParentEdge)) expandFun + +errors' :: TestNode -> CacheTry (Graph TestNode StructureEdge) +errors' tn = do + g <- buildGraph tn :: Either Text (Graph TestNode StructureEdge) + fillAutoCache expandFun acGen g + +intErrors :: LocalData a -> Try ComputeGraph +intErrors ld = + let cg = buildComputationGraph ld + in performGraphTransforms emptySession =<< cg + +emptySession :: SparkSession +emptySession = SparkSession c (LocalSessionId "id") 3 emptyNodeCache + where c = SparkSessionConf "end_point" (negate 1) 10 "session_name" True + +spec :: Spec +spec = do + describe "Caching operations" $ do + it "missing parent node" $ do + let n1 = node "1" CacheNode [] + errors n1 `shouldSatisfy` isLeft + it "caching: parent node" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" CacheNode [n0] + errors n1 `shouldBe` Right [] + it "uncaching: missing parent node" $ do + let n1 = node "1" UncacheNode [] + errors n1 `shouldSatisfy` isLeft + it "uncaching: parent node" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" CacheNode [n0] + let n2 = node "2" CacheNode [n1] + errors n2 `shouldBe` Right [] + it "too many nodes for uncaching" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" CacheNode [n0] + let n2 = node "2" UncacheNode [n1, n2] + errors n2 `shouldSatisfy` isLeft + it "access after uncaching" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" CacheNode [n0] + let n2 = node "2" UncacheNode [n1] + let n3 = node "3" Dataset [n1, n2] + errors n3 `shouldBe` Right [CachingFailure (nid "1") (nid "2") (nid "3")] + it "ambigous access after uncaching" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" CacheNode [n0] + let n2 = node "2" UncacheNode [n1] + let n3 = node "3" Dataset [n1] + let n4 = node "4" Dataset [n3, n2] + errors n4 `shouldBe` Right [CachingFailure (nid "1") (nid "2") (nid "3") + ,CachingFailure (nid "1") (nid "2") (nid "4")] + describe "Autocaching operations" $ do + it "missing parent node" $ do + let n1 = node "1" AutocacheNode [] + let g = traceHint "g=" (errors' n1) + g `shouldSatisfy` isLeft + it "auto-uncaching with no child should not create uncaching" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" AutocacheNode [n0] + let g = traceHint "g=" (errors' n1) + g `shouldSatisfy` isRight + ((length . toList . gVertices) <$> g) `shouldBe` Right 2 + it "access after uncaching" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" AutocacheNode [n0] + let n2 = node "2" Row [n1] + let g = traceHint "g=" (errors' n2) + g `shouldSatisfy` isRight + ((length . toList . gVertices) <$> g) `shouldBe` Right 5 + it "access after and scoping" $ do + let n0 = node "0" Dataset [] + let n1 = node "1" AutocacheNode [n0] + let n2a = node "2a" Row [n1] + let n2b = node "2b" Row [n1] + let n3 = node "3" Row [n2a, n2b] + let g = traceHint "g=" (errors' n3) + g `shouldSatisfy` isRight + ((length . toList . gVertices) <$> g) `shouldBe` Right 8 + describe "Autocaching integration tests" $ do + it "test 1" $ do + let l = [1,2,3] :: [Int] + let ds = dataset l + let ds' = autocache ds + let c1 = asCol ds' + let s1 = sumCol c1 + let s2 = count ds' + let x = s1 + s2 + let g = traceHint "g=" (intErrors x) + g `shouldSatisfy` isRight diff --git a/test/Spark/Core/Internal/DAGFunctionsSpec.hs b/test/Spark/Core/Internal/DAGFunctionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/DAGFunctionsSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- :script test/Spark/Core/Internal/PathsSpec.hs +module Spark.Core.Internal.DAGFunctionsSpec where + +import Test.Hspec +import qualified Data.Map.Strict as M +import qualified Data.Vector as V +import qualified Data.ByteString.Char8 as C8 +import Control.Arrow((&&&)) +import Data.Foldable(toList) + +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.Utilities + +data MyV = MyV { + mvId :: VertexId, + mvParents :: [MyV] +} deriving (Eq) + +id2Str :: VertexId -> String +id2Str = C8.unpack . unVertexId + +instance Show MyV where + show v = "MyV(" ++ (id2Str . mvId $ v) ++ ")" + + +instance GraphVertexOperations MyV where + vertexToId = mvId + expandVertexAsVertices = mvParents + +instance GraphOperations MyV () where + expandVertex = ((const () &&& id) <$>) . mvParents + +myv :: String -> [MyV] -> MyV +myv s = MyV (VertexId (C8.pack s)) + +expandNodes :: MyV -> DagTry [String] +expandNodes vx = + let tg = buildGraph vx :: DagTry (Graph MyV ()) + in (id2Str . mvId . vertexData <$>) . toList . gVertices <$> tg + +-- edges: from -> to +expandEdges :: MyV -> DagTry [(String, String)] +expandEdges vx = + let tg = buildGraph vx :: DagTry (Graph MyV ()) + in tg <&> \g -> + concat $ M.assocs (gEdges g) <&> \(vid, v) -> + (C8.unpack . unVertexId . vertexId . veEndVertex &&& + C8.unpack . unVertexId . const vid) <$> V.toList v + +spec :: Spec +spec = do + describe "Tests on paths" $ do + it "no parent" $ do + let v0 = myv "v0" [] + expandNodes v0 `shouldBe` Right ["v0"] + it "common parent" $ do + let v0 = myv "v0" [] + let v0' = myv "v0" [] + let v1 = myv "v1" [v0, v0'] + expandEdges v1 `shouldBe` Right [("v0", "v1"), ("v0", "v1")] + it "diamond" $ do + let va = myv "va" [] + let va' = myv "va" [] + let v0 = myv "v0" [va] + let v0' = myv "v0" [va'] + let v1 = myv "v1" [v0, v0'] + expandEdges v1 `shouldBe` Right [("va", "v0"), ("v0", "v1"), ("v0", "v1")] + it "simple sources" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let tg = buildGraph v1 :: DagTry (Graph MyV ()) + let g = forceRight tg + mvId . vertexData <$> graphSources g `shouldBe` [mvId v1] + it "simple sinks" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let tg = buildGraph v1 :: DagTry (Graph MyV ()) + let g = forceRight tg + mvId . vertexData <$> graphSinks g `shouldBe` [mvId v0] + it "longer sources" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let v2 = myv "v2" [v1] + let tg = buildGraph v2 :: DagTry (Graph MyV ()) + let g = forceRight tg + mvId . vertexData <$> graphSources g `shouldBe` [mvId v2] + it "longer sinks" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let v2 = myv "v2" [v1] + let tg = buildGraph v2 :: DagTry (Graph MyV ()) + let g = forceRight tg + mvId . vertexData <$> graphSinks g `shouldBe` [mvId v0] + describe "building DAGs" $ do + it "2 nodes" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let v2 = myv "v2" [v1] + let l = forceRight $ buildVertexList v2 + id2Str . mvId <$> l `shouldBe` ["v0", "v1", "v2"] + it "triangle" $ do + let v0 = myv "v0" [] + let v1 = myv "v1" [v0] + let v2 = myv "v2" [v0, v1] + let l = forceRight $ buildVertexList v2 + -- The return order should be in lexicographic order + -- (which is unique in this case). + id2Str . mvId <$> l `shouldBe` ["v0", "v1", "v2"] diff --git a/test/Spark/Core/Internal/GroupsSpec.hs b/test/Spark/Core/Internal/GroupsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/GroupsSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Spark.Core.Internal.GroupsSpec where + +import Data.Text(Text) +import Test.Hspec +import GHC.Generics +import Data.Either(isRight) + +import Spark.Core.Functions +import Spark.Core.ColumnFunctions +import Spark.Core.Dataset +import Spark.Core.Column +import Spark.Core.Row +import Spark.Core.Types +import Spark.Core.Internal.Groups + + +data MyPair = MyPair { + myKey :: Text, + myVal :: Int } deriving (Generic, Show) + +myKey' :: StaticColProjection MyPair Text +myKey' = unsafeStaticProjection buildType "myKey" +myVal' :: StaticColProjection MyPair Int +myVal' = unsafeStaticProjection buildType "myVal" +instance SQLTypeable MyPair +instance ToSQL MyPair + +-- The tests are really light for now, and just check that the code passes the +-- dynamic type checker. +spec :: Spec +spec = do + describe "typed grouping tests" $ do + let ds = dataset [MyPair "1" 1, MyPair "2" 2] + let keys = ds // myKey' + let values = ds // myVal' + let g = groupByKey keys values + let sqlt1 = buildType :: SQLType MyPair + it "group" $ do + let tds2 = castType sqlt1 (groupAsDS g) + tds2 `shouldSatisfy` isRight + it "map group" $ do + let g2 = g `mapGroup` \c -> c + c + let tds2 = castType sqlt1 (groupAsDS g2) + tds2 `shouldSatisfy` isRight + it "simple reduce" $ do + let ds2 = g `aggKey` sumCol + let tds3 = castType sqlt1 ds2 + tds3 `shouldSatisfy` isRight + it "complex reduce" $ do + let ds2 = g `aggKey` \c -> sumCol (c + c) + let tds3 = castType sqlt1 ds2 + tds3 `shouldSatisfy` isRight diff --git a/test/Spark/Core/Internal/LocalDataFunctionsSpec.hs b/test/Spark/Core/Internal/LocalDataFunctionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/LocalDataFunctionsSpec.hs @@ -0,0 +1,18 @@ + +module Spark.Core.Internal.LocalDataFunctionsSpec where + +import Test.Hspec + +import Spark.Core.Dataset +import Spark.Core.Functions() + +spec :: Spec +spec = do + describe "Arithmetic operations on local data (integers)" $ do + it "ints" $ do + let x1 = 1 :: LocalData Int + let x2 = 2 :: LocalData Int + let y1 = x1 + x2 + let y2 = x1 `div` x2 + (y2 `shouldBe` y2) + (y1 `shouldBe` y1) diff --git a/test/Spark/Core/Internal/OpFunctionsSpec.hs b/test/Spark/Core/Internal/OpFunctionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/OpFunctionsSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +module Spark.Core.Internal.OpFunctionsSpec where + +import Data.Aeson +import Test.Hspec +import Text.RawString.QQ + +import Spark.Core.Functions +import Spark.Core.Internal.OpFunctions +import Spark.Core.Internal.DatasetFunctions + + +spec :: Spec +spec = do + describe "extraNodeOpData" $ do + it "should have the content of a constant dataset" $ do + let l = [1,2,3] :: [Int] + let res :: Maybe Value + res = decode + ([r|{"content": [1,2,3], + "cellType" : { + "dt": "integer", + "nullable": false + } + }|]) + let ds = dataset l + let d = extraNodeOpData . nodeOp $ ds + Just d `shouldBe` res diff --git a/test/Spark/Core/Internal/PathsSpec.hs b/test/Spark/Core/Internal/PathsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/PathsSpec.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- :script test/Spark/Core/Internal/PathsSpec.hs +module Spark.Core.Internal.PathsSpec where + +import Test.Hspec +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Text as T + +import Spark.Core.StructuresInternal +import Spark.Core.Functions +import Spark.Core.Dataset +import Spark.Core.Internal.Paths +import Spark.Core.Internal.DAGStructures +import Spark.Core.Internal.DAGFunctions +import Spark.Core.Internal.ComputeDag +import Spark.Core.Internal.PathsUntyped +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.DatasetFunctions +import Spark.Core.Internal.DatasetStructures + +data MyV = MyV { + mvId :: VertexId, + mvLogical :: [MyV], + mvParents :: [MyV] +} deriving (Eq) + +instance Show MyV where + show v = "MyV(" ++ (C8.unpack . unVertexId . mvId $ v) ++ ")" + + +assignPaths :: UntypedNode -> [UntypedNode] +assignPaths n = + let cgt = buildCGraph n :: DagTry (ComputeDag UntypedNode NodeEdge) + cg = forceRight cgt + acgt = assignPathsUntyped cg + ncg = forceRight acgt + in graphDataLexico . tieNodes $ ncg + + +instance GraphVertexOperations MyV where + vertexToId = mvId + expandVertexAsVertices = mvParents + +myv :: String -> [MyV] -> [MyV] -> MyV +myv s logical inner = MyV (VertexId (C8.pack s)) logical inner + +myvToVertex :: MyV -> Vertex MyV +myvToVertex x = Vertex (mvId x) x + +buildScopes :: [MyV] -> Scopes +buildScopes l = iGetScopes0 l' fun where + l' = myvToVertex <$> l + fun vx = ParentSplit { + psLogical = myvToVertex <$> (mvLogical . vertexData $ vx), + psInner = myvToVertex <$> (mvParents . vertexData $ vx) } + +simple :: [(Maybe String, [String])] -> Scopes +simple [] = M.empty +simple ((ms, ss) : t) = + let + key = VertexId . C8.pack <$> ms + vals = VertexId . C8.pack <$> ss + new = M.singleton key (S.fromList vals) + in mergeScopes new (simple t) + +gatherings :: [(String, [[String]])] -> M.Map VertexId [[VertexId]] +gatherings [] = M.empty +gatherings ((key, paths) : t) = + let + k = VertexId . C8.pack $ key + ps = (VertexId . C8.pack <$>) <$> paths + new = M.singleton k ps + in M.unionWith (++) new (gatherings t) + +gatherPaths' :: [MyV] -> M.Map VertexId [[VertexId]] +gatherPaths' = gatherPaths . buildScopes + +spec :: Spec +spec = do + describe "Tests on paths" $ do + it "nothing" $ do + buildScopes [] `shouldBe` simple [] + it "no parent" $ do + let v0 = myv "v0" [] [] + let res = [ (Nothing, ["v0"]), (Just "v0", []) ] + buildScopes [v0] `shouldBe` simple res + it "one logical parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [v0] [] + let res = [ (Nothing, ["v0", "v1"]) + , (Just "v1", []) + , (Just "v0", []) ] + buildScopes [v1, v0] `shouldBe` simple res + it "one inner parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [] [v0] + let res = [ (Nothing, ["v1"]) + , (Just "v1", ["v0"]) + , (Just "v0", []) ] + buildScopes [v1, v0] `shouldBe` simple res + it "logical scoping over a parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [v0] [] + let v2 = myv "v2" [v0] [v1] + let res = [ (Nothing, ["v0", "v2"]) + , (Just "v0", []) + , (Just "v1", []) + , (Just "v2", ["v1"]) ] + buildScopes [v2] `shouldBe` simple res + it "common ancestor" $ do + let top = myv "top" [] [] + let inner = myv "inner" [top] [] + let v1 = myv "v1" [top] [inner] + let v2 = myv "v2" [top] [inner] + let res = [ (Nothing, ["top", "v1", "v2"]) + , (Just "inner", []) + , (Just "top", []) + , (Just "v1", ["inner"]) + , (Just "v2", ["inner"]) ] + buildScopes [v1, v2] `shouldBe` simple res + it "common ancestor, unbalanced" $ do + let top = myv "top" [] [] + let inner = myv "inner" [top] [] + let v1 = myv "v1" [top] [inner] + let v2 = myv "v2" [] [inner] + let res = [ (Nothing, ["top", "v1", "v2"]) + , (Just "inner", []) + , (Just "top", []) + , (Just "v1", ["inner"]) + , (Just "v2", ["inner", "top"]) ] + buildScopes [v1, v2] `shouldBe` simple res + describe "Path gatherings" $ do + it "nothing" $ do + gatherPaths' [] `shouldBe` gatherings [] + it "no parent" $ do + let v0 = myv "v0" [] [] + let res = [("v0", [[]])] + gatherPaths' [v0] `shouldBe` gatherings res + it "one logical parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [v0] [] + let res = [ ("v1", [[]]) + , ("v0", [[]])] + gatherPaths' [v1] `shouldBe` gatherings res + it "one inner parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [] [v0] + let res = [ ("v1", [[]]) + , ("v0", [["v1"]])] + gatherPaths' [v1] `shouldBe` gatherings res + it "logical scoping over a parent" $ do + let v0 = myv "v0" [] [] + let v1 = myv "v1" [v0] [] + let v2 = myv "v2" [v0] [v1] + let res = [ ("v0", [[]]) + , ("v1", [["v2"]]) + , ("v2", [[]]) ] + gatherPaths' [v2] `shouldBe` gatherings res + it "common ancestor" $ do + let top = myv "top" [] [] + let inner = myv "inner" [top] [] + let v1 = myv "v1" [top] [inner] + let v2 = myv "v2" [top] [inner] + let res = [ ("inner", [["v1"], ["v2"]]) + , ("top", [[]]) + , ("v1", [[]]) + , ("v2", [[]]) ] + gatherPaths' [v1, v2] `shouldBe` gatherings res + describe "Real paths" $ do + it "simple test" $ do + let c0 = constant (1 :: Int) @@ "c0" + let c1 = identity c0 @@ "c1" + let c2 = identity c1 `logicalParents` [untyped c0] @@ "c2" + nodeId <$> nodeParents c1 `shouldBe` [nodeId c0] + nodeId <$> nodeParents c2 `shouldBe` [nodeId c1] + let withParents = T.unpack . catNodePath . nodePath <$> assignPaths (untyped c2) + withParents `shouldBe` ["c0", "c2/c1", "c2"] + it "simple test 2" $ do + let ds = dataset ([1 ,2, 3, 4]::[Int]) @@ "ds" + let c = count ds @@ "c" + let c2 = (c + (identity c @@ "id")) `logicalParents` [untyped ds] @@ "c2" + let withParents = T.unpack . catNodePath . nodePath <$> assignPaths (untyped c2) + withParents `shouldBe` ["ds", "c2/c","c2/id","c2"] diff --git a/test/Spark/Core/Internal/RowUtilsSpec.hs b/test/Spark/Core/Internal/RowUtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/Internal/RowUtilsSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Spark.Core.Internal.RowUtilsSpec where + +import Data.Aeson +import Data.Maybe(fromJust) +import Test.Hspec +import Data.ByteString.Lazy(ByteString) +import qualified Data.Vector as V +import Data.Either(isRight) + +import Spark.Core.Types +import Spark.Core.Row +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.RowGenericsFrom +import Spark.Core.Internal.TypesStructuresRepr(DataTypeElementRepr) + +fun :: ByteString -> DataType -> Cell -> IO () +fun js dt cell2 = + let + mval = decode js :: Maybe Value + val = fromJust mval + cellt = jsonToCell dt val + in cellt `shouldBe` (Right cell2) + + +spec :: Spec +spec = do + describe "JSON -> Row" $ do + it "ints" $ do + fun "2" intType (IntElement 2) + it "[ints]" $ do + fun "[2]" (arrayType' intType) (RowArray (V.singleton (IntElement 2))) + describe "Decoding data types" $ do + it "should decode DataTypeElementRepr" $ do + let x = rowArray [rowArray [StringElement "ts3f1"],BoolElement True,IntElement 1,IntElement 0] + let elt = cellToValue x :: TryS DataTypeElementRepr + elt `shouldSatisfy` isRight diff --git a/test/Spark/Core/PathSpec.hs b/test/Spark/Core/PathSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/PathSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} + +module Spark.Core.PathSpec where + +import Data.Maybe(fromJust) +import Test.Hspec + +import Spark.Core.Functions +import Spark.Core.Dataset + +fun1 :: LocalData Int +fun1 = + let m1 = constant (1::Int) + m2 = constant (2::Int) in + constant (3::Int) + `logicalParents` [untyped m1, untyped m2] + `parents` [] + + +fun2 :: LocalData Int -> LocalData Int +fun2 ld1 = let + m1 = constant (1 :: Int) `parents` [untyped ld1] @@ "m1" + in + constant (3 :: Int) + `logicalParents` [untyped m1] + `parents` [untyped ld1] + @@ "c2" + +-- fun3 :: LocalData Int -> LocalData Int +-- fun3 ld = ld + 3 + +spec :: Spec +spec = do + describe "Tests with nodes" $ do + it "should get a node" $ do + let n1 = fun1 + let l = fromJust $ nodeLogicalParents n1 + (length l) `shouldBe` 2 + -- it "should work with ints" $ do + -- let n2 = (fun3 4) @@ "" in + -- (length $ nodeDependencies n2) `shouldBe` 2 diff --git a/test/Spark/Core/ProjectionsSpec.hs b/test/Spark/Core/ProjectionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/ProjectionsSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.ProjectionsSpec where + +import Test.Hspec +import GHC.Generics +import Data.List(isPrefixOf) +import Data.Either(isRight, isLeft) +import qualified Data.Vector as V +import qualified Data.Text as T + +import Spark.Core.Functions +import Spark.Core.Dataset +import Spark.Core.Column +import Spark.Core.Row +import Spark.Core.Types +import Spark.Core.Try +import Spark.Core.Internal.Utilities +import Spark.Core.Internal.TypesFunctions + + +data Tree = Tree { + treeId :: Int, + treeWidth :: Int, + treeHeight :: Int } deriving (Generic, Show) + +treeId' :: StaticColProjection Tree Int +treeId' = unsafeStaticProjection buildType "treeId" +treeWidth' :: StaticColProjection Tree Int +treeWidth' = unsafeStaticProjection buildType "treeWidth" +instance SQLTypeable Tree +instance ToSQL Tree + +newtype MyId = MyId Int deriving (Generic, Show, Num) +instance SQLTypeable MyId +instance ToSQL MyId + +newtype Height = Height Int deriving (Generic, Num, Show) +instance SQLTypeable Height +instance ToSQL Height + +data STree = STree { + sTreeId :: MyId, + sTreeWidth :: Height, + sTreeHeight :: Int } deriving (Generic, Show) + +instance SQLTypeable STree +instance ToSQL STree +sTreeId' :: StaticColProjection STree MyId +sTreeId' = unsafeStaticProjection buildType "sTreeId" +sTreeWidth' :: StaticColProjection STree Height +sTreeWidth' = unsafeStaticProjection buildType "sTreeWidth" +instance TupleEquivalence STree (MyId, Height, Int) where + tupleFieldNames = NameTuple ["sTreeId", "sTreeWidth", "sTreeHeight"] + +rawData :: [(Int, Int, Int)] +rawData = [(1, 3, 2)] + +spec :: Spec +spec = do + let ds = dataset [Tree 1 3 2] + -- The untyped elements + let dt = structType [structField (T.pack "treeId") intType, structField (T.pack "treeWidth") intType, structField (T.pack "treeHeight") intType] + let fun (id', height, width) = RowArray $ V.fromList [IntElement id', IntElement height, IntElement width] + let df1 = traceHint (T.pack "df1=") $ dataframe dt (fun <$> rawData) + let ds1 = traceHint (T.pack "ds1=") $ forceRight (asDS df1) :: Dataset Tree + describe "Simple projection demos" $ do + it "should get a node" $ do + ds `shouldBe` ds1 + it "Failing dynamic projection on dataframe" $ do + df1/-"xx" `shouldSatisfy` isLeft + it "Failing dynamic projection on dataset" $ do + ds1/-"xx" `shouldSatisfy` isLeft + it "Basic arithmetic on DS cols" $ do + let c1 = ds1//treeWidth' + let c2 = (c1 + c1) + (show c2) `shouldSatisfy` ("treeWidth + treeWidth{int}" `isPrefixOf`) + it "Basic arithmetic on DF cols" $ do + let c1 = df1 // treeWidth' + let c2 = c1 + c1 + (show c2) `shouldSatisfy` ("Right treeWidth + treeWidth{int}" `isPrefixOf`) + it "Construction of ds2" $ do + let str = struct' [ (df1/-"treeId") @@ "sTreeId", + (df1/-"treeWidth") @@ "sTreeWidth", + (df1/-"treeHeight") @@ "sTreeHeight"] + let df2 = pack' str + let ds2 = traceHint (T.pack "ds2=") $ asDS df2 :: Try (Dataset STree) + ds2 `shouldSatisfy` isRight + it "Static construction of ds2" $ do + let ds2 = do + idCol <- castCol' (buildType::SQLType MyId) (df1/-"treeId") + widthCol <- castCol' (buildType::SQLType Height) (df1/-"treeWidth") + heightCol <- castCol' (buildType::SQLType Int) (df1/-"treeWidth") + let s = pack (idCol, widthCol, heightCol) :: Dataset STree + return $ traceHint (T.pack "ds2=") s + ds2 `shouldSatisfy` isRight + it "Basic arithmetic on DS cols 1" $ do + let ds2' = do + idCol <- castCol' (buildType::SQLType MyId) (df1/-"treeId") + widthCol <- castCol' (buildType::SQLType Height) (df1/-"treeWidth") + heightCol <- castCol' (buildType::SQLType Int) (df1/-"treeWidth") + let s = pack (idCol, widthCol, heightCol) :: Dataset STree + return $ traceHint (T.pack "ds2=") s + let ds2 = forceRight ds2' + let c1 = ds2//sTreeWidth' + let c2 = c1 + c1 + (show c2) `shouldSatisfy` ("sTreeWidth + sTreeWidth{int}" `isPrefixOf`) diff --git a/test/Spark/Core/RowToSQLSpec.hs b/test/Spark/Core/RowToSQLSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/RowToSQLSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +module Spark.Core.RowToSQLSpec where + +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Test.Hspec + +import Spark.Core.Types +import Spark.Core.Row + +data TestStruct1 = TestStruct1 { + ts1f1 :: Int, + ts1f2 :: Maybe Int } deriving (Show, Eq, Generic, ToSQL, FromSQL) + +data TestStruct2 = TestStruct2 { ts2f1 :: [Int] } deriving (Show, Generic, SQLTypeable) + +data TestStruct3 = TestStruct3 { ts3f1 :: Int } deriving (Show, Eq, Generic, ToSQL, FromSQL) +data TestStruct4 = TestStruct4 { ts4f1 :: TestStruct3 } deriving (Show, Eq, Generic, ToSQL, FromSQL) + +data TestStruct5 = TestStruct5 { + ts5f1 :: Int, + ts5f2 :: Int, + ts5f3 :: TestStruct3 +} deriving (Show, Eq, Generic, ToSQL, FromSQL) + +newtype TestT1 = TestT1 { unTestT1 :: Int } deriving (Eq, Show, Generic, ToSQL, FromSQL) + + +v2c :: (Show a, ToSQL a, FromSQL a, Eq a) => a -> Cell -> IO () +v2c !x !y = do + _ <- shouldBe (valueToCell x) y + _ <- shouldBe (cellToValue y) (Right x) + return () + +spec :: Spec +spec = do + describe "Simple type tests" $ do + it "int" $ + v2c (3 :: Int) (IntElement 3) + it "int?" $ + v2c (Just 3 :: Maybe Int) (IntElement 3) + it "int? 2" $ + v2c (Nothing :: Maybe Int) Empty + it "TestStruct3" $ + v2c (TestStruct3 2) (RowArray $ V.fromList [IntElement 2]) + it "TestStruct4" $ + v2c (TestStruct4 (TestStruct3 3)) $ + (RowArray $ V.fromList [ + RowArray $ V.fromList [IntElement 3] + ]) + it "TestStruct1 - empty" $ + v2c (TestStruct1 2 Nothing) (RowArray $ V.fromList [IntElement 2, Empty]) + it "TestStruct1 - full" $ + v2c (TestStruct1 2 (Just 4)) (RowArray $ V.fromList [IntElement 2, IntElement 4]) + it "TestStruct5" $ + v2c (TestStruct5 1 2 (TestStruct3 3)) $ + (RowArray $ V.fromList [ + IntElement 1, + IntElement 2, + RowArray $ V.fromList [IntElement 3] + ]) + -- describe "Simple type tests" $ do + -- it "newtype" $ + -- v2c (TestT1 3) (IntElement 3) diff --git a/test/Spark/Core/SimpleExamplesSpec.hs b/test/Spark/Core/SimpleExamplesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/SimpleExamplesSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +-- Some small examples that get fully verified. +module Spark.Core.SimpleExamplesSpec where + +import Data.Either(isRight) +import Data.Maybe(isJust) +import Test.Hspec +import qualified Data.Text as T +import Text.RawString.QQ + +import Spark.Core.Dataset +import Spark.Core.Functions +import Spark.Core.Column +import Spark.Core.ColumnFunctions +import Spark.Core.Internal.DatasetStructures +import Spark.Core.Internal.Utilities(pretty) +import Spark.Core.Internal.OpFunctions(extraNodeOpData) + +ds1 :: Dataset Int +ds1 = dataset [1,2,3] + +ds2 :: Dataset Double +ds2 = error "ds2" + +spec :: Spec +spec = do + describe "Simple examples" $ do + it "Precdence of renaming" $ do + let numbers = asCol ds1 + let s = sumCol numbers + let numCount = count ds1 + let avg = s `div` numCount @@ "myaverage" + _cnName avg `shouldSatisfy` isJust + it "name for simple integers" $ do + let numbers = asCol ds1 + let s = sumCol numbers + let numCount = count ds1 + let avg = s `div` numCount @@ "myaverage" + -- TODO: should it show "value: int" instead? + -- I think it should show it for distributed nodes only. + -- SQL is not allowed on observables + (show avg) `shouldBe` "/myaverage@org.spark.LocalDiv!int" + describe "pack1" $ do + it "Extracting and packing one column" $ do + let numbers = asCol ds1 + let ds1' = pack1 numbers + (nodeType ds1) `shouldBe` (nodeType ds1') + describe "pack" $ do + it "Extracting and packing one column" $ do + let ds1' = pack' . asCol $ ds1 + (nodeType <$> (asDF ds1)) `shouldBe` (nodeType <$> ds1') + describe "simple json example" $ do + it "packing and unpacking one column" $ do + let ds1' = pack' . asCol $ ds1 + let d' = pretty . extraNodeOpData . nodeOp <$> ds1' + d' `shouldBe` Right (T.pack "{\"cellType\":{\"dt\":\"integer\",\"nullable\":false},\"content\":[1,2,3]}") + it "packing and unpacking 2 columns, one with a bad name" $ do + let col1 = asCol ds1 + let col2 = col1 @@ "other" + let ds1' = pack' (col1, col2) + ds1' `shouldSatisfy` isRight -- NOT SURE WHY IT WOULD FAIL + it "packing and unpacking 2 columns, one with a good name" $ do + let col1 = asCol ds1 @@ "first" + let col2 = col1 @@ "second" + let ds1' = pack' (col1, col2) + ds1' `shouldSatisfy` isRight + + + -- it "example2" $ do + -- let numbers = asCol ds2 + -- let avg = (colSum numbers) / (count ds2) + -- 1 `shouldBe` 1 diff --git a/test/Spark/Core/TypesSpec.hs b/test/Spark/Core/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spark/Core/TypesSpec.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Spark.Core.TypesSpec where + +import GHC.Generics (Generic) +import Test.Hspec +import Test.Hspec.QuickCheck + +import Spark.Core.Types +import Spark.Core.Internal.TypesFunctions +import Spark.Core.Internal.TypesGenerics() + +data TestStruct1 = TestStruct1 { + ts1f1 :: Int, + ts1f2 :: Maybe Int } deriving (Show, Generic) + +instance SQLTypeable TestStruct1 + +data TestStruct2 = TestStruct2 { ts2f1 :: [Int] } deriving (Show, Generic, SQLTypeable) + +data TestStruct3 = TestStruct3 { ts3f1 :: Int } deriving (Show, Generic, SQLTypeable) +data TestStruct4 = TestStruct4 { ts4f1 :: TestStruct3 } deriving (Show, Generic, SQLTypeable) + +-- instance SQLTypeable TestStruct1 +-- instance Menu TestStruct1 + + +-- main :: IO () +-- main = hspec spec + +spec :: Spec +spec = do + describe "Simple type tests" $ do + it "show ints" $ + show intType `shouldBe` "int" + + it "show arrays" $ + show (arrayType' intType) `shouldBe` "[int]" + + it "show structures" $ + show (arrayType' (canNull intType)) `shouldBe` "[int?]" + + describe "The basic tests for int types" $ do + it "ints" $ + let t = buildType :: (SQLType Int) + dt = columnType t in + dt `shouldBe` intType + + it "opt ints" $ + let t = buildType :: (SQLType (Maybe Int)) + dt = columnType t in + dt `shouldBe` canNull intType + + -- The projection of all the product types + it "opt opt ints" $ + let t = buildType :: (SQLType (Maybe (Maybe Int))) in + columnType t `shouldBe` canNull intType + + it "array ints" $ + let t = buildType :: (SQLType [Int]) in + columnType t `shouldBe` arrayType' intType + + it "array opt ints" $ + let t = buildType :: (SQLType [Maybe Int]) in + columnType t `shouldBe` arrayType' (canNull intType) + + it "opt array ints" $ + let t = buildType :: (SQLType (Maybe [Int])) in + columnType t `shouldBe` canNull (arrayType' intType) + + describe "The basic tests for records" $ do + it "records with maybe" $ + let t = buildType :: (SQLType TestStruct1) + out = structType [structField "ts1f1" intType, structField "ts1f2" (canNull intType)] in + columnType t `shouldBe` out + + it "records with arrays" $ + let t = buildType :: (SQLType TestStruct2) + out = structType [structField "ts2f1" (arrayType' intType)] in + columnType t `shouldBe` out + + it "records within records" $ + let t = buildType :: (SQLType TestStruct4) + out0 = structType [structField "ts3f1" intType] + out = structType [structField "ts4f1" out0] in + columnType t `shouldBe` out + + describe "Construction of frame types" $ do + prop "frameTypeFromCol should be invertible" $ + \x -> + let dt = colTypeFromFrame x + y = frameTypeFromCol dt + in x == y + -- TODO this is not always working. Figure out the rules here. + -- prop "colTypeFromFrame should be invertible" $ + -- \x -> (colTypeFromFrame . frameTypeFromCol) x == x diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- Not working??? +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}