packages feed

tensorflow-ops (empty) → 0.1.0.0

raw patch · 24 files changed

+3569/−0 lines, 24 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, containers, criterion, data-default, deepseq, fgl, lens-family, mtl, proto-lens, random, temporary, tensorflow, tensorflow-core-ops, tensorflow-ops, tensorflow-proto, tensorflow-test, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,203 @@+Copyright 2016 The TensorFlow Authors.  All rights reserved.++                                 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 2016, The TensorFlow Authors.++   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,3 @@+import Distribution.Simple++main = defaultMain
+ src/TensorFlow/EmbeddingOps.hs view
@@ -0,0 +1,91 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- | Parallel lookups on the list of tensors.+module TensorFlow.EmbeddingOps where++import Control.Monad (zipWithM)+import Data.Int (Int32, Int64)+import TensorFlow.Build (MonadBuild)+import TensorFlow.Ops (shape, vector)  -- Also Num instance for Tensor+import TensorFlow.Tensor (Tensor, Value, Rendered, colocateWith, render)+import TensorFlow.Types (OneOf, TensorType)+import qualified TensorFlow.GenOps.Core as CoreOps++-- | Looks up `ids` in a list of embedding tensors.+--+-- This function is used to perform parallel lookups on the list of+-- tensors in `params`.  It is a generalization of `TF.gather`, where+-- `params` is interpreted as a partition of a larger embedding+-- tensor.+--+-- The partition_strategy is "mod", we assign each id to partition+-- `p = id % len(params)`. For instance,+-- 13 ids are split across 5 partitions as:+-- `[[0, 5, 10], [1, 6, 11], [2, 7, 12], [3, 8], [4, 9]]`+--+-- The results of the lookup are concatenated into a dense+-- tensor. The returned tensor has shape `shape(ids) + shape(params)[1:]`.+embeddingLookup :: forall a b v1 v2 m .+                   ( MonadBuild m+                   , Rendered v1+                   , TensorType a+                   , OneOf '[Int64, Int32] b+                   , Num b+                   )+                => [Tensor v1 a]+                -- ^ A list of tensors which can be concatenated along+                -- dimension 0. Each `Tensor` must be appropriately+                -- sized for `mod` partition strategy.+                -> Tensor v2 b+                -- ^ A `Tensor` with type `int32` or `int64`+                -- containing the ids to be looked up in `params`.+                -- The ids are required to have fewer than 2^31+                -- entries.+                -> m (Tensor Value a)+                -- ^ A dense tensor with shape `shape(ids) + shape(params)[1:]`.+embeddingLookup [p0] ids = colocateWith p0 (render $ CoreOps.gather p0 ids)+embeddingLookup params@(p0 : _) ids = do+    -- Do np separate lookups, finding embeddings for plist[p] in params[p]+    partitionedResult <- zipWithM+                        (\p g -> colocateWith p $ render $ CoreOps.gather p g)+                        params gatherIds+    let unshapedResult = CoreOps.dynamicStitch pindices partitionedResult+    -- Shape restoration is not as optimal as it would be with client+    -- side shape tracking.+    paramShape <- colocateWith p0 (render (shape p0))+    let finalShape = CoreOps.concat 0 [shape ids, tailShape]+        tailShape = CoreOps.slice paramShape (singleton 1) (singleton (-1))+    render $ CoreOps.reshape unshapedResult finalShape+  where+    -- Avoids genericLength here which would be evaluated by TF.+    np = fromIntegral (length params)+    flatIds = CoreOps.reshape ids (singleton (-1))+    pAssignments = CoreOps.cast (flatIds `CoreOps.mod` np)+    newIds = flatIds `CoreOps.div` np+    originalIndices = CoreOps.range 0 (CoreOps.size flatIds) 1+    -- Partition list of ids based on assignments into np separate lists+    gatherIds = CoreOps.dynamicPartition np newIds pAssignments+    -- Similarly, partition the original indices.+    pindices = CoreOps.dynamicPartition np originalIndices pAssignments+    singleton i = vector [i :: Int32]++embeddingLookup [] _ = error "embeddingLookup requires params to be non empty"
+ src/TensorFlow/Gradient.hs view
@@ -0,0 +1,756 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TensorFlow.Gradient+    ( gradients+    ) where++import Control.Monad (forM, zipWithM)+import Control.Monad.State.Strict (State, evalState, gets, modify)+import Data.ByteString (ByteString)+import Data.Complex (Complex)+import Data.Default (def)+import Data.Int (Int32, Int64)+import Data.Foldable (foldlM)+import Data.List (foldl', sortBy)+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe, maybeToList, mapMaybe)+import Data.Ord (comparing)+import Data.ProtoLens.TextFormat (showMessage)+import Data.Set (Set)+import Data.Text (Text)+import Data.Tuple (swap)+import Lens.Family2 (Lens', view, (&), (^.), (.~), (%~))+import Lens.Family2.State.Strict (uses)+import Lens.Family2.Stock (at, intAt)+import Lens.Family2.Unchecked (lens, iso)+import Prelude hiding (sum)+import Text.Printf (printf)+import qualified Data.Graph.Inductive.Basic as FGL+import qualified Data.Graph.Inductive.Graph as FGL+import qualified Data.Graph.Inductive.PatriciaTree as FGL+import qualified Data.Graph.Inductive.Query.DFS as FGL+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text++import qualified TensorFlow.GenOps.Core as CoreOps+import TensorFlow.Build+    ( MonadBuild+    , Build+    , build+    , renderedNodeDefs+    , opDef+    , opAttr+    , opInputs+    )+import TensorFlow.BuildOp+import TensorFlow.Ops+    ( addN+    , broadcastGradientArgs+    , expandDims+    , fill+    , matMul+    , matMul'+    , reducedShape+    , reluGrad+    , reshape+    , scalar+    , shape+    , softmaxCrossEntropyWithLogits+    , sum+    , scalarize+    , vector+    , zerosLike+    )+import TensorFlow.Output+    ( NodeName(..)+    , Output(..)+    , OutputIx(..)+    , outputIndex+    )+import TensorFlow.Tensor+    ( Tensor(..)+    , Value+    , render+    , expr+    , Rendered+    , tensorNodeName+    , renderedOutput+    , renderValue+    )+import TensorFlow.Types (Attribute, OneOf, TensorType, attrLens)+import Proto.Tensorflow.Core.Framework.NodeDef+    (NodeDef, attr, input, op, name)++type GradientCompatible a =+    -- TODO(fmayle): MaxPoolGrad doesn't support Double for some reason.+    (Num a, OneOf '[ Float, Complex Float, Complex Double ] a)++-- TODO(fmayle): Support control flow.+-- TODO(fmayle): Support gate_gradients-like option to avoid race conditions.+-- TODO(fmayle): Do we need to consider control inputs? See _PendingCount in+-- tensorflow/python/ops/gradients.py.+-- TODO(fmayle): Maybe store the gradient functions and numOutputs on the OpDef.+++-- | Gradient of @y@ w.r.t. each element of @xs@.+gradients :: forall a v1 v2 m . (MonadBuild m+                              , Rendered v2+                              , GradientCompatible a+                              )+          => Tensor v1 a  -- ^ The output of the graph.+          -> [Tensor v2 a]  -- ^ Tensors for which gradients are computed.+          -> m [Tensor Value a]+gradients y xs = build $ do+    -- The gradients are computed using "reverse accumulation", similarly to+    -- what is described here:+    -- https://en.wikipedia.org/wiki/Automatic_differentiation#The_chain_rule.2C_forward_and_reverse_accumulation+    --+    -- The code is summarised as follows:+    --+    -- 1. Create an fgl graph of the relevant nodes (ops) and edges (tensors).+    -- 2. Initialize the gradient of y to 1 (∂y/∂y = 1) and the rest of tensor's+    --    gradients to nothing.+    -- 3. Process the nodes in reverse topological order (i.e. each node comes+    --    after all of its outputs so that the output gradients for a node have+    --    been completely calculated before it is processed):+    --      a. Record the gradient for each of the node's output tensors (∂y/∂w+    --         for each output tensor w).+    --      b. Calculate the gradient of y w.r.t. each of the node's input+    --         tensors using the gradients of the node's output tensors.+    --+    --         Written differently, for each output tensor w and input tensor v:+    --           ∂y/∂w = ...            (calculated in previous steps)+    --           ∂w/∂v = ...            (op specific)+    --           ∂y/∂v = ∂y/∂w * ∂w/∂v  (technically, if tensor v is an input+    --                                   to multiple nodes, then this is only+    --                                   part of ∂y/∂v)+    --+    -- 4. Lookup the recorded gradient for each x in xs.++    y' <- renderValue y+    let yName = tensorNodeName y'+    yOne <- render $ fill (shape y') (scalar 1)+    -- TODO(fmayle): Move this into Build.hs and call it unsafeNodeDefFromName?+    nodeDefLookup :: (NodeName -> NodeDef) <- uses renderedNodeDefs $+        (\f x -> fromMaybe (error $ "no NodeDef found for " ++ show x) (f x))+        . flip Map.lookup+    let (gr, nodeMap) = createGraph yName nodeDefLookup+    -- Set gradient of y to one.+    -- TODO: nicer+    let initPending :: Map.Map FGL.Node (PendingGradients a)+            = Map.empty & (at (nodeMap Map.! yName)+                                . nonEmpty+                                . outputIxAt (outputIndex $ renderedOutput y')+                                . nonEmpty+                                .~ [yOne]+                                )+    -- Calculate the gradients of y w.r.t. each node in the graph.+    gradientMap <- graphGrads gr initPending+    -- Lookup the gradients for each x.+    forM xs $ \x ->+        let xName = tensorNodeName x+        in maybe (render $ zerosLike x) return $ do+            n <- nodeMap ^. at xName+            let i = outputIndex $ renderedOutput x+            gradientMap ^. at n . nonEmpty . outputIxAt i++outputIxAt :: OutputIx -> Lens' (IntMap.IntMap v) (Maybe v)+outputIxAt = intAt . unOutputIx++-- | Incomplete gradients of a node's outputs.+--+-- The lists represent partial sums. The key is an OutputIx sans newtype.+type PendingGradients a = IntMap.IntMap [Tensor Value a]++-- | Gradients of a node's outputs. The key is an OutputIx sans newtype.+-- TODO: precache the rendering?+type Gradients a = IntMap.IntMap (Tensor Value a)++-- | Graph of TensorFlow operations.+type Graph = FGL.Gr NodeDef EdgeLabel++-- | Data associated with an edge.+--+-- Pair of+--   1. Output index of a tensor from the source node.+--   2. Input index that the tensor connects to on the destination node.+type EdgeLabel = (OutputIx, OutputIx)+++-- | State used for calculating gradients.+data GradientsState a = GradientsState+                      { _gradientsPending :: !(Map FGL.Node (PendingGradients a))+                      , _gradientsResult  :: !(Map FGL.Node (Gradients a))+                      }++gradientsPending :: Lens' (GradientsState a) (Map FGL.Node (PendingGradients a))+gradientsPending = lens _gradientsPending (\x y -> x { _gradientsPending = y })++gradientsResult :: Lens' (GradientsState a) (Map FGL.Node (Gradients a))+gradientsResult = lens _gradientsResult (\x y -> x { _gradientsResult = y })+++-- TODO(fmayle): Use something like Data.List.Safe.+-- | Safe version of (!!).+safeIndex :: [a] -> Int -> Maybe a+_      `safeIndex` n | n < 0 = Nothing+[]     `safeIndex` _         = Nothing+(x:_)  `safeIndex` 0         = Just x+(_:xs) `safeIndex` n         = xs `safeIndex` (n-1)++-- Copy of http://hackage.haskell.org/package/lens-3.9.0.2/docs/Control-Lens-Iso.html#v%3anon+anon :: a -> (a -> Bool) -> Lens' (Maybe a) a+anon a p = iso (fromMaybe a) go where+  go b | p b       = Nothing+       | otherwise = Just b++non :: Eq a => a -> Lens' (Maybe a) a+non a = anon a (a==)++-- | Lens that defaults Nothing to mempty.+nonEmpty :: (Monoid (t v), Foldable t) => Lens' (Maybe (t v)) (t v)+nonEmpty = anon mempty null++-- TODO: strictness (e.g., foldlM')++-- | Calculate the gradients for every node in a graph.+graphGrads :: forall a. GradientCompatible a+           => Graph+           -> Map FGL.Node (PendingGradients a)+           -- ^ Initial gradients (usually just 1 for the node of interest).+           -> Build (Map FGL.Node (Gradients a))+graphGrads gr initPending = view gradientsResult <$> foldlM go initState nodeOrder+  where+    initState = GradientsState initPending Map.empty+    -- Reverse topological sort.+    -- TODO(fmayle): Filter out nodes that are not successors of any x in xs to+    -- avoid calculating gradients that won't be used.+    nodeOrder = FGL.topsort $ FGL.grev gr+    go :: GradientsState a -> Int -> Build (GradientsState a)+    go state node = do+        -- Aggregate the accumulated gradients for this node.+        outputGrads <-+                sumPendingGradient (state ^. gradientsPending . at node . nonEmpty)+        if null outputGrads+           then pure state+           else do+              let ctx = FGL.context gr node+              inputGrads <- calculateInputGrads ctx outputGrads gr+              -- Calculate the gradients for each of the node's inputs.+              let nextState = state & gradientsResult %~ Map.insert node outputGrads+              pure $ updatePendingGradients ctx inputGrads nextState++-- | Reduce accumulated gradients for each output to one Tensor.+sumPendingGradient :: GradientCompatible a+                   => PendingGradients a -> Build (Gradients a)+sumPendingGradient = sequence . IntMap.mapMaybe f+  where+    f [] = Nothing+    f [x] = Just (pure x)+    f xs = Just (render $ addN xs)+++-- | Calculate the gradients of a node's input tensors.+--+-- This is mostly just a wrapper around opGrad.+calculateInputGrads :: forall a. GradientCompatible a+                    => FGL.Context NodeDef EdgeLabel+                    -> Gradients a  -- ^ Output gradients of the node.+                    -> Graph+                    -> Build [Maybe (Tensor Value a)]+calculateInputGrads (inputEdges, _, nodeDef, _) outputGrads gr = do+    fullOutGrads <- fullOutputGrads (numOutputs nodeDef) (nodeDefName nodeDef)+                        outputGrads+    traverse (traverse render) $ opGrad (nodeDef ^. op) nodeDef inputTensors fullOutGrads+  where+    -- Create a tensor from an edge (technically an Output, but it seems less+    -- confusing to refer to it as a tensor here).+    edgeToTensor :: (EdgeLabel, FGL.Node) -> Output+    edgeToTensor ((i, _), n) =+        case FGL.lab gr n of+            Just edgeNodeDef -> Output i (NodeName $ edgeNodeDef ^. name)+            Nothing -> error $ "calculateInputGrads: missing input node for "+                               ++ Text.unpack (nodeDef ^. name)+    -- Input tensors, sorted by input index.+    inputTensors = map edgeToTensor $ sortBy (comparing (snd . fst)) inputEdges++-- | Convert a Map of gradients to a list, with zeros for missing outputs.+fullOutputGrads :: (TensorType a, Num a)+                => OutputIx  -- ^ Number of outputs.+                -> NodeName+                -> Gradients a+                -> Build [Tensor Value a]+fullOutputGrads n o gs =+    mapM (\i -> maybe (render $ zero i) return (gs ^. outputIxAt i)) [0..n-1]+  where+    -- A tensor of zeros with the same shape as the i'th output.+    zero i = zerosLike $ toT (Output i o)+++-- | Update the pending gradients of a node's inputs.+updatePendingGradients :: forall a. (TensorType a, Num a)+                       => FGL.Context NodeDef EdgeLabel+                       -> [Maybe (Tensor Value a)]+                       -- ^ Gradient of each input tensor.+                       -> GradientsState a+                       -> GradientsState a+updatePendingGradients (inputEdges, _, nodeDef, _) inputGrads initState =+    foldl' go initState inputEdges+  where+    go :: GradientsState a -> (EdgeLabel, FGL.Node) -> GradientsState a+    go state ((outIndex, OutputIx inIndex), node) =+        case maybeGradient of+            Nothing -> state+            Just g ->+                -- Add to the list of pending gradients for this tensor.+                state & gradientsPending+                      . at node+                      . nonEmpty+                      . outputIxAt outIndex+                      . nonEmpty+                      %~ (g:)+      where+        badSizeErr = error $ printf "updatePendingGradients: bad input index \+                                    \%d for inputGrads of length %d in %s"+                                    inIndex (length inputGrads)+                                    (show (nodeDef ^. name))+        maybeGradient = fromMaybe badSizeErr (safeIndex inputGrads inIndex)+++-- | Create a graph that includes a node and its transitive dependencies.+createGraph :: NodeName -> (NodeName -> NodeDef)+            -> (Graph, Map NodeName FGL.Node)+createGraph nodeName nodeDefLookup = (FGL.nmap nodeDefLookup graph, nodeMap)+  where+    -- Parse a tensor name.+    parseTensorName :: Text -> Maybe (NodeName, OutputIx)+    parseTensorName n+        | Text.null n        = error "parseTensorName: empty name"+        | Text.head n == '^' = Nothing  -- Control edge+        | otherwise          =+            let (nm, indexStr) = Text.breakOn ":" n+                index | Text.null indexStr = 0+                      | otherwise = read $ Text.unpack $ Text.tail indexStr+            in Just (NodeName nm, OutputIx index)++    -- Build a map from node name to outward edges.+    --+    -- The state is the set of visited nodes.+    collect :: Maybe (NodeName, OutputIx, OutputIx)+            -> NodeName+            -> State (Set NodeName)+                     (Map NodeName [(NodeName, OutputIx, OutputIx)])+    collect outgoingEdge nm = do+        let nextLookup = Map.singleton nm (maybeToList outgoingEdge)+        seen <- gets (Set.member nm)+        modify (Set.insert nm)+        if seen+            then pure nextLookup+            else do+                let inputs = nodeDefLookup nm ^. input+                    recurse inIndex (parentName, outIndex) =+                        collect (Just (nm, outIndex, inIndex)) parentName+                subEdgeLookups <-+                    zipWithM recurse [0..] $ mapMaybe parseTensorName inputs+                pure $ Map.unionsWith (++) (nextLookup:subEdgeLookups)++    edgeLookup = evalState (collect Nothing nodeName) Set.empty+    -- Associate an ID with each node name.+    nodeMap = Map.fromList $ zip (Map.keys edgeLookup) [0..]+    -- Create the graph.+    graph = FGL.mkGraph (swap <$> Map.toList nodeMap)+                        [ (nodeMap Map.! n, nodeMap Map.! m, (i, j))+                        | (n, edges) <- Map.toList edgeLookup+                        , (m, i, j) <- edges+                        ]++-- | Function to compute the gradient of y w.r.t. each input.+--+-- Let y be an arbitrary tensor+-- and [w_0, ..., w_n] be the output tensors of a node+-- and [v_0, ..., v_n] be the input tensors of the same node.+--+-- Given [∂y/∂w_0, ..., ∂y/∂w_n] and [v_0, ..., v_n], a GradientFunc computes+-- [∂y/∂v_0, ..., ∂y/∂v_n] for a particular op type.+--+-- A Nothing gradient is equivalent to zero (but allows for short circuiting+-- computation when all the gradients for something are Nothing).+type GradientFunc a = NodeDef+                    -> [Output]+                    -- ^ Input tensors.+                    -> [Tensor Value a]+                    -- ^ Gradient of y w.r.t. each output tensor.+                    -> [Maybe (Tensor Build a)]+                    -- ^ Gradient of y w.r.t. each input tensor.+++-- TODO(fmayle): Assert the type is correct.+-- | Create a Tensor from an Output.+toT :: Output -> Tensor Build a+toT = Tensor . pure+++-- | Wrapper around `TensorFlow.GenOps.Core.slice` that builds vectors from scalars for+-- simple slicing operations.+flatSlice :: forall v1 t . TensorType t+         => Tensor v1 t    -- ^ __input__+         -> Int32          -- ^ __begin__: specifies the offset into the first dimension of+                           -- 'input' to slice from.+         -> Int32          -- ^ __size__: specifies the number of elements of the first dimension+                           -- of 'input' to slice. If size is -1, all remaining elements in the dimension+                           -- are included in the slice (i.e. this is equivalent to setting+                           -- size = input.dim_size(0) - begin).+         -> Tensor Build t -- ^ __output__+flatSlice t begin size = CoreOps.slice t (vector [begin]) (vector [size])++nodeDefName :: NodeDef -> NodeName+nodeDefName = NodeName . view name+++-- | The gradient function for an op type.+--+-- These implementations should match their python counterparts in:+-- third_party/tensorflow/python/ops/*_grad.py+opGrad :: forall a . GradientCompatible a => Text -> GradientFunc a++opGrad "Abs" _ [toT -> x] [dz] = [Just $ expr dz * signum x]+opGrad "Neg" _ [_] [dz] = [Just $ negate $ expr dz]+opGrad "Relu" _ [toT -> x] [dz] = [Just $ reluGrad dz x]+opGrad "ReluGrad" _ [_, toT -> x ] [dz] = [Just $ reluGrad dz x, Just $ CoreOps.zerosLike x]++opGrad "Square" _ [toT -> x] [dz] =+    -- TODO(fmayle): Handle complex numbers.+    -- TODO(fmayle): The python code makes dz a control dependency of the 2*x+    -- (for performance reasons?). Will need to put these functions in the Build+    -- monad to replicate that.+    [Just $ dz `CoreOps.mul` (2 * x)]++opGrad "Gather" _ [toT -> x, toT -> indices] [dz] =+    -- TODO(fmayle): The python version uses a better performance implementation+    -- when the shape is known without having to run the graph.+    -- TODO(fmayle): We shouldn't convert the result to a dense tensor. Sparse+    -- tensor support will require some thinking.+    [ Just $ CoreOps.unsortedSegmentSum values indices' numRows+    , Nothing+    ]+  where+    -- TODO(gnezdo): Use colocateWith but it requires Build monad.+    denseShape = shape (x :: Tensor Build a)+    numRows = scalarize $ flatSlice denseShape 0 1+    valuesShape = CoreOps.concat 0 [ allDimensions+                                   , flatSlice denseShape 1 (-1)+                                   ]+    values = reshape dz valuesShape+    -- TODO(fmayle): This could be either Int32 or Int64.+    indices' = reshape indices allDimensions :: Tensor Build Int32++opGrad "Max" _ [toT -> x, toT -> indices] [dz] =+    [Just $ indicators `CoreOps.div` numSelected * dz', Nothing]+  where+    sx = shape (x :: Tensor Build a)+    outputShapeKeptDims = reducedShape sx (indices :: Tensor Build Int32)+    y = CoreOps.max x indices+    y' = reshape y outputShapeKeptDims+    dz' = reshape dz outputShapeKeptDims+    indicators = CoreOps.cast $ CoreOps.equal y' x+    numSelected = reshape (sum indicators indices) outputShapeKeptDims++-- Min and Max have identical gradient implementations.+opGrad "Min" u v w = opGrad "Max" u v w++opGrad "Sum" _ [toT -> x, toT -> indices] [dz] =+    [ Just $ CoreOps.tile grad tileScaling, Nothing ]+  where+    -- TODO(gnezdo): Implement the fast-path from math_grad._SumGrad.+    sx = shape (x :: Tensor Build a)+    outputShapeKeptDims = reducedShape sx (indices :: Tensor Build Int32)+    tileScaling = safeShapeDiv sx outputShapeKeptDims+    grad = reshape dz outputShapeKeptDims++opGrad "Mean" u v@[toT -> x, _] w =+    [Just $ dz `CoreOps.div` CoreOps.cast factor, Nothing]+  where+    [Just dz, Nothing] = opGrad "Sum" u v w+    inputShape = shape (x :: Tensor Build a)+    outputShape = shape (dz :: Tensor Build a)+    -- TODO(fmayle): Add fast path when shape is known.+    inputSize = CoreOps.prod inputShape $ rangeOfRank inputShape+    outputSize = CoreOps.prod outputShape $ rangeOfRank outputShape+    factor = safeShapeDiv inputSize outputSize++opGrad "Add" _ [toT -> x, toT -> y] [dz] =+    [ Just $ reshape (sum dz rx) sx+    , Just $ reshape (sum dz ry) sy ]+  where+    sx = shape (x :: Tensor Build a)+    sy = shape (y :: Tensor Build a)+    (rx, ry) = broadcastGradientArgs sx sy++opGrad "Sub" u v w =+    [Just x, Just (-y)]+  where+    [Just x, Just y] = opGrad "Add" u v w++opGrad "SoftmaxCrossEntropyWithLogits" _ [toT -> x, toT -> y] [dz, _] =+    [ Just $ expandDims dz (-1) * snd (softmaxCrossEntropyWithLogits x y)+    , Nothing ]++opGrad "Mul" _ [toT -> x, toT -> y] [dz] =+    -- TODO(fmayle): Handle complex numbers.+    [ Just $ reshape (sum (dz `CoreOps.mul` y) rx) sx+    , Just $ reshape (sum (x `CoreOps.mul` dz) ry) sy ]+  where+    sx = shape (x :: Tensor Build a)+    sy = shape (y :: Tensor Build a)+    (rx, ry) = broadcastGradientArgs sx sy++opGrad "Div" _ [toT -> x, toT -> y] [dz] =+    -- TODO(fmayle): Handle complex numbers.+    -- TODO(gnezdo): Provide Fractional instance and use '/' instead of div.+    [ Just $ reshape (sum (dz `CoreOps.div` y) rx) sx+    , Just $ reshape (sum (dz `CoreOps.mul` (negate x `CoreOps.div` (y * y)))+                         ry)+                sy+    ]+  where+    sx = shape (x :: Tensor Build a)+    sy = shape (y :: Tensor Build a)+    (rx, ry) = broadcastGradientArgs sx sy++opGrad "MatMul" nodeDef [toT -> x, toT -> y] [dz] =+    let transposeA = lookupAttr nodeDef "transpose_a"+        transposeB = lookupAttr nodeDef "transpose_b"+        transAttrs a b =+            (opAttr "transpose_a" .~ a) . (opAttr "transpose_b" .~ b)+    in case (transposeA, transposeB) of+       (False, False) ->+           [ Just $ matMul' (transAttrs False True) dz y+           , Just $ matMul' (transAttrs True False) x dz]+       (False, True) ->+           [ Just $ matMul dz y+           , Just $ matMul' (transAttrs True False) dz x]+       (True, False) ->+           [ Just $ matMul' (transAttrs False True) y dz+           , Just $ matMul x dz]+       (True, True) ->+           [ Just $ matMul' (transAttrs True True) y dz+           , Just $ matMul' (transAttrs True True) dz x]++opGrad "Transpose" _ [_, toT -> p] [dz] =+    [ Just $ CoreOps.transpose dz+            (CoreOps.invertPermutation p :: Tensor Build Int32)+    , Nothing+    ]++opGrad "Conv2D" nodeDef [toT -> x, toT -> y] [dz] =+    [ Just $ CoreOps.conv2DBackpropInput'+                ((opAttr "strides" .~ strides)+                    . (opAttr "padding" .~ padding)+                    . (opAttr "use_cudnn_on_gpu" .~ useCudnnOnGpu)+                    . (opAttr "data_format" .~ dataFormat))+                (shape x) y dz+    , Just $ CoreOps.conv2DBackpropFilter'+                ((opAttr "strides" .~ strides)+                    . (opAttr "padding" .~ padding)+                    . (opAttr "use_cudnn_on_gpu" .~ useCudnnOnGpu)+                    . (opAttr "data_format" .~ dataFormat))+                x (shape y) dz+    ]+  where+    strides = lookupAttr nodeDef "strides" :: [Int64]+    padding = lookupAttr nodeDef "padding" :: ByteString+    useCudnnOnGpu = lookupAttr nodeDef "use_cudnn_on_gpu" :: Bool+    dataFormat = lookupAttr nodeDef "data_format" :: ByteString++opGrad "MaxPool" nodeDef [toT -> x] [dz] =+    [ Just $ CoreOps.maxPoolGrad'+                ((opAttr "ksize" .~ ksize)+                    . (opAttr "strides" .~ strides)+                    . (opAttr "padding" .~ padding)+                    . (opAttr "data_format" .~ dataFormat))+                x output dz+    ]+  where+    output :: Tensor Build a+    output = toT $ Output 0 (nodeDefName nodeDef)+    ksize = lookupAttr nodeDef "ksize" :: [Int64]+    strides = lookupAttr nodeDef "strides" :: [Int64]+    padding = lookupAttr nodeDef "padding" :: ByteString+    dataFormat = lookupAttr nodeDef "data_format" :: ByteString++opGrad "Reshape" _ [toT -> x, _] [dz] =+    [Just $ reshape dz $ shape (x :: Tensor Build a), Nothing]++opGrad "OneHot" _ _ _ = [Nothing, Nothing, Nothing, Nothing]+opGrad "TruncatedNormal" _ _ _ = [Nothing]++opGrad "RefIdentity" _ _ [dz] = [Just $ expr dz]+opGrad "Cast" nodeDef _ [dz] = [Just reverseCast]+  where+    -- TODO(gnezdo): too permissive, python only allows float types as src_type.+    reverseCast =+        pureOp [] $ pure (opDef "Cast"+                 & opAttr "DstT" .~ (lookupAttr nodeDef "SrcT" :: ByteString)+                 & opAttr "SrcT" .~ (lookupAttr nodeDef "DstT" :: ByteString)+                 & opInputs .~ [renderedOutput dz])++opGrad "DynamicStitch" nodeDef inputs [dz] =+    replicate halfLen Nothing ++ valuesGrads+  where+    halfLen =+        let len = length inputs+            half = len `div` 2+        in if 2 * half == len+           then half+           else error ("Uneven input size " ++ show (len, showMessage nodeDef))+    valuesGrads = [ Just $ CoreOps.gather dz (toT idx :: Tensor Build Int32)+                  | idx <- take halfLen inputs+                  ]++opGrad "DynamicPartition" nodeDef [toT -> xs, toT -> indices] dz =+    [ Just reconstructed, Nothing ]+  where+    reconstructed = CoreOps.reshape stitched+                    (CoreOps.shape (xs :: Tensor Build a) :: Tensor Build Int32)+    stitched = CoreOps.dynamicStitch partitionedIndices dz+    partitionedIndices = CoreOps.dynamicPartition np originalIndices indices+    np = lookupAttr nodeDef "num_partitions" :: Int64+    originalIndices =+        CoreOps.reshape (CoreOps.range 0 (CoreOps.size indices) 1) prefixShape+    prefixShape = shapeInt32 indices+    shapeInt32 t = CoreOps.shape t :: Tensor Build Int32++opGrad "Select" _ [toT -> c, toT -> x, _] [dz] =+    [ Nothing+    , Just $ CoreOps.select c dz zeros+    , Just $ CoreOps.select c zeros dz+    ]+  where zeros = CoreOps.zerosLike x++-- TODO(gnezdo): Unlike Python, no control dependency on dz.+opGrad "Log" _ [toT -> x] [dz] = [ Just $ dz `CoreOps.mul` CoreOps.inv x ]+-- TODO(gnezdo): Reuse the output instead of doing another exp,+-- though, it is probably CSE'd away anyway.+opGrad "Exp" _ [toT -> x] [dz] = [ Just $ dz `CoreOps.mul` CoreOps.exp x ]+opGrad "SparseSegmentSum" _ [toT -> x, toT -> y, toT -> t] [dz] =+    [ Just $ CoreOps.unsortedSegmentSum+             (CoreOps.gather dz (t :: Tensor Build Int32))+             (y :: Tensor Build Int32) inputRows+    , Nothing+    , Nothing+    ]+  where inputRows = flatSlice (shape (x :: Tensor Build a)) 0 1++opGrad "LabelClasses" _ _ _ = [Nothing, Nothing]+opGrad "LabelWeights" _ _ _ = [Nothing]+opGrad "Size" _ _ _ = [Nothing]++-- TODO (jcberentsen): Python implementation uses set_shape for+-- static shape inference, which is unsupported.+-- TODO: implement support for static shape inference+opGrad "Tile" _ [toT -> x, toT -> multiples] [dz] =+    [Just inputGrad, Nothing]+  where+    inputGrad = sum reshapedDz axes+    inputShape = shape (x :: Tensor Build a)+    packed = CoreOps.pack [multiples, inputShape]+    perm = vector [1, 0 :: Int32]+    splitShape = CoreOps.reshape (CoreOps.transpose packed perm) allDimensions+    axes = CoreOps.range 0 (CoreOps.size splitShape) (2 :: Tensor Build Int32)+    reshapedDz = CoreOps.reshape dz splitShape++opGrad "ZerosLike" _ _ _ = [Nothing]+opGrad "Fill" _ _ [dz] = [Nothing, Just $ sum dz rx]+  where+    rx = rangeOfRank dz++-- TODO(fmayle): These can go away if we properly prune the graph.+opGrad "Const" _ _ _ = [Nothing, Nothing]+opGrad "Placeholder" _ _ _ = []+opGrad "Variable" _ _ _ = []++opGrad n nodeDef ins grads =+    error $ "no gradient implemented for " +++            show (n, length ins, length grads, showMessage nodeDef, ins)++-- | The number of outputs for an op type.+numOutputs :: NodeDef -> OutputIx+numOutputs o =+    case o ^. op of+        "Abs" -> 1+        "Add" -> 1+        "Cast" -> 1+        "Const" -> 1+        "Conv2D" -> 1+        "Div" -> 1+        "DynamicStitch" -> 1+        "DynamicPartition" ->+            fromIntegral (lookupAttr o "num_partitions" :: Int64)+        "Exp" -> 1+        "Gather" -> 1+        "LabelClasses" -> 1+        "LabelWeights" -> 1+        "Log" -> 1+        "MatMul" -> 1+        "Max" -> 1+        "MaxPool" -> 1+        "Mean" -> 1+        "Min" -> 1+        "Mul" -> 1+        "Neg" -> 1+        "Placeholder" -> 1+        "OneHot" -> 1+        "RefIdentity" -> 1+        "Relu" -> 1+        "ReluGrad" -> 1+        "Reshape" -> 1+        "Select" -> 1+        "Size" -> 1+        "SoftmaxCrossEntropyWithLogits" -> 2+        "Square" -> 1+        "SparseSegmentSum" -> 1+        "Sub" -> 1+        "Sum" -> 1+        "Tile" -> 1+        "Transpose" -> 1+        "TruncatedNormal" -> 1+        "Variable" -> 1+        "ZerosLike" -> 1+        "Fill" -> 1+        _ -> error $ "numOuputs not implemented for " ++ show (o ^. op)++-- Divides `x / y` assuming `x, y >= 0`, treating `0 / 0 = 0`+safeShapeDiv :: Tensor v1 Int32 -> Tensor v2 Int32 -> Tensor Build Int32+safeShapeDiv x y = x `CoreOps.div` (CoreOps.maximum y 1)++allDimensions :: Tensor Build Int32+allDimensions = vector [-1 :: Int32]++rangeOfRank :: forall v1 t. TensorType t => Tensor v1 t -> Tensor Build Int32+rangeOfRank x = CoreOps.range 0 (CoreOps.rank x) 1++lookupAttr ::  Attribute a1 => NodeDef -> Text -> a1+lookupAttr nodeDef attrName = nodeDef ^. attr . at attrName . non def . attrLens
+ src/TensorFlow/NN.hs view
@@ -0,0 +1,88 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module TensorFlow.NN+    ( sigmoidCrossEntropyWithLogits+    ) where++import Prelude hiding           ( log+                                , exp+                                )+import TensorFlow.Build         ( MonadBuild+                                , withNameScope+                                )+import TensorFlow.GenOps.Core   ( greaterEqual+                                , select+                                , log+                                , exp+                                )+import TensorFlow.Tensor        ( Tensor(..)+                                , render+                                , Value+                                )+import TensorFlow.Types         ( TensorType(..)+                                , OneOf+                                )+import TensorFlow.Ops           ( zerosLike+                                , add+                                , mul+                                , neg+                                )++-- | Computes sigmoid cross entropy given `logits`.+--+-- Measures the probability error in discrete classification tasks in which each+-- class is independent and not mutually exclusive.  For instance, one could+-- perform multilabel classification where a picture can contain both an elephant+-- and a dog at the same time.+--+-- For brevity, let `x = logits`, `z = targets`.  The logistic loss is+--+--        z * -log(sigmoid(x)) + (1 - z) * -log(1 - sigmoid(x))+--      = z * -log(1 / (1 + exp(-x))) + (1 - z) * -log(exp(-x) / (1 + exp(-x)))+--      = z * log(1 + exp(-x)) + (1 - z) * (-log(exp(-x)) + log(1 + exp(-x)))+--      = z * log(1 + exp(-x)) + (1 - z) * (x + log(1 + exp(-x))+--      = (1 - z) * x + log(1 + exp(-x))+--      = x - x * z + log(1 + exp(-x))+--+--  For x < 0, to avoid overflow in exp(-x), we reformulate the above+--+--        x - x * z + log(1 + exp(-x))+--      = log(exp(x)) - x * z + log(1 + exp(-x))+--      = - x * z + log(1 + exp(x))+--+--  Hence, to ensure stability and avoid overflow, the implementation uses this+--  equivalent formulation+--+--      max(x, 0) - x * z + log(1 + exp(-abs(x)))+--+--  `logits` and `targets` must have the same type and shape.+sigmoidCrossEntropyWithLogits+  :: (MonadBuild m, OneOf '[Float, Double] a, TensorType a, Num a)+     => Tensor Value a          -- ^ __logits__+     -> Tensor Value a          -- ^ __targets__+     -> m (Tensor Value a)+sigmoidCrossEntropyWithLogits logits targets = do+    let zeros = zerosLike logits+        cond = logits `greaterEqual` zeros+        relu_logits = select cond logits zeros+        neg_abs_logits = select cond (neg logits) logits+    withNameScope "logistic_loss" $ do+        left <- render $ relu_logits - logits `mul` targets+        right <- render $ log (1 + exp neg_abs_logits)+        withNameScope "sigmoid_add" $ render $ left `add` right
+ src/TensorFlow/Ops.hs view
@@ -0,0 +1,389 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++-- | This module contains definitions for some built-in TensorFlow operations.+--+-- Note that certain, "stateful" ops like 'variable' and 'assign' return a+-- 'Build' action (e.g., @Build (Tensor Ref a)@ instead of a pure value; the+-- returned 'Tensor's are always rendered in the current 'Build' context.  This+-- approach helps us avoid problems with inlining or common subexpression+-- elimination, by writing+--+-- > do+-- >     v <- variable []+-- >     w <- assign v 3+-- >     render $ w * w+--+-- instead of+--+-- > let+-- >    v = variable []+-- >    w = assign v 3+-- > in w * w+--+-- since the latter could be reasonably transformed by the compiler into (or+-- vice versa)+--+-- > let+-- >    v = variable []+-- >    w = assign v 3+-- >    w' = assign v 3+-- > in w * w'+--+-- Ops should return a 'Build' action if their original 'OpDef' marks them as+-- stateful, or if they take any Refs as input.  (This mirrors the rules that+-- TensorFlow uses to avoid common subexpression elimination.)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TensorFlow.Ops+    ( CoreOps.add+    , CoreOps.add'+    , CoreOps.abs+    , CoreOps.abs'+    , CoreOps.addN+    , CoreOps.addN'+    , CoreOps.argMax+    , CoreOps.argMax'+    , CoreOps.assign+    , CoreOps.assign'+    , CoreOps.broadcastGradientArgs+    , CoreOps.broadcastGradientArgs'+    , CoreOps.cast+    , CoreOps.cast'+    , CoreOps.concat+    , CoreOps.concat'+    , constant+    , constant'+    , CoreOps.equal+    , CoreOps.equal'+    , expandDims+    , expandDims'+    , initializedVariable+    , initializedVariable'+    , zeroInitializedVariable+    , zeroInitializedVariable'+    , CoreOps.fill+    , CoreOps.fill'+    , CoreOps.identity+    , CoreOps.identity'+    , CoreOps.matMul+    , CoreOps.matMul'+    , matTranspose+    , matTranspose'+    , CoreOps.mean+    , CoreOps.mean'+    , CoreOps.mul+    , CoreOps.mul'+    , CoreOps.neg+    , CoreOps.neg'+    , CoreOps.oneHot+    , CoreOps.oneHot'+    , CoreOps.pack+    , CoreOps.pack'+    , placeholder+    , placeholder'+    , CoreOps.range+    , CoreOps.range'+    , reducedShape+    , CoreOps.relu+    , CoreOps.relu'+    , CoreOps.reluGrad+    , CoreOps.reluGrad'+    , CoreOps.reshape+    , CoreOps.reshape'+    , restore+    , restoreFromName+    , save+    , scalar+    , scalar'+    , shape+    , shape'+    , CoreOps.sign+    , CoreOps.sign'+    , CoreOps.size+    , CoreOps.size'+    , CoreOps.softmax+    , CoreOps.softmax'+    , CoreOps.softmaxCrossEntropyWithLogits+    , CoreOps.softmaxCrossEntropyWithLogits'+    , CoreOps.sparseToDense+    , CoreOps.sparseToDense'+    , CoreOps.sub+    , CoreOps.sub'+    , CoreOps.sum+    , CoreOps.sum'+    , reduceSum+    , reduceSum'+    , CoreOps.transpose+    , CoreOps.transpose'+    , truncatedNormal+    , truncatedNormal'+    , CoreOps.variable+    , CoreOps.variable'+    , vector+    , vector'+    , zeros+    , CoreOps.zerosLike+    , CoreOps.zerosLike'+    , scalarize+    ) where++import Data.ByteString (ByteString)+import Data.Complex (Complex)+import Data.Int (Int32, Int64)+import Data.Word (Word16)+import Prelude hiding (abs, sum, concat)+import Data.ProtoLens (def)+import Data.Text.Encoding (encodeUtf8)+import Lens.Family2 ((.~), (&))+import Text.Printf (printf)+import Proto.Tensorflow.Core.Framework.Tensor+    ( TensorProto+    , dtype+    , tensorShape+    )+import qualified Proto.Tensorflow.Core.Framework.TensorShape+  as TensorShape+import TensorFlow.Build+import TensorFlow.BuildOp+import TensorFlow.ControlFlow (group)+import TensorFlow.Tensor+import TensorFlow.Types++import qualified TensorFlow.GenOps.Core as CoreOps++import qualified Prelude (abs)++-- TODO: Look into hs-boot refactoring to allow mutually recursive imports.+-- | Must be defined as an orphan because of the dependency order between Ops+-- and Tensor.+--+-- The indirect constraint "v ~ Value" helps disambiguate types, for example in+-- "neg 1 :: Tensor Value Float", it helps find the type of the subexpression+-- "1".+instance ( TensorType a+         , Num a+         , v ~ Build+         , OneOf '[ Double, Float, Int32, Int64+                  , Complex Float, Complex Double] a) => Num (Tensor v a) where+    (+) = CoreOps.add+    (*) = CoreOps.mul+    (-) = CoreOps.sub+    abs = CoreOps.abs+    fromInteger = scalar . fromInteger+    signum = CoreOps.sign+    negate = CoreOps.neg++matTranspose :: TensorType a => Tensor e a -> Tensor Build a+matTranspose = matTranspose' id++matTranspose' :: TensorType a => OpParams -> Tensor v a -> Tensor Build a+matTranspose' params = flip (CoreOps.transpose' params) (vector [1, 0 :: Int32])++placeholder :: (MonadBuild m, TensorType a) => Shape -> m (Tensor Value a)+placeholder = placeholder' id++placeholder' :: forall m a . (MonadBuild m, TensorType a)+             => OpParams -> Shape -> m (Tensor Value a)+placeholder' params pShape+    -- Note: we don't use CoreOps.placeholder' since that op isn't stateful,+    -- and thus would be CSE'd.+    = build $ buildOp [] $ opDef "Placeholder"+                & opAttr "dtype" .~ tensorType (undefined :: a)+                & opAttr "shape" .~ pShape+                & params++-- | Creates a variable initialized to the given value.+-- Initialization happens next time session runs.+initializedVariable :: (MonadBuild m, TensorType a)+                    => Tensor v a -> m (Tensor Ref a)+initializedVariable = initializedVariable' id++initializedVariable' :: (MonadBuild m, TensorType a)+                    => OpParams -> Tensor v a -> m (Tensor Ref a)+initializedVariable' params initializer = do+    v <- CoreOps.variable' params []  -- The shape is not known initially.+    i <- CoreOps.assign' (opAttr "validate_shape" .~ False) v+                            initializer+    addInitializer =<< group i+    return v++-- | Creates a zero-initialized variable with the given shape.+zeroInitializedVariable+  :: (MonadBuild m, TensorType a, Num a) =>+     TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a)+zeroInitializedVariable = zeroInitializedVariable' id++zeroInitializedVariable'+  :: (MonadBuild m, TensorType a, Num a) =>+     OpParams -> TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a)+zeroInitializedVariable' params = initializedVariable' params . zeros++-- TODO: Support heterogeneous list of tensors.+save :: forall a m v . (Rendered v, MonadBuild m, TensorType a)+        => ByteString     -- ^ File path.+        -> [Tensor v a]  -- ^ Tensors to save.+        -> m ControlNode+save path xs = build $ do+    let toByteStringTensor = scalar . encodeUtf8 . encodeOutput . renderedOutput+    let names = fmap toByteStringTensor xs+    let types = replicate (length xs) (tensorType (undefined :: a))+    names' <- buildInputs $ CoreOps.pack names+    xs' <- buildInputs xs+    path' <- buildInputs $ scalar path+    buildOp [] $ opDef "Save"+                    & opAttr "T" .~ types+                    & opInputs .~ (path' ++ names' ++ xs')++-- | Restore a tensor's value from a checkpoint file.+--+-- This version allows restoring from a checkpoint file that uses a different+-- tensor name than the variable.+restoreFromName :: forall a m . (MonadBuild m, TensorType a)+                => ByteString    -- ^ File path.+                -> ByteString    -- ^ Tensor name override.+                -> Tensor Ref a  -- ^ Tensor to restore.+                -> m ControlNode+restoreFromName path name x = build $ do+    path' <- buildInputs $ scalar path+    name' <- buildInputs $ scalar name+    restoreOp <- buildOp [] $ opDef "Restore"+                               & opAttr "dt" .~ tensorType (undefined :: a)+                               & opInputs .~ (path' ++ name')+    group =<< CoreOps.assign x (restoreOp :: Tensor Value a)++-- | Restore a tensor's value from a checkpoint file.+restore :: forall a m . (MonadBuild m, TensorType a)+        => ByteString    -- ^ File path.+        -> Tensor Ref a  -- ^ Tensor to restore.+        -> m ControlNode+restore path x = restoreFromName path name x+  where+    name = encodeUtf8 $ encodeOutput $ renderedOutput x++-- | Create a constant tensor.+--+-- The values should be in row major order, e.g.,+--+--   element 0:   index (0, ..., 0)+--   element 1:   index (0, ..., 1)+--   ...+constant :: TensorType a => Shape -> [a] -> Tensor Build a+constant = constant' id++constant' :: forall a . TensorType a => OpParams -> Shape -> [a] -> Tensor Build a+constant' params (Shape cShape) values+    | invalidLength = error invalidLengthMsg+    | otherwise = CoreOps.const' (params . (opAttr "value" .~ typedNode))+  where+    invalidLength = product cShape /= fromIntegral (length values)+    invalidLengthMsg = printf "invalid tensor length: expected %d got %d"+                              (product cShape)+                              (length values)+    typedNode :: TensorProto+    typedNode = def+                & dtype .~ tensorType (undefined :: a)+                & tensorShape.TensorShape.dim .~+                      [def & TensorShape.size .~ x | x <- cShape]+                & tensorVal .~ values++-- | Reshape a N-D tensor down to a scalar.+--+-- See `TensorFlow.GenOps.Core.reshape`.+scalarize :: TensorType a => Tensor v a -> Tensor Build a+scalarize t = CoreOps.reshape t (vector scalarShape)+    where+        scalarShape = [] :: [Int32]++-- | Sum a tensor down to a scalar+-- Seee `TensorFlow.GenOps.Core.sum`+reduceSum :: (OneOf '[ Double, Float, Int32, Int64+                     , Complex Float, Complex Double] a) =>+             Tensor v a -> Tensor Build a+reduceSum x = CoreOps.sum x allAxes+  where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1++reduceSum' :: (OneOf '[ Double, Float, Int32, Int64+                      , Complex Float, Complex Double] a) =>+              OpParams -> Tensor v a -> Tensor Build a+reduceSum' params x = CoreOps.sum' params x allAxes+  where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1++-- | Create a constant vector.+vector :: TensorType a => [a] -> Tensor Build a+vector = vector' id++vector' :: TensorType a => OpParams -> [a] -> Tensor Build a+vector' params xs = constant' params [fromIntegral $ length xs] xs++-- | Create a constant scalar.+scalar :: TensorType a => a -> Tensor Build a+scalar = scalar' id++scalar' :: TensorType a => OpParams -> a -> Tensor Build a+scalar' params x = constant' params [] [x]++-- | Random tensor from the unit normal distribution with bounded values.+--+-- This is a type-restricted version of 'TensorFlow.GenOps.Core.truncatedNormal'.+truncatedNormal :: (MonadBuild m, OneOf '[Word16, Double, Float] a)+                => Tensor v Int64  -- ^ Shape.+                -> m (Tensor Value a)+truncatedNormal = CoreOps.truncatedNormal++truncatedNormal' :: (MonadBuild m, OneOf '[Word16, Double, Float] a)+                => OpParams -> Tensor v Int64  -- ^ Shape.+                -> m (Tensor Value a)+truncatedNormal' = CoreOps.truncatedNormal'++zeros :: forall a . (Num a, TensorType a) => Shape -> Tensor Build a+zeros (Shape s) = CoreOps.fill (vector $ map fromIntegral s) (scalar 0)++shape :: TensorType t => Tensor v t -> Tensor Build Int32+shape = CoreOps.shape++shape' :: TensorType t => OpParams -> Tensor v t -> Tensor Build Int32+shape' = CoreOps.shape'++expandDims :: TensorType t => Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t+expandDims = CoreOps.expandDims++expandDims' :: TensorType t => OpParams -> Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t+expandDims' = CoreOps.expandDims'++-- | Helper function for reduction ops (translation of math_ops.reduced_shape).+reducedShape :: (OneOf '[ Int32, Int64 ] t1, OneOf '[ Int32, Int64 ] t2) =>+                Tensor v1 t1 -> Tensor v2 t2 -> Tensor Build Int32+reducedShape inputShape axes =+    let inputShape32 = toInt32 inputShape         -- [2, 3, 5, 7]+        axes32 = toInt32 axes                     -- [1, 2]+        toInt32 x = CoreOps.cast x :: Tensor Build Int32+        inputRank = CoreOps.size inputShape32     -- 4+        axesMod = (axes32 + inputRank) `CoreOps.mod` inputRank+        axesShape = shape axesMod                 -- [2]+    in CoreOps.dynamicStitch                      -- [2, 1, 1, 7]+         [CoreOps.range 0 inputRank 1,            -- [0, 1, 2, 3]+           axesMod]                               -- [1, 2]+         [inputShape32,                           -- [2, 3, 5, 7]+           CoreOps.fill axesShape 1]              -- [1, 1]
+ src/TensorFlow/Queue.hs view
@@ -0,0 +1,71 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Queues in TensorFlow graph. Very limited support for now.+module TensorFlow.Queue (Queue, makeQueue, enqueue, dequeue) where++import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Proxy (Proxy(..))+import Lens.Family2 ((.~), (&))+import TensorFlow.Build (ControlNode, MonadBuild, build, addInitializer, opAttr, opDef)+import TensorFlow.BuildOp (buildOp)+import TensorFlow.ControlFlow (group)+import qualified TensorFlow.GenOps.Core as CoreOps+import TensorFlow.Tensor (Ref, Value, Tensor, TensorList)+import TensorFlow.Types (TensorTypes, fromTensorTypes)++-- | A queue carrying tuples.+data Queue (as :: [*]) = Queue { handle :: Handle }++type Handle = Tensor Ref ByteString++-- | Adds the given values to the queue.+enqueue :: forall as v m . (MonadBuild m, TensorTypes as)+           => Queue as+           -> TensorList v as+           -> m ControlNode+enqueue = CoreOps.queueEnqueue . handle++-- | Retrieves the values from the queue.+dequeue :: forall as m . (MonadBuild m, TensorTypes as)+           => Queue as+           -> m (TensorList Value as)+           -- ^ Dequeued tensors. They are coupled in a sense+           -- that values appear together, even if they are+           -- not consumed together.+dequeue = CoreOps.queueDequeue . handle++-- | Creates a new queue with the given capacity and shared name.+makeQueue :: forall as m . (MonadBuild m, TensorTypes as)+              => Int64  -- ^ The upper bound on the number of elements in+                        --  this queue. Negative numbers mean no limit.+              -> ByteString -- ^ If non-empty, this queue will be shared+                            -- under the given name across multiple sessions.+              -> m (Queue as)+makeQueue capacity sharedName = do+    q <- build $ buildOp [] (opDef "FIFOQueue"+                     & opAttr "component_types" .~ fromTensorTypes (Proxy :: Proxy as)+                     & opAttr "shared_name" .~ sharedName+                     & opAttr "capacity" .~ capacity+                    )+    group q >>= addInitializer+    return (Queue q)++-- TODO(gnezdo): Figure out the closing story for queues.
+ src/TensorFlow/Variable.hs view
@@ -0,0 +1,123 @@+-- | An implementation of ResourceHandle-based variables.+--+-- The main difference between this and 'Ref'-based variables is+-- that reads are explicit, via the 'readValue' op.+--+-- TODO: given that distinction, figure out a good story around+-- gradients and save/restore.  Then, merge this module into+-- TensorFlow.Ops.+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+module TensorFlow.Variable+    ( Variable+    , variable+    , variable'+    , readValue+    , initializedVariable+    , initializedVariable'+    , zeroInitializedVariable+    , zeroInitializedVariable'+    , assign+    , assign'+    , assignAdd+    , assignAdd'+    ) where++import Data.Text.Encoding (encodeUtf8)+import Lens.Family2 ((.~), (&))+import TensorFlow.Core+import TensorFlow.Build (opDef)+import TensorFlow.BuildOp (buildInputs, pureOp, OpParams)+import TensorFlow.Output (opInputs, unNodeName)+import TensorFlow.Tensor (tensorNodeName)+import TensorFlow.Types (tensorType)+import qualified TensorFlow.GenOps.Core as CoreOps+import TensorFlow.Ops (zeros)++newtype Variable a = Variable (Tensor Value ResourceHandle)++-- | Creates a new, uninitialized variable.+variable :: (MonadBuild m, TensorType a) => Shape -> m (Variable a)+variable = variable' id++variable' :: forall m a . (MonadBuild m, TensorType a)+                    => OpParams -> Shape -> m (Variable a)+variable' params s = build $ do+    -- Each variable needs a unique "shared_name".  Use MonadFix to+    -- set the attribute to the same name as the variable itself, without+    -- exposing more internals of the Build module.+    rec t <- CoreOps.varHandleOp' (params . (opAttr "shared_name" .~ n))+                                    (tensorType (undefined :: a)) s+        let n = encodeUtf8 $ unNodeName $ tensorNodeName t+    return $ Variable t++-- | Creates a variable initialized to the given value.+-- Initialization happens next time session runs.+initializedVariable :: (MonadBuild m, TensorType a)+                    => Tensor v a -> m (Variable a)+initializedVariable = initializedVariable' id++initializedVariable' :: forall a m v . (MonadBuild m, TensorType a)+                    => OpParams -> Tensor v a -> m (Variable a)+initializedVariable' params initializer = do+    -- The shape is not known initially.+    v@(Variable h) <- variable' params (Shape [])+    i <- CoreOps.assignVariableOp h initializer+    addInitializer =<< group i+    return v++-- | Creates a zero-initialized variable with the given shape.+zeroInitializedVariable+  :: (MonadBuild m, TensorType a, Num a) => Shape -> m (Variable a)+zeroInitializedVariable = zeroInitializedVariable' id++zeroInitializedVariable'+  :: (MonadBuild m, TensorType a, Num a) => OpParams -> Shape -> m (Variable a)+zeroInitializedVariable' params = initializedVariable' params . zeros++-- | Gets the value stored in a variable.+--+-- Note that this op is stateful since it depends on the value of the variable;+-- however, it may be CSE'd with other reads in the same context.  The context can+-- be fixed by using 'render' along with (for example) 'withControlDependencies'.+-- For example:+--+-- >   runSession $ do+-- >     v <- variable []+-- >     a <- assign v 24+-- >     r <- withControlDependencies a $ render $ readValue v + 18+-- >     result <- run r+-- >     liftIO $ (42 :: Float) @=? unScalar result+--+--+readValue :: TensorType a => Variable a -> Tensor Build a+readValue = readValue' id++readValue' :: forall a . TensorType a+    => OpParams -> Variable a -> Tensor Build a+readValue' params (Variable h)+    = pureOp [] $ do+        os <- buildInputs h+        pure $ opDef "ReadVariableOp"+                & (params+                    . (opAttr "dtype" .~ tensorType (undefined :: a))+                    . (opInputs .~ os))++-- | Sets the value of a variable.+assign :: (MonadBuild m, TensorType a)+    => Variable a -> Tensor v a -> m ControlNode+assign = assign' id++assign' :: (MonadBuild m, TensorType a)+    => OpParams -> Variable a -> Tensor v a -> m ControlNode+assign' params (Variable h) v = CoreOps.assignVariableOp' params h v++-- | Increments the value of a variable.+assignAdd :: (MonadBuild m, TensorType a)+    => Variable a -> Tensor v a -> m ControlNode+assignAdd = assignAdd' id++assignAdd' :: (MonadBuild m, TensorType a)+    => OpParams -> Variable a -> Tensor v a -> m ControlNode+assignAdd' params (Variable h) v = CoreOps.assignAddVariableOp' params h v
+ tensorflow-ops.cabal view
@@ -0,0 +1,306 @@+name:                tensorflow-ops+version:             0.1.0.0+synopsis:            Friendly layer around TensorFlow bindings.+description:         Please see README.md+homepage:            https://github.com/tensorflow/haskell#readme+license:             Apache+license-file:        LICENSE+author:              TensorFlow authors+maintainer:          tensorflow-haskell@googlegroups.com+copyright:           Google Inc.+category:            Machine Learning+build-type:          Simple+cabal-version:       >=1.22++library+  hs-source-dirs:   src+  exposed-modules: TensorFlow.Gradient+                 , TensorFlow.Ops+                 , TensorFlow.EmbeddingOps+                 , TensorFlow.NN+                 , TensorFlow.Queue+                 , TensorFlow.Variable+  build-depends:  proto-lens == 0.2.*+                , base >= 4.7 && < 5+                , bytestring+                , fgl+                , mtl+                , data-default+                , lens-family+                , containers+                , tensorflow == 0.1.*+                , tensorflow-proto == 0.1.*+                , tensorflow-core-ops == 0.1.*+                , text+  default-language:    Haskell2010++Test-Suite RegressionTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: RegressionTest.hs+  hs-source-dirs: tests+  build-depends: base+               , HUnit+               , lens-family+               , transformers+               , random+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops++Test-Suite MatrixTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: MatrixTest.hs+  hs-source-dirs: tests+  build-depends: base+               , HUnit+               , random+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-test+               , test-framework+               , test-framework-hunit+               , transformers+               , vector++Test-Suite BuildTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: BuildTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , base+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , transformers+               , vector++Test-Suite EmbeddingOpsTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: EmbeddingOpsTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-test+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , transformers+               , vector++Test-Suite ArrayOpsTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: ArrayOpsTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , transformers+               , vector++Test-Suite OpsTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: OpsTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , bytestring+               , proto-lens+               , lens-family+               , temporary+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , transformers+               , vector++Test-Suite VariableTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: VariableTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , base+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , test-framework+               , test-framework-hunit+               , transformers+               , vector+++Test-Suite DataFlowOpsTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: DataFlowOpsTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , vector++Test-Suite GradientTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: GradientTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , base+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit+               , transformers+               , vector++Test-Suite MiscTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: MiscTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , base+               , bytestring+               , vector+               , transformers+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , test-framework+               , test-framework-hunit++Test-Suite NNTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: NNTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , tensorflow+               , tensorflow-test+               , tensorflow-ops+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , vector++Test-Suite QueueTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: QueueTest.hs+  hs-source-dirs: tests+  -- Uses multiple threads and blocks without this option.+  ghc-options: -threaded+  build-depends: HUnit+               , base+               , bytestring+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , test-framework+               , test-framework-hunit+               , transformers+               , vector++Test-Suite TracingTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: TracingTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , base+               , bytestring+               , data-default+               , lens-family+               , tensorflow+               , tensorflow-ops+               , test-framework+               , test-framework-hunit++Test-Suite TypesTest+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: TypesTest.hs+  hs-source-dirs: tests+  build-depends: HUnit+               , QuickCheck+               , base+               , bytestring+               , proto-lens+               , lens-family+               , tensorflow+               , tensorflow-core-ops+               , tensorflow-ops+               , tensorflow-proto+               , transformers+               , test-framework+               , test-framework-hunit+               , test-framework-quickcheck2+               , vector++Benchmark FeedFetchBench+  default-language: Haskell2010+  type:       exitcode-stdio-1.0+  main-is:    FeedFetchBench.hs+  hs-source-dirs: tests+  build-depends: base+               , criterion+               , deepseq+               , tensorflow+               , tensorflow-ops+               , transformers+               , vector+  ghc-options: -O2 -threaded++source-repository head+  type:     git+  location: https://github.com/tensorflow/haskell
+ tests/ArrayOpsTest.hs view
@@ -0,0 +1,51 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedLists #-}+module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int64)+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+import qualified Data.Vector as V++import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Core as TF+import qualified TensorFlow.GenOps.Core as CoreOps++-- | Test split and concat are inverses.+testSplit :: Test+testSplit = testCase "testSplit" $ TF.runSession $ do+    let original = TF.constant [2, 3] [0..5 :: Float]+        splitList = CoreOps.split 3 dim original+        restored = CoreOps.concat dim splitList+        dim = 1  -- dimension to split along (with size of 3 in original)+    liftIO $ 3 @=? length splitList+    (x, y, z) <- TF.run (original, restored, splitList !! 1)+    liftIO $ x @=? (y :: V.Vector Float)+    liftIO $ V.fromList [1, 4] @=? z++testShapeN :: Test+testShapeN = testCase "testShapeN" $ TF.runSession $ do+    let shapes = map TF.Shape [[1],[2,3]]+    let tensors = map TF.zeros shapes :: [TF.Tensor TF.Build Float]+    result <- TF.run $ CoreOps.shapeN tensors+    liftIO $ [V.fromList [1], V.fromList [2,3]] @=? (result :: [V.Vector Int64])++main :: IO ()+main = defaultMain [ testSplit+                   , testShapeN+                   ]
+ tests/BuildTest.hs view
@@ -0,0 +1,176 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Lens.Family2 ((^.), (.~))+import Data.List (sort)+import Proto.Tensorflow.Core.Framework.Graph+    ( node )+import Proto.Tensorflow.Core.Framework.NodeDef+    ( NodeDef+    , device+    , name+    , op )+import TensorFlow.Build+    ( Build+    , BuildT+    , asGraphDef+    , evalBuildT+    , flushNodeBuffer+    , withDevice+    , withNameScope+    , opName+    )+import TensorFlow.Types (unScalar)+import TensorFlow.Ops+    ( add+    , assign+    , constant+    , initializedVariable+    , variable+    , variable'+    )+import TensorFlow.Output (Device(..))+import TensorFlow.Tensor+    ( colocateWith+    , render+    , Tensor+    , Value+    , Ref+    )+import TensorFlow.Session+    ( run+    , runSession+    , run_+    )+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+import qualified Data.Vector as V++-- | Test 'opName' behavior.+testOpName :: Test+testOpName = testCase "testOpName" $ do+    let graph = variable' (opName .~ "foo") [] :: Build (Tensor Ref Float)+        nodeDef :: NodeDef+        nodeDef = head $ asGraphDef graph ^. node+    "Variable" @=? (nodeDef ^. op)+    "foo" @=? (nodeDef ^. name)++-- | Test that "run" will render and extend any pure ops that haven't already+-- been rendered.+testPureRender :: Test+testPureRender = testCase "testPureRender" $ runSession $ do+    result <- run $ 2 `add` 2+    liftIO $ 4 @=? (unScalar result :: Float)++-- | Test that "run" assigns any previously accumulated initializers.+testInitializedVariable :: Test+testInitializedVariable =+    testCase "testInitializedVariable" $ runSession $ do+        (formula, reset) <- do+            v <- initializedVariable 42+            r <- assign v 24+            return (1 `add` v, r)+        result <- run formula+        liftIO $ 43 @=? (unScalar result :: Float)+        run_ reset  -- Updates v to a different value+        rerunResult <- run formula+        liftIO $ 25 @=? (unScalar rerunResult :: Float)++testInitializedVariableShape :: Test+testInitializedVariableShape =+    testCase "testInitializedVariableShape" $ runSession $ do+        vector <- initializedVariable (constant [1] [42 :: Float])+        result <- run vector+        liftIO $ [42] @=? (result :: V.Vector Float)++-- | Test nameScoped behavior.+testNameScoped :: Test+testNameScoped = testCase "testNameScoped" $ do+    let graph = withNameScope "foo" $ variable [] :: Build (Tensor Ref Float)+        nodeDef :: NodeDef+        [nodeDef] = asGraphDef graph ^. node+    "foo/Variable_0" @=? (nodeDef ^. name)  -- TODO: Check prefix.+    "Variable" @=? (nodeDef ^. op)++-- | Test combined opName and nameScoped behavior.+testNamedAndScoped :: Test+testNamedAndScoped = testCase "testNamedAndScoped" $ do+    let graph :: Build (Tensor Ref Float)+        graph = withNameScope "foo1" (variable' (opName .~ "bar1") [])+        nodeDef :: NodeDef+        nodeDef = head $ asGraphDef graph ^. node+    "Variable" @=? (nodeDef ^. op)+    "foo1/bar1" @=? (nodeDef ^. name)++-- | Flush the node buffer and sort the nodes by name (for more stable tests).+flushed :: Ord a => (NodeDef -> a) -> BuildT IO [a]+flushed field = sort . map field <$> flushNodeBuffer++-- | Test the interaction of rendering, CSE and scoping.+testRenderDedup :: Test+testRenderDedup = testCase "testRenderDedup" $ evalBuildT $ do+   renderNodes+   names <- flushed (^. name)+   liftIO $ ["Const_1", "Variable_0", "Variable_2"] @=? names+   -- Render the nodes in a different scope, which should cause them+   -- to be distinct from the previous ones.+   withNameScope "foo" renderNodes+   scopedNames <- flushed (^. name)+   liftIO $ ["foo/Const_4", "foo/Variable_3", "foo/Variable_5"] @=? scopedNames+  where+    renderNodes = do+        -- A stateful op and a pure op.+        _ :: Tensor Ref Float <- variable []+        _ :: Tensor Value Float <- render 3+        -- Another stateful op, and a pure op which should be+        -- deduped with the previous one.+        _ :: Tensor Ref Float <- variable []+        _ :: Tensor Value Float <- render 3+        return ()++-- | Test the interaction of rendering, CSE and scoping.+testDeviceColocation :: Test+testDeviceColocation = testCase "testDeviceColocation" $ evalBuildT $ do+   renderNodes+   devices <- flushed (\x -> (x ^. name, x ^. device))+   liftIO $ [ ("Add_2","dev0")+            , ("Const_1","dev0")+            , ("Variable_0","dev0")] @=? devices+  where+    renderNodes = do+        -- A stateful op and a pure op.+        var :: Tensor Ref Float <- withDevice (Just $ Device "dev0") $ variable []+        -- Uses render to cause the expression be added to the graph.+        _ <- colocateWith var $ render $ 3 `add` var+        return ()++main :: IO ()+main = defaultMain+            [ testInitializedVariable+            , testInitializedVariableShape+            , testDeviceColocation+            , testOpName+            , testNameScoped+            , testNamedAndScoped+            , testPureRender+            , testRenderDedup+            ]
+ tests/DataFlowOpsTest.hs view
@@ -0,0 +1,65 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Data.Int (Int32, Int64)+import Data.List (genericLength)+import Test.Framework (defaultMain)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import Test.QuickCheck (Arbitrary(..), Property, choose, vectorOf)+import Test.QuickCheck.Monadic (monadicIO, run)++import qualified Data.Vector as V+import qualified TensorFlow.GenOps.Core as CoreOps+import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Core as TF++-- DynamicSplit is undone with DynamicStitch to get the original input+-- back.+testDynamicPartitionStitchInverse :: forall a.+    (TF.TensorDataType V.Vector a, Show a, Eq a) => StitchExample a -> Property+testDynamicPartitionStitchInverse (StitchExample numParts values partitions) =+   let splitParts :: [TF.Tensor TF.Build a] =+           CoreOps.dynamicPartition numParts (TF.vector values) partTensor+       partTensor = TF.vector partitions+       restitchIndices = CoreOps.dynamicPartition numParts+                             (TF.vector [0..genericLength values-1])+                             partTensor+       -- drop (numParts - 2) from both args to expose b/27343984+       restitch = CoreOps.dynamicStitch restitchIndices splitParts+    in monadicIO $ run $ do+       fromIntegral numParts @=? length splitParts+       valuesOut <- TF.runSession $ TF.run restitch+       V.fromList values @=? valuesOut++data StitchExample a = StitchExample Int64 [a] [Int32]+    deriving Show++instance Arbitrary a => Arbitrary (StitchExample a) where+    arbitrary = do+        -- Limits the size of the vector.+        size <- choose (1, 100)+        values <- vectorOf size arbitrary+        numParts <-  choose (2, 15)+        partitions <- vectorOf size (choose (0, fromIntegral numParts - 1))+        return $ StitchExample numParts values partitions++main :: IO ()+main = defaultMain+       [ testProperty "DynamicPartitionStitchInverse"+         (testDynamicPartitionStitchInverse :: StitchExample Int64 -> Property)+       ]
+ tests/EmbeddingOpsTest.hs view
@@ -0,0 +1,177 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Tests for EmbeddingOps.+module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int32, Int64)+import Data.List (genericLength)+import TensorFlow.EmbeddingOps (embeddingLookup)+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import Test.Framework.Providers.HUnit (testCase)+import Test.QuickCheck (Arbitrary(..), Property, choose, vectorOf)+import Test.QuickCheck.Monadic (monadicIO, run)+import TensorFlow.Test (assertAllClose)++import qualified Data.Vector as V+import qualified TensorFlow.GenOps.Core as CoreOps+import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Session as TF+import qualified TensorFlow.Tensor as TF+import qualified TensorFlow.Types as TF+import qualified TensorFlow.Gradient as TF+import qualified TensorFlow.Build as TF+++-- | Tries to perform a simple embedding lookup, with two partitions.+testEmbeddingLookupHasRightShapeWithPartition :: Test+testEmbeddingLookupHasRightShapeWithPartition =+        testCase "testEmbeddingLookupHasRightShapeWithPartition" $ do+    let embShape     = TF.Shape [1, 3] -- Consider a 3-dim embedding of two items.+    let embedding1  = [1, 1, 1 :: Int32]+    let embedding2  = [0, 0, 0 :: Int32]++    let idValues  = [0, 1 :: Int32]++    (values, shape) <- TF.runSession $ do+        embedding   <- mapM TF.render [ TF.constant embShape embedding1+                        , TF.constant embShape embedding2+                        ]+        let ids     = TF.constant (TF.Shape [1, 2]) idValues+        vs          <- embeddingLookup embedding ids+        TF.run (vs, TF.shape vs)++    -- This is the shape that is returned in the equiv. Python.+    shape  @=? V.fromList [1, 2, 3]++    -- "[0, 1]" should pull out the resulting vector.+    values @=? V.fromList [1, 1, 1, 0, 0, 0]+++-- | Tries to perform a simple embedding lookup, with only a single partition.+testEmbeddingLookupHasRightShape :: Test+testEmbeddingLookupHasRightShape =+        testCase "testEmbeddingLookupHasRightShape" $ do+    -- Consider a 3-dim embedding of two items+    let embShape      = TF.Shape [2, 3]+    let embeddingInit = [ 1, 1, 1+                        , 0, 0, 0 :: Int32+                        ]++    let idValues  = [0, 1 :: Int32]++    (values, shape) <- TF.runSession $ do+        embedding <- TF.render $ TF.constant embShape embeddingInit+        let ids = TF.constant (TF.Shape [1, 2]) idValues+        vs <- embeddingLookup [embedding] ids+        TF.run (vs, TF.shape vs)++    -- This is the shape that is returned in the equiv. Python.+    shape  @=? V.fromList [1, 2, 3]++    -- "[0, 1]" should pull out the resulting vector.+    values @=? V.fromList [1, 1, 1, 0, 0, 0]++-- | Check that we can calculate gradients w.r.t embeddings.+testEmbeddingLookupGradients :: Test+testEmbeddingLookupGradients = testCase "testEmbeddingLookupGradients" $ do+    -- Agrees with "embedding", so gradient should be zero.+    let xVals = V.fromList ([20, 20 :: Float])+    let shape = TF.Shape [2]++    gs <- TF.runSession $ do+            let embShape      = TF.Shape [2, 1]+            let embeddingInit = [1, 20 ::Float]+            let idValues      = [1, 1 :: Int32]+            let ids           = TF.constant (TF.Shape [1, 2]) idValues++            x <- TF.placeholder (TF.Shape [2])+            embedding <- TF.initializedVariable+                            (TF.constant embShape embeddingInit)++            op <- embeddingLookup [embedding] ids+            let twoNorm = CoreOps.square $ TF.abs (op `TF.sub` x)+                loss    = TF.mean twoNorm (TF.scalar (0 :: Int32))++            grad <- fmap head (TF.gradients loss [embedding])+            TF.runWithFeeds+                [TF.feed x $ TF.encodeTensorData shape xVals]+                grad+    -- Gradients should be zero (or close)+    assertAllClose gs (V.fromList ([0, 0 :: Float]))+++-- Verifies that direct gather is the same as dynamic split into+-- partitions, followed by embedding lookup.+testEmbeddingLookupUndoesSplit ::+    forall a. (TF.TensorDataType V.Vector a, Show a, Eq a)+    => LookupExample a -> Property+testEmbeddingLookupUndoesSplit+    (LookupExample numParts+                   shape@(TF.Shape (firstDim : restDims))+                   values+                   indices) = monadicIO $ run $ TF.runSession $ do+    let shapedValues = TF.constant shape values+    indicesVector <- TF.render $ TF.vector indices+    let directs = CoreOps.gather shapedValues indicesVector+    let cyclicCounter :: TF.Tensor TF.Build Int32 =+            TF.vector [0..fromIntegral firstDim-1]+            `CoreOps.mod` fromIntegral numParts+    modShardedValues :: [TF.Tensor TF.Value a] <-+            mapM TF.render $ CoreOps.dynamicPartition numParts shapedValues cyclicCounter+    embeddings <- embeddingLookup modShardedValues indicesVector+    (shapeOut, got, want :: V.Vector a) <-+            TF.run (TF.cast (TF.shape embeddings), embeddings, directs)+    -- Checks the explicitly documented invariant of embeddingLookup.+    liftIO $ shapeOut @=? V.fromList (genericLength indices : restDims)+    liftIO $ got @=? want+testEmbeddingLookupUndoesSplit _ = error "Bug in Arbitrary (LookupExample)"++-- | Consistent set of parameters for EmbeddingLookupUndoesSplit.+data LookupExample a = LookupExample+                       Int64  -- ^ number of ways to split.+                       TF.Shape  -- ^ shape of the generated tensor+                       [a]       -- ^ data for the tensor+                       [Int32]   -- ^ indices to split the tensor by+    deriving Show++instance Arbitrary a => Arbitrary (LookupExample a) where+    arbitrary = do+        rank <- choose (1, 4)+        -- Takes rank-th root of 100 to cap the tensor size.+        let maxDim = fromIntegral (ceiling doubleMaxDim :: Int64)+            doubleMaxDim :: Double+            doubleMaxDim = 100 ** (1 / fromIntegral rank)+        shape@(firstDim : _) <- vectorOf rank (choose (1, maxDim))+        values <- vectorOf (fromIntegral $ product shape) arbitrary+        numParts <- choose (2, 15)+        indSize <- choose (0, fromIntegral $ firstDim - 1)+        indices <- vectorOf indSize (choose (0, fromIntegral firstDim - 1))+        return $ LookupExample numParts (TF.Shape shape) values indices++main :: IO ()+main = defaultMain+       [ testProperty "EmbeddingLookupUndoesSplit"+         (testEmbeddingLookupUndoesSplit :: LookupExample Double -> Property)+       , testEmbeddingLookupHasRightShape+       , testEmbeddingLookupHasRightShapeWithPartition+       , testEmbeddingLookupGradients+       ]
+ tests/FeedFetchBench.hs view
@@ -0,0 +1,43 @@+-- Disable full-laziness to keep ghc from optimizing most of the benchmark away.+{-# OPTIONS_GHC -fno-full-laziness #-}+import Control.DeepSeq (NFData(rnf))+import Control.Exception (evaluate)+import Control.Monad.IO.Class (liftIO)+import Criterion.Main (defaultMain, bgroup, bench)+import Criterion.Types (Benchmarkable(..))+import qualified Data.Vector.Storable as S+import qualified TensorFlow.Core as TF+import qualified TensorFlow.Ops as TF++-- | Create 'Benchmarkable' for 'TF.Session'.+--+-- The entire benchmark will be run in a single tensorflow session. The+-- 'TF.Session' argument will be run once and then its result will be run N+-- times.+nfSession :: NFData b => TF.Session (a -> TF.Session b) -> a -> Benchmarkable+nfSession init x = Benchmarkable $ \m -> TF.runSession $ do+    f <- init+    -- Can't use replicateM because n is Int64.+    let go n | n <= 0    = return ()+             | otherwise = f x >>= liftIO . evaluate . rnf >> go (n-1)+    go m++-- | Benchmark feeding and fetching a vector.+feedFetchBenchmark :: TF.Session (S.Vector Float -> TF.Session (S.Vector Float))+feedFetchBenchmark = do+    input <- TF.build (TF.placeholder (TF.Shape [-1]))+    output <- TF.build (TF.render (TF.identity input))+    return $ \v -> do+        let shape = TF.Shape [fromIntegral (S.length v)]+            inputData = TF.encodeTensorData shape v+            feeds = [TF.feed input inputData]+        TF.runWithFeeds feeds output++main :: IO ()+main = defaultMain+    [ bgroup "feedFetch"+        [ bench "4 byte" $ nfSession feedFetchBenchmark (S.replicate 1 0)+        , bench "4 KiB" $ nfSession feedFetchBenchmark (S.replicate 1024 0)+        , bench "4 MiB" $ nfSession feedFetchBenchmark (S.replicate (1024^2) 0)+        ]+    ]
+ tests/GradientTest.hs view
@@ -0,0 +1,312 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++import Data.Int (Int32, Int64)+import Data.List (sort)+import Data.ProtoLens.TextFormat (showMessage)+import Test.Framework (defaultMain, Test)+import Lens.Family2 ((^..), (.~))++import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), assertEqual)+import qualified Data.Vector as V+import Control.Monad.IO.Class (liftIO)++import qualified TensorFlow.Core as TF+import qualified TensorFlow.GenOps.Core as TF (max, tile)+import qualified TensorFlow.Gradient as TF+import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Output as TF+import qualified TensorFlow.Types as TF++import Proto.Tensorflow.Core.Framework.Graph (node)+import Proto.Tensorflow.Core.Framework.NodeDef (op)++testGradientSimple :: Test+testGradientSimple = testCase "testGradientSimple" $ do+    let grads = do+                x <- TF.render $ TF.scalar (3 :: Float)+                b <- TF.render $ TF.scalar (4 :: Float)+                let y = x `TF.mul` x `TF.add` b+                TF.gradients y [x, b]+    -- Assert that the gradients are right.+    [dx, db] <- TF.runSession $ grads >>= TF.run+    6 @=? TF.unScalar dx+    1 @=? TF.unScalar db+    -- Assert that the graph has the expected ops.+    let graphDef = TF.asGraphDef grads+    putStrLn $ showMessage graphDef+    let ops = graphDef ^.. node . traverse . op+        expected = [ "Const"+                   , "Mul"+                   , "Const"+                   , "Add"+                     -- Default output gradient of y.+                   , "Shape"+                   , "Const"+                   , "Fill"+                     -- Add gradient.+                   , "Shape"+                   , "Shape"+                   , "BroadcastGradientArgs"+                   , "Sum"+                   , "Sum"+                   , "Reshape"+                   , "Reshape"+                     -- Mul gradient.+                   , "Shape"+                   -- This Op gets dedup'd because the inputs are the same.+                   -- TODO(fmayle): The same would happen to the Mul and Sum ops+                   -- below if the gradient function didn't multiply one as+                   -- 'dz * y' and the other as 'x * dz'. We could change the+                   -- order, but I'm going to keep it the same as the python+                   -- version for now.+                   --+                   -- , "Shape"+                   , "BroadcastGradientArgs"+                   , "Mul"+                   , "Mul"+                   , "Sum"+                   , "Sum"+                   , "Reshape"+                   , "Reshape"+                     -- AddN to combine x's output gradients.+                   , "AddN"+                   ]+    sort expected @=? sort ops++testGradientDisconnected :: Test+testGradientDisconnected = testCase "testGradientDisconnected" $ do+    let grads = do+            x <- TF.render $ TF.scalar (3 :: Float)+            b <- TF.render $ TF.scalar (4 :: Float)+            TF.gradients x [x, b]+    -- Assert that the gradients are right.+    [dx, db] <- TF.runSession $ grads >>= TF.run+    1 @=? TF.unScalar dx+    0 @=? TF.unScalar db+    -- Assert that the graph has the expected ops.+    let graphDef = TF.asGraphDef grads+    putStrLn $ showMessage graphDef+    let ops = graphDef ^.. node . traverse . op+        expected = [ "Const"+                   , "Const"+                     -- Default output gradient of x.+                   , "Shape"+                   , "Const"+                   , "Fill"+                     -- Default output gradient of b.+                   , "ZerosLike"+                   ]+    sort expected @=? sort ops+++-- Test that identical "stateful" ops work with createGraph.+testCreateGraphStateful :: Test+testCreateGraphStateful = testCase "testCreateGraphStateful" $ do+    [dx, dy] <- TF.runSession $ do+        let shape = TF.constant (TF.Shape [1]) [1]+        x :: TF.Tensor TF.Value Float <- TF.truncatedNormal shape+        y :: TF.Tensor TF.Value Float <- TF.truncatedNormal shape+        TF.gradients (TF.expr x + TF.expr y * 3) [x, y] >>= TF.run+    -- If this test fails, it will likely be caused by an exception within+    -- `TF.gradients`. These asserts are extra.+    1 @=? TF.unScalar dx+    3 @=? TF.unScalar dy+++-- Test that name scopes work with createGraph.+testCreateGraphNameScopes :: Test+testCreateGraphNameScopes = testCase "testCreateGraphNameScopes" $ do+    [dx] <- TF.runSession $ do+        let shape = TF.constant (TF.Shape [1]) [1]+        x :: TF.Tensor TF.Value Float <-+            TF.withNameScope "foo" (TF.truncatedNormal shape)+        TF.gradients x [x] >>= TF.run+    -- If this test fails, it will likely be caused by an exception within+    -- `TF.gradients`. This assert is extra.+    1 @=? TF.unScalar dx+++-- Test that createGraph can handle graphs with diamond shapes.+testDiamond :: Test+testDiamond = testCase "testDiamond" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.vector [1]+        let y = x `TF.mul` x+            z = y*y+        TF.gradients z [x] >>= TF.run+    (4 :: Float) @=? TF.unScalar dx+++testMaxGradient :: Test+testMaxGradient = testCase "testMaxGradient" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.vector [1, 2, 3, 0, 1 :: Float]+        let y = TF.max x (0 :: TF.Tensor TF.Build Int32)+        TF.gradients y [x] >>= TF.run+    V.fromList [0, 0, 1, 0, 0 :: Float] @=? dx+++testReluGrad :: Test+testReluGrad = testCase "testReluGrad" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.vector [2 :: Float]+        let y = TF.relu x+        TF.gradients y [x] >>= TF.run+    V.fromList [1] @=? dx++testReluGradGrad :: Test+testReluGradGrad = testCase "testReluGradGrad" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.vector [2 :: Float]+        let y = TF.relu x+        [y'] <- TF.gradients y [x]+        TF.gradients y' [x] >>= TF.run+    V.fromList [0] @=? dx+++testFillGrad :: Test+testFillGrad = testCase "testFillGrad" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.scalar (9 :: Float)+        let shape = TF.vector [2, 3 :: Int32]+        let y = TF.fill shape x+        TF.gradients y [x] >>= TF.run+    V.fromList [6] @=? dx+++testTileGrad :: Test+testTileGrad = testCase "testTileGrad" $ do+    [dx] <- TF.runSession $ do+        x <- TF.render $ TF.vector [5, 9 :: Float]+        let multiples = TF.vector [2 :: Int32]+        let y = TF.tile x multiples+        TF.gradients y [x] >>= TF.run+    V.fromList [2, 2] @=? dx+++testTile2DGrad :: Test+testTile2DGrad = testCase "testTileGrad2D" $ do+    (dx, shapeDX, shapeX) <- TF.runSession $ do+        let shape = TF.vector [3, 2 :: Int32]+        x <- TF.render $ TF.fill shape (TF.scalar (1::Float))+        let multiples = TF.vector [2, 3 :: Int32]+        let y = TF.tile x multiples++        [dx] <- TF.gradients y [x]+        TF.run (dx, TF.shape dx, TF.shape x)+    shapeX @=? (shapeDX :: V.Vector Int32)+    V.fromList [6, 6, 6, 6, 6, 6::Float] @=? (dx :: V.Vector Float)+++matMulGradient :: Test+matMulGradient = testCase "matMulGradients" $ do++  let dfBuild = do+        x <- TF.render $ TF.zeros $ TF.Shape [3, 1 :: Int64]+        w <- TF.zeroInitializedVariable $ TF.Shape [1, 2 :: Int64]+        let f = x `TF.matMul` w :: TF.Tensor TF.Build Float+        dfs <- TF.gradients f [x]+        return (x, dfs)++  (xShape, dxShape) <- TF.runSession $ do+    (x, [dx]) <- TF.build dfBuild+    TF.run (TF.shape x, TF.shape dx)++  assertEqual "Shape of gradient must match shape of input" xShape (dxShape :: V.Vector Int32)+++-- test that gradient of matMul can be taken gradient of+matMulGradGrad :: Test+matMulGradGrad = testCase "matMulGradGrad" $ do+  let width = 2 :: Int64+      batch = 4 :: Int64++  let tower = do+        x <- TF.render $ TF.zeros $ TF.Shape [batch, 1]+        w <- TF.zeroInitializedVariable $ TF.Shape [1, width]+        let f = x `TF.matMul` w+        [dfdx] <- TF.gradients f [x]+        let f'x = TF.reduceSum dfdx+        [dfdw] <- TF.gradients f'x [w] -- take gradient again (this time over w)+        return [TF.value w, dfdw]++  TF.runSession $ do+    [w, dfdw] <- TF.build tower+    (wShape, dfdwShape) <- TF.run (TF.shape w, TF.shape dfdw)+    liftIO $ assertEqual "Shape of gradient must match input" wShape (dfdwShape :: V.Vector Int32)++    let step = w `TF.add` dfdw+    w0 <- TF.run step+    liftIO $ ((V.fromList [4, 4 :: Float]) @=? w0)+++-- test that gradient of matMul deals correctly with transpose_a and transpose_b+matMulTransposeGradient :: (Bool, Bool) -> Test+matMulTransposeGradient txw = testCase ("matMulTransposeGradients " ++ (show txw)) $ do+  let (transposeX, transposeW) = txw++  let dfBuild = do+        let xShape = TF.Shape [3, 1 :: Int64]+        let xZeros = TF.zeros xShape+        x <- TF.render $ if transposeX then TF.matTranspose xZeros else xZeros+        variable <- TF.zeroInitializedVariable $ TF.Shape [1, 2 :: Int64]+        let wv = if transposeW then TF.matTranspose variable else TF.expr variable+        let f = TF.matMul' (transAttrs transposeX transposeW) x wv :: TF.Tensor TF.Build Float+        w <- TF.render wv+        ds <- TF.gradients f [x, w]+        return (x, w, ds)++  TF.runSession $ do+    (x, w, [dx, dw]) <- TF.build dfBuild+    xShape <- TF.run $ TF.shape x+    dxShape <- TF.run $ TF.shape dx+    liftIO $ assertEqual "xShape must match dxShape" xShape (dxShape :: V.Vector Int32)++    wShape <- TF.run $ TF.shape w+    dwShape <- TF.run $ TF.shape dw+    liftIO $ assertEqual "wShape must match dwShape" wShape (dwShape :: V.Vector Int32)++transAttrs :: (TF.Attribute a,+               TF.Attribute b) =>+              a -> b -> TF.OpDef -> TF.OpDef+transAttrs a b =+  (TF.opAttr "transpose_a" .~ a) . (TF.opAttr "transpose_b" .~ b)++main :: IO ()+main = defaultMain+            [ testGradientSimple+            , testGradientDisconnected+            , testCreateGraphStateful+            , testCreateGraphNameScopes+            , testDiamond+            , testMaxGradient+            , testReluGrad+            , testReluGradGrad+            , testFillGrad+            , testTileGrad+            , testTile2DGrad+            , matMulGradient+            , matMulGradGrad+            , matMulTransposeGradient (False, False)+            , matMulTransposeGradient (False, True)+            , matMulTransposeGradient (True, False)+            , matMulTransposeGradient (True, True)+            ]
+ tests/MatrixTest.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}++import Control.Monad.IO.Class (liftIO)+import Control.Monad (replicateM_, zipWithM)++import qualified TensorFlow.GenOps.Core as TF (square, rank)+import qualified TensorFlow.Core as TF+import qualified TensorFlow.Gradient as TF+import qualified TensorFlow.Ops as TF+import qualified Data.Vector as V++import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import TensorFlow.Test (assertAllClose)++randomParam :: TF.Shape -> TF.Session (TF.Tensor TF.Value Float)+randomParam (TF.Shape shape) = TF.truncatedNormal (TF.vector shape)++reduceMean :: TF.Tensor v Float -> TF.Tensor TF.Build Float+reduceMean xs = TF.mean xs (TF.range 0 (TF.rank xs) 1)++fitMatrix :: Test+fitMatrix = testCase "fitMatrix" $ TF.runSession $ do+  u <- TF.initializedVariable =<< randomParam [2, 1]+  v <- TF.initializedVariable =<< randomParam [1, 2]+  let ones = [1, 1, 1, 1] :: [Float]+      matx = TF.constant [2, 2] ones+      diff = matx `TF.sub` (u `TF.matMul` v)+      loss = reduceMean $ TF.square diff+  trainStep <- gradientDescent 0.01 loss [u, v]+  replicateM_ 1000 (TF.run trainStep)+  (u',v') <- TF.run (u, v)+  -- ones = u * v+  liftIO $ assertAllClose (V.fromList ones) ((*) <$> u' <*> v')+  +gradientDescent :: Float+                -> TF.Tensor TF.Build Float+                -> [TF.Tensor TF.Ref Float]+                -> TF.Session TF.ControlNode+gradientDescent alpha loss params = do+    let applyGrad param grad =+            TF.assign param (param `TF.sub` (TF.scalar alpha `TF.mul` grad))+    TF.group =<< zipWithM applyGrad params =<< TF.gradients loss params++main :: IO ()+main = defaultMain [ fitMatrix ]
+ tests/MiscTest.hs view
@@ -0,0 +1,50 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int32)+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+import qualified Data.Vector as V+import qualified TensorFlow.GenOps.Core as CoreOps++import TensorFlow.Ops+import TensorFlow.Session++-- | Test fetching multiple outputs from an op.+testMultipleOutputs :: Test+testMultipleOutputs = testCase "testMultipleOutputs" $+    runSession $ do+        (values, indices) <-+            run $ CoreOps.topKV2 (constant [1, 4] [10, 40, 20, 30]) 2+        liftIO $ [40, 30] @=? V.toList (values :: V.Vector Float)+        liftIO $ [1, 3] @=? V.toList (indices :: V.Vector Int32)++-- | Test op with variable number of inputs.+testVarargs :: Test+testVarargs = testCase "testVarargs" $+    runSession $ do+        xs <- run $ pack $ map scalar [1..8]+        liftIO $ [1..8] @=? V.toList (xs :: V.Vector Float)++main :: IO ()+main = defaultMain [ testMultipleOutputs+                   , testVarargs+                   ]
+ tests/NNTest.hs view
@@ -0,0 +1,103 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}++module Main where++import           TensorFlow.Test                    (assertAllClose)+import           Test.Framework (defaultMain, Test)+import           Test.Framework.Providers.HUnit     (testCase)+import qualified Data.Vector                        as V+import qualified TensorFlow.Gradient                as TF+import qualified TensorFlow.NN                      as TF+import qualified TensorFlow.Ops                     as TF+import qualified TensorFlow.Core                    as TF++-- | These tests are ported from:+--+--      <tensorflow>/tensorflow/python/ops/nn_xent_tests.py+--+-- This is the implementation we use to check the implementation we+-- wrote in `TensorFlow.NN.sigmoidCrossEntropyWithLogits`.+--+sigmoidXentWithLogits :: Floating a => Ord a => [a] -> [a] -> [a]+sigmoidXentWithLogits logits' targets' =+    let sig  = map (\x -> 1 / (1 + exp (-x))) logits'+        eps  = 0.0001+        predictions = map (\p -> min (max p eps) (1 - eps)) sig+        xent y z = (-z) * (log y) - (1 - z) * log (1 - y)+     in zipWith xent predictions targets'+++data Inputs = Inputs {+      logits  :: [Float]+    , targets :: [Float]+    }+++defInputs :: Inputs+defInputs = Inputs {+      logits    = [-100, -2, -2, 0, 2, 2,   2, 100]+    , targets   = [   0,  0,  1, 0, 0, 1, 0.5,   1]+    }+++testLogisticOutput :: Test+testLogisticOutput = testCase "testLogisticOutput" $ do+    let inputs     = defInputs+    r <- run $ do+        vLogits    <- TF.render $ TF.vector $ logits  inputs+        vTargets   <- TF.render $ TF.vector $ targets inputs+        TF.sigmoidCrossEntropyWithLogits vLogits vTargets+    let ourLoss    = V.fromList $ sigmoidXentWithLogits (logits inputs) (targets inputs)+    assertAllClose r ourLoss+++testLogisticOutputMultipleDim :: Test+testLogisticOutputMultipleDim =+        testCase "testLogisticOutputMultipleDim" $ do+    let inputs   = defInputs+        shape    = [2, 2, 2]+    r <- run $ do+        vLogits  <- TF.render $ TF.constant shape (logits  inputs)+        vTargets <- TF.render $ TF.constant shape (targets inputs)+        TF.sigmoidCrossEntropyWithLogits vLogits vTargets+    let ourLoss  = V.fromList $ sigmoidXentWithLogits (logits inputs) (targets inputs)+    assertAllClose r ourLoss+++testGradientAtZero :: Test+testGradientAtZero = testCase "testGradientAtZero" $ do+    r <- run $ do+        let inputs   = defInputs { logits = [0, 0], targets = [0, 1] }+        vTargets <- TF.render $ TF.vector $ targets inputs+        vLogits  <- TF.render $ TF.vector $ logits  inputs+        let tfLoss   = TF.sigmoidCrossEntropyWithLogits vLogits vTargets++        l <- tfLoss+        TF.gradients l [vLogits]++    assertAllClose (head r) (V.fromList [0.5, -0.5])++run :: TF.Fetchable t a => TF.Session t -> IO a+run = TF.runSession . (>>= TF.run)++main :: IO ()+main = defaultMain+            [ testGradientAtZero+            , testLogisticOutput+            , testLogisticOutputMultipleDim+            ]
+ tests/OpsTest.hs view
@@ -0,0 +1,115 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int32, Int64)+import Test.Framework (defaultMain, Test)+import Lens.Family2 ((.~))+import System.IO.Temp (withSystemTempDirectory)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+import qualified Data.ByteString.Char8 as B8++import qualified Data.Vector as V+import qualified TensorFlow.Build as TF+import qualified TensorFlow.Nodes as TF+import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Session as TF+import qualified TensorFlow.Tensor as TF+import qualified TensorFlow.Types as TF++-- | Test that one can easily determine number of elements in the tensor.+testSize :: Test+testSize = testCase "testSize" $ do+    x <- eval $ TF.size (TF.constant (TF.Shape [2, 3]) [0..5 :: Float])+    TF.Scalar (2 * 3 :: Int32) @=? x++eval :: TF.Fetchable t a => t -> IO a+eval = TF.runSession . TF.run++-- | Confirms that the original example from Python code works.+testReducedShape :: Test+testReducedShape = testCase "testReducedShape" $ do+    x <- eval $ TF.reducedShape (TF.vector [2, 3, 5, 7 :: Int64])+                                (TF.vector [1, 2 :: Int32])+    V.fromList [2, 1, 1, 7 :: Int32] @=? x++testSaveRestore :: Test+testSaveRestore = testCase "testSaveRestore" $+    withSystemTempDirectory "" $ \dirPath -> do+        let path = B8.pack $ dirPath ++ "/checkpoint"+            var :: TF.MonadBuild m => m (TF.Tensor TF.Ref Float)+            var = TF.zeroInitializedVariable' (TF.opName .~ "a")+                                        (TF.Shape [])+        TF.runSession $ do+            v <- var+            TF.assign v 134 >>= TF.run_+            TF.save path [v] >>= TF.run_+        result <- TF.runSession $ do+            v <- var+            TF.restore path v >>= TF.run_+            TF.run v+        liftIO $ TF.Scalar 134 @=? result++-- | Test that 'placeholder' is not CSE'd.+testPlaceholderCse :: Test+testPlaceholderCse = testCase "testPlaceholderCse" $ TF.runSession $ do+    p1 <- TF.placeholder []+    p2 <- TF.placeholder []+    let enc :: Float -> TF.TensorData Float+        enc n = TF.encodeTensorData [] (V.fromList [n])+    result <- TF.runWithFeeds [TF.feed p1 (enc 2), TF.feed p2 (enc 3)]+                $ p1 `TF.add` p2+    liftIO $ result @=? TF.Scalar 5++-- | Test that regular tensors can also be used for feeds, as long as they each+-- have a different name.+testScalarFeedCse :: Test+testScalarFeedCse = testCase "testScalarFeedCse" $ TF.runSession $ do+    p1 <- TF.render $ TF.scalar' (TF.opName .~ "A") 0+    -- The second op is identical to the first other than its name; make sure+    -- we don't aggressively CSE them together and prevent feeding them+    -- separately.+    p2 <- TF.render $ TF.scalar' (TF.opName .~ "B") 0+    let enc :: Float -> TF.TensorData Float+        enc n = TF.encodeTensorData [] (V.fromList [n])+    result <- TF.runWithFeeds [TF.feed p1 (enc 2), TF.feed p2 (enc 3)]+                $ p1 `TF.add` p2+    liftIO $ result @=? TF.Scalar 5++-- | See https://github.com/tensorflow/haskell/issues/92.+-- Even though we're not explicitly evaluating `f0` until the end,+-- it should hold the earlier value of the variable.+testRereadRef :: Test+testRereadRef = testCase "testReRunAssign" $ TF.runSession $ do+    w <- TF.initializedVariable 0+    f0 <- TF.run w+    TF.run_ =<< TF.assign w (TF.scalar (0.1 :: Float))+    f1 <- TF.run w+    liftIO $ (0.0, 0.1) @=? (TF.unScalar f0, TF.unScalar f1)++main :: IO ()+main = defaultMain+            [ testSaveRestore+            , testSize+            , testReducedShape+            , testPlaceholderCse+            , testScalarFeedCse+            , testRereadRef+            ]
+ tests/QueueTest.hs view
@@ -0,0 +1,91 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Int (Int64)+import Test.Framework (defaultMain, Test)+import TensorFlow.Types (ListOf(..), Scalar(..), (/:/))+import TensorFlow.Ops (scalar)+import TensorFlow.Queue+import TensorFlow.Session+    ( asyncProdNodes+    , build+    , run+    , runSession+    , run_+    )+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+import qualified Data.ByteString as BS++-- | Test basic queue behaviors.+testBasic :: Test+testBasic = testCase "testBasic" $ runSession $ do+    q :: Queue [Int64, BS.ByteString] <- build $ makeQueue 1 ""+    run_ =<< enqueue q (42 :/ scalar "Hi" :/ Nil)+    x <- run =<< dequeue q+    liftIO $ (Scalar 42 /:/ Scalar "Hi" /:/ Nil) @=? x++    run_ =<< enqueue q (56 :/ scalar "Bar" :/ Nil)+    y <- run =<< dequeue q+    -- Note: we use explicit "Scalar" here to specify the type that was+    -- fetched.  Equivalently we could write+    -- 56 /:/ "Bar" /:/ Nil :: List [Scalar Int64, Scalar BS.ByteString]+    -- or else allow the types to be determined by future use of the fetched+    -- value.+    let expected = Scalar 56 /:/ Scalar "Bar" /:/ Nil+    liftIO $ expected @=? y++-- | Test queue pumping.+testPump :: Test+testPump = testCase "testPump" $ runSession $ do+    (deq, pump) <- build $ do+        q :: Queue [Int64, BS.ByteString] <- makeQueue 2 "ThePumpQueue"+        (,) <$> dequeue q+            <*> enqueue q (31 :/ scalar "Baz" :/ Nil)+    -- This is a realistic use. The pump inputs are pre-bound to some+    -- nodes that produce values when pumped (e.g. read from a+    -- file).+    run_ (pump, pump)++    (x, y) <- run (deq, deq)+    let expected = Scalar 31 /:/ Scalar "Baz" /:/ Nil+    liftIO $ expected @=? x+    liftIO $ expected @=? y++testAsync :: Test+testAsync = testCase "testAsync" $ runSession $ do+    (deq, pump) <- do+        q :: Queue [Int64, BS.ByteString] <- makeQueue 2 ""+        (,) <$> dequeue q+            <*> enqueue q (10 :/ scalar "Async" :/ Nil)+    -- Pumps the queue until canceled by runSession exiting.+    asyncProdNodes pump+    -- Picks up a couple values and verifies they are as expected.+    let expected = Scalar 10 /:/ Scalar "Async" /:/ Nil+    run deq >>= liftIO . (expected @=?)+    run deq >>= liftIO . (expected @=?)++main :: IO ()+main = defaultMain+            [ testBasic+            , testPump+            , testAsync+            ]
+ tests/RegressionTest.hs view
@@ -0,0 +1,47 @@+-- | Simple linear regression example for the README.++import Control.Monad (replicateM, replicateM_, zipWithM)+import System.Random (randomIO)+import Test.HUnit (assertBool)++import qualified TensorFlow.Core as TF+import qualified TensorFlow.GenOps.Core as TF+import qualified TensorFlow.Gradient as TF+import qualified TensorFlow.Ops as TF++main :: IO ()+main = do+    -- Generate data where `y = x*3 + 8`.+    xData <- replicateM 100 randomIO+    let yData = [x*3 + 8 | x <- xData]+    -- Fit linear regression model.+    (w, b) <- fit xData yData+    assertBool "w == 3" (abs (3 - w) < 0.001)+    assertBool "b == 8" (abs (8 - b) < 0.001)++fit :: [Float] -> [Float] -> IO (Float, Float)+fit xData yData = TF.runSession $ do+    -- Create tensorflow constants for x and y.+    let x = TF.vector xData+        y = TF.vector yData+    -- Create scalar variables for slope and intercept.+    w <- TF.initializedVariable 0+    b <- TF.initializedVariable 0+    -- Define the loss function.+    let yHat = (x `TF.mul` w) `TF.add` b+        loss = TF.square (yHat `TF.sub` y)+    -- Optimize with gradient descent.+    trainStep <- gradientDescent 0.001 loss [w, b]+    replicateM_ 1000 (TF.run trainStep)+    -- Return the learned parameters.+    (TF.Scalar w', TF.Scalar b') <- TF.run (w, b)+    return (w', b')++gradientDescent :: Float+                -> TF.Tensor TF.Build Float+                -> [TF.Tensor TF.Ref Float]+                -> TF.Session TF.ControlNode+gradientDescent alpha loss params = do+    let applyGrad param grad =+            TF.assign param (param `TF.sub` (TF.scalar alpha `TF.mul` grad))+    TF.group =<< zipWithM applyGrad params =<< TF.gradients loss params
+ tests/TracingTest.hs view
@@ -0,0 +1,49 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE OverloadedStrings #-}++-- | Testing tracing.+module Main where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, tryReadMVar)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy (isPrefixOf)+import Data.Default (def)+import Lens.Family2 ((&), (.~))+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertBool, assertFailure)++import qualified TensorFlow.Core as TF+import qualified TensorFlow.Ops as TF++testTracing :: IO ()+testTracing = do+    -- Verifies that tracing happens as a side-effect of graph extension.+    loggedValue <- newEmptyMVar+    TF.runSessionWithOptions+        (def & TF.sessionTracer .~ putMVar loggedValue)+        (TF.run_ (TF.scalar (0 :: Float)))+    tryReadMVar loggedValue >>=+        maybe (assertFailure "Logging never happened") expectedFormat+  where expectedFormat x =+            let got = toLazyByteString x in+            assertBool ("Unexpected log entry " ++ show got)+                       ("Session.extend" `isPrefixOf` got)++main :: IO ()+main = defaultMain+    [ testCase "Tracing" testTracing+    ]
+ tests/TypesTest.hs view
@@ -0,0 +1,134 @@+-- Copyright 2016 TensorFlow authors.+--+-- 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.++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- Purposely disabled to confirm doubleFuncNoSig can be written without type.+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Control.Monad (replicateM)+import Control.Monad.IO.Class (liftIO)+import Data.Int (Int64)+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import Test.QuickCheck (Arbitrary(..), listOf, suchThat)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Vector as V++import qualified TensorFlow.GenOps.Core as TF (select)+import qualified TensorFlow.Ops as TF+import qualified TensorFlow.Session as TF+import qualified TensorFlow.Tensor as TF+import qualified TensorFlow.Types as TF++instance Arbitrary B.ByteString where+    arbitrary = B.pack <$> arbitrary++-- Test encoding tensors, feeding them through tensorflow, and decoding the+-- results.+testFFIRoundTrip :: Test+testFFIRoundTrip = testCase "testFFIRoundTrip" $+    TF.runSession $ do+        let floatData = V.fromList [1..6 :: Float]+            stringData = V.fromList [B8.pack (show x) | x <- [1..6::Integer]]+            boolData = V.fromList [True, True, False, True, False, False]+        f <- TF.placeholder [2,3]+        s <- TF.placeholder [2,3]+        b <- TF.placeholder [2,3]+        let feeds = [ TF.feed f (TF.encodeTensorData [2,3] floatData)+                    , TF.feed s (TF.encodeTensorData [2,3] stringData)+                    , TF.feed b (TF.encodeTensorData [2,3] boolData)+                    ]+        -- Do something idempotent to the tensors to verify that tensorflow can+        -- handle the encoding. Originally this used `TF.identity`, but that+        -- wasn't enough to catch a bug in the encoding of Bool.+        (f', s', b') <- TF.runWithFeeds feeds+                            (f `TF.add` 0, TF.identity s, TF.select b b b)+        liftIO $ do+            floatData @=? f'+            stringData @=? s'+            boolData @=? b'+++data TensorDataInputs a = TensorDataInputs [Int64] (V.Vector a)+    deriving Show++instance Arbitrary a => Arbitrary (TensorDataInputs a) where+    arbitrary = do+        -- Limit the size of the final vector, and also guard against overflow+        -- (i.e., p<0) when there are too many dimensions+        let validProduct p = p > 0 && p < 100+        sizes <- listOf (arbitrary `suchThat` (>0))+                    `suchThat` (validProduct . product)+        elems <- replicateM (fromIntegral $ product sizes) arbitrary+        return $ TensorDataInputs sizes (V.fromList elems)++-- Test that a vector is unchanged after being encoded and decoded.+encodeDecodeProp :: (TF.TensorDataType V.Vector a, Eq a) => TensorDataInputs a -> Bool+encodeDecodeProp (TensorDataInputs shape vec) =+    TF.decodeTensorData (TF.encodeTensorData (TF.Shape shape) vec) == vec++testEncodeDecodeQcFloat :: Test+testEncodeDecodeQcFloat = testProperty "testEncodeDecodeQcFloat"+    (encodeDecodeProp :: TensorDataInputs Float -> Bool)++testEncodeDecodeQcInt64 :: Test+testEncodeDecodeQcInt64 = testProperty "testEncodeDecodeQcInt64"+    (encodeDecodeProp :: TensorDataInputs Int64 -> Bool)++testEncodeDecodeQcString :: Test+testEncodeDecodeQcString = testProperty "testEncodeDecodeQcString"+    (encodeDecodeProp :: TensorDataInputs B.ByteString -> Bool)++doubleOrInt64Func :: TF.OneOf '[Double, Int64] a => a -> a+doubleOrInt64Func = id++doubleOrFloatFunc :: TF.OneOf '[Double, Float] a => a -> a+doubleOrFloatFunc = id++doubleFunc :: TF.OneOf '[Double] a => a -> a+doubleFunc = doubleOrFloatFunc . doubleOrInt64Func++-- No explicit type signature; make sure it can be inferred automatically.+-- (Note: this would fail if we didn't have NoMonomorphismRestriction, since it+-- can't simplify the type all the way to `Double -> Double`.+doubleFuncNoSig = doubleOrFloatFunc . doubleOrInt64Func++typeConstraintTests :: Test+typeConstraintTests = testCase "type constraints" $ do+    42 @=? doubleOrInt64Func (42 :: Double)+    42 @=? doubleOrInt64Func (42 :: Int64)+    42 @=? doubleOrFloatFunc (42 :: Double)+    42 @=? doubleOrFloatFunc (42 :: Float)+    42 @=? doubleFunc (42 :: Double)+    42 @=? doubleFuncNoSig (42 :: Double)+++main :: IO ()+main = defaultMain+            [ testFFIRoundTrip+            , testEncodeDecodeQcFloat+            , testEncodeDecodeQcInt64+            , testEncodeDecodeQcString+            , typeConstraintTests+            ]
+ tests/VariableTest.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedLists #-}+module Main (main) where++import Control.Monad.IO.Class (liftIO)+import qualified Data.Vector.Storable as V+import TensorFlow.Core+    ( unScalar+    , render+    , run_+    , runSession+    , run+    , withControlDependencies)+import qualified TensorFlow.Ops as Ops+import TensorFlow.Variable+    ( readValue+    , initializedVariable+    , assign+    , assignAdd+    , variable+    )+import Test.Framework (defaultMain, Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))++main :: IO ()+main = defaultMain+            [ testInitializedVariable+            , testInitializedVariableShape+            , testDependency+            , testRereadRef+            , testAssignAdd+            ]++testInitializedVariable :: Test+testInitializedVariable =+    testCase "testInitializedVariable" $ runSession $ do+        (formula, reset) <- do+            v <- initializedVariable 42+            r <- assign v 24+            return (1 + readValue v, r)+        result <- run formula+        liftIO $ 43 @=? (unScalar result :: Float)+        run_ reset  -- Updates v to a different value+        rerunResult <- run formula+        liftIO $ 25 @=? (unScalar rerunResult :: Float)++testInitializedVariableShape :: Test+testInitializedVariableShape =+    testCase "testInitializedVariableShape" $ runSession $ do+        vector <- initializedVariable (Ops.constant [1] [42 :: Float])+        result <- run (readValue vector)+        liftIO $ [42] @=? (result :: V.Vector Float)++testDependency :: Test+testDependency =+    testCase "testDependency" $ runSession $ do+        v <- variable []+        a <- assign v 24+        r <- withControlDependencies a $ render (readValue v + 18)+        result <- run r+        liftIO $ (42 :: Float) @=? unScalar result++-- | See https://github.com/tensorflow/haskell/issues/92.+-- Even though we're not explicitly evaluating `f0` until the end,+-- it should hold the earlier value of the variable.+testRereadRef :: Test+testRereadRef = testCase "testReRunAssign" $ runSession $ do+    w <- initializedVariable 0+    f0 <- run (readValue w)+    run_ =<< assign w (Ops.scalar (0.1 :: Float))+    f1 <- run (readValue w)+    liftIO $ (0.0, 0.1) @=? (unScalar f0, unScalar f1)++testAssignAdd :: Test+testAssignAdd = testCase "testAssignAdd" $ runSession $ do+    w <- initializedVariable 42+    run_ =<< assignAdd w 17+    f1 <- run (readValue w)+    liftIO $ (42 + 17 :: Float) @=? unScalar f1