packages feed

cognimeta-utils (empty) → 0.1.0

raw patch · 41 files changed

+3435/−0 lines, 41 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, bytestring, cognimeta-utils, collections-api, comonad-transformers, containers, data-lens, data-lens-fd, data-lens-template, deepseq, ghc-prim, mtl, primitive, stm, tagged, template-haskell, transformers

Files

+ LICENSE-2.0.txt view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ cognimeta-utils.cabal view
@@ -0,0 +1,112 @@+Name: cognimeta-utils+version: 0.1.0+cabal-version: >= 1.8+build-type: Simple+license: OtherLicense+license-file: "LICENSE-2.0.txt"+copyright: (c) 2010-2012 Cognimeta Inc.+maintainer: Patrick Premont <ppremont@cognimeta.com>+homepage: https://github.com/Cognimeta/cognimeta-utils+package-url:+bug-reports:+synopsis: Utilities for Cognimeta products (such as perdure). API may change often.+description: +	     These utilities are used by Perdure and other internal Cognimeta products.+	     .+	     Please do not rely on these APIs. If parts of this are of interest to you please contact+	     ppremont@cognimeta.com and we will consider creating a cleaner separate package.+category:+author: Patrick Premont for Cognimeta Inc.+tested-with:+data-files:+data-dir: ""+extra-source-files:+extra-tmp-files:+ +library+  buildable: True+  hs-source-dirs: src+  if arch(i386)+    cpp-options: -DWORDSIZE=32+  if arch(x86_64)+    cpp-options: -DWORDSIZE=64+  extensions: CPP+  exposed-modules:+    Cgm.Control.Combinators+    Cgm.Control.Concurrent.Await+    Cgm.Control.Concurrent.MVar+    Cgm.Control.Concurrent.NotificationCount+    Cgm.Control.Concurrent.TThread+    Cgm.Control.InFunctor+    Cgm.Control.Monad.State+    Cgm.Control.Profile+    Cgm.Data.Array+    Cgm.Data.Bool+    Cgm.Data.Either+    Cgm.Data.Empty+    Cgm.Data.Functor+    Cgm.Data.Functor.Sum+    Cgm.Data.Len +    Cgm.Data.List+    Cgm.Data.LongWord+    Cgm.Data.MapMultiset+    Cgm.Data.Maybe+    Cgm.Data.Monoid+    Cgm.Data.Multiset+    Cgm.Data.NEList+    Cgm.Data.Nat+    Cgm.Data.Nat.Base+    Cgm.Data.Nat.Constants+    Cgm.Data.SortedPair+    Cgm.Data.Structured+    Cgm.Data.Structured.Derive+    Cgm.Data.Super +    Cgm.Data.Tagged+    Cgm.Data.Typeable+    Cgm.Data.Word+    Cgm.Data.WordN+    Cgm.TH.Label+    Cgm.Prelude+    Cgm.System.Endian+    Cgm.System.Mem.Alloc+  other-modules:        +  build-depends:+    base >= 4.5.0.0 && < 5,+    template-haskell >= 2.7.0.0,+    QuickCheck >=2.4.0.1,+    mtl >= 2.1.2,+    transformers >= 0.3.0.0,+    containers >= 0.4.2.1,+    collections-api >= 1.0.0.0,+    bytestring >= 0.9.2.1,+    array >= 0.4.0.0,+    stm >= 2.3,+    ghc-prim >= 0.2.0.0,+    primitive >= 0.4.1,+    tagged >= 0.4.2.1,+    data-lens >= 2.9.0,+    data-lens-fd >= 2.0.2,+    data-lens-template >= 2.1.5,+    comonad-transformers >= 2.1.1.1,+    deepseq >= 1.3.0.0+  ghc-options: -rtsopts -fcontext-stack=80 -O2 -funfolding-use-threshold=24 -pgmP cpphs -optP --cpp+  extensions: ++source-repository head+  type:     git+  location: git://github.com/Cognimeta/perdure.git++executable cognimeta-utils+  hs-source-dirs: exe-src+  main-is: Main.hs+  other-modules: +  build-depends:+    base >= 4.5.0.0,+    template-haskell >= 2.7.0.0,+    mtl >= 2.1.2,+    QuickCheck >=2.4.0.1,+    cognimeta-utils >= 0.1.0,+    transformers >= 0.3.0.0,+    bytestring >= 0.9.2.1,+    containers >= 0.4.2.1+  ghc-options: -rtsopts -fcontext-stack=80 -fno-warn-duplicate-exports -O2 -funfolding-use-threshold=24 -threaded
+ exe-src/Main.hs view
@@ -0,0 +1,45 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 FlexibleInstances, ScopedTypeVariables, TypeFamilies, TemplateHaskell #-}++module Main (+  main++) where++import Data.Int+import Data.Word+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Test.QuickCheck as QC+import Test.QuickCheck.Arbitrary+import System.Environment+import Language.Haskell.TH+import Cgm.TH.Label++import Cgm.Control.Profile++main :: IO ()+main = getArgs >>= argsMain++argsMain :: [String] -> IO ()+argsMain (x:xs) = maybe invalidArgs ($ xs) $ lookup x mains+argsMain [] = invalidArgs++invalidArgs :: IO ()+invalidArgs = putStrLn $ "Invalid arguments, first argument should be one of " ++ (show $ map fst mains)++mains :: [(String, [String] -> IO ())]+mains = [+  ]
+ src/Cgm/Control/Combinators.hs view
@@ -0,0 +1,81 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++module Cgm.Control.Combinators (+    fk,+    dot2,+    dot2i,+    dup,+    (./),+    (.//),+    (.///),+    (.////),+    Id,+    todo+) where++++-- A combinator like Generics.Pointless.Combinators./\ but generalized from (,) to any binary function.+-- T+-- /\ = fk (,)+{-# INLINE fk #-}+fk :: (x -> y -> b) -> (a -> x) -> (a -> y) -> a -> b+fk b x y a = b (x a) (y a)+-- fk b x y = dup (dot2 b x y)++-- Like '.' but takes two unary functions on the right, and composes them with a binary+-- functions on the left. May be used infix as in: ++ `dot2` show $ show+{-# INLINE dot2 #-}+dot2 :: (a' -> b' -> c) -> (a -> a') -> (b -> b') -> a -> b -> c+dot2 c a' b' a b = c (a' a) (b' b)++-- Like '.' but takes a binary function on the left, and a unary function on the right+-- The unary function is applied to both arguments+{-# INLINE dot2i #-}+dot2i :: (a' -> a' -> b) -> (a -> a') -> a -> a -> b+dot2i b = dup $ dot2 b++{-# INLINE dup #-}+dup :: (a -> a -> b) -> a -> b+dup bin a = bin a a++-- Composes a function with a binary function+-- It is called 'dot' at http://www.haskell.org/haskellwiki/Pointfree and is equivalent to (.) . (.)+infixr 9 ./+{-# INLINE (./) #-}+(./) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c+f ./ b = (f .) . b++-- Composes a function with a ternary function+infixr 9 .//+{-# INLINE (.//) #-}+(.//) :: (b -> c) -> (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> c+f .// t = (f .) ./ t++-- Composes a function with a 4-ary function+infixr 9 .///+{-# INLINE (.///) #-}+(.///) :: (b -> c) -> (a1 -> a2 -> a3 -> a4 -> b) -> a1 -> a2 -> a3 -> a4 -> c+f ./// q = (f .) .// q++-- Composes a function with a 5-ary function+infixr 9 .////+{-# INLINE (.////) #-}+(.////) :: (b -> c) -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> c+f .//// q = (f .) ./// q++type Id a = a -> a++todo = undefined+
+ src/Cgm/Control/Concurrent/Await.hs view
@@ -0,0 +1,40 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Control.Concurrent.Await (
+  Async,
+  await0,
+  await1,
+  mapAsync
+  ) where
+
+import Control.Concurrent
+import Control.Monad
+
+-- Takes a operation that takes a nullary callback, performs the operation and awaits the callback
+await0 :: (IO () -> IO a) -> IO a
+await0 kop = do v <- newEmptyMVar
+                a <- kop (putMVar v ())
+                takeMVar v
+                return a
+
+type Async a s = (a -> IO ()) -> IO s
+
+-- Takes a operation that takes a unary callback, performs the operation, awaits the callback, and returns the value
+await1 :: Async a () -> IO a
+await1 kop = do v <- newEmptyMVar
+                kop (putMVar v)
+                takeMVar v
+
+mapAsync :: (a -> IO b) -> Async a () -> Async b ()
+mapAsync f async k = async (f >=> k)
+ src/Cgm/Control/Concurrent/MVar.hs view
@@ -0,0 +1,43 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TupleSections #-}
+
+module Cgm.Control.Concurrent.MVar (
+  stateModifyMVar,
+  stateTModifyMVar,
+  withNewMVar,
+  module Control.Concurrent.MVar
+  ) where
+
+import Control.Concurrent.MVar
+import Control.Applicative
+import Control.Monad.State.Strict
+import Data.Tuple
+import Control.Exception
+
+stateModifyMVar :: MVar a -> State a b -> IO b
+stateModifyMVar v state = modifyMVar v (return . swap . runState state)
+
+stateTModifyMVar :: MVar a -> StateT a IO b -> IO b
+stateTModifyMVar v st = modifyMVar v ((>>= forceState) . fmap swap . runStateT st) where 
+  forceState (a, b) = fmap (, b) $ evaluate a
+  -- forceState fixes a selector leak. We do not want the mvar to hold a thunk that keeps b alive
+  -- I no longer understand what I did here. modifyMVar seems already strict in the pair it receives
+  -- But forcing the state is still not a bad idea...
+
+-- z must not refer to the MVar t
+withNewMVar :: (MVar t -> IO z) -> StateT t IO z
+withNewMVar z = StateT $ (>>= \var -> liftA2 (,) (z var) (readMVar var)) . newMVar
+
+
+ src/Cgm/Control/Concurrent/NotificationCount.hs view
@@ -0,0 +1,44 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Control.Concurrent.NotificationCount (
+  NotificationCount,
+  withNotificationCount,
+  notifying
+  ) where
+
+import Data.Word
+import Control.Concurrent
+import Control.Applicative
+import Control.Arrow
+
+-- Counts required notifications that have not yet been received. When they reach zero, registered actions are called.
+type NotificationCount = MVar (Word64, [IO ()])
+
+mkNotificationCount :: IO NotificationCount
+mkNotificationCount = newMVar (0, [])
+
+requireNotify :: NotificationCount -> IO ()
+requireNotify = flip modifyMVar_ $ return . first (+ 1)
+
+notify :: NotificationCount -> IO ()
+notify = flip modifyMVar_ $ \(n, ios) -> if n == 1 then const (0,[]) <$> sequence_ ios else return (n - 1, ios)
+
+whenFullyNotified :: IO () -> NotificationCount -> IO ()
+whenFullyNotified io = flip modifyMVar_ $ \s@(n, ios) -> if n == 0 then const s <$> io else return (n, io : ios)
+
+withNotificationCount :: (NotificationCount -> IO a) -> IO () -> IO a
+withNotificationCount f k = mkNotificationCount >>= \n -> f n >>= (<$ whenFullyNotified k n)
+
+notifying :: NotificationCount -> (IO () -> IO a) -> IO a
+notifying n kf = requireNotify n >> kf (notify n)
+ src/Cgm/Control/Concurrent/TThread.hs view
@@ -0,0 +1,135 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 ScopedTypeVariables, DeriveDataTypeable, TupleSections #-}
+
+module Cgm.Control.Concurrent.TThread (
+  run2,
+  runWithDeamon
+  ) where
+
+import Prelude hiding (catch)
+import Data.IntMap
+import Data.Typeable
+import Control.Exception
+import Control.Monad
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.STM
+import Cgm.Control.Combinators
+import Cgm.Data.Bool
+
+data Task n a = Task n ((Task n a -> IO ()) -> IO (a -> a))
+data State n a = State {val :: a, nextId :: Int, threads :: IntMap (n, ThreadId, Bool), forcedCancel :: Bool}
+
+data Abort = Abort deriving (Show, Typeable)
+instance Exception Abort -- Not exported since it should not be thrown by anyone else 
+-- Could malicious code still throw it, by catching it as SomeException, unpacking the exitential, and using throwTo on  
+-- itself (myThreadId) or some other thread which has leaked its identity?
+
+-- When a task completes, it applies a transition function to the candidate return value. Whenever the cancel predicate is
+-- true for that value, or if a forced cancellation has been triggerred by an exception in a child thread or an abort request
+-- in the parent, then all tasks that have not yet been cancelled are cancelled. Tasks starting will start cancelled if
+-- the cancel predicate is true on the current value, or if forced cancellation has been triggerred.
+-- Users wil probably want to ensure that once the cancel predicate becomes true, it never becomes false again.
+-- This function should not be used with asynchronous exceptions in the parent thread (beyond the Abort exception
+-- that may be thrown by an outer invocation of this function). Any unhandled exception in a child will be rethrown (wrapped)
+-- in the parent, after all children have been cancelled and have completed. The user should only rely on this behavior
+-- to handle unexepected exceptions. Other exceptions should be caught and transformed into a value in the children, so
+-- that the cancellation predicate can determine if cancellation is appropriate, and that the result transformation function
+-- can determine the appropriate result (the caller of run can transform back some values into exceptions).
+run :: forall n a. [Task n a] -> a -> (a -> Bool) -> IO a
+run tasks initial cancel = newChan >>= run' where
+  run' c = foldM (flip startTransition) (State initial 0 Data.IntMap.empty False) tasks >>= handler where
+    handler s = do 
+      state'@(State a _ ts _) <- readChan c >>= ($ s)
+      bool (handler state') (return a) $ Data.IntMap.null ts
+    startTransition :: Task n a -> State n a -> IO (State n a)
+    startTransition (Task n f) (State a i ts fc) = do
+      t <- forkIO (f (writeChan c . startTransition) >>= writeChan c . endTransition)
+      let cancelT = fc || cancel a
+      when cancelT $ throwTo t Abort
+      return $ State a (i+1) (insert i (n, t, cancelT) ts) fc where
+        endTransition :: (a -> a) -> State n a -> IO (State n a)
+        endTransition af (State a next ts fc) = do
+          let ts' = delete i ts
+          let a' = af a
+          ts'' <- bool (return ts') (foldWithKey cancelNonCancelled (return ts') ts') $ not fc && cancel a'
+          return (State a' next ts' fc) where
+            cancelNonCancelled :: Int -> (n, ThreadId, Bool) -> Id (IO (IntMap (n, ThreadId, Bool)))
+            cancelNonCancelled i (n, t, x) = if x then id else (>>= (<$ throwTo t Abort) . adjust (const (n, t, True)) i)
+
+-- A task represented as pair of a description, and an IO of a triple containing: 
+--  1) whether to attempt to cancel the other task, 
+--  2) our result when we finish first, which the other task will convert into a final result
+--  3) a function from that result of the other task to the final result, to be used only if we finish second
+type Task2 c a b = (String, IO (Task2Result c a b))
+type Task2Result c a b = ((Bool, a), b -> c)
+
+data UnexpectedTaskException = UnexpectedTaskException Bool String SomeException deriving (Show, Typeable)
+data ConcurrentExceptions = ConcurrentExceptions SomeException SomeException deriving (Show, Typeable)
+instance Exception UnexpectedTaskException
+instance Exception ConcurrentExceptions
+
+data PeerTaskException = PeerTaskException deriving (Show, Typeable)
+instance Exception PeerTaskException
+
+
+-- Unexpected exceptions in a child will be wrapped in an UnexpectedTaskException, and an asynchronous
+-- exception PeerTaskException will be thrown in the other task (if it has not already completed). In that case
+-- the PeerTaskException is expected by the run2 method, so it does not have to be handled in the child.
+-- If both children return an exception, then both are wrapped and the resulting pair is thrown as a ConcurrentExceptions.
+-- Child tasks are required to catch Abort (if the peer requests it), and produce a Task2Result
+-- TODO handle Abort in parent 
+
+run2 :: Task2 c a b -> Task2 c b a -> IO c
+run2 (n1, task1) (n2, task2) = do
+  h1@(_, m1) <- forkIOT task1
+  h2@(_, m2) <- forkIOT task2
+  let w1 = UnexpectedTaskException False n1
+  let w2 = UnexpectedTaskException True n2
+  join $ atomically $ getEitherJust (firstComplete w2 h2 w1) (firstComplete w1 h1 w2) m1 m2 where
+    firstComplete :: Wrapper -> ThreadHandles (Task2Result c b a) -> Wrapper -> Either SomeException (Task2Result c a b) -> IO c
+    firstComplete wl (tl, ml) wf = either ex normal where
+      ex ef = do
+        throwTo tl PeerTaskException
+        atomically (getJust ml) >>= either exl (const $ throw wrappedFirst) where
+          wrappedFirst = wf ef
+          exl el = maybe twoExceptions (const $ throw wrappedFirst) (fromException el :: Maybe PeerTaskException) where
+            twoExceptions = throw $ ConcurrentExceptions (SomeException $ wl el) (SomeException wrappedFirst)
+      normal ((cancel, intermediate), _) = do
+        when cancel $ throwTo tl Abort
+        final <- atomically (getJust ml) >>= either (throw . wl) (return . snd)
+        return $ final intermediate
+type Wrapper = SomeException -> UnexpectedTaskException
+          
+runWithDeamon :: (String, IO c) -> (String, IO ()) -> IO c
+runWithDeamon (n1, f1) (n2, f2) = run2
+                                 (n1, handle (\(e::Abort) -> error deamonEnded) f1 >>= \c -> return ((True, c), error deamonEnded)) 
+                                 (n2, handle (\(e::Abort) -> return ()) f2 >> return ((True, ()), id)) where
+  deamonEnded = "Deamon ended spontaneously"
+
+type ThreadHandles a = (ThreadId, STM (Maybe (Either SomeException a)))
+
+forkIOT :: IO a -> IO (ThreadHandles a)
+forkIOT f = do
+  v <- atomically $ newTVar Nothing
+  t <- forkIO $ handle (set v . Left) (f >>= set v . Right)
+  return (t, readTVar v) where
+    set v = atomically . writeTVar v . Just
+
+getJust :: STM (Maybe a) -> STM a
+getJust = (>>= maybe retry return)
+
+getEitherJust :: (a -> z) -> (b -> z) -> STM (Maybe a) -> STM (Maybe b) -> STM z
+getEitherJust z1 z2 m1 m2 = m1 >>= maybe (m2 >>= maybe retry (return . z2)) (return . z1)
+ src/Cgm/Control/InFunctor.hs view
@@ -0,0 +1,290 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts, TypeFamilies, TypeOperators #-}++module Cgm.Control.InFunctor (+    Function(..),+    ($*),++    Increasing(..),+    Increasing',+    (:>>=),+    uncheckedIncreasing,+    +    StrictlyIncreasing(..),+    StrictlyIncreasing',+    (:>>),+    uncheckedStrictlyIncreasing,+    +    InjectionA(..),+    InjectionA',+    uncheckedInjectionA,+    injectionA',++    Injection(..),+    Injection',+    uncheckedInjection,+    injection',+    pairInjection,++    InjectionM(..),+    InjectionM',+    uncheckedInjectionM,+    injectionM',++    Bijection(..),+    Bijection',+    uncheckedBijection,+    pairBijection,+    inv,+    liftAB,++    InjectionACofunctor(..),+    InjectionCofunctor(..),+    InjectionMCofunctor(..),+    ExpFunctor(..),+    IncreasingFunctor(..),+    StrictlyIncreasingFunctor(..),+    +    Cofunctor(..),+    functorCofunctorComap,+    Comonoidal(..),+    functorIacomap,+    cofunctorIacomap,+    RevFun(..),+    (:<-),+    +    wrapU,+    wrapB,+    liftItI,+    liftIItK,+    liftIItI,+    liftIKtI,+    liftIItII+) where++import Prelude (Ord, (>>=), ($), uncurry)+import Control.Category+import Control.Arrow+import Data.Monoid+import Data.Maybe+import Data.Functor+import Control.Applicative+import Data.Functor.Constant+import Data.Functor.Compose+import Cgm.Control.Combinators++-- Function+-- Laws: f is total++class Category f => Function f where+    apply :: f a b -> a -> b++infixr 0 $*+{-# INLINE ($*) #-}+($*) :: Function f => f a b -> a -> b+($*) = apply++instance Function (->) where +  {-# INLINE apply #-}+  apply = id++-- Increasing+-- Additional laws: forall a b. a > b implies f a >= f b+class Function f => Increasing f++newtype Increasing' a b = Increasing' (a -> b) -- could be generalized wrap any f in Function instead of just ->+type a :>>= b = Increasing' a b+uncheckedIncreasing :: (a -> b) -> Increasing' a b+uncheckedIncreasing = Increasing'+instance Category Increasing' where+  id = Increasing' id+  (Increasing' a) . (Increasing' b) = Increasing' $ a . b+instance Function Increasing' where apply (Increasing' f) = f+instance Increasing Increasing'++-- Note: assuming total order, strictly increasing implies Injective, we cold reflect that here++-- StrictlyIncreasing+-- Additional laws: forall a b. a > b implies f a > f b+class Increasing f => StrictlyIncreasing f++newtype StrictlyIncreasing' a b = StrictlyIncreasing' (a -> b)+type a :>> b = StrictlyIncreasing' a b+uncheckedStrictlyIncreasing :: (a -> b) -> StrictlyIncreasing' a b+uncheckedStrictlyIncreasing = StrictlyIncreasing'+instance Category StrictlyIncreasing' where+  id = StrictlyIncreasing' id+  (StrictlyIncreasing' a) . (StrictlyIncreasing' b) = StrictlyIncreasing' $ a . b+instance Function StrictlyIncreasing' where apply (StrictlyIncreasing' f) = f+instance Increasing StrictlyIncreasing'+instance StrictlyIncreasing StrictlyIncreasing'++-- InjectionA+-- Additions laws: "fromJust . unapply f . apply f = id", and unapply is total+-- This leaves unspecified the behavior of unapply on values outside the image of apply.++class Function f => InjectionA f where+    unapply :: f a b -> b -> Maybe a++data InjectionA' a b = InjectionA' !(a -> b) !(b -> Maybe a)+instance Category InjectionA' where+  id = InjectionA' id Just+  f . g = InjectionA' (apply f . apply g) ((>>= unapply g) . unapply f)+instance Function InjectionA' where apply (InjectionA' f _) = f+instance InjectionA InjectionA' where unapply (InjectionA' _ f') = f'++uncheckedInjectionA :: (a -> b) -> (b -> Maybe a) -> InjectionA' a b+uncheckedInjectionA = InjectionA'++injectionA' :: InjectionA f => f a b -> InjectionA' a b+injectionA' f = uncheckedInjectionA (apply f) (unapply f)++-- Injection+-- Additions laws: retract.apply = id+-- This leaves unspecified the behavior of unapply on values outside the image of apply.++class InjectionA f => Injection f where+    retract :: f a b -> b -> a++data Injection' a b = Injection' !(a -> b) !(b -> a)+instance Category Injection' where+  id = Injection' id id+  f . g = Injection' (apply f . apply g) (retract g . retract f)+instance Function Injection' where apply (Injection' f _) = f+instance InjectionA Injection' where unapply (Injection' _ f') = Just . f'+instance Injection Injection' where retract (Injection' _ f') = f'++uncheckedInjection :: (a-> b) -> (b -> a) -> Injection' a b+uncheckedInjection = Injection'++injection' :: Injection f => f a b -> Injection' a b+injection' f = uncheckedInjection (apply f) (retract f)++pairInjection :: (Injection f1, Injection f2) => f1 a1 b1 -> f2 a2 b2 -> Injection' (a1, a2) (b1, b2)+pairInjection f1 f2 = uncheckedInjection (apply f1 *** apply f2) (retract f1 *** retract f2)++-- InjectionM+-- Additions laws: "unapply f b = Nothing" for any b such that forall a, "apply f a \= b"+class InjectionA f => InjectionM f++newtype InjectionM' a b = InjectionM' (InjectionA' a b) deriving (Category, Function, InjectionA)+instance InjectionM InjectionM'++uncheckedInjectionM :: (a-> b) -> (b -> Maybe a) -> InjectionM' a b+uncheckedInjectionM = InjectionM' ./ uncheckedInjectionA++injectionM' :: InjectionM f => f a b -> InjectionM' a b+injectionM' f = uncheckedInjectionM (apply f) (unapply f)+++-- Bijection+-- Laws: "apply f . retract f = id", and the laws of the superclasses++class (Injection f, InjectionM f) => Bijection f++newtype Bijection' a b = Bijection' (Injection' a b) deriving (Category, Function, InjectionA, Injection)+instance InjectionM Bijection'+instance Bijection Bijection'++uncheckedBijection :: (a -> b) -> (b -> a) -> Bijection' a b+uncheckedBijection = Bijection' ./ uncheckedInjection++pairBijection :: (Bijection f1, Bijection f2) => f1 a1 b1 -> f2 a2 b2 -> Bijection' (a1, a2) (b1, b2)+pairBijection = Bijection' ./ pairInjection++inv :: Bijection f => f a b -> Bijection' b a+inv f = uncheckedBijection (retract f) (apply f)++liftAB :: (Bijection g, Applicative f) => g a b -> Bijection' (f a) (f b)+liftAB g = uncheckedBijection (apply g <$>) (retract g <$>)++--++class InjectionACofunctor f where iacomap :: InjectionA g => f b -> g a b -> f a+class InjectionCofunctor f where icomap :: Injection g => f b -> g a b -> f a+class InjectionMCofunctor f where imcomap :: InjectionM g => f b -> g a b -> f a++class ExpFunctor f where bmap :: Bijection g => g a b -> f a -> f b++class IncreasingFunctor f where incmap :: Increasing g => g a b -> f a -> f b+class StrictlyIncreasingFunctor f where sincmap :: StrictlyIncreasing g => g a b -> f a -> f b+  +-----+                                        +instance (Applicative a, InjectionACofunctor c) => InjectionACofunctor (Compose a c) where  +  iacomap (Compose c) i = Compose $ iacomap <$> c <*> pure i+                                        +-----+                                        +class Cofunctor f where+  infixr 4 >$<+  (>$<) :: f b -> (a -> b) -> f a+  +newtype RevFun b a = RevFun {getRevFun :: a -> b} deriving Monoid+type (:<-) = RevFun -- until deriveStructure can accept a type operator+instance Cofunctor (RevFun b) where +  {-# INLINE (>$<) #-}+  (RevFun g) >$< f = RevFun $ g . f+instance Cofunctor (Constant a) where +  {-# INLINE (>$<) #-}+  (Constant a) >$< f = Constant a                                   +instance (Functor f, Cofunctor c) => Cofunctor (Compose f c) where +  {-# INLINE (>$<) #-}+  (>$<) = functorCofunctorComap -- TODO: cleanup: There is an alternative defintion so a newtype would be required to indicate which is desired+  +functorCofunctorComap :: (Functor f, Cofunctor c) => (Compose f c) b -> (a -> b) -> (Compose f c) a+functorCofunctorComap (Compose c) abf = Compose $ (>$< abf) <$> c++-- See definition of Monoidal in http://strictlypositive.org/IdiomLite.pdf+-- If the superclass is changed to Cofunctor (or an exponential functor), it seems the Monoidal laws can be adapted.+-- The munit and mpair methods here would be the special case where the cofunctor is (_ -> m) for some monoid m.+-- Maybe we could move the operations to a superclass with no laws, and have empty Monoidal/Comonoidal classes+-- that derive it and just introduce the laws.+class Comonoidal f where  +  munit :: f ()+  mpair :: f a -> f b -> f (a, b)+  +instance Monoid m => Comonoidal (RevFun m) where+  munit = mempty+  mpair (RevFun fa) (RevFun fb) = RevFun $ uncurry $ mappend `dot2` fa $ fb+instance Monoid m => Comonoidal (Constant m) where+  munit = Constant mempty+  mpair (Constant fa) (Constant fb) = Constant $ mappend fa fb+instance (Applicative a, Comonoidal c) => Comonoidal (Compose a c) where+  munit = Compose $ pure munit+  mpair (Compose a) (Compose b) = Compose $ mpair <$> a <*> b++-- TODO rename to unsafe+{-# INLINE functorIacomap #-}+functorIacomap :: (Functor f, InjectionA g) => f b -> g a b ->  f a+functorIacomap f g = (fromJust . unapply g) <$> f+{-# INLINE cofunctorIacomap #-}+cofunctorIacomap :: (Cofunctor f, InjectionA g) => f b -> g a b ->  f a+cofunctorIacomap f g = f >$< apply g++-----++wrapU :: (Bijection og, Function i1g) => og o o' -> i1g i1 i1' -> (i1' -> o') -> i1 -> o+wrapU o i1 f = retract o . f . (i1 $*)+wrapB :: (Bijection og, Function i1g, Function i2g) => og o o' -> i1g i1 i1' -> i2g i2 i2' -> (i1' -> i2' -> o') -> i1 -> i2 -> o+wrapB o i1 i2 f = retract o ./ dot2 f (i1 $*) (i2 $*)++-- We cannot express sufficiently general type. Those functions are rarely useful.+liftItI b f = retract b . f . apply b+liftIItK b f = dot2i f (apply b)+liftIItI b f = retract b ./ liftIItK b f+liftIKtI b f = retract b ./ dot2 f (apply b) id+liftIItII b f = (retract b *** retract b) ./ liftIItK b f+
+ src/Cgm/Control/Monad/State.hs view
@@ -0,0 +1,111 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TupleSections, FlexibleInstances, MultiParamTypeClasses #-}
+
+module Cgm.Control.Monad.State(
+  StateT(..),
+  State,
+  mState,
+  runState,
+  focus,
+  viewState,
+  partialState,
+  partialStateE,
+  eitherState,
+  maybeState,
+  toStandardState,
+  mapStateT,
+  pairStateT,
+  module Control.Monad.State.Class,
+  module Control.Monad.Trans.Class,
+  module Control.Monad.IO.Class
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Arrow
+import Data.Functor.Identity
+import Data.Maybe
+import Control.Monad.State.Class
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+import Control.Concurrent.MVar
+import qualified Control.Monad.State.Strict as Std
+
+import Data.Lens hiding (focus)
+import Control.Comonad.Trans.Store
+
+-- | runStateT and runState do not have the usual types: for now we do not make it too easy to discard the precious 'Nothing'
+newtype StateT s m a = StateT {runStateT :: s -> m (a, Maybe s)}
+
+type State s = StateT s Identity
+mState :: (s -> (a, Maybe s)) -> State s a 
+mState = StateT . fmap Identity
+runState :: State s a -> s -> (a, Maybe s)
+runState = fmap runIdentity . runStateT
+
+instance Functor m => Functor (StateT s m) where
+  fmap f = StateT . fmap (fmap $ first f) . runStateT
+instance (Functor m, Monad m) => Applicative (StateT s m) where  
+  pure = return
+  (<*>) = ap
+instance Monad m => Monad (StateT s m) where
+  return = lift . return
+  (StateT c) >>= fd = StateT $ \s -> 
+    c s >>= \(a, ms) ->   -- We are strict in the state. We do as in Control.Monad.Trans.State.Strict (not .Lazy)
+    let d = runStateT (fd a) 
+    in maybe (d s) (\s' -> liftM (second $ Just . fromMaybe s') $ d s') ms
+  
+instance MonadTrans (StateT s) where
+  lift = StateT . const . liftM (, Nothing)
+  
+instance MonadIO m => MonadIO (StateT s m) where
+  liftIO = lift . liftIO
+  
+instance Monad m => MonadState s (StateT s m) where
+  get = StateT $ return . (, Nothing)
+  put = StateT . const . return . ((), ) . Just
+
+focus :: Monad m => Lens t s -> StateT s m a -> StateT t m a
+focus l (StateT smas) = StateT $ (\(st, s) -> liftM (second $ fmap st) $ smas s) . runStore . runLens l
+
+-- | functions st and ts should form a bijection since a StateT t with no changes will become a StateT s with no changes, no matter what st and ts are
+viewState :: Monad m => (s -> t, t -> s) -> StateT t m a -> StateT s m a
+viewState (st, ts) (StateT tf) = StateT $ liftM (second $ fmap ts) . tf . st
+
+-- Work on a part of the state, that may not exist for some inputs
+partialState :: Monad m => m a -> (s -> Maybe t, t -> s) -> StateT t m a -> StateT s m a
+--partialState d (smt, ts) (StateT tf) = get >>= \s -> maybe (lift d) ((>>= \(a, mt) -> maybe (return ()) (put . ts) mt >> return a) . lift . tf) $ smt s
+partialState d (smt, ts) t = viewState (\s -> maybe (Left s) Right $ smt s, either id ts) $ eitherState (lift d) t -- note that we use a view 's -> Either s t'
+
+-- Like partialState, but remembers which path was taken
+partialStateE :: Monad m => m a -> (s -> Maybe t, t -> s) -> StateT t m b -> StateT s m (Either a b)
+partialStateE d fs t = partialState (liftM Left d) fs (liftM Right t)
+
+eitherState :: Monad m => StateT s m a -> StateT t m a -> StateT (Either s t) m a
+eitherState (StateT sf) (StateT tf) = StateT $ either (liftM (second $ fmap Left) . sf) (liftM (second $ fmap Right) . tf)
+  
+maybeState :: Monad m => m a -> StateT s m a -> StateT (Maybe s) m a
+maybeState n s = viewState (maybe (Left ()) Right, either (const Nothing) Just) $ eitherState (lift n) s
+  
+toStandardState :: Monad m => StateT s m a -> Std.StateT s m a
+toStandardState (StateT f) = Std.StateT $ \s -> liftM (second $ fromMaybe s) $ f s
+
+mapStateT :: (m (a, Maybe s) -> n (b, Maybe s)) -> StateT s m a -> StateT s n b
+mapStateT f m = StateT $ f . runStateT m
+
+pairStateT :: Functor m => StateT s (StateT t m) a -> StateT (s, t) m a
+pairStateT (StateT sf) = StateT $ \(s, t) -> fmap (\((a, ms), mt) -> (a, combineMaybes s t ms mt)) $ runStateT (sf s) t where
+  combineMaybes s t ms = maybe (fmap (, t) ms) (Just . (fromMaybe s ms,))
+
+ src/Cgm/Control/Profile.hs view
@@ -0,0 +1,37 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++module Cgm.Control.Profile (+    putCpuTime,+    cpuTimeNF,+    cpuTime+) where++import System.CPUTime+import Control.DeepSeq+import Data.Functor+import Control.Exception++putCpuTime :: String -> IO a -> IO a+putCpuTime s io = cpuTime io >>= \(a, t) -> a <$ (putStrLn $ s ++ " = " ++ show t)++cpuTimeNF :: NFData a => a -> IO (a, Float)+cpuTimeNF f = cpuTime $ evaluate $ (rnf f) `seq` f++cpuTime :: IO a -> IO (a, Float)+cpuTime f = do t0 <- getCPUTime+               a <- f+               t1 <- getCPUTime+               return $ (a, (((fromInteger (t1 - t0)))::Float) / 1e12)++
+ src/Cgm/Data/Array.hs view
@@ -0,0 +1,292 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 ScopedTypeVariables, UnboxedTuples, BangPatterns, MagicHash, TupleSections, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, Rank2Types, EmptyDataDecls #-}
+
+module Cgm.Data.Array (
+  ArrayIx,
+  Array(..),
+  ImmArray(..),
+  STArray(..),
+  STMkArray(..),
+  STZArray(..),
+  PinnedArray(..),
+  Allocation(..),
+  newAlignedPinnedWord8Array,
+  withArrayByteString,
+  arrayFromByteString,
+  unsafeWithCastArrayByteString,
+  Free,
+  Pinned,
+  primArrayMatchAllocation,
+  PrimArray,
+  runSTPrimArray,
+  unsafeFreezeSTPrimArray,
+  STPrimArray,
+  ArrayRange(..),
+  fullArrayRange,
+  skipArrayRange,
+  headArrayRange,
+  wordConvArrayRange,
+  unsafePrimArrayCast,
+  unsafeSTPrimArrayCast,
+  mapMArray,
+  mapMArrayCopy,
+  mapMArrayCopyImm,
+  mapImmArray,
+  mkArrayWith,
+  ioToST,
+  primSizeOf,
+  ST(ST),
+  module Control.Monad.ST,
+  module Data.Primitive.Types
+  ) where
+
+import Prelude ()
+import Cgm.Prelude
+import GHC.IO( IO(..), ioToST )
+import GHC.ST( ST(..) )
+import GHC.Exts
+import GHC.Prim
+import qualified Data.ByteString as ByteString
+import Data.ByteString.Unsafe
+import Foreign.Storable
+import Foreign.Ptr
+import Control.Monad.ST
+import Cgm.Data.Word
+import Cgm.Data.Len
+import Cgm.System.Mem.Alloc
+import Data.Primitive.Types
+--import Cgm.System.Endian
+
+type ArrayIx a = Len (ArrayElem a) Word
+type ArrayST a = ST (ArrayState a)
+
+class Array a where
+  type ArrayElem a :: *
+  arrayLen :: a -> ArrayIx a
+  
+class Array a => ImmArray a where
+  indexArray :: a -> ArrayIx a -> ArrayElem a
+
+class Array a => STArray a where
+  type ArrayState a :: *
+
+-- | STArrays that are instantiable in GCed memory
+class STArray a => STMkArray a where
+  mkArray :: ArrayIx a -> ArrayST a a
+
+-- | STArrays that can be mutated using zero based indexing
+class STArray a => STZArray a where
+  readArray :: a -> ArrayIx a -> ArrayST a (ArrayElem a)
+  writeArray :: a -> ArrayIx a -> ArrayElem a -> ArrayST a ()
+
+class Array a => PinnedArray a where 
+  withArrayPtr :: (Ptr (ArrayElem a) -> ArrayIx a -> IO b) -> a -> IO b
+
+class Allocation f where
+  newWord8Array :: Len Word8 Word -> ST s (STPrimArray s f Word8)
+  onAllocation :: (f ~ Free => z) -> (f ~ Pinned => z) -> Tagged f z
+
+withArrayByteString :: (PinnedArray a, ArrayElem a ~ Word8) => (ByteString.ByteString -> IO b) -> a -> IO b
+withArrayByteString f a = flip withArrayPtr a $ \ptr len -> (unsafePackCStringFinalizer ptr (fromIntegral $ getLen len) $ return ()) >>= f
+
+unsafeWithCastArrayByteString :: forall a b. (PinnedArray a, Prim (ArrayElem a)) => (ByteString.ByteString -> IO b) -> a -> IO b
+unsafeWithCastArrayByteString f a = flip withArrayPtr a $ 
+                                    \ptr len -> (unsafePackCStringFinalizer (castPtr ptr) (fromIntegral (getLen len) * primSizeOf (undefined :: ArrayElem a)) $ return ()) >>= f
+
+-- Could we avoid the copy or do a memcpy ? Can we access the Ptr of the ByteString ?
+arrayFromByteString :: Allocation f => ByteString.ByteString -> PrimArray f Word8
+arrayFromByteString b = mkArrayWith (unsafeLen $ fromIntegral $ ByteString.length b) $ ByteString.index b . fromIntegral . getLen
+
+arrayToList :: ImmArray a => a -> [ArrayElem a]
+arrayToList a = fmap (indexArray a) $ counting $ arrayLen a
+  
+-- TODO remove Prim constraint, by adding method to get byte length of an array
+immArrayEq :: (ImmArray a, Eq (ArrayElem a), Prim (ArrayElem a)) => a -> a -> Bool
+immArrayEq a b = (arrayLen a == arrayLen b) && (and $ fmap (\i -> indexArray a i == indexArray b i) (counting $ min (arrayLen a) (arrayLen b)))
+
+---------------------------------------------------------------------------
+  
+st_ :: (State# s -> State# s) -> ST s ()
+st_ f = ST $ \s -> (# f s, () #)
+
+---------------------------------------------------------------------------
+
+data Free
+data Pinned
+
+instance Allocation Free where 
+  newWord8Array l = ST $ \s -> case newByteArray# (unI# (fromIntegral $ getLen l)) s of (# s', a #) -> (# s', STPrimArray a #)
+  onAllocation f p = tag f
+instance Allocation Pinned where
+  newWord8Array l = ST $ \s -> case newPinnedByteArray# (unI# (fromIntegral $ getLen l)) s of (# s', a #) -> (# s', STPrimArray a #)
+  onAllocation f p = tag p
+
+newAlignedPinnedWord8Array :: Len Word8 Word -> Len Word8 Word -> ST s (STPrimArray s f Word8)
+newAlignedPinnedWord8Array al l = ST $ \s -> 
+  case newAlignedPinnedByteArray# (unI# (fromIntegral $ getLen l)) (unI# (fromIntegral $ getLen al)) s of (# s', a #) -> (# s', STPrimArray a #)
+
+primArrayMatchAllocation :: forall f f' w. (Allocation f, Allocation f', Prim w) => ArrayRange (PrimArray f w) -> ArrayRange (PrimArray f' w)
+primArrayMatchAllocation = (at :: At f) $ onAllocation 
+                           ((at :: At f') $ onAllocation id (fullArrayRange . mapImmArray id)) 
+                           ((at :: At f') $ onAllocation (fullArrayRange . mapImmArray id) id)
+
+---------------------------------------------------------------------------
+
+primSizeOf :: Prim w => w -> Int  
+primSizeOf w = I# (sizeOf# w)
+
+-- | f is either Free or Pinned
+data STPrimArray s f w = STPrimArray (MutableByteArray# s)
+
+instance Eq (STPrimArray s f w) where (STPrimArray a) == (STPrimArray b) = sameMutableByteArray# a b
+
+instance Prim w => Array (STPrimArray s f w) where
+  type ArrayElem (STPrimArray s f w) = w
+  arrayLen (STPrimArray a) = unsafeLen $ fromIntegral $ I# (sizeofMutableByteArray# a `quotInt#` sizeOf# (undefined :: w))
+
+instance Prim w => STArray (STPrimArray s f w) where
+  type ArrayState (STPrimArray s f w) = s
+
+instance (Allocation f, Prim w) => STMkArray (STPrimArray s f w) where
+  mkArray l = unsafeSTPrimArrayCast <$> newWord8Array (unsafeLen $ getLen l * fromIntegral (I# (sizeOf# (undefined :: w))))
+
+instance Prim w => STZArray (STPrimArray s f w) where
+  {-# INLINE readArray #-}
+  readArray (STPrimArray a) i = ST $ readByteArray# a (word2Int# (unW# (getLen i)))
+  {-# INLINE writeArray #-}
+  writeArray (STPrimArray a) i w = st_ $ writeByteArray# a (word2Int# (unW# (getLen i))) w
+
+instance Prim w => PinnedArray (STPrimArray s Pinned w) where
+  {-# INLINE withArrayPtr #-}
+  withArrayPtr f arr@(STPrimArray a) = f (Ptr (byteArrayContents# (unsafeCoerce# a))) (arrayLen arr) >>= (<$ (IO $ \s -> (# touch# a s, () #)))
+
+---------------------------------------------------------------------------
+
+-- | f is either Free or Pinned
+data PrimArray f w = PrimArray ByteArray#
+
+instance (Prim w, Eq w) => Eq (PrimArray f w) where (==) = immArrayEq
+                                                    
+instance (Prim w, Show w) => Show (PrimArray f w) where show = show . arrayToList
+
+instance Prim w => Array (PrimArray f w) where
+  type ArrayElem (PrimArray f w) = w
+  arrayLen (PrimArray a) = unsafeLen $ fromIntegral $ I# (sizeofByteArray# a `quotInt#` sizeOf# (undefined :: w))
+
+instance Prim w => ImmArray (PrimArray f w) where
+  {-# INLINE indexArray #-}
+  indexArray (PrimArray a) i = indexByteArray# a (word2Int# (unW# (getLen i)))
+
+instance Prim w => PinnedArray (PrimArray Pinned w) where
+  {-# INLINE withArrayPtr #-}
+  withArrayPtr f arr@(PrimArray a) = f (Ptr (byteArrayContents# a)) (arrayLen arr) >>= (<$ (IO $ \s -> (# touch# a s, () #)))
+
+runSTPrimArray :: (forall s . ST s (STPrimArray s f w)) -> PrimArray f w
+runSTPrimArray st = runST (st >>= unsafeFreezeSTPrimArray)
+
+-- | Safe as long as the input array is not written to after this call. Use the safe runSTPrimArray when possible.
+unsafeFreezeSTPrimArray :: STPrimArray s f w -> ST s (PrimArray f w)
+unsafeFreezeSTPrimArray (STPrimArray a) = ST (\s -> case unsafeFreezeByteArray# a s of (# s', a' #) -> (#s', PrimArray a' #) )
+
+---------------------------------------------------------------------------
+
+data ArrayRange a = ArrayRange a (ArrayIx a) (ArrayIx a) -- start and size
+
+instance (ImmArray a, Eq (ArrayElem a), Prim (ArrayElem a)) => Eq (ArrayRange a) where (==) = immArrayEq
+instance (ImmArray a, Show (ArrayElem a)) => Show (ArrayRange a) where show = show . arrayToList
+instance Array a => Array (ArrayRange a) where 
+  type ArrayElem (ArrayRange a) = ArrayElem a
+  arrayLen (ArrayRange _ _ len) = len
+instance ImmArray a => ImmArray (ArrayRange a) where  
+  indexArray (ArrayRange a s _) i = indexArray a $ s + i
+instance STArray a => STArray (ArrayRange a) where 
+  type ArrayState (ArrayRange a) = ArrayState a
+instance STZArray a => STZArray (ArrayRange a) where
+  readArray (ArrayRange a s _) i = readArray a $ i + s
+  writeArray (ArrayRange a s _) i e = writeArray a (i + s) e
+
+instance (Prim (ArrayElem a), PinnedArray a) => PinnedArray (ArrayRange a) where 
+  withArrayPtr f (ArrayRange a start sz) = withArrayPtr (\ptr _ -> f (ptr `plusPtrLen` start) sz) a
+
+{-# INLINE plusPtrLen #-}
+plusPtrLen :: forall a b. (Prim a, Integral b) => Ptr a -> Len a b -> Ptr a
+plusPtrLen p = plusPtr p . (* primSizeOf (undefined :: a)) . fromIntegral . getLen
+
+fullArrayRange :: Array a => a -> ArrayRange a
+fullArrayRange a = ArrayRange a 0 (arrayLen a)
+
+skipArrayRange :: Array a => ArrayIx a -> ArrayRange a -> ArrayRange a
+skipArrayRange n (ArrayRange a s l) = ArrayRange a (s + n) (l - n)
+
+headArrayRange :: Array a => ArrayIx a -> ArrayRange a -> ArrayRange a
+headArrayRange n (ArrayRange a s l) = ArrayRange a s $ min n l
+
+-- Can't be an instance of WordConv1 since ArrayRange has the wrong kind
+wordConvArrayRange :: WordConv c => Bijection' (ArrayRange (PrimArray f Word)) (ArrayRange (PrimArray f c))
+wordConvArrayRange = uncheckedBijection 
+                       (\(ArrayRange a s l) -> ArrayRange (apply wordConv1 a) (apply wordLenB s) (apply wordLenB l))
+                       (\(ArrayRange a s l) -> ArrayRange (retract wordConv1 a) (retract wordLenB s) (retract wordLenB l))
+
+---------------------------------------------------------------------------
+
+{-# INLINE unsafeSTPrimArrayCast #-}
+unsafeSTPrimArrayCast :: STPrimArray s f w -> STPrimArray s f w'
+unsafeSTPrimArrayCast (STPrimArray a) = STPrimArray a
+
+{-# INLINE unsafePrimArrayCast #-}
+unsafePrimArrayCast :: PrimArray f w -> PrimArray f w'
+unsafePrimArrayCast (PrimArray a) = PrimArray a
+
+instance WordConv1 (PrimArray f) where wordConv1 = uncheckedBijection unsafePrimArrayCast unsafePrimArrayCast
+instance WordConv1 (STPrimArray s f) where wordConv1 = uncheckedBijection unsafeSTPrimArrayCast unsafeSTPrimArrayCast
+
+{-# INLINE mapMArray #-}
+mapMArray :: STZArray a => (ArrayElem a -> ArrayST a (ArrayElem a)) -> a -> ArrayST a ()
+mapMArray f a = mapM_ (\i -> readArray a i >>= f >>= writeArray a i) $ counting $ arrayLen a
+
+-- | The number of elements copied is the minimum of the number of elements in the source and the number of elements in the destination
+{-# INLINE mapMArrayCopy #-}
+mapMArrayCopy :: (STZArray a, STZArray b, ArrayState a ~ ArrayState b) => (ArrayElem a -> ArrayST a (ArrayElem b)) -> a -> b -> ArrayST a ()
+mapMArrayCopy f src dest = mapM_ (\i -> readArray src (unsafeLen i) >>= f >>= writeArray dest (unsafeLen i)) $ 
+                           counting $ min (getLen $ arrayLen src) (getLen $ arrayLen dest)
+
+-- | The number of elements copied is the minimum of the number of elements in the source and the number of elements in the destination
+{-# INLINE mapMArrayCopyImm #-}
+mapMArrayCopyImm :: (ImmArray a, STZArray b) => (ArrayElem a -> ArrayST b (ArrayElem b)) -> a -> b -> ArrayST b ()
+mapMArrayCopyImm f src dest = mapM_ (\i -> f (indexArray src $ unsafeLen i) >>= writeArray dest (unsafeLen i)) $ 
+                           counting $ min (getLen $ arrayLen src) (getLen $ arrayLen dest)
+
+mkArrayWith :: (Allocation f, Prim a) => Len a Word -> (Len a Word -> a) -> PrimArray f a
+mkArrayWith l f = runSTPrimArray $ do
+  m <- mkArray l 
+  mapM_ (\i -> writeArray m i $ f i) $ counting l
+  return m
+
+mapImmArray :: (Allocation f', Prim b, ImmArray r) => (ArrayElem r -> b) -> r -> PrimArray f' b
+mapImmArray f src = mkArrayWith (unsafeLen $ getLen $ arrayLen src) (f . indexArray src . unsafeLen . getLen)
+
+{-
+
+asSharedByteArray :: Endian w => STPrimArray s f w -> IO (STPrimArray s f Word8)
+asSharedByteArray = unsafeSTPrimArrayCast
+
+{-# INLINE destructivePlatformToLE #-}
+destructivePlatformToLE :: (SizedArray (STPrimArray s f w), STZArray (STPrimArray s f w), Endian w) => STPrimArray s f w -> IO (STPrimArray s f w)
+destructivePlatformToLE a = a <$ (littleEndianConv >>= maybe (return ()) (\c -> mapMArray (return . c) a))
+
+-}
+---------------------------------------------------------------------------
+
+--instance Show (Buffer a) where show = ($ "") . showListWith showHex . ByteString.unpack . unsafePerformIO . bufferByteString
+ src/Cgm/Data/Bool.hs view
@@ -0,0 +1,6 @@+module Cgm.Data.Bool(
+  bool
+  ) where
+       
+bool :: z -> z -> Bool -> z
+bool f t c = if c then t else f
+ src/Cgm/Data/Either.hs view
@@ -0,0 +1,62 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TypeOperators #-}
+
+module Cgm.Data.Either ( 
+  (:|),
+  isRight,
+  mkRight,
+  mkLeft,
+  boolEither,
+  fromRight,
+  throwErrorT,
+  mapError
+  ) where
+
+import Cgm.Control.InFunctor
+import Cgm.Data.Bool
+import Control.Monad.Error
+import Control.Exception
+import Control.Arrow
+
+infixr 2 :|
+type a :| b = Either a b
+
+isRight :: Either a b -> Bool
+isRight = either (const False) (const True)
+
+mkRight :: a :>> Either b a
+mkRight = uncheckedStrictlyIncreasing Right
+mkLeft :: a :>> Either a b
+mkLeft = uncheckedStrictlyIncreasing Left
+
+boolEither :: a -> b -> Bool -> Either a b
+boolEither a b = bool (Left a) (Right b)
+
+fromRight :: Either a b -> b
+fromRight (Left _)  = error "fromRight called on Left"
+fromRight (Right x) = x
+
+throwErrorT :: (Show e, MonadIO m) => ErrorT e m a -> m a
+throwErrorT = (>>= liftIO . evaluate . either (error . show) id) . runErrorT
+
+mapError :: Monad m => (e -> e') -> ErrorT e m a -> ErrorT e' m a
+mapError e = mapErrorT $ liftM $ left e
+
+
+--filterEither :: (a -> Either b c) -> DList a -> (DList b, DList c)
+--filterEither f = foldr (flip add . f) (empty, empty)
+--    where add lists = either (\b -> flip fmap1 lists (cons b))
+--                             (\c -> flip fmap2 lists (cons c))
+
+ src/Cgm/Data/Empty.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE EmptyDataDecls #-}
+
+module Cgm.Data.Empty(
+  onØ,
+  Ø
+  ) where
+
+data Ø
+
+onØ :: Ø -> a
+onØ _ = undefined
+ src/Cgm/Data/Functor.hs view
@@ -0,0 +1,27 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Data.Functor(
+  mapf,
+  (<$$>),
+  module Data.Functor
+  ) where
+
+import Data.Functor
+
+mapf :: Functor f => f a -> (a -> b) -> f b
+mapf = flip fmap
+
+(<$$>) :: Functor f => f a -> (a -> b) -> f b
+(<$$>) = flip fmap
+
+ src/Cgm/Data/Functor/Sum.hs view
@@ -0,0 +1,24 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TemplateHaskell, TypeFamilies #-}
+
+module Cgm.Data.Functor.Sum (
+  Sum(..)
+  ) where
+
+import Cgm.Data.Structured
+
+newtype Sum a b e = Sum {getSum :: Either (a e) (b e)}
+
+deriveStructured ''Sum
+ src/Cgm/Data/Len.hs view
@@ -0,0 +1,134 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TemplateHaskell, TypeFamilies, ScopedTypeVariables, BangPatterns, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveDataTypeable  #-}
+
+module Cgm.Data.Len (
+  Len,
+  showLen,
+  bitLen,
+  word8,
+  word16,
+  word32,
+  word64,
+  word,
+  LgMultiple(..),
+  unsafeLen,
+  getLen,
+  wordLenB,
+  bitSizeLen,
+  refineLen,
+  coarsenLen,
+  coarseRem,
+  ceilDivPower2,
+  roundUpPower2
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Data.Bits
+import Control.Category
+import Cgm.Data.Tagged
+import Cgm.Data.Word
+import Cgm.Data.WordN
+import Cgm.Control.InFunctor
+import Cgm.Data.Structured
+import Cgm.Data.Super
+import Data.Typeable
+
+newtype Len u n = Len {getLen :: n} deriving (Ord, Enum, Real, Integral, Num, Eq, Bounded, Functor, Typeable)
+
+instance Show n => Show (Len u n) where show = show . getLen
+
+showLen :: forall n u. (Show n, LgMultiple u Bool) => Len u n -> String 
+showLen (Len n) = show n ++ "_" ++ show ((1::Int) `shiftL` getLgMul (lgMul :: LgMul u Bool))
+
+unsafeLen = Len
+
+bitLen :: Integral a => Len Bool a
+bitLen = Len 1
+word8 :: Integral a => Len Word8 a
+word8 = Len 1
+word16 :: Integral a => Len Word16 a
+word16 = Len 1
+word32 :: Integral a => Len Word32 a
+word32 = Len 1
+word64 :: Integral a => Len Word64 a
+word64 = Len 1
+word :: Integral a => Len Word a
+word = Len 1
+
+-- Says that type a's size is a (non-negative) power of 2 multiple of type b's size
+newtype LgMul a b = LgMul {getLgMul :: Int}
+class LgMultiple a b where lgMul :: LgMul a b
+instance LgMultiple Word8 Bool where lgMul = LgMul 3
+instance LgMultiple Word16 Word8 where lgMul = LgMul 1
+instance LgMultiple Word32 Word16 where lgMul = LgMul 1
+instance LgMultiple Word64 Word32 where lgMul = LgMul 1
+-- Reflexive instances
+instance LgMultiple Bool Bool where lgMul = id                                        
+instance LgMultiple Word8 Word8 where lgMul = id                                        
+instance LgMultiple Word16 Word16 where lgMul = id                                        
+instance LgMultiple Word32 Word32 where lgMul = id                                        
+instance LgMultiple Word64 Word64 where lgMul = id
+-- Transitive closure
+instance LgMultiple Word16 Bool where lgMul = (at :: At Word8) lgMulTrans
+instance LgMultiple Word32 Bool where lgMul = (at :: At Word8) lgMulTrans
+instance LgMultiple Word64 Bool where lgMul = (at :: At Word8) lgMulTrans
+instance LgMultiple Word32 Word8 where lgMul = (at :: At Word16) lgMulTrans
+instance LgMultiple Word64 Word8 where lgMul = (at :: At Word16) lgMulTrans
+instance LgMultiple Word64 Word16 where lgMul = (at :: At Word32) lgMulTrans
+-- Word instances                                      
+instance LgMultiple Word Bool where lgMul = wordLgMul
+instance LgMultiple Word Word8 where lgMul = wordLgMul
+instance LgMultiple Word Word16 where lgMul = wordLgMul
+instance LgMultiple Word Word32 where lgMul = wordLgMul
+instance LgMultiple Word64 Word where lgMul = wordLgMul'
+
+wordLgMul :: forall a. (LgMultiple Word32 a, LgMultiple Word64 a) => LgMul Word a
+wordLgMul = onWordConv (LgMul $ getLgMul (lgMul :: LgMul Word32 a)) (LgMul $ getLgMul (lgMul :: LgMul Word64 a))
+
+wordLgMul' :: forall a. (LgMultiple a Word32, LgMultiple a Word64) => LgMul a Word
+wordLgMul' = onWordConv (LgMul $ getLgMul (lgMul :: LgMul a Word32)) (LgMul $ getLgMul (lgMul :: LgMul a Word64))
+
+instance Category LgMul where
+  id = LgMul 0
+  LgMul a . LgMul b = LgMul $ a + b
+  
+lgMulTrans :: forall a b c. (LgMultiple a b, LgMultiple b c) => Tagged b (LgMul a c)
+lgMulTrans = tag $ lgMul . (at :: At b) idAt . lgMul
+
+idAt :: Category c => Tagged a (c a a)
+idAt = tag id
+
+bitSizeLen :: forall a b. (Bits a, Integral b) => Tagged a (Len Bool b)
+bitSizeLen = tag $ Len $ fromIntegral $ bitSize (undefined :: a)
+
+wordLenB :: WordConv a => Bijection' (Len Word b) (Len a b)
+wordLenB = uncheckedBijection (Len . getLen) (Len . getLen)
+
+refineLen :: forall u v n. (Bits n, LgMultiple u v) => Len u n -> Len v n
+refineLen (Len u) = Len $ u `shiftL` getLgMul (lgMul :: LgMul u v)
+coarsenLen :: forall u v n. (Bits n, LgMultiple v u) => Len u n -> Len v n
+coarsenLen (Len u) = Len $ ceilDivPower2 (getLgMul (lgMul :: LgMul v u)) u
+
+{-# INLINE coarseRem #-}
+coarseRem ::  forall u v n. (Bits n, LgMultiple v u) => Len u n -> (Len v n, Len u n)
+coarseRem (Len u) = let s = getLgMul (lgMul :: LgMul v u) in (Len $ u `shiftR` s, Len $ u .&. ((1 `shiftL` s) - 1))
+
+ceilDivPower2 n x = (x + ((1 `shiftL` n) - 1)) `shiftR` n
+roundUpPower2 n x = ceilDivPower2 n x `shiftL` n
+
+instance Super a b => Super (Len u a) (Len u b) where super = injectionM' (inv struct) . super . injectionM' struct
+
+deriveStructured ''Len
+ src/Cgm/Data/List.hs view
@@ -0,0 +1,105 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++-----------------------------------------------------------------------------+--+-- Module      :  List+-- Copyright   :+-- License     :  AllRightsReserved+--+-- Maintainer  :+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies, TupleSections #-}++module Cgm.Data.List (+    testList,+    List(..),+    listHead,+    addListContext,+    foldWithContext,+    prependReverse,+    listFoldMap,+    Sizable(..),+    listStructure,+    maybeMaximumBy,+    maxBy,+    unfoldlE,+    unfoldrE+) where++--import Data.Foldable+import Data.Collections.Foldable as Foldable+import Data.Monoid+import Cgm.Control.Combinators+import Cgm.Control.InFunctor+import Control.Arrow++testList :: b -> (a -> [a] -> b) -> [a] -> b+testList empty nonEmpty list = case list of {[] -> empty; (x:xs) -> nonEmpty x xs}++class List a where+    type Listed a :: *+    onList :: b -> (Listed a -> a -> b) -> a -> b+    consList :: Listed a -> a -> a+    emptyList :: a++prependReverse :: List a => a -> a -> a+prependReverse rev end = onList end (\r rs -> prependReverse rs $ consList r end) rev++instance List [a] where+    type Listed [a] = a+    onList e _ [] = e+    onList _ c (x:xs) = c x xs+    consList = (:)+    emptyList = []++listFoldMap :: (List a, Monoid m) => (Listed a -> m) -> a -> m+listFoldMap f = onList mempty $ dot2 mappend f $ listFoldMap f++listHead :: List a => a -> Maybe (Listed a)+listHead = onList Nothing (Just ./ const)++-- For each element in a List, it makes available a reversed List of elements that come before it, and a List of those that come after it.+addListContext :: (List a, List c, Listed a ~ Listed c) => a -> [(c, Listed a, a)]+addListContext = foldWithContext (\before elem after -> ((before, elem, after) :)) []++foldWithContext :: (List a, List c, Listed a ~ Listed c) => (c -> Listed a -> a -> b -> b) -> b -> a -> b+foldWithContext f e = fold2 emptyList+    where fold2 revPrefix = onList e (\x suffix -> f revPrefix x suffix (fold2 (consList x revPrefix) suffix))++-- counts the elements, returning Nothing if at least i elements were present, or i-length if less than i elements were present+class Sizable a where countDown :: Int -> a -> Maybe Int++listStructure :: List a => Bijection' a (Maybe (Listed a, a))+listStructure = uncheckedBijection (onList Nothing $ Just ./ (,)) (maybe emptyList $ uncurry consList)++maybeMaximumBy :: Foldable l a => (a -> a -> Ordering) -> l -> Maybe a+maybeMaximumBy o = Foldable.foldr (\a -> Just . maybe a (maxBy o a)) Nothing+  +maxBy :: (a -> a -> Ordering) -> a -> a -> a+maxBy o a b = case o a b of {GT -> a; _ -> b}++-- similar to unfoldl but uses Either instead of Maybe to signal the end of the list+unfoldlE :: (b -> Either c (b, a)) -> b -> (c, [a])+unfoldlE f = unfoldl' []+  where unfoldl' as = either (, as) (\(b', a) -> unfoldl' (a : as) b') . f++-- similar to unfoldr but uses Either instead of Maybe to signal the end of the list+unfoldrE :: (b -> Either c (a, b)) -> b -> ([a], c)+unfoldrE f = either ([], ) (\(a, b') -> first (a:) $ unfoldrE f b') . f
+ src/Cgm/Data/LongWord.hs view
@@ -0,0 +1,28 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TemplateHaskell, TypeFamilies #-}
+
+module Cgm.Data.LongWord (
+  Word128,
+  word128BE
+  ) where
+
+import Cgm.Data.Word
+import Cgm.Data.Structured
+       
+data Word128 = Word128 {word128_64 :: {-# UNPACK #-} !Word64, word128_0 :: {-# UNPACK #-} !Word64} deriving (Eq, Ord, Show)
+
+word128BE = Word128
+
+deriveStructured ''Word128
+ src/Cgm/Data/MapMultiset.hs view
@@ -0,0 +1,38 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TypeFamilies, TemplateHaskell, DeriveDataTypeable #-}
+
+module Cgm.Data.MapMultiset(
+  MapMultiset(mapMultisetMap)
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Cgm.Data.Maybe
+import Cgm.Data.Multiset
+import Cgm.Data.Typeable
+
+import Data.Map(Map)
+import qualified Data.Map as Map
+
+newtype MapMultiset a = MapMultiset {mapMultisetMap :: Map a Integer} deriving Typeable
+
+instance Multiset MapMultiset where
+  emptySet = MapMultiset Map.empty
+  insert e (MapMultiset a) = MapMultiset $ Map.insertWith' (+) e 1 a
+  delete e (MapMultiset a) = fmap (\c -> MapMultiset $ if c == 1 then Map.delete e a else Map.insert e (c - 1) a) $ Map.lookup e a
+
+instance Ord a => Monoid (MapMultiset a) where
+  mempty = MapMultiset Map.empty
+  mappend (MapMultiset a) (MapMultiset b) = MapMultiset $ Map.unionWith (+) a b
+ src/Cgm/Data/Maybe.hs view
@@ -0,0 +1,55 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++-----------------------------------------------------------------------------+--+-- Module      :  Maybe+-- Copyright   :+-- License     :  AllRightsReserved+--+-- Maintainer  :+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Cgm.Data.Maybe (+  module Data.Maybe,+  ifJust,+  justIf,+  predJust,+  firstJust,+  maybeToEither+) where++import Data.Monoid+import Data.Maybe+import Cgm.Control.Combinators+import Cgm.Data.Bool++ifJust :: Bool -> a -> Maybe a+ifJust = bool (const Nothing) Just++justIf :: a -> Bool -> Maybe a+justIf = flip ifJust++predJust :: (a -> Bool) -> a -> Maybe a+predJust p a = p a `ifJust` a++firstJust :: Maybe a -> Maybe a -> Maybe a+firstJust = getFirst ./ dot2i mappend First++maybeToEither :: b -> Maybe a -> Either b a+maybeToEither b = maybe (Left b) Right
+ src/Cgm/Data/Monoid.hs view
@@ -0,0 +1,39 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Data.Monoid(
+  (◊),
+  ø,
+  inter,
+  foldInter,
+  module Data.Monoid
+  ) where
+
+import Data.Monoid
+import Data.Foldable
+import Data.List
+
+-- Right associativity helps with performance, on [] or on Data.Text.Lazy.Builder for example
+infixr 9 ◊ -- rfc1345="&LZ"
+(◊) :: Monoid a => a -> a -> a
+(◊) = mappend
+
+-- Unicode (LATIN SMALL LETTER O WITH STROKE) rfc1345="&o/"
+ø :: Monoid m => m
+ø = mempty
+
+inter :: Monoid m => m -> m -> m -> m
+inter i a b = a ◊ i ◊ b
+
+foldInter :: (Monoid m, Foldable l) => m -> l m -> m
+foldInter i l = fold $ intersperse i $ toList l
+ src/Cgm/Data/Multiset.hs view
@@ -0,0 +1,34 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TypeFamilies, FlexibleContexts #-}
+
+module Cgm.Data.Multiset (
+  Multiset(..)
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Cgm.Data.Maybe
+
+class Multiset a where
+  emptySet :: a e
+  insert :: Ord e => e -> a e -> a e
+  delete :: Ord e => e -> a e -> Maybe (a e) -- ^ Returns Nothing when the elem was absent
+
+-- | Inefficient instance. May be useful as a temporary solution.
+instance Multiset [] where
+  emptySet = []
+  insert = (:)
+  delete e a = case break (== e) a of (before, rest) -> (before ++ tail rest) `justIf` not (null rest)
+
+ src/Cgm/Data/NEList.hs view
@@ -0,0 +1,29 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Data.NEList (
+  NEList,
+  neSingleton,
+  neCons,
+  onNEList,
+  neAppend
+  ) where
+
+-- Non empty list
+
+data NEList a = Single a | NECons a (NEList a) deriving Show
+neSingleton = Single
+neCons = NECons
+onNEList :: (a -> Maybe (NEList a) -> z) -> NEList a -> z
+onNEList f l = case l of {Single a -> f a Nothing; NECons a r -> f a (Just r)}
+neAppend l1 l2 = onNEList (\a1 r1 -> neCons a1 $ maybe id neAppend r1 l2) l1
+ src/Cgm/Data/Nat.hs view
@@ -0,0 +1,35 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++-----------------------------------------------------------------------------+--+-- Module      :  Nat+-- Copyright   :+-- License     :  AllRightsReserved+--+-- Maintainer  :+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+++module Cgm.Data.Nat (+    module Cgm.Data.Nat.Base,+    module Cgm.Data.Nat.Constants+) where++import Cgm.Data.Nat.Base+import Cgm.Data.Nat.Constants
+ src/Cgm/Data/Nat/Base.hs view
@@ -0,0 +1,177 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 FlexibleInstances, ScopedTypeVariables, TypeFamilies, Rank2Types, FlexibleContexts, GADTs, TypeOperators, DeriveDataTypeable #-}++module Cgm.Data.Nat.Base (+    D0,+    d0,+    Nat(..),+    Succ,+    intOfNat,+    (:+:),+    addZ,+    addS,+    addSC,+    addC,+    addComm,+    (:-:),+    subZ,+    subS,+    subI,+    addSub,+    geTrans,+    module Cgm.Data.Tagged+) where++import Control.Applicative+import Cgm.Data.Tagged+import Data.Typeable++data D0 = D0 deriving Typeable+newtype Succ n = Succ n deriving Typeable++d0 = D0++-- Similar to http://www.mail-archive.com/haskell-cafe@haskell.org/msg60806.html++class Nat n where onNat :: (n ~ D0 => c) -> (forall n'. (Succ n' ~ n, Nat n') => Tagged n' c) -> Tagged n c+instance Nat D0 where onNat z _ = Tagged z+instance Nat n => Nat (Succ n) where onNat _ s = Tagged $ untag s++intOfNat :: Nat a => Tagged a Int+intOfNat = onNat 0 $ (+ 1) <$> intOfNat++on2Nats :: (Nat a, Nat b) => +           ((a ~ D0, b ~ D0) => z) -> +           (forall b'. (a ~ D0, Succ b' ~ b, Nat b') => Tagged b' z) -> +           (forall a'. (Succ a' ~ a, Nat a', b ~ D0) => Tagged a' z) -> +           (forall a' b'. (Succ a' ~ a, Nat a', Succ b' ~ b, Nat b') => Tagged2 a' b' z) -> +           Tagged2 a b z+on2Nats zz zs sz ss = onNat (onNat zz zs) $ flipTags $ onNat sz $ flipTags ss++--instance Show (Nat a) where+--  showsPrec _ D0 = showString "d0"+--  showsPrec p a@(S n) = if (natToInt a <= 65)+--                        then showString ("d" ++ show (natToInt a))+--                        else showParen (p > 10) $ showString "S" . showChar ' ' . showsPrec 11 n++--++--type family Nest n (f :: * -> *) a+--type instance Nest D0 f a = a+--type instance Nest (Nat (Succ n)) f a = f (Nest n f a)++--nest :: Nat n -> (forall a. a -> f a) -> a -> Nest n f a+--nest D0 f a = a+--nest (S n) f a = f (nest n f a)++-- Add++type family a :+: b+type instance D0 :+: D0 = D0+type instance D0 :+: Succ b = Succ b+type instance Succ a :+: D0 = Succ a+type instance Succ a :+: Succ b = Succ (Succ (a :+: b))++addZ :: Nat b =>  (((D0 :+: b) ~ b, (b :+: D0) ~ b) => c) -> Tagged b c+addZ c = onNat c $ tag c++addS :: forall a b z. (Nat a, Nat b) => ((Succ a :+: b) ~ Succ (a :+: b) => z) -> Tagged2 a b z+addS z = on2Nats z (addZ z) (tag z) $ addS z+--This is what the above definition looked like before we used on2Nats:+--addS c = onNat (onNat c $ addZ c) (flipTags $ onNat (tag c) $ flipTags $ addS c)++addSC :: forall a b z. (Nat a, Nat b) => (((Succ a :+: b) ~ Succ (a :+: b), Nat (a :+: b)) => z) -> Tagged2 a b z+addSC z = on2Nats z (addZ z) (tag z) $ addSC z++addSR :: forall a b z. (Nat a, Nat b) => ((a :+: Succ b) ~ Succ (a :+: b) => z) -> Tagged2 a b z+addSR z = on2Nats z (tag z) (addZ z) $ addSR z++addComm :: forall a b z. (Nat a, Nat b) => ((a :+: b) ~ (b :+: a) => z) -> Tagged2 a b z+addComm z = on2Nats z (tag z) (tag z) $ addComm z++addC :: forall a b z. (Nat a, Nat b) => (Nat (a :+: b) => z) -> Tagged2 a b z+addC z = on2Nats z (tag z) (tag z) $ addC z++-- Subtract++-- We use only the canonical representation: Succ (Pred a) is never used, and neither is Pred (Succ a)+newtype Pred n = Pred n++type family a :-: b+type instance D0 :-: D0 = D0+type instance D0 :-: Succ a = Pred a+type instance Succ a :-: D0 = Succ a+type instance Succ a :-: Succ b = a :-: b++newtype Neg a = Neg a++-- Usatisfiable context, would prove any z+--zSubS :: forall a z. (Nat a, Nat (D0 :-: Succ a)) => (D0 ~ Succ D0 => z) -> Tagged a z+--zSubS z = (at :: At (D0 :-: Succ a)) $ onNat (onNat z (tag z)) (flipTags $ onNat (tag z) (flipTags $ zSubS z))++-- GHC produces an error on dead code, instead of not checking it. Not checking at all might be confusing+-- when the code was not expected by the programmer to be dead. So a warning seems appropriate (but there should be no type errors,+-- no matter what the code contains). When the programmer expects the code to be dead, it should be possible+-- to write dead code which does not produce the warning. One solution would be to warn only when the dead code+-- calls non-dead code (more precisely, code that the compiler cannot determine to be dead based on its incomplete checks.)+-- This way a special function dead :: Bool ~ Int => a could be called to disable the warning, but recursive calls to the dead-code would+-- also not generate any warning. Using undefined instead of dead would no be satisfactory, since undefined may be used+-- anywhere including in non-dead code, without producing any error.+-- As a temporary solution, we define badNat :: Nat (Pred D0) => z, which is similar to undefined, but requires a proof+-- that we are in quasi-dead code, code which violates the invariants on Nat, and which may legally call an intOfNat which+-- is undefined. If we had the treatment discussed above for dead-code, we could replace uses of this by onNat dead dead+badNat :: Nat (Pred a) => Tagged (Pred a) z+badNat = undefined -- equavalient to (intOfNat `seq` undefined)++subZ :: Nat b =>  ((b :-: D0) ~ b => z) -> Tagged b z+subZ z = onNat z $ Tagged z++subI :: Nat b =>  ((b :-: b) ~ D0 => z) -> Tagged b z+subI z = onNat z $ subI z++subS :: forall a b z. (Nat a, Nat b, Nat (a :-: b)) => ((Succ a :-: b) ~ Succ (a :-: b) => z) -> Tagged2 a b z+subS z = on2Nats z (tag $ (at :: At (a :-: b)) badNat) (tag z) $ subS z++addSubI :: forall a b z. (Nat a, Nat b) => (((a :+: b) :-:  b) ~ a => z) -> Tagged2 a b z+addSubI z = on2Nats z (dupTag $ addZ $ (at :: At D0) $ addSubI z)+           (tag z) $ dup2Tags $ addS $ tag $ (at :: At a) $ addSubI z++addSub :: forall a b c z. (Nat a, Nat b, Nat c, Nat (b :-: c)) => ((((a :+: b) :-: c) ~ (a :+: (b :-: c)), Nat (a :+: (b :-: c))) => z) -> Tagged3 a b c z+addSub z = onNat ((at2 :: At2 b (b :-: c)) $ addZ $ addZ $ tag2 z) addSubS where+  addSubS :: forall a'. (Nat a', a ~ Succ a') => Tagged3 a' b c z+  addSubS = addSub $ +             (at2 :: At2 a' (b :-: c)) $ addSC $+             (at2 :: At2 a' b) $ addSC $+             (at2 :: At2 (a' :+: b) c) $ subS z++--subRS :: forall a b z. (Nat a, Nat (b :-: Succ a)) => (Succ (b :-: Succ a) ~ (b :-: a) => z) -> Tagged2 a b z++geTrans :: forall a b c z. (Nat a, Nat b, Nat c, Nat (a :-: b), Nat (b :-: c)) => (Nat (a :-: c) => z) -> Tagged3 a b c z+geTrans = undefined++++-- Notes+-- We have no true kind system, so polymorphic data types may be instantiated at any type, whether it makes sense or not.+-- However we can express the constraint on types as type equality constraints and/or type classes, to be attached+-- to all methods involving the type.+-- These constrains rely on type classes and type families, which are always open. We can close them with+-- the NatArg/IsNat trick below, but this just closes them to a single type constructor, in which case+-- the type family could have been defined on the argument of the constructor.+--type family NatArg a+--type instance NatArg (Nat a) = a+--class Nat (NatArg a) ~ a => IsNat a+--instance IsNat (Nat a)+
+ src/Cgm/Data/Nat/Constants.hs view
@@ -0,0 +1,86 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}++module Cgm.Data.Nat.Constants where++import Cgm.Data.Nat.Base++-- putStr $ unlines $ ["type D" ++ show x ++ " = Succ D" ++ show (x-1) | x <- [1..65]]+type D1 = Succ D0+type D2 = Succ D1+type D3 = Succ D2+type D4 = Succ D3+type D5 = Succ D4+type D6 = Succ D5+type D7 = Succ D6+type D8 = Succ D7+type D9 = Succ D8+type D10 = Succ D9+type D11 = Succ D10+type D12 = Succ D11+type D13 = Succ D12+type D14 = Succ D13+type D15 = Succ D14+type D16 = Succ D15+type D17 = Succ D16+type D18 = Succ D17+type D19 = Succ D18+type D20 = Succ D19+type D21 = Succ D20+type D22 = Succ D21+type D23 = Succ D22+type D24 = Succ D23+type D25 = Succ D24+type D26 = Succ D25+type D27 = Succ D26+type D28 = Succ D27+type D29 = Succ D28+type D30 = Succ D29+type D31 = Succ D30+type D32 = Succ D31+type D33 = Succ D32+type D34 = Succ D33+type D35 = Succ D34+type D36 = Succ D35+type D37 = Succ D36+type D38 = Succ D37+type D39 = Succ D38+type D40 = Succ D39+type D41 = Succ D40+type D42 = Succ D41+type D43 = Succ D42+type D44 = Succ D43+type D45 = Succ D44+type D46 = Succ D45+type D47 = Succ D46+type D48 = Succ D47+type D49 = Succ D48+type D50 = Succ D49+type D51 = Succ D50+type D52 = Succ D51+type D53 = Succ D52+type D54 = Succ D53+type D55 = Succ D54+type D56 = Succ D55+type D57 = Succ D56+type D58 = Succ D57+type D59 = Succ D58+type D60 = Succ D59+type D61 = Succ D60+type D62 = Succ D61+type D63 = Succ D62+type D64 = Succ D63+type D65 = Succ D64+++-- putStr $ unlines $ ["d" ++ show x ++ " = S d" ++ show (x-1) | x <- [1..65]]
+ src/Cgm/Data/SortedPair.hs view
@@ -0,0 +1,34 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Data.SortedPair (
+  SortedPair,
+  onSortedPair,
+  sortedPair,
+  unsafeSortedPair
+  ) where
+
+import Cgm.Control.InFunctor
+
+-- SortedPair
+-- The two values cannot be equal. The second is strictly greater than the first.
+  
+data SortedPair a = SortedPair a a deriving Show
+onSortedPair :: (a -> a -> z) -> SortedPair a -> z
+onSortedPair f (SortedPair a1 a2) = f a1 a2
+sortedPair :: Ord a => a -> a -> SortedPair a
+sortedPair a1 a2 = if a1 <= a2 then SortedPair a1 a2 else SortedPair a2 a1
+unsafeSortedPair = SortedPair
+
+instance StrictlyIncreasingFunctor SortedPair where sincmap f (SortedPair a1 a2) = SortedPair (f $* a1) (f $* a2)
+
+ src/Cgm/Data/Structured.hs view
@@ -0,0 +1,79 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 TypeFamilies, TemplateHaskell #-}++module Cgm.Data.Structured (+    Structured(..),+    struct,+    wrap,+    unwrap,+    in1,+    in2,+    structureMap,+    deriveStructured,+    module Cgm.Control.InFunctor+) where++import Cgm.Data.Structured.Derive++import Control.Arrow+import Data.Functor.Compose+import Cgm.Control.Combinators+import Cgm.Control.InFunctor++-- Similar to instant-generics but we reuse the haskell types (), (,) and Either+-- We do not make construtors explicit, nor de we introduce types Var and Rec++class Structured a where+    type Structure a+    structure :: a -> Structure a+    fromStructure :: Structure a -> a++deriveStructured ''(,,)+deriveStructured ''(,,,)+deriveStructured ''(,,,,)+deriveStructured ''(,,,,,)+deriveStructured ''[]+deriveStructured ''Maybe+deriveStructured ''Bool+deriveStructured ''Ordering++deriveStructured ''Kleisli+deriveStructured ''Compose+deriveStructured ''RevFun++{-# INLINE struct #-}+struct :: Structured a => Bijection' a (Structure a)+struct = uncheckedBijection structure fromStructure++-- TODO: decide if we replace structure and fromStructure with those+{-# INLINE unwrap #-}+unwrap :: Structured a => a -> Structure a+unwrap = structure+{-# INLINE wrap #-}+wrap :: Structured a => Structure a -> a+wrap = fromStructure++{-# INLINE in1 #-}+in1 :: (Structured a, Structured b) => (Structure a -> Structure b) -> a -> b+in1 f = wrap . f . unwrap++{-# INLINE in2 #-}+in2 :: (Structured a, Structured b, Structured c) => (Structure a -> Structure b -> Structure c) -> a -> b -> c+in2 f = wrap ./ dot2 f unwrap unwrap++{-# INLINE structureMap #-}+structureMap :: (InjectionACofunctor p, Structured a) => p (Structure a) -> p a+structureMap = (`iacomap` struct)+
+ src/Cgm/Data/Structured/Derive.hs view
@@ -0,0 +1,176 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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.+-}+++module Cgm.Data.Structured.Derive (+    deriveStructured+) where++import Language.Haskell.TH+import Control.Monad++-- TODO: Deriving an instance is problematic since it must be exported. And most often this is+-- undesirable because it breaks the type abstraction. Instead we should derive+-- a method which provides the bijection, and modules which perform the derivation +-- would then be free to define an instance and/or use the bijection. We may want to+-- derive a structure type also.++--instance Structured a => Structured [a] where+--    type Structure [a] = Either () (a, [a])+--    structure [] = Left ()+--    structure (x : xs) = Right (x, xs)+--    fromStructure (Left ()) = []+--    fromStructure (Right (x, xs)) = (x : xs)++--[InstanceD [ClassP Structured.Structured [VarT a_0]]+--           (AppT (ConT Structured.Structured)+--                 (AppT ListT (VarT a_0)))+--           [TySynInstD Structure+--                       [AppT ListT (VarT a_1)]+--                       (AppT (AppT (ConT Data.Either.Either) (ConT GHC.Unit.()))+--                             (AppT (AppT (TupleT 2) (VarT a_1))+--                                   (AppT ListT (VarT a_1)))),+--            FunD structure [Clause [ConP GHC.Types.[] []]+--                                   (NormalB (AppE (ConE Data.Either.Left) (ConE GHC.Unit.()))) [],+--                            Clause [InfixP (VarP x_2) GHC.Types.: (VarP xs_3)]+--                                   (NormalB (AppE (ConE Data.Either.Right) (TupE [VarE x_2,VarE xs_3]))) []],+--            FunD fromStructure [Clause [ConP Data.Either.Left [ConP GHC.Unit.() []]]+--                                       (NormalB (ConE GHC.Types.[])) [],+--                                Clause [ConP Data.Either.Right [TupP [VarP x_4,VarP xs_5]]]+--                                       (NormalB (InfixE (Just (VarE x_4)) (ConE GHC.Types.:) (Just (VarE xs_5)))) []]]]++-- Options for defintion of generic persistence++-- http://www.cse.unsw.edu.au/~chak/papers/instant-generics.pdf is interresting but its+-- implementation instant-generics, does not yet come with a Template Haskell+-- function to derive Representable instances++-- See also "A generic deriving mechanism for Haskell, Draft"+-- (http://www.dreixel.net/research/pdf/gdmh_draft.pdf)+-- To be presented at Haskell Symposium 2010, in September+-- Implementation is in UHC, not GHC for now.++-- GDMH seems very powerful, but it appears we do not need tagging and meta-information.+-- It also avoids using type families and functional dependencies, to show that their+-- design is workable without those new features. But here we can use type famillies+-- as in instant-generics. We could use the instant-generics design (and library).+-- We might not need to use the shallow representation, but if we stay close to+-- their design we will have less thinking to do, and we may be able to use+-- their library directly (and add TH to derive instances). The shallow representation appears+-- necessary to support subuniverses for specific generic methods (something we think+-- we do no need at this point).++-- DEBUG with -ddump-splices++deriveStructured :: Name -> Q [Dec]+deriveStructured typName =+  do (TyConI d) <- reify typName+     (type_name,tvars,_,constructors) <- typeInfo (return d)+     appliedType <- appsT $ conT' type_name : map (varT . fromTyVar) tvars+     let structureType = tySynInstD (mkName "Structure") [return appliedType] $+                                     nestedEitherT $ map (nestedTupT . map (return . snd) . snd) constructors+         structureFun = do clauses <- mapM structureClause constructors+                           return $ FunD (mkName "structure") $ addETags clauses+         structureClause (conName, components) =+           do vars <- newNames "a" components+              clause [conP conName $ map varP vars] (normalB $ nestedTupE $ map varE vars) []+         fromStructureFun =+           do clauses <- mapM fromStructureClause constructors+              return $ FunD (mkName "fromStructure") $ addPTags clauses+         fromStructureClause (conName, components) =+           do vars <- newNames "s" components+              clause [nestedTupP $ map varP vars] (normalB (appsE (conE conName : map varE vars))) []+         in sequence [instanceD (cxt []) (appT (conT $ mkName "Structured") (return appliedType))+                                [structureType, structureFun, fromStructureFun]]++conT' name = if nameBase name == "[]" then listT else conT name++-- A foldr with special cases for empty lists and singletons+nested :: b -> (a -> b) -> (a -> b -> b) -> [a] -> b+nested empty single pair [] = empty+nested empty single pair (x:[]) = single x+nested empty single pair (x:xs) = pair x $ nested empty single pair xs++nestedTupE = nested (tupE []) id (\a b -> tupE [a, b])+nestedTupT = nested (tupT []) id (\a b -> tupT [a, b])+nestedTupP = nested (tupP []) id (\a b -> tupP [a, b])+nestedEitherT = nested (error "nestedEitherT []") id eitherT++addETags = nested [] return $ \c cs -> mapClauseBodyE leftETag c : map (mapClauseBodyE rightETag) cs+addPTags = nested [] return $ \c cs -> mapClausePat1 leftPTag c : map (mapClausePat1 rightPTag) cs+leftETag = AppE $ ConE $ mkName "Left"+rightETag = AppE $ ConE $ mkName "Right"+leftPTag p = ConP (mkName "Left") [p]+rightPTag p = ConP (mkName "Right") [p]+mapClauseBodyE f (Clause ps b ds) = Clause ps (mapBodyE f b) ds+mapClausePat1 f (Clause [p] b ds) = Clause [f p] b ds+mapBodyE f (GuardedB gs) = GuardedB $ map (\p -> (fst p, f $ snd p)) gs+mapBodyE f (NormalB e) = NormalB $ f e++appsT :: [TypeQ] -> TypeQ+appsT [] = error "appsT []"+appsT [x] = x+appsT (x:y:zs) = appsT $ appT x y : zs++tupT ts = appsT $ tupleT (length ts) : ts++eitherT ta tb = appsT [conT (mkName "Either"), ta, tb]++fromTyVar :: TyVarBndr -> Name+fromTyVar (PlainTV v) = v+fromTyVar (KindedTV v _) = v++newNames prefix = mapM $ const $ newName prefix++-- And some borrowed helper code taken from Syb III / replib 0.2++typeInfo :: DecQ -> Q (Name, [TyVarBndr], [(Name, Int)], [(Name, [(Maybe Name, Type)])])+typeInfo m =+     do d <- m+        case d of+           d@DataD{} ->+            return (simpleName $ name d, paramsA d, consA d, termsA d)+           d@NewtypeD{} ->+            return (simpleName $ name d, paramsA d, consA d, termsA d)+           _ -> error ("derive: not a data type declaration: " ++ show d)++     where+        consA (DataD _ _ _ cs _)    = map conA cs+        consA (NewtypeD _ _ _ c _)  = [ conA c ]++        paramsA (DataD _ _ ps _ _) = ps+        paramsA (NewtypeD _ _ ps _ _) = ps++        termsA (DataD _ _ _ cs _) = map termA cs+        termsA (NewtypeD _ _ _ c _) = [ termA c ]++        termA (NormalC c xs)        = (c, map (\x -> (Nothing, snd x)) xs)+        termA (RecC c xs)           = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs)+        termA (InfixC t1 c t2)      = (c, [(Nothing, snd t1), (Nothing, snd t2)])++        conA (NormalC c xs)         = (simpleName c, length xs)+        conA (RecC c xs)            = (simpleName c, length xs)+        conA (InfixC _ c _)         = (simpleName c, 2)++        name (DataD _ n _ _ _)      = n+        name (NewtypeD _ n _ _ _)   = n+        name d                      = error $ show d++simpleName :: Name -> Name+simpleName nm =+   let s = nameBase nm+   in case dropWhile (/=':') s of+        []          -> mkName s+        _:[]        -> mkName s+        _:t         -> mkName t+
+ src/Cgm/Data/Super.hs view
@@ -0,0 +1,69 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 MultiParamTypeClasses, ScopedTypeVariables, TypeOperators #-}++module Cgm.Data.Super (+    Super(..),+    up,+    superSInc,+    narrowIntegral,+    module Cgm.Data.Maybe,+    module Cgm.Control.InFunctor+) where++import Data.Int+import Data.Word+import Data.Bits+import Control.Applicative+import Cgm.Data.Maybe+import Cgm.Control.InFunctor++-- Laws: properties of and relations on between values in a must still hold in b. For example 0 must map to 0, and Ord must be respected.+-- However some properites cannot hold, such as (== maxBound). So this law needs some elaboration.+class Super a b where+    super ::  InjectionM' a b++superSInc :: Super a b => a :>> b+superSInc = uncheckedStrictlyIncreasing (apply super)++up :: Super a b => a -> b+up = apply super++instance Super Word8 Word64 where super = integralInjectionMaxOnly+instance Super Word8 Word32 where super = integralInjectionMaxOnly+instance Super Word8 Word16 where super = integralInjectionMaxOnly+instance Super Word16 Word64 where super = integralInjectionMaxOnly+instance Super Word16 Word32 where super = integralInjectionMaxOnly+instance Super Word32 Word64 where super = integralInjectionMaxOnly++instance Super Word8 Word where super = integralInjectionMaxOnly+instance Super Word16 Word where super = integralInjectionMaxOnly+instance Super Word32 Word where super = integralInjectionMaxOnly+instance Super Word Word64 where super = integralInjectionMaxOnly++instance Super Word8 Integer where super = integralInjection ++integralInjectionMaxOnly :: forall a b. (Integral a, Integral b, Bounded a) => InjectionM' a b+integralInjectionMaxOnly = uncheckedInjectionM fromIntegral narrowIntegralMaxOnly++integralInjection :: forall a b. (Integral a, Integral b, Bounded a) => InjectionM' a b+integralInjection = uncheckedInjectionM fromIntegral narrowIntegral++{-# INLINE narrowIntegral #-}+narrowIntegral :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b+narrowIntegral = (fromIntegral <$>) . predJust (\a -> fromIntegral (minBound :: b) <= a && a <= fromIntegral (maxBound :: b))++narrowIntegralMaxOnly :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b+narrowIntegralMaxOnly = (fromIntegral <$>) . predJust (<= fromIntegral (maxBound :: b))+
+ src/Cgm/Data/Tagged.hs view
@@ -0,0 +1,96 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 Rank2Types #-}++module Cgm.Data.Tagged (+    module Data.Tagged,+    tag,+    at,+    At,+    Tagged2,+    tag2,+    at2,+    At2,+    Tagged3,+    tag3,+    at3,+    At3,+    Tagged4,+    tag4,+    at4,+    At4,+    flipTags,+    rot3Tags,+    rot3Tags2,+    rot4Tags,+    rot4Tags2,+    rot4Tags3,+    dupTag,+    dup2Tags,+    pushTagIn,+    constAt+) where++import Data.Tagged+import Control.Applicative+import Cgm.Control.Combinators++type At a = forall z. Tagged a z -> z+at = untag++type Tag a = forall z. z -> Tagged a z+tag = Tagged++type Tagged2 a b z = Tagged a (Tagged b z)+tag2 = tag . tag+type At2 a b = forall z. Tagged2 a b z -> z+at2 = at . at++type Tagged3 a b c z = Tagged a (Tagged2 b c z)+tag3 = tag . tag2+type At3 a b c = forall z. Tagged3 a b c z -> z+at3 = at . at . at++type Tagged4 a b c d z = Tagged a (Tagged3 b c d z)+tag4 = tag . tag3+type At4 a b c d = forall z. Tagged4 a b c d z -> z+at4 = at . at . at . at++flipTags :: Tagged2 a b z -> Tagged2 b a z+flipTags = tag2 . at2++rot3Tags :: Tagged3 b c a z -> Tagged3 a b c z+rot3Tags = tag3 . at3+rot3Tags2 :: Tagged3 c a b z -> Tagged3 a b c z+rot3Tags2 = tag3 . at3++rot4Tags :: Tagged4 b c d a z -> Tagged4 a b c d z+rot4Tags = tag4 . at4+rot4Tags2 :: Tagged4 c d a b z -> Tagged4 a b c d z+rot4Tags2 = tag4 . at4+rot4Tags3 :: Tagged4 d a b c z -> Tagged4 a b c d z+rot4Tags3 = tag4 . at4++dupTag :: Tagged2 a a z -> Tagged a z+dupTag = tag . at2++dup2Tags :: Tagged4 a b a b z -> Tagged2 a b z+dup2Tags = tag2 . at4++pushTagIn :: Functor f => Tagged a (f b) -> f (Tagged a b)+pushTagIn = (tag <$>) . untag++constAt :: Tagged b a -> b -> a+constAt = at ./ const
+ src/Cgm/Data/Typeable.hs view
@@ -0,0 +1,19 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Data.Typeable(
+  module Data.Typeable
+  ) where
+       
+import Data.Typeable
+
+ src/Cgm/Data/Word.hs view
@@ -0,0 +1,121 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 MagicHash, TypeFamilies, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}
+
+module Cgm.Data.Word (
+  WordConv(..),
+  onWordConv,
+  onWordConvB,
+  wordBits,
+  partialShiftL,
+  partialShiftRL,
+  uShiftL,
+  uShiftRL,
+  unI#,
+  unW#,
+  Signed(..),
+  unsigned,
+  WordConv1(..),
+  splitWord64LE,
+  module Data.Word
+  ) where
+
+import Prelude()
+import Cgm.Prelude
+import Control.Category
+import Data.Bits
+import Data.Int
+import Data.Word
+import GHC.Prim
+import GHC.Exts
+import Cgm.Control.InFunctor
+import Cgm.Data.Tagged
+import Cgm.Data.WordN
+import Cgm.Control.Combinators
+
+{-# INLINE wordBits #-}
+wordBits :: Integral a => a
+wordBits = fromIntegral $ bitSize (undefined :: Word)
+
+
+class WordConv a where
+  wordConv  :: Bijection' Word a
+
+onWordConvB :: (Bijection' Word Word32 -> z) -> (Bijection' Word Word64 -> z) -> z
+onWordConvB a b = onWordConv (a wordConv) (b wordConv)
+
+onWordConv :: (WordConv Word32 => z) -> (WordConv Word64 => z) -> z
+
+#if WORDSIZE == 32
+instance WordConv Word32 where
+  wordConv = uncheckedBijection fromIntegral fromIntegral
+onWordConv a _ = a
+#endif
+
+#if WORDSIZE == 64
+instance WordConv Word64 where
+  wordConv = uncheckedBijection fromIntegral fromIntegral
+onWordConv _ a = a
+#endif
+
+-- | 0 <= n < wordBits
+{-# INLINE partialShiftL #-}
+partialShiftL :: Word -> Word -> Word
+partialShiftL (W# w) (W# n) = W# (w `uncheckedShiftL#` word2Int# n)
+
+-- | 0 <= n < wordBits
+{-# INLINE partialShiftRL #-}
+partialShiftRL :: Word -> Word -> Word
+partialShiftRL (W# w) (W# n) = W# (w `uncheckedShiftRL#` word2Int# n)
+
+{-# INLINE uShiftL #-}
+uShiftL :: Word -> Word -> Word
+uShiftL w n = if n >= wordBits then 0 else partialShiftL w n
+
+{-# INLINE uShiftRL #-}
+uShiftRL :: Word -> Word -> Word
+uShiftRL w n = if n >= wordBits then 0 else partialShiftRL w n
+
+{-# INLINE unW# #-}
+unW# (W# a) = a
+{-# INLINE unI# #-}
+unI# (I# a) = a
+
+
+class Signed u s | u -> s, s -> u where signed :: Bijection' u s
+instance Signed Word8 Int8 where 
+  {-# INLINE signed #-}
+  signed = uncheckedBijection fromIntegral fromIntegral
+instance Signed Word16 Int16 where 
+  {-# INLINE signed #-}
+  signed = uncheckedBijection fromIntegral fromIntegral
+instance Signed Word32 Int32 where 
+  {-# INLINE signed #-}
+  signed = uncheckedBijection fromIntegral fromIntegral
+instance Signed Word64 Int64 where 
+  {-# INLINE signed #-}
+  signed = uncheckedBijection fromIntegral fromIntegral
+instance Signed Word Int where 
+  {-# INLINE signed #-}
+  signed = uncheckedBijection fromIntegral fromIntegral
+
+{-# INLINE unsigned #-}
+unsigned :: Signed u s => Bijection' s u
+unsigned = inv signed
+
+class WordConv1 a where
+  wordConv1 :: WordConv c => Bijection' (a Word) (a c)
+
+splitWord64LE :: Bijection' Word64 (Word32, Word32)
+splitWord64LE = uncheckedBijection (fk (,) fromIntegral $ fromIntegral . (`shiftR` 32)) (\(l, h) -> fromIntegral h `shiftL` 32 + fromIntegral l)
+ src/Cgm/Data/WordN.hs view
@@ -0,0 +1,234 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 FlexibleInstances, +FlexibleContexts, +UndecidableInstances,+ScopedTypeVariables,+TypeSynonymInstances,+TypeOperators,+MultiParamTypeClasses, +TypeFamilies, +FunctionalDependencies, DeriveDataTypeable #-}++module Cgm.Data.WordN (+    RWord,+    toRWord,+    fromRWord,+    rWord,+    WordN(..),+    wordNBits,+    boolAsWord,+    RWordC,+    RWord8,+    RWord16,+    RWord32,+    RWord64,+    rChangeWord,+    rChangeWord',+    rAdd,+    rWordJoin,+    rWordSplit,+    rWordBool,+    module Cgm.Data.Nat,+    module Cgm.Data.Super+) where++import Data.Word+import Data.Int+import Data.Bits+import Control.Applicative+import GHC.Enum+import Cgm.Data.Bool+import Cgm.Data.Super+import Cgm.Data.Nat+import Cgm.Control.Combinators+import Cgm.Control.InFunctor+import Test.QuickCheck (Arbitrary(..), Gen)+import Data.Typeable++--testAddZ :: forall a. Nat a -> RWord (Add D0 (Nat a)) -> RWord (Nat a)+--testAddZ a r = addZ a r'+--	where r' :: (Add D0 (Nat a) ~ (Nat a)) => RWord (Nat a)+--              r' = r+--+--testRWordJoin :: forall a b. (NatClass a, NatClass b) => RWord (Nat a) -> RWord (Nat b) -> RWord (Add (Nat a) (Nat b))+--testRWordJoin a b = addComm (nat :: Nat a) (nat :: Nat b) $ addClosed (nat :: Nat b) (nat :: Nat a) $ \s -> rWordAdd (rWordJoin a b) $ rWordJoin b a+--+--runTestRWordJoin = print $ testRWordJoin (RWord 2 :: RWord D4) (RWord 3 :: RWord D5)++-- WordN++class (Bits w, Integral w, Nat (WordNBits w)) => WordN w where+    type WordNBits w :: *++instance WordN Word8 where type WordNBits Word8 = D8+instance WordN Word16 where type WordNBits Word16 = D16+instance WordN Word32 where type WordNBits Word32 = D32+instance WordN Word64 where type WordNBits Word64 = D64++wordNBits :: forall w. WordN w => w -> Int+wordNBits _ = (at :: At (WordNBits w)) intOfNat++-- RWord++newtype RWord w n = RWord {unRWord :: w} deriving Typeable++toRWord :: WordN w => w -> RWord w (WordNBits w)+toRWord = RWord++fromRWord :: RWord w n -> w+fromRWord = unRWord++rWord :: WordN w => Bijection' w (RWord w (WordNBits w))+rWord = uncheckedBijection toRWord fromRWord++boolAsWord :: Bijection' Bool (RWord Word8 D1)+boolAsWord = uncheckedBijection (bool 0 1) (== 1)++-- RWordC is just shorthand for an otherwise verbose context+class (WordN w, Nat n, Nat (WordNBits w :-: n)) => RWordC w n+instance (WordN w, Nat n, Nat (WordNBits w :-: n)) => RWordC w n++rWordJoin :: forall n m w. (Nat n, Nat m, Bits w) => RWord w n -> RWord w m -> Tagged n (RWord w (m :+: n))+rWordJoin (RWord un) (RWord um) = Tagged $ RWord $ um .|. (un `shiftL` (at :: At m) intOfNat)++rWordBool :: RWordC w D1 => RWord w D1 -> Bool+rWordBool = (`testBit` 0)++rWordSplit :: forall w n m. (RWordC w (n :+: m), RWordC w n, RWordC w m) => RWord w (n :+: m) -> Tagged m (RWord w m, RWord w n)+rWordSplit (RWord w) = Tagged $ (RWord (w `shiftR` (at :: At m) intOfNat), rClean $ RWord w)++rClean :: forall w n. RWordC w n => RWord w n -> RWord w n+rClean = liftRToR $ (.&.) $ (at :: At n) $ lowMaskNat++rSaturate :: forall w n. RWordC w n => RWord w n -> RWord w n+rSaturate = liftRToR $ (.|.) $ complement $ (at :: At n) $ lowMaskNat++-- TODO: The Nat ((WordNBits w) :-: n) is not used, so if it were defined as 'undefined' it would side-step out type checks (Nat only+-- closed if we exclude 'undefined' definitions). We could change the code so that it is used just to make sure it is not undefined.+-- Would representing the bound by a TBool valued type function be safer?+lowMaskNat :: RWordC w n => Tagged n w+lowMaskNat = (complement . shiftL (complement 0)) <$> intOfNat++-- TODO replace with more general versions in InFunctor, lift.... Oops no. That would no work. A Bijection cannot+-- be polymorphic. If we use a type function, like Structure, we could have more general lift functions.+liftRToA f = f . unRWord+liftAToR f = RWord . f+liftRToR f = RWord . f . unRWord+liftRRToR f = RWord ./ dot2i f unRWord -- could be written "wrapB rw rw rw", and we might then want to inline manually+liftRRToA f = dot2i f unRWord+liftRAToR f = RWord ./ dot2 f unRWord id+liftRRToRR f = (\(a, b) -> (RWord a, RWord b)) ./ dot2i f unRWord++-- Todo: remove Nat (WordNBits w' :-: n) which is redundant, it can be infered by transitivity: WordNBits w' >= n' >= n+--instance (RWordC w n, RWordC w' n', Nat (n' :-: n), Nat (WordNBits w' :-: n)) => Super (RWord w n) (RWord w' n') where +--  super = rMoreBits `composeM` rChangeWord+--instance RWordC w n => Super (RWord w n) w where+--    super = uncheckedBijection unRWord RWord `composeM` (rMoreBits :: InjectionM' (RWord w n) (RWord w (WordNBits w)))+-- The above two commented instances are subsumed by the following instance, which might be less efficient++instance (RWordC w n, RWordC w' n) => Super (RWord w n) w' where+    super = uncheckedInjectionM fromIntegral (((RWord . fromIntegral) <$>) . predJust (<= bound)) where+      bound = fromIntegral (maxBound :: RWord w n) :: w'++rChangeWord :: forall w w' n . (RWordC w n, RWordC w' n) => Bijection' (RWord w n) (RWord w' n)+rChangeWord = uncheckedBijection (RWord . fromIntegral . unRWord) (RWord . fromIntegral . unRWord)++rChangeWord' :: forall w w' n . (RWordC w n, WordN w', Nat (WordNBits w' :-: WordNBits w)) => Bijection' (RWord w n) (RWord w' n)+rChangeWord' = uncheckedBijection (RWord . fromIntegral . unRWord) (RWord . fromIntegral . unRWord)++rMoreBits :: forall w n n' d . (RWordC w n, Nat d, (n' :-: n) ~ d) => InjectionM' (RWord w n) (RWord w n')+rMoreBits = uncheckedInjectionM (liftRToR id) ((RWord <$>) . predJust (<= (at :: At n) lowMaskNat) . unRWord)++rAdd :: Num w =>  RWord w n -> RWord w n -> RWord w (Succ n)+rAdd = liftRRToR (+)++instance RWordC w n => Bounded (RWord w n) where+    minBound = 0+    maxBound = (at :: At n) $ dupTag $ subI $ lowMaskNat++instance RWordC w n => Bits (RWord w n) where+    (.&.) = liftRRToR (.&.)+    (.|.) = liftRRToR (.|.)+    xor = liftRRToR xor+    complement = liftRToR (`xor` (at :: At n) lowMaskNat)+    shiftL = rClean ./ liftRAToR shiftL+    shiftR = liftRAToR shiftR+    rotateL x i = shiftL x i .|. shiftR x ((at :: At n) intOfNat - i)+    rotateR x i = rotateL x ((at :: At n) intOfNat - i)+    bitSize _ = (at :: At n) intOfNat+    isSigned _ = False++instance RWordC w n => Ord (RWord w n) where+    compare = liftRRToA compare++instance RWordC w n => Enum (RWord w n) where+  succ = rClean . liftRToR succ . rSaturate+  pred = liftRToR pred+  toEnum = rClean . liftAToR toEnum . ((+) $ fromIntegral $ complement $ ((at :: At n) lowMaskNat :: w))+  fromEnum = liftRToA fromEnum+  enumFrom     = boundedEnumFrom+  enumFromThen = boundedEnumFromThen++instance RWordC w n => Real (RWord w n) where+    toRational = liftRToA toRational++instance RWordC w n => Integral (RWord w n) where+    quot = liftRRToR quot+    rem = liftRRToR rem+    div = liftRRToR div+    mod = liftRRToR mod+    quotRem = liftRRToRR quotRem+    divMod = liftRRToRR divMod+    toInteger = liftRToA toInteger++instance RWordC w n => WordN (RWord w n) where+    type WordNBits (RWord w n) = n++instance RWordC w n => Eq (RWord w n) where+    (==) = liftRRToA (==)++instance (Show w, RWordC w n) => Show (RWord w n) where+    show = liftRToA show++instance RWordC w n => Num (RWord w n) where+    (+) = rClean ./ liftRRToR (+)+    (-) = rClean ./ liftRRToR (-)+    (*) = rClean ./ liftRRToR (*)+    negate = rClean . liftRToR negate+    fromInteger = rClean . liftAToR fromInteger+    abs = liftRToR abs+    signum = liftRToR signum++instance (Arbitrary w, RWordC w n) => Arbitrary (RWord w n) where+  arbitrary = (rClean . RWord) <$> arbitrary+  shrink = (RWord <$>) . shrink . unRWord++type RWord8 = RWord Word8+type RWord16 = RWord Word16+type RWord32 = RWord Word32+type RWord64 = RWord Word64++--type RangeT n iMin eMax = (n :>=: iMin) :&&: (n :<: eMax)+--+--type RWord n = If (RangeT n D0 D8) (RWord Word8 n)+--                  (If (n :==: D8) Word8+--                      (If (RangeT n D9 D16) (RWord Word16 n)+--                          (If (n :==: D16) Word16+--                              (If (RangeT n D17 D32) (RWord Word32 n)+--                                  (If (n :==: D32) Word32+--                                      (If (RangeT n D33 D64) (RWord Word64 n)+--                                          (If (n :==: D64) Word64+--                                              ())))))))+
+ src/Cgm/Prelude.hs view
@@ -0,0 +1,70 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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.
+-}
+
+module Cgm.Prelude (
+  counting,
+  --module Prelude.Plus,
+  module Control.Applicative, 
+  module Control.Arrow, 
+  module Control.Monad, 
+  module Control.Exception, 
+  module Control.Category, 
+  module Data.Traversable, 
+  module Data.Foldable, 
+  module Data.Monoid, 
+  module Data.List, 
+  module Data.Function, 
+  module Data.Ord, 
+  module Prelude, 
+
+  module Cgm.Control.Combinators,
+  module Cgm.Control.InFunctor,
+  module Cgm.Data.Tagged,
+  module Cgm.Data.Bool
+  ) where
+
+--import Prelude ()
+import Prelude hiding (
+    catch, ioError, appendFile, foldr, all, and, any, concat, concatMap, elem, 
+    foldl, foldr1, notElem, or, mapM, sequence, mapM_, sequence_, foldl1, 
+    maximum, minimum, product, sum, id,(.))
+import Control.Applicative
+import Control.Arrow
+import Control.Exception
+import Control.Monad hiding (
+    mapM,sequence,forM,mapM_,sequence_,forM_,msum,Monad(..),(=<<),Functor(..))
+import Data.Traversable
+import Data.Foldable
+import Data.Monoid hiding (Sum(..)) 
+import Data.List hiding (
+    foldr,all,and,any,concat,concatMap,elem,foldl,foldr1
+  , notElem,or,foldl1,maximum,minimum,product,sum,find,foldl'
+  , maximumBy,minimumBy,mapAccumL,mapAccumR,null
+  , (++),map,(!!),break,cycle,drop,dropWhile,filter
+  , head,init,iterate,last,length,lookup,repeat,replicate
+  , reverse,scanl,scanl1,scanr,scanr1,span,splitAt,tail,take
+  , takeWhile,unzip,unzip3,zip,zip3,zipWith,zipWith3,lines
+  , unlines,unwords,words )
+import Data.Function hiding ((.),($),const,flip,id)
+import Data.Ord (comparing)
+
+--import Prelude.Plus hiding (Sum, dup)
+import Control.Category
+import Cgm.Control.Combinators
+import Cgm.Control.InFunctor
+import Cgm.Data.Tagged
+import Cgm.Data.Bool
+
+{-# INLINE counting #-}
+counting :: (Num a, Enum a) => a -> [a]
+counting a = [0 .. pred a]
+ src/Cgm/System/Endian.hs view
@@ -0,0 +1,117 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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 TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+
+module Cgm.System.Endian (
+  Endian(..),
+  swapHalves,
+  ixBytes,
+  littleEndianIxBytes,
+  bigEndianIxBytes,
+  platformEndianness,
+  platformWordEndianness,
+  ByteSwapped,
+  swapBytes,
+  unswapBytes,
+  Endianness(..),
+  reverseEndianness
+  ) where
+
+import Data.Bits
+import Data.Ix
+import Control.Applicative
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import Cgm.Data.Tagged
+import Cgm.Data.Word
+import Cgm.Data.Array
+import Cgm.Data.Len
+import Cgm.Data.Structured
+import Cgm.Control.InFunctor
+import Cgm.Control.Combinators
+
+class (Prim w, Bits w) => Endian w where 
+  untypedSwapBytes :: w -> w
+
+instance Endian Word8 where 
+  {-# INLINE untypedSwapBytes #-} 
+  untypedSwapBytes = id
+instance Endian Word16 where 
+  {-# INLINE untypedSwapBytes #-} 
+  untypedSwapBytes = swapHalves
+instance Endian Word32 where 
+  {-# INLINE untypedSwapBytes #-} 
+  untypedSwapBytes = swapMask 0xff00ff 8 . swapHalves
+instance Endian Word64 where 
+  {-# INLINE untypedSwapBytes #-} 
+  untypedSwapBytes = swapMask 0xff00ff00ff00ff 8 . swapMask 0xffff0000ffff 16 . swapHalves
+instance Endian Word where
+  {-# INLINE untypedSwapBytes #-} 
+  untypedSwapBytes = onWordConvB (flip liftItI untypedSwapBytes) (flip liftItI untypedSwapBytes)
+  
+
+{-# INLINE swapHalves #-} 
+swapHalves :: forall w. Bits w => w -> w
+swapHalves w = w `shiftR` halfBitSize + w `shiftL` halfBitSize where
+  halfBitSize = bitSize (undefined :: w) `div` 2
+
+{-# INLINE swapMask #-} 
+swapMask :: Bits w => w -> Int -> w -> w
+swapMask mask shift w = ((w `shiftR` shift) .&. mask) + ((w .&. mask) `shiftL` shift)
+
+-- Number with byte value n in the nth byte, in order of increasing significance (starting at 0)
+byteNumbers :: forall w. Endian w => w
+byteNumbers = sum $ fmap (\n -> fromIntegral n `shiftL` (8 * fromIntegral n)) $ (at :: At w) increasingBytes
+
+increasingBytes :: forall w. Prim w => Tagged w [Word8]
+increasingBytes = Tagged $ range (0, fromIntegral (primSizeOf (undefined :: w)) - 1)
+
+singletonArray :: Prim w => w -> PrimArray Free w
+singletonArray w = runSTPrimArray (mkArray 1 >>= \a -> a <$ writeArray a 0 w)
+
+-- Indexes each byte of a word
+ixBytes :: forall w. Endian w => w -> [Word8]
+ixBytes w = let a = unsafePrimArrayCast (singletonArray w) :: PrimArray Free Word8 in indexArray a . unsafeLen . fromIntegral <$> (at :: At w) increasingBytes
+
+littleEndianIxBytes :: forall w. Prim w => Tagged w [Word8]
+littleEndianIxBytes = increasingBytes
+bigEndianIxBytes :: forall w. Prim w => Tagged w [Word8]
+bigEndianIxBytes = reverse <$> increasingBytes
+
+data Endianness = LittleEndian | BigEndian deriving (Eq, Show)
+
+-- | Undefined when the platform is neither big nor little endian.
+{-# SPECIALIZE platformEndianness :: Tagged Word32 Endianness #-}
+{-# SPECIALIZE platformEndianness :: Tagged Word64 Endianness #-}
+{-# SPECIALIZE platformEndianness :: Tagged Word Endianness #-}
+platformEndianness :: forall w. Endian w => Tagged w Endianness
+platformEndianness = do
+  let plat = ixBytes (byteNumbers :: w)
+  l <- littleEndianIxBytes
+  b <- bigEndianIxBytes
+  if plat == l then return LittleEndian else if plat == b then return BigEndian else undefined
+
+platformWordEndianness :: Endianness
+platformWordEndianness = (at :: At Word) platformEndianness
+reverseEndianness LittleEndian = BigEndian
+reverseEndianness BigEndian = LittleEndian
+
+newtype ByteSwapped w = ByteSwapped w deriving (Prim, Show)
+swapBytes :: Endian w => w -> ByteSwapped w
+swapBytes = ByteSwapped . untypedSwapBytes
+unswapBytes :: Endian w => ByteSwapped w -> w
+unswapBytes (ByteSwapped w) = untypedSwapBytes w
+
+deriveStructured ''Endianness
+ src/Cgm/System/Mem/Alloc.hs view
@@ -0,0 +1,67 @@+{-
+Copyright 2010-2012 Cognimeta Inc.
+
+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, TupleSections #-}
+
+module Cgm.System.Mem.Alloc (
+  mallocArrayLen,
+  copyArrayLen,
+  advancePtrLen,
+  minusPtrLen,
+  pokeLenOff,
+  peekLenOff,
+  hPutBufLen,
+  hGetBufLen
+  ) where
+
+import Debug.Trace
+import Data.Functor
+import Data.Word
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Array
+import System.IO
+import Cgm.Data.Len
+import Cgm.Control.Combinators
+
+{-# INLINE mallocArrayLen #-}
+mallocArrayLen :: (Storable a, Integral b) => Len a b -> IO (Ptr a)
+mallocArrayLen = mallocArray . fromIntegral . getLen
+
+{-# INLINE copyArrayLen #-}
+copyArrayLen :: (Storable a, Integral b) => Ptr a -> Ptr a -> Len a b -> IO ()
+copyArrayLen dest src = copyArray dest src . fromIntegral . getLen
+
+{-# INLINE advancePtrLen #-}
+advancePtrLen :: (Storable a, Integral b) => Ptr a -> Len a b -> Ptr a
+advancePtrLen p = advancePtr p . fromIntegral . getLen
+
+{-# INLINE minusPtrLen #-}
+minusPtrLen :: (LgMultiple a Word8) => Ptr a -> Ptr a -> Len a Int
+minusPtrLen a b = fst $ coarseRem (unsafeLen $ a `minusPtr` b :: Len Word8 Int)
+
+{-# INLINE pokeLenOff #-}
+pokeLenOff :: (Show a, Storable a, Integral b) => Ptr a -> Len a b -> a -> IO ()
+pokeLenOff ptr = pokeElemOff ptr . fromIntegral . getLen
+
+{-# INLINE peekLenOff #-}
+peekLenOff :: (Storable a, Integral b) => Ptr a -> Len a b -> IO a
+peekLenOff ptr = peekElemOff ptr . fromIntegral . getLen
+
+{-# INLINE hPutBufLen #-}
+hPutBufLen :: (Storable a, Integral b) => Handle -> Ptr a -> Len a b -> IO ()
+hPutBufLen h ptr = hPutBuf h ptr . fromIntegral . getLen
+
+{-# INLINE hGetBufLen #-}
+hGetBufLen :: (Storable a, Integral b) => Handle -> Ptr a -> Len a b -> IO (Len a b)
+hGetBufLen h ptr = ((unsafeLen . fromIntegral) <$>) . hGetBuf h ptr . fromIntegral . getLen
+ src/Cgm/TH/Label.hs view
@@ -0,0 +1,25 @@+{-+Copyright 2010-2012 Cognimeta Inc.++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 TemplateHaskell #-}++module Cgm.TH.Label (+  label+) where++import Language.Haskell.TH++label :: Name -> ExpQ+label s = [|($(return $ LitE $ stringL $ nameBase s),$(varE s))|]++