packages feed

karps (empty) → 0.1.9.0

raw patch · 85 files changed

+10153/−0 lines, 85 filesdep +QuickCheckdep +SHAdep +aesonsetup-changed

Dependencies added: QuickCheck, SHA, aeson, aeson-pretty, base, base16-bytestring, binary, bytestring, containers, cryptohash-sha256, deepseq, either, exceptions, formatting, hashable, hspec, karps, lens, monad-logger, mtl, random, raw-strings-qq, scientific, semigroups, text, text-format, transformers, unordered-containers, vector, wreq

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ karps.cabal view
@@ -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
+ src/Spark/Core.hs view
@@ -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
+ src/Spark/Core/Column.hs view
@@ -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
+ src/Spark/Core/ColumnFunctions.hs view
@@ -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()
+ src/Spark/Core/Context.hs view
@@ -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+  }
+ src/Spark/Core/Dataset.hs view
@@ -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()
+ src/Spark/Core/Functions.hs view
@@ -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))
+ src/Spark/Core/Internal/AggregationFunctions.hs view
@@ -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)
+ src/Spark/Core/Internal/AlgebraStructures.hs view
@@ -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 (/)
+ src/Spark/Core/Internal/Arithmetics.hs view
@@ -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)
+ src/Spark/Core/Internal/ArithmeticsImpl.hs view
@@ -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
+ src/Spark/Core/Internal/Caching.hs view
@@ -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
+ src/Spark/Core/Internal/CachingUntyped.hs view
@@ -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
+ src/Spark/Core/Internal/CanRename.hs view
@@ -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
+ src/Spark/Core/Internal/Client.hs view
@@ -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)
+ src/Spark/Core/Internal/ColumnFunctions.hs view
@@ -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"
+ src/Spark/Core/Internal/ColumnStandard.hs view
@@ -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
+ src/Spark/Core/Internal/ColumnStructures.hs view
@@ -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)
+ src/Spark/Core/Internal/ComputeDag.hs view
@@ -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)
+ src/Spark/Core/Internal/ContextIOInternal.hs view
@@ -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
+ src/Spark/Core/Internal/ContextInteractive.hs view
@@ -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+  }
+ src/Spark/Core/Internal/ContextInternal.hs view
@@ -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
+ src/Spark/Core/Internal/ContextStructures.hs view
@@ -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
+ src/Spark/Core/Internal/DAGFunctions.hs view
@@ -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)
+ src/Spark/Core/Internal/DAGStructures.hs view
@@ -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
+ src/Spark/Core/Internal/DatasetFunctions.hs view
@@ -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
+ src/Spark/Core/Internal/DatasetStructures.hs view
@@ -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]
+ src/Spark/Core/Internal/FunctionsInternals.hs view
@@ -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.
+ src/Spark/Core/Internal/Groups.hs view
@@ -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+           }
+ src/Spark/Core/Internal/Joins.hs view
@@ -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)
+ src/Spark/Core/Internal/LocalDataFunctions.hs view
@@ -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+}
+ src/Spark/Core/Internal/LocatedBase.hs view
@@ -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
+ src/Spark/Core/Internal/ObservableStandard.hs view
@@ -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
+ src/Spark/Core/Internal/OpFunctions.hs view
@@ -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
+ src/Spark/Core/Internal/OpStructures.hs view
@@ -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
+ src/Spark/Core/Internal/Paths.hs view
@@ -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
+ src/Spark/Core/Internal/PathsUntyped.hs view
@@ -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' }
+ src/Spark/Core/Internal/Projections.hs view
@@ -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
+ src/Spark/Core/Internal/Pruning.hs view
@@ -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
+ src/Spark/Core/Internal/RowGenerics.hs view
@@ -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
+ src/Spark/Core/Internal/RowGenericsFrom.hs view
@@ -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
+ src/Spark/Core/Internal/RowStructures.hs view
@@ -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
+ src/Spark/Core/Internal/RowUtils.hs view
@@ -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
+ src/Spark/Core/Internal/TypesFunctions.hs view
@@ -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]
+ src/Spark/Core/Internal/TypesGenerics.hs view
@@ -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"
+ src/Spark/Core/Internal/TypesStructures.hs view
@@ -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])
+ src/Spark/Core/Internal/TypesStructuresRepr.hs view
@@ -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)
+ src/Spark/Core/Internal/Utilities.hs view
@@ -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)
+ src/Spark/Core/Row.hs view
@@ -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
+ src/Spark/Core/StructuresInternal.hs view
@@ -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
+ src/Spark/Core/Try.hs view
@@ -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
+ src/Spark/Core/Types.hs view
@@ -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.
+ src/Spark/IO/Inputs.hs view
@@ -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
+ src/Spark/IO/Internal/InputGeneric.hs view
@@ -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
+ src/Spark/IO/Internal/Json.hs view
@@ -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"
+ src/Spark/IO/Internal/OutputCommon.hs view
@@ -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
+ test-integration/Spark/Core/CachingSpec.hs view
@@ -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])
+ test-integration/Spark/Core/CollectSpec.hs view
@@ -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])
+ test-integration/Spark/Core/ColumnSpec.hs view
@@ -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]
+ test-integration/Spark/Core/GroupsSpec.hs view
@@ -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)]
+ test-integration/Spark/Core/IntegrationUtilities.hs view
@@ -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
+ test-integration/Spark/Core/JoinsSpec.hs view
@@ -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]]
+ test-integration/Spark/Core/PruningSpec.hs view
@@ -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'
+ test-integration/Spark/Core/SimpleAddSpec.hs view
@@ -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)
+ test-integration/Spark/IO/JsonSpec.hs view
@@ -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"]]
+ test-integration/Spark/IO/StampSpec.hs view
@@ -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
+ test-integration/Spec.hs view
@@ -0,0 +1,2 @@+-- Not working???+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Spark/Core/ColumnSpec.hs view
@@ -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)
+ test/Spark/Core/ContextSpec.hs view
@@ -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
+ test/Spark/Core/DatasetSpec.hs view
@@ -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
+ test/Spark/Core/Internal/CachingSpec.hs view
@@ -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
+ test/Spark/Core/Internal/DAGFunctionsSpec.hs view
@@ -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"]
+ test/Spark/Core/Internal/GroupsSpec.hs view
@@ -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
+ test/Spark/Core/Internal/LocalDataFunctionsSpec.hs view
@@ -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)
+ test/Spark/Core/Internal/OpFunctionsSpec.hs view
@@ -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
+ test/Spark/Core/Internal/PathsSpec.hs view
@@ -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"]
+ test/Spark/Core/Internal/RowUtilsSpec.hs view
@@ -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
+ test/Spark/Core/PathSpec.hs view
@@ -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
+ test/Spark/Core/ProjectionsSpec.hs view
@@ -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`)
+ test/Spark/Core/RowToSQLSpec.hs view
@@ -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)
+ test/Spark/Core/SimpleExamplesSpec.hs view
@@ -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
+ test/Spark/Core/TypesSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- Not working???+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}