packages feed

zm (empty) → 0.2

raw patch · 46 files changed

+3551/−0 lines, 46 filesdep +ListLikedep +basedep +bytestringsetup-changed

Dependencies added: ListLike, base, bytestring, containers, cryptonite, deepseq, flat, ghcjs-base, memory, model, mtl, pretty, tasty, tasty-hunit, tasty-quickcheck, text, timeit, transformers, zm

Files

+ LICENSE view
@@ -0,0 +1,34 @@+JavaScript code from https://github.com/emn178/js-sha3+Copyright (c) 2015 Chen Yi-Cyuan+MIT License++Copyright Pasqualino `Titto` Assini (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Pasqualino `Titto` Assini nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,385 @@++[![Build Status](https://travis-ci.org/tittoassini/zm.svg?branch=master)](https://travis-ci.org/tittoassini/zm) [![Hackage version](https://img.shields.io/hackage/v/zm.svg)](http://hackage.haskell.org/package/zm)++Haskell implementation of 正名 (read as: [Zhèng Míng](https://translate.google.com/#auto/en/%E6%AD%A3%E5%90%8D)) a minimalistic, expressive and language independent data modelling language ([specs](http://quid2.org/docs/ZhengMing.pdf)).++### How To Use It For Fun and Profit++With `zm` you can derive and manipulate canonical and language-independent definitions and unique identifiers of (a subset) of Haskell data types.++This can be used, for example:++* in combination with a serialisation library to provide type-safe deserialisation+* for data exchange across different programming languages and software systems+* for long term data preservation++#### Canonical Models of Haskell Data Types++For a data type to have a canonical representation, it has to implement the `Model` type class.++Instances for a few common data types (Bool, Maybe, Tuples, Lists, Ints, Words, String, Text ..) are already defined and there is `Generics` based support to automatically derive additional instances.++Let's see some code, we need a couple of GHC extensions:++```haskell+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, NoMonomorphismRestriction #-}+```++Import the library:++```haskell+import ZM+```++We use `absTypeModel` to get the canonical type of `Maybe Bool` and `pPrint` to print is nicely:++```haskell+prt = pPrint+```++```haskell+prt $ absTypeModel (Proxy :: Proxy (Maybe Bool))+-> Type:+-> +-> Kda6836778fd4 K306f1981b41c:+-> Maybe Bool+-> +-> Environment:+-> +-> K306f1981b41c:+->  Bool ≡   False+->         | True+-> +-> Kda6836778fd4:+->  Maybe a ≡   Nothing+->            | Just a+```+++We can see how the data types `Maybe` and `Bool` have been assigned unique canonical identifiers and how the type `Maybe Bool` is accordingly represented.++Contrary to Haskell, `ZhengMing` has no 'magic' built-in types so even something as basic as a `Char` or a `Word` have to be defined explicitly.++For example, a `Word7` (an unsigned integer of 7 bits length) is defined as an explicit enumeration of all the 128 different values that can fit in 7 bits:++```haskell+prt $ absTypeModel (Proxy :: Proxy Word7)+-> Type:+-> +-> Kf4c946334a7e:+-> Word7+-> +-> Environment:+-> +-> Kf4c946334a7e:+->  Word7 ≡   V0+->          | V1+->          | V2+->          | V3+->          | V4+-> ...+->          | V123+->          | V124+->          | V125+->          | V126+->          | V127+```+++A `Word32` can be defined as a `NonEmptyList` list of `Word7`s (a definition equivalent to the [Base 128 Varints encoding](https://developers.google.com/protocol-buffers/docs/encoding#varints)).++```haskell+prt $ absTypeModel (Proxy :: Proxy Word32)+-> Type:+-> +-> K2412799c99f1:+-> Word32+-> +-> Environment:+-> +-> K20ffacc8f8c9:+->  LeastSignificantFirst a ≡ LeastSignificantFirst a+-> +-> K74e2b3b89941:+->  MostSignificantFirst a ≡ MostSignificantFirst a+-> +-> Kbf2d1c86eb20:+->  NonEmptyList a ≡   Elem a+->                   | Cons a (NonEmptyList a)+-> +-> Kf92e8339908a:+->  Word ≡ Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))+-> +-> K2412799c99f1:+->  Word32 ≡ Word32 Word+-> +-> Kf4c946334a7e:+->  Word7 ≡   V0+->          | V1+->          | V2+->          | V3+->          | V4+-> ...+->          | V123+->          | V124+->          | V125+->          | V126+->          | V127+```+++And finally a `Char` can be defined as a tagged `Word32`:++```haskell+prt $ absTypeModel (Proxy :: Proxy Char)+-> Type:+-> +-> K066db52af145:+-> Char+-> +-> Environment:+-> +-> K066db52af145:+->  Char ≡ Char Word32+-> +-> K20ffacc8f8c9:+->  LeastSignificantFirst a ≡ LeastSignificantFirst a+-> +-> K74e2b3b89941:+->  MostSignificantFirst a ≡ MostSignificantFirst a+-> +-> Kbf2d1c86eb20:+->  NonEmptyList a ≡   Elem a+->                   | Cons a (NonEmptyList a)+-> +-> Kf92e8339908a:+->  Word ≡ Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))+-> +-> K2412799c99f1:+->  Word32 ≡ Word32 Word+-> +-> Kf4c946334a7e:+->  Word7 ≡   V0+->          | V1+->          | V2+->          | V3+->          | V4+-> ...+->          | V123+->          | V124+->          | V125+->          | V126+->          | V127+```+++Most common haskell data types can be automatically mapped to the equivalent canonical data type.++There are however a couple of restrictions: data types definitions cannot be mutually recursive and type variables must be of kind *.++So for example, these won't work:++```haskell+-- BAD: f has higher kind+data Free f a = Impure (f (Free f a)) | Pure a++-- BAD: mutually recursive+data Forest a = Nil | Cons (Tree a) (Forest a)+data Tree a = Empty | Node a (Forest a)+```++So now that we have canonical types, what about some practical applications?++#### Safe Deserialisation++To illustrate the problem, consider the two following data types:++The [Cinque Terre](https://en.wikipedia.org/wiki/Cinque_Terre) villages:++```haskell+data CinqueTerre = Monterosso | Vernazza | Corniglia | Manarola | RioMaggiore deriving (Show,Generic,Flat,Model)+```++The traditional Chinese directions:++```haskell+data Direction = North | South | Center | East | West deriving (Show,Generic,Flat,Model)+```++Though their meaning is obviously different they share the same syntactical structure (simple enumerations of 5 values) and most binary serialisation libraries won't be able to distinguish between the two.++To demonstrate this, let's serialise `Center` and `Corniglia`, the third value of each enumeration using the `flat` library.++```haskell+pPrint $ flat Center+-> [ 129 ]+```+++```haskell+pPrint $ flat Corniglia+-> [ 129 ]+```+++As you can see they have the same binary representation.++We have used the `flat` binary serialisation as it is already a dependency of `zm` (and automatically imported by `ZM`) but the same principle apply to other serialisation libraries (`binary`, `cereal` ..).++Let's go full circle, using `unflat` to decode the value :++```haskell+decoded = unflat . flat+```++```haskell+decoded Center :: Decoded Direction+-> Right Center+```+++One more time:++```haskell+decoded Center :: Decoded CinqueTerre+-> Right Corniglia+```+++Oops, that's not quite right.++We got our types crossed, `Center` was read back as `Corniglia`, a `Direction` was interpreted as one of the `CinqueTerre`.++To fix this, we convert the value to a `TypedValue`, a value combined with its canonical type:++```haskell+pPrint $ typedValue Center+-> Center :: K170d0e47bef6+```+++TypedValues can be serialised as any other value:++```haskell+pPrint <$> (decoded $ typedValue Center :: Decoded (TypedValue Direction))+-> Right Center :: K170d0e47bef6+```+++And just as before, we can get things wrong:++```haskell+pPrint <$> (decoded $ typedValue Center :: Decoded (TypedValue CinqueTerre))+-> Right Corniglia :: K170d0e47bef6+```+++However this time is obvious that the value is inconsistent with its type, as the `CinqueTerre` data type has a different unique code:++```haskell+pPrint $ absTypeModel (Proxy :: Proxy CinqueTerre)+-> Type:+-> +-> K747ebaa65778:+-> CinqueTerre+-> +-> Environment:+-> +-> K747ebaa65778:+->  CinqueTerre ≡   Monterosso+->                | Vernazza+->                | Corniglia+->                | Manarola+->                | RioMaggiore+```+++We can automate this check, with `untypedValue`:++This is ok:++```haskell+untypedValue . decoded . typedValue $ Center :: TypedDecoded Direction+-> Right Center+```+++And this is wrong:++```haskell+untypedValue . decoded . typedValue $ Center :: TypedDecoded CinqueTerre+-> Left+->   WrongType+->     { expectedType =+->         TypeCon (AbsRef (SHAKE128_48 116 126 186 166 87 120))+->     , actualType = TypeCon (AbsRef (SHAKE128_48 23 13 14 71 190 246))+->     }+```+++### Data Exchange++For an example of using canonical data types as a data exchange mechanism see [top](https://github.com/tittoassini/top), the Type Oriented Protocol.++<!--+### Long Term Data Preservation++For an example of using canonical data types as a long term data preservation mechanism see [timeless](https://github.com/tittoassini/timeless).++Inspect the data to figure out its type dynamically++So far so good but what if we lose the definitions of our data types?++Two ways:+-- save the full canonical definition of the data with the data itself or+-- save the def in the cloud so that it can be shared++Better save them for posterity:++sv = saveTypeIn theCloud (Couple One Tre)++The type has been saved, with all its dependencies.+TypeApp (TypeApp (TypeCon (CRC16 91 93)) (TypeCon (CRC16 79 130))) (TypeCon (CRC16 65 167))++Now that they are safe in the Cloud we can happily burn our code+in the knowledge that when we are presented with a binary of unknown type+we can always recover the full definition of our data.++PUT BACK dt = e2 >>= recoverTypeFrom theCloud+What if we have no idea of what is the type++instance (Flat a , Flat b) => Flat (CoupleB a b)++t = ed False >> ed Tre >> ed (Couple (CoupleB True Uno One) Three)+ed = pp . unflatDynamically . flat . typedValue++We can now use it to define a hard-wired decoder++Or use a dynamic decder to directly show the value.++The final system will also keep track of the documentation that comes with the types to give you a fully human understandable description of the data.+-->++### Haskell Compatibility++Tested with:+  * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1 and 8.0.2 (x64)+  * [ghcjs](https://github.com/ghcjs/ghcjs)++### Installation++ Get the latest stable version from [hackage](https://hackage.haskell.org/package/zm).++### Acknowledgements+ Contains the following JavaScript library:++ js-sha3 v0.5.1 https://github.com/emn178/js-sha3++ Copyright 2015, emn178@gmail.com++ Licensed under the MIT license:http://www.opensource.org/licenses/MIT++### Known Bugs and Infelicities++* The unique codes generated for the data types are not yet final and might change in the final version.+* Instances for parametric data types have to be declared separately (won't work in `deriving`)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jsbits/sha3.js view
@@ -0,0 +1,473 @@+/*+ * js-sha3 v0.5.1+ * https://github.com/emn178/js-sha3+ *+ * Copyright 2015, emn178@gmail.com+ *+ * Licensed under the MIT license:+ * http://www.opensource.org/licenses/MIT+ */+;(function(root, undefined) {+  'use strict';++  var NODE_JS = typeof(module) != 'undefined';+  if(NODE_JS) {+    root = global;+    if(root.JS_SHA3_TEST) {+      root.navigator = { userAgent: 'Chrome'};+    }+  }+  var HEX_CHARS = '0123456789abcdef'.split('');+  var SHAKE_PADDING = [31, 7936, 2031616, 520093696];+  var KECCAK_PADDING = [1, 256, 65536, 16777216];+  var PADDING = [6, 1536, 393216, 100663296];+  var SHIFT = [0, 8, 16, 24];+  var RC = [1, 0, 32898, 0, 32906, 2147483648, 2147516416, 2147483648, 32907, 0, 2147483649,+            0, 2147516545, 2147483648, 32777, 2147483648, 138, 0, 136, 0, 2147516425, 0, +            2147483658, 0, 2147516555, 0, 139, 2147483648, 32905, 2147483648, 32771, +            2147483648, 32770, 2147483648, 128, 2147483648, 32778, 0, 2147483658, 2147483648,+            2147516545, 2147483648, 32896, 2147483648, 2147483649, 0, 2147516424, 2147483648];+  var BITS = [224, 256, 384, 512];+  var SHAKE_BITS = [128, 256];+  var OUTPUT_TYPES = ['hex', 'buffer', 'array'];++  var createOutputMethod = function(bits, padding, outputType) {+    return function(message) {+      return new Keccak(bits, padding, bits).update(message)[outputType]();+    }+  };++  var createShakeOutputMethod = function(bits, padding, outputType) {+    return function(message, outputBits) {+      return new Keccak(bits, padding, outputBits).update(message)[outputType]();+    }+  };++  var createMethod = function(bits, padding) {+    var method = createOutputMethod(bits, padding, 'hex');+    method.create = function() {+      return new Keccak(bits, padding, bits);+    };+    method.update = function(message) {+      return method.create().update(message);+    };+    for(var i = 0;i < OUTPUT_TYPES.length;++i) {+      var type = OUTPUT_TYPES[i];+      method[type] = createOutputMethod(bits, padding, type);+    }+    return method;+  };++  var createShakeMethod = function(bits, padding) {+    var method = createShakeOutputMethod(bits, padding, 'hex');+    method.create = function(outputBits) {+      return new Keccak(bits, padding, outputBits);+    };+    method.update = function(message, outputBits) {+      return method.create(outputBits).update(message);+    };+    for(var i = 0;i < OUTPUT_TYPES.length;++i) {+      var type = OUTPUT_TYPES[i];+      method[type] = createShakeOutputMethod(bits, padding, type);+    }+    return method;+  };++  var algorithms = [+    {name: 'keccak', padding: KECCAK_PADDING, bits: BITS, createMethod: createMethod},+    {name: 'sha3', padding: PADDING, bits: BITS, createMethod: createMethod},+    {name: 'shake', padding: SHAKE_PADDING, bits: SHAKE_BITS, createMethod: createShakeMethod}+  ];++  var methods = {};++  for(var i = 0;i < algorithms.length;++i) {+    var algorithm = algorithms[i];+    var bits  = algorithm.bits;+    var createMethod = algorithm.createMethod;+    for(var j = 0;j < bits.length;++j) {+      var method = algorithm.createMethod(bits[j], algorithm.padding);+      methods[algorithm.name +'_' + bits[j]] = method;+    }+  }++  function Keccak(bits, padding, outputBits) {+    this.blocks = [];+    this.s = [];+    this.padding = padding;+    this.outputBits = outputBits;+    this.reset = true;+    this.block = 0;+    this.start = 0;+    this.blockCount = (1600 - (bits << 1)) >> 5;+    this.byteCount = this.blockCount << 2;+    this.outputBlocks = outputBits >> 5;+    this.extraBytes = (outputBits & 31) >> 3;++    for(var i = 0;i < 50;++i) {+      this.s[i] = 0;+    }+  };++  Keccak.prototype.update = function(message) {+    var notString = typeof(message) != 'string';+    if(notString && message.constructor == root.ArrayBuffer) {+      message = new Uint8Array(message);+    }+    var length = message.length, blocks = this.blocks, byteCount = this.byteCount, +        blockCount = this.blockCount, index = 0, s = this.s, i, code;+    +    while(index < length) {+      if(this.reset) {+        this.reset = false;+        blocks[0] = this.block;+        for(i = 1;i < blockCount + 1;++i) {+          blocks[i] = 0;+        }+      }+      if(notString) {+        for (i = this.start;index < length && i < byteCount; ++index) {+          blocks[i >> 2] |= message[index] << SHIFT[i++ & 3];+        }+      } else {+        for (i = this.start;index < length && i < byteCount; ++index) {+          code = message.charCodeAt(index);+          if (code < 0x80) {+            blocks[i >> 2] |= code << SHIFT[i++ & 3];+          } else if (code < 0x800) {+            blocks[i >> 2] |= (0xc0 | (code >> 6)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | (code & 0x3f)) << SHIFT[i++ & 3];+          } else if (code < 0xd800 || code >= 0xe000) {+            blocks[i >> 2] |= (0xe0 | (code >> 12)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | ((code >> 6) & 0x3f)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | (code & 0x3f)) << SHIFT[i++ & 3];+          } else {+            code = 0x10000 + (((code & 0x3ff) << 10) | (message.charCodeAt(++index) & 0x3ff));+            blocks[i >> 2] |= (0xf0 | (code >> 18)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | ((code >> 12) & 0x3f)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | ((code >> 6) & 0x3f)) << SHIFT[i++ & 3];+            blocks[i >> 2] |= (0x80 | (code & 0x3f)) << SHIFT[i++ & 3];+          }+        }+      }+      this.lastByteIndex = i;+      if(i >= byteCount) {+        this.start = i - byteCount;+        this.block = blocks[blockCount];+        for(i = 0;i < blockCount;++i) {+          s[i] ^= blocks[i];+        }+        f(s);+        this.reset = true;+      } else {+        this.start = i;+      }+    }+    return this;+  };++  Keccak.prototype.finalize = function() {+    var blocks = this.blocks, i = this.lastByteIndex, blockCount = this.blockCount, s = this.s;+    blocks[i >> 2] |= this.padding[i & 3];+    if(this.lastByteIndex == this.byteCount) {+      blocks[0] = blocks[blockCount];+      for(i = 1;i < blockCount + 1;++i) {+        blocks[i] = 0;+      }+    }+    blocks[blockCount - 1] |= 0x80000000;+    for(i = 0;i < blockCount;++i) {+      s[i] ^= blocks[i];+    }+    f(s);+  };++  Keccak.prototype.toString = Keccak.prototype.hex = function() {+    this.finalize();++    var blockCount = this.blockCount, s = this.s, outputBlocks = this.outputBlocks, +        extraBytes = this.extraBytes, i = 0, j = 0;+    var hex = '', block;+    while(j < outputBlocks) {+      for(i = 0;i < blockCount && j < outputBlocks;++i, ++j) {+        block = s[i];+        hex += HEX_CHARS[(block >> 4) & 0x0F] + HEX_CHARS[block & 0x0F] ++               HEX_CHARS[(block >> 12) & 0x0F] + HEX_CHARS[(block >> 8) & 0x0F] ++               HEX_CHARS[(block >> 20) & 0x0F] + HEX_CHARS[(block >> 16) & 0x0F] ++               HEX_CHARS[(block >> 28) & 0x0F] + HEX_CHARS[(block >> 24) & 0x0F];+      }+      if(j % blockCount == 0) {+        f(s);+      }+    }+    if(extraBytes) {+      block = s[i];+      if(extraBytes > 0) {+        hex += HEX_CHARS[(block >> 4) & 0x0F] + HEX_CHARS[block & 0x0F];+      }+      if(extraBytes > 1) {+        hex += HEX_CHARS[(block >> 12) & 0x0F] + HEX_CHARS[(block >> 8) & 0x0F];+      }+      if(extraBytes > 2) {+        hex += HEX_CHARS[(block >> 20) & 0x0F] + HEX_CHARS[(block >> 16) & 0x0F];+      }+    }+    return hex;+  };++  Keccak.prototype.buffer = function() {+    this.finalize();++    var blockCount = this.blockCount, s = this.s, outputBlocks = this.outputBlocks, +        extraBytes = this.extraBytes, i = 0, j = 0;+    var bytes = this.outputBits >> 3;+    var buffer;+    if(extraBytes) {+      buffer = new ArrayBuffer((outputBlocks + 1) << 2);+    } else {+      buffer = new ArrayBuffer(bytes);+    }+    var array = new Uint32Array(buffer);+    while(j < outputBlocks) {+      for(i = 0;i < blockCount && j < outputBlocks;++i, ++j) {+        array[j] = s[i];+      }+      if(j % blockCount == 0) {+        f(s);+      }+    }+    if(extraBytes) {+      array[i] = s[i];+      buffer = buffer.slice(0, bytes);+    }+    return buffer;+  };++  Keccak.prototype.digest = Keccak.prototype.array = function() {+    this.finalize();++    var blockCount = this.blockCount, s = this.s, outputBlocks = this.outputBlocks, +        extraBytes = this.extraBytes, i = 0, j = 0;+    var array = [], offset, block;+    while(j < outputBlocks) {+      for(i = 0;i < blockCount && j < outputBlocks;++i, ++j) {+        offset = j << 2;+        block = s[i];+        array[offset] = block & 0xFF;+        array[offset + 1] = (block >> 8) & 0xFF;+        array[offset + 2] = (block >> 16) & 0xFF;+        array[offset + 3] = (block >> 24) & 0xFF;+      }+      if(j % blockCount == 0) {+        f(s);+      }+    }+    if(extraBytes) {+      offset = j << 2;+      block = s[i];+      if(extraBytes > 0) {+        array[offset] = block & 0xFF;+      }+      if(extraBytes > 1) {+        array[offset + 1] = (block >> 8) & 0xFF;+      }+      if(extraBytes > 2) {+        array[offset + 2] = (block >> 16) & 0xFF;+      }+    }+    return array;+  };++  var f = function(s) {+    var h, l, n, c0, c1, c2, c3, c4, c5, c6, c7, c8, c9, +        b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, +        b18, b19, b20, b21, b22, b23, b24, b25, b26, b27, b28, b29, b30, b31, b32, b33, +        b34, b35, b36, b37, b38, b39, b40, b41, b42, b43, b44, b45, b46, b47, b48, b49;+    for(n = 0; n < 48; n += 2) {+      c0 = s[0] ^ s[10] ^ s[20] ^ s[30] ^ s[40];+      c1 = s[1] ^ s[11] ^ s[21] ^ s[31] ^ s[41];+      c2 = s[2] ^ s[12] ^ s[22] ^ s[32] ^ s[42];+      c3 = s[3] ^ s[13] ^ s[23] ^ s[33] ^ s[43];+      c4 = s[4] ^ s[14] ^ s[24] ^ s[34] ^ s[44];+      c5 = s[5] ^ s[15] ^ s[25] ^ s[35] ^ s[45];+      c6 = s[6] ^ s[16] ^ s[26] ^ s[36] ^ s[46];+      c7 = s[7] ^ s[17] ^ s[27] ^ s[37] ^ s[47];+      c8 = s[8] ^ s[18] ^ s[28] ^ s[38] ^ s[48];+      c9 = s[9] ^ s[19] ^ s[29] ^ s[39] ^ s[49];++      h = c8 ^ ((c2 << 1) | (c3 >>> 31));+      l = c9 ^ ((c3 << 1) | (c2 >>> 31));+      s[0] ^= h;+      s[1] ^= l;+      s[10] ^= h;+      s[11] ^= l;+      s[20] ^= h;+      s[21] ^= l;+      s[30] ^= h;+      s[31] ^= l;+      s[40] ^= h;+      s[41] ^= l;+      h = c0 ^ ((c4 << 1) | (c5 >>> 31));+      l = c1 ^ ((c5 << 1) | (c4 >>> 31));+      s[2] ^= h;+      s[3] ^= l;+      s[12] ^= h;+      s[13] ^= l;+      s[22] ^= h;+      s[23] ^= l;+      s[32] ^= h;+      s[33] ^= l;+      s[42] ^= h;+      s[43] ^= l;+      h = c2 ^ ((c6 << 1) | (c7 >>> 31));+      l = c3 ^ ((c7 << 1) | (c6 >>> 31));+      s[4] ^= h;+      s[5] ^= l;+      s[14] ^= h;+      s[15] ^= l;+      s[24] ^= h;+      s[25] ^= l;+      s[34] ^= h;+      s[35] ^= l;+      s[44] ^= h;+      s[45] ^= l;+      h = c4 ^ ((c8 << 1) | (c9 >>> 31));+      l = c5 ^ ((c9 << 1) | (c8 >>> 31));+      s[6] ^= h;+      s[7] ^= l;+      s[16] ^= h;+      s[17] ^= l;+      s[26] ^= h;+      s[27] ^= l;+      s[36] ^= h;+      s[37] ^= l;+      s[46] ^= h;+      s[47] ^= l;+      h = c6 ^ ((c0 << 1) | (c1 >>> 31));+      l = c7 ^ ((c1 << 1) | (c0 >>> 31));+      s[8] ^= h;+      s[9] ^= l;+      s[18] ^= h;+      s[19] ^= l;+      s[28] ^= h;+      s[29] ^= l;+      s[38] ^= h;+      s[39] ^= l;+      s[48] ^= h;+      s[49] ^= l;++      b0 = s[0];+      b1 = s[1];+      b32 = (s[11] << 4) | (s[10] >>> 28);+      b33 = (s[10] << 4) | (s[11] >>> 28);+      b14 = (s[20] << 3) | (s[21] >>> 29);+      b15 = (s[21] << 3) | (s[20] >>> 29);+      b46 = (s[31] << 9) | (s[30] >>> 23);+      b47 = (s[30] << 9) | (s[31] >>> 23);+      b28 = (s[40] << 18) | (s[41] >>> 14);+      b29 = (s[41] << 18) | (s[40] >>> 14);+      b20 = (s[2] << 1) | (s[3] >>> 31);+      b21 = (s[3] << 1) | (s[2] >>> 31);+      b2 = (s[13] << 12) | (s[12] >>> 20);+      b3 = (s[12] << 12) | (s[13] >>> 20);+      b34 = (s[22] << 10) | (s[23] >>> 22);+      b35 = (s[23] << 10) | (s[22] >>> 22);+      b16 = (s[33] << 13) | (s[32] >>> 19);+      b17 = (s[32] << 13) | (s[33] >>> 19);+      b48 = (s[42] << 2) | (s[43] >>> 30);+      b49 = (s[43] << 2) | (s[42] >>> 30);+      b40 = (s[5] << 30) | (s[4] >>> 2);+      b41 = (s[4] << 30) | (s[5] >>> 2);+      b22 = (s[14] << 6) | (s[15] >>> 26);+      b23 = (s[15] << 6) | (s[14] >>> 26);+      b4 = (s[25] << 11) | (s[24] >>> 21);+      b5 = (s[24] << 11) | (s[25] >>> 21);+      b36 = (s[34] << 15) | (s[35] >>> 17);+      b37 = (s[35] << 15) | (s[34] >>> 17);+      b18 = (s[45] << 29) | (s[44] >>> 3);+      b19 = (s[44] << 29) | (s[45] >>> 3);+      b10 = (s[6] << 28) | (s[7] >>> 4);+      b11 = (s[7] << 28) | (s[6] >>> 4);+      b42 = (s[17] << 23) | (s[16] >>> 9);+      b43 = (s[16] << 23) | (s[17] >>> 9);+      b24 = (s[26] << 25) | (s[27] >>> 7);+      b25 = (s[27] << 25) | (s[26] >>> 7);+      b6 = (s[36] << 21) | (s[37] >>> 11);+      b7 = (s[37] << 21) | (s[36] >>> 11);+      b38 = (s[47] << 24) | (s[46] >>> 8);+      b39 = (s[46] << 24) | (s[47] >>> 8);+      b30 = (s[8] << 27) | (s[9] >>> 5);+      b31 = (s[9] << 27) | (s[8] >>> 5);+      b12 = (s[18] << 20) | (s[19] >>> 12);+      b13 = (s[19] << 20) | (s[18] >>> 12);+      b44 = (s[29] << 7) | (s[28] >>> 25);+      b45 = (s[28] << 7) | (s[29] >>> 25);+      b26 = (s[38] << 8) | (s[39] >>> 24);+      b27 = (s[39] << 8) | (s[38] >>> 24);+      b8 = (s[48] << 14) | (s[49] >>> 18);+      b9 = (s[49] << 14) | (s[48] >>> 18);++      s[0] = b0 ^ (~b2 & b4);+      s[1] = b1 ^ (~b3 & b5);+      s[10] = b10 ^ (~b12 & b14);+      s[11] = b11 ^ (~b13 & b15);+      s[20] = b20 ^ (~b22 & b24);+      s[21] = b21 ^ (~b23 & b25);+      s[30] = b30 ^ (~b32 & b34);+      s[31] = b31 ^ (~b33 & b35);+      s[40] = b40 ^ (~b42 & b44);+      s[41] = b41 ^ (~b43 & b45);+      s[2] = b2 ^ (~b4 & b6);+      s[3] = b3 ^ (~b5 & b7);+      s[12] = b12 ^ (~b14 & b16);+      s[13] = b13 ^ (~b15 & b17);+      s[22] = b22 ^ (~b24 & b26);+      s[23] = b23 ^ (~b25 & b27);+      s[32] = b32 ^ (~b34 & b36);+      s[33] = b33 ^ (~b35 & b37);+      s[42] = b42 ^ (~b44 & b46);+      s[43] = b43 ^ (~b45 & b47);+      s[4] = b4 ^ (~b6 & b8);+      s[5] = b5 ^ (~b7 & b9);+      s[14] = b14 ^ (~b16 & b18);+      s[15] = b15 ^ (~b17 & b19);+      s[24] = b24 ^ (~b26 & b28);+      s[25] = b25 ^ (~b27 & b29);+      s[34] = b34 ^ (~b36 & b38);+      s[35] = b35 ^ (~b37 & b39);+      s[44] = b44 ^ (~b46 & b48);+      s[45] = b45 ^ (~b47 & b49);+      s[6] = b6 ^ (~b8 & b0);+      s[7] = b7 ^ (~b9 & b1);+      s[16] = b16 ^ (~b18 & b10);+      s[17] = b17 ^ (~b19 & b11);+      s[26] = b26 ^ (~b28 & b20);+      s[27] = b27 ^ (~b29 & b21);+      s[36] = b36 ^ (~b38 & b30);+      s[37] = b37 ^ (~b39 & b31);+      s[46] = b46 ^ (~b48 & b40);+      s[47] = b47 ^ (~b49 & b41);+      s[8] = b8 ^ (~b0 & b2);+      s[9] = b9 ^ (~b1 & b3);+      s[18] = b18 ^ (~b10 & b12);+      s[19] = b19 ^ (~b11 & b13);+      s[28] = b28 ^ (~b20 & b22);+      s[29] = b29 ^ (~b21 & b23);+      s[38] = b38 ^ (~b30 & b32);+      s[39] = b39 ^ (~b31 & b33);+      s[48] = b48 ^ (~b40 & b42);+      s[49] = b49 ^ (~b41 & b43);++      s[0] ^= RC[n];+      s[1] ^= RC[n + 1];+    }+  }++  if(!root.JS_SHA3_TEST && NODE_JS) {+    module.exports = methods;+  } else if(root) {+    for(var key in methods) {+      root[key] = methods[key];+    }+  }+}(this));
+ src/Data/Digest/Keccak.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI            #-}+{-# LANGUAGE PackageImports           #-}++-- |Crypto algorithms of the Keccak family (SHA3/SHAKE), with support for GHCJS.+module Data.Digest.Keccak (sha3_256, shake_128) where++import qualified Data.ByteString         as B++#ifdef ghcjs_HOST_OS+import           GHCJS.Marshal+import           GHCJS.Types+import           System.IO.Unsafe++#else++import qualified "cryptonite" Crypto.Hash             as S+import qualified Data.ByteArray          as S+#endif++-- |Return the specified number of bytes of the SHAKE-128 hash of the provided byte string+shake_128 :: Int -> B.ByteString -> B.ByteString+shake_128 numBytes bs | numBytes <=0 || numBytes > 32 = error "shake128: Invalid number of bytes"+                      | otherwise = shake_128_ numBytes bs++-- |Return the specified number of bytes of the SHA-3 hash of the provided byte string+sha3_256 :: Int -> B.ByteString -> B.ByteString+sha3_256 numBytes bs | numBytes <=0 || numBytes > 32 = error "sha3_256: Invalid number of bytes"+                     | otherwise = sha3_256_ numBytes bs++#ifdef ghcjs_HOST_OS++-- CHECK: is it necessary to pack/unpack the ByteStrings?+shake_128_ :: Int -> B.ByteString -> B.ByteString+shake_128_ numBytes = stat (js_shake128 $ numBytes*8) numBytes -- 256)++sha3_256_ :: Int -> B.ByteString -> B.ByteString+sha3_256_ = stat js_sha3_256++stat f n bs = unsafePerformIO $ do+   jbs <- toJSVal $ B.unpack $ bs+   Just bs' <- fromJSVal $ f jbs+   return . B.take n . B.pack $ bs'++-- PROB: these references will be scrambled by the `closure` compiler, as they are not static functions but are setup dynamically by the sha3.hs library+foreign import javascript unsafe "shake_128.array($2, $1)" js_shake128 :: Int -> JSVal -> JSVal++foreign import javascript unsafe "sha3_224.array($1)" js_sha3_224 :: JSVal -> JSVal++foreign import javascript unsafe "sha3_256.array($1)" js_sha3_256 :: JSVal -> JSVal++foreign import javascript unsafe "keccak_256.array($1)" js_keccak256 :: JSVal -> JSVal+-- foreign import javascript unsafe "(window == undefined ? global : window)['keccak_256']['array']($1)" js_keccak256 :: JSVal -> JSVal++#else++shake_128_ :: Int -> B.ByteString -> B.ByteString+shake_128_ = stat (S.SHAKE128 :: S.SHAKE128 256)++sha3_256_ :: Int -> B.ByteString -> B.ByteString+sha3_256_ = stat S.SHA3_256++stat+  :: (S.ByteArrayAccess ba, S.HashAlgorithm alg) =>+     alg -> Int -> ba -> B.ByteString+stat f numBytes = B.take numBytes . S.convert . S.hashWith f++#endif
+ src/ZM.hs view
@@ -0,0 +1,20 @@+module ZM(+  -- |Check the <https://github.com/tittoassini/typed tutorial and github repo>.+  module X+  --,module Data.Model+  --,module ZM.BLOB+  ) where++import           Data.Flat               as X+import           Data.Model              as X hiding (Name)+import           ZM.Abs          as X+import           ZM.BLOB         as X hiding (content)+--import           ZM.Class     as X+import           ZM.Dynamic      as X+import           ZM.Model        ()+import           ZM.Pretty       as X+import           ZM.Pretty.Value ()+import           ZM.Transform    as X+import           ZM.Types        as X++
+ src/ZM/Abs.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PackageImports            #-}+{-# LANGUAGE ScopedTypeVariables       #-}++-- |Derive absolute/canonical data type models+module ZM.Abs (absType,absTypeModel,absTypeModelMaybe) where++import           "mtl" Control.Monad.Reader+import qualified Data.ListLike.String as L+import qualified Data.Map             as M+import           Data.Model+import           ZM.Types++-- |Derive an absolute type for a type, or throw an error if derivation is impossible+absType :: Model a => Proxy a -> AbsType+absType = typeName . absTypeModel++-- |Derive an absolute type model for a type, or throw an error if derivation is impossible+absTypeModel :: Model a => Proxy a -> AbsTypeModel+absTypeModel = either error id . absTypeModelMaybe++{- |+Derive an absolute type model for a type, provided that:++* is an instance of Model+* no data type referred directly or indirectly by the type:++    * has higher kind variables+    * is mutually recursive with other data types+-}+absTypeModelMaybe :: Model a => Proxy a -> Either String AbsTypeModel+absTypeModelMaybe a =+  let (TypeModel t henv) = typeModel a+      names = M.keys henv++      -- TODO: Check for higher kind variables (currently not required as they cannot be present due to limitations in the 'model' library)++      -- Check for forbidden mutual references+      errs = filter ((> 1) . length) $ mutualGroups getHRef henv+  in if null errs+       then+       -- convert environment and type to absolute form+       let adtEnv :: [(AbsRef, AbsADT)]+           adtEnv = runReader (mapM absADT names) henv++           qnEnv :: M.Map QualName AbsRef+           qnEnv = M.fromList $ zip names (map fst adtEnv)+       in Right (TypeModel (solveAll qnEnv t) (M.fromList adtEnv))+       else Left .+            unlines+            . map (\ms -> unwords ["Found mutually recursive types", unwords . map prettyShow $ ms]) $ errs++absADT :: QualName -> Reader HTypeEnv (AbsRef, AbsADT)+absADT qn = do+     hadt <- solve qn <$> ask+     cs' <- mapM (mapM (adtRef qn)) $ declCons hadt++     let adt :: AbsADT = adtNamesMap L.fromString L.fromString $ ADT (declName hadt) (declNumParameters hadt) cs'+     return (absRef adt,adt)++adtRef :: QualName -> HTypeRef -> Reader HTypeEnv (ADTRef AbsRef)+adtRef _ (TypVar v) = return $ Var v++adtRef me (TypRef qn) =+     if me == qn+       then return Rec+       else Ext . fst <$> absADT qn
+ src/ZM/BLOB.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+module ZM.BLOB (+    BLOB(..),+    blob,+    unblob,+    TypedBLOB(..),+    typedBLOB,+    typedBLOB_,+    untypedBLOB,+    TypedValue(..),+    typedValue,+    untypedValue,+    typeErr,+    ) where++import           Control.DeepSeq+import           Data.Bifunctor+import qualified Data.ByteString         as B+import           Data.ByteString.Convert+import           Data.Flat+import           Data.Model+import           ZM.Abs+import           ZM.Model        ()+import qualified ZM.Type.BLOB    as Z+import           ZM.Types+import           ZM.Util++-- |A BLOB is binary value encoded according to a specified encoding (e.g. UTF8)+data BLOB encoding = BLOB {encoding::encoding,content::B.ByteString}+  deriving (Eq, Ord, NFData, Generic, Flat)++instance Model encoding => Model (BLOB encoding)++instance Show encoding => Show (BLOB encoding) where show (BLOB enc bs) = unwords ["BLOB",show enc,show $ B.unpack bs]++-- |Extract the binary content of a BLOB+unblob :: BLOB t -> B.ByteString+--unblob (BLOB _ bs) = bs+unblob = content++-- |Build a BLOB from an encoding and a ByteString-like value+blob :: AsByteString a => encoding -> a -> BLOB encoding+blob enc = BLOB enc . toByteString++-- |A typed value, a Flat encoded value and its absolute type+data TypedBLOB = TypedBLOB AbsType (BLOB Z.FlatEncoding)+  deriving (Eq, Ord, Show, NFData, Generic, Flat, Model)++-- |Build a TypedBLOB out of a value+typedBLOB :: forall a . (Model a,Flat a) => a -> TypedBLOB+typedBLOB = typedBLOB_ (absType (Proxy :: Proxy a))++-- |Build a TypedBLOB out of a type and a value+typedBLOB_ :: Flat a => AbsType -> a -> TypedBLOB+typedBLOB_ t v = TypedBLOB t (blob Z.FlatEncoding . flat $ v)++-- |A typed value, a value and its absolute type+data TypedValue a = TypedValue AbsType a deriving (Eq, Ord, Show, Functor,NFData,  Generic, Flat)++-- |Build a TypedValue out of a value+typedValue :: forall a . Model a => a -> TypedValue a+typedValue = TypedValue (absType (Proxy :: Proxy a))++-- |Type-checked extraction of a value of a known type from a decoded TypedBLOB+untypedBLOB ::  forall a.  (Flat a, Model a) => Decoded TypedBLOB -> TypedDecoded a+untypedBLOB ea = case ea of+                    Left e -> Left . DecodeError $ e+                    Right (TypedBLOB typ' bs) ->+                      let typ = absType (Proxy :: Proxy a)+                      in if typ' /= typ+                         then typeErr typ typ'+                         else first DecodeError . unflat $ (unblob bs :: B.ByteString)++-- |Type-checked extraction of a value of a known type from a decoded TypedValue+untypedValue ::  Model a => Decoded (TypedValue a) -> TypedDecoded a+untypedValue ea = case ea of+                    Left e -> Left . DecodeError $ e+                    Right (TypedValue typ' a) ->+                      let typ = absType (proxyOf a)+                      in if typ' /= typ+                         then typeErr typ typ'+                         else Right a++-- |Return a WrongType error+typeErr :: AbsType -> AbsType -> TypedDecoded a+typeErr typ typ' = Left $ WrongType typ typ'
+ src/ZM/Dynamic.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |Dynamical decoding of serialised typed values+module ZM.Dynamic(+  decodeAbsTypeModel+  ,typeDecoder+  ,typeDecoderMap+  ,MapTypeDecoder+  ) where++import qualified Data.ByteString      as B+import           Data.Flat+import qualified Data.ListLike.String as S+import qualified Data.Map             as M+import           Data.Model+import           ZM.Transform+import           ZM.Types++-- | Decode a Flat encoded value with a known type model to the corresponding Value+decodeAbsTypeModel :: AbsTypeModel -> B.ByteString -> Decoded Value+decodeAbsTypeModel = unflatWith . typeDecoder++-- |Returns a decoder for the type defined by the given model+typeDecoder :: AbsTypeModel -> Get Value+typeDecoder tm = solve (typeName tm) (typeDecoderMap tm)++-- |A mapping between references to absolute types and the corresponding decoder+type MapTypeDecoder = M.Map (Type AbsRef) (Get Value)++-- |Returns decoders for all types in the given model+typeDecoderMap :: AbsTypeModel -> MapTypeDecoder+typeDecoderMap tm =+  let denv = M.mapWithKey (\t ct -> conDecoder denv t [] ct) (typeTree tm)+  in denv++conDecoder :: (S.StringLike name) => MapTypeDecoder -> AbsType -> [Bool] -> ConTree name AbsRef -> Get Value+conDecoder env t bs (ConTree l r) = do+  tag :: Bool <- decode+  conDecoder env t (tag:bs) (if tag then r else l)++conDecoder env t bs (Con cn cs) = Value t (S.toString cn) (reverse bs) <$> mapM (`solve` env) (fieldsTypes cs)++
+ src/ZM/Model.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveFoldable      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |Mapping of basic Haskell types to equivalent ZhengMing types (Char, (), Words, Ints, Floats, Text, Tuples, List, Seq, Map)+module ZM.Model () where++import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as L+import qualified Data.ByteString.Short   as SBS+import           Data.Flat               (UTF16Text, UTF8Text)+import qualified Data.Int                as H+import qualified Data.Map                as M+import           Data.Model+import qualified Data.Sequence           as S+import           Data.Text               (Text)+import           ZM.Type.Array+import qualified ZM.Type.BLOB    as Z+import qualified ZM.Type.Char    as Z+import           ZM.Type.Float32+import           ZM.Type.Float64+import           ZM.Type.List+import qualified ZM.Type.Map     as Z+import           ZM.Type.Tuples+import           ZM.Type.Unit+import qualified ZM.Type.Words   as Z+import qualified Data.Word               as H+import qualified Prelude                 as H+import           Type.Analyse++#include "MachDeps.h"++instance Model H.Char where envType _ = envType (Proxy::Proxy Z.Char)++instance Model () where envType _ = envType (Proxy::Proxy Unit)++-- Signed and Unsigned Whole Numbers++#if WORD_SIZE_IN_BITS == 64+instance Model H.Word where envType _ = envType (Proxy::Proxy Z.Word64)+instance Model H.Int where envType _ = envType (Proxy::Proxy Z.Int64)+#elif WORD_SIZE_IN_BITS == 32+instance Model H.Word where envType _ = envType (Proxy::Proxy Z.Word32)+instance Model H.Int where envType _ = envType (Proxy::Proxy Z.Int32)+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif++instance Model H.Word8 where envType _ = envType (Proxy::Proxy Z.Word8)+instance Model H.Word16 where envType _ = envType (Proxy::Proxy Z.Word16)+instance Model H.Word32 where envType _ = envType (Proxy::Proxy Z.Word32)+instance Model H.Word64 where envType _ = envType (Proxy::Proxy Z.Word64)+instance Model H.Int8 where envType _ = envType (Proxy::Proxy Z.Int8)+instance Model H.Int16 where envType _ = envType (Proxy::Proxy Z.Int16)+instance Model H.Int32 where envType _ = envType (Proxy::Proxy Z.Int32)+instance Model H.Int64 where envType _ = envType (Proxy::Proxy Z.Int64)+instance Model H.Integer where envType _ = envType (Proxy::Proxy Z.Int)++-- Floating-Point Numbers+instance Model H.Float where envType _ = envType (Proxy::Proxy IEEE_754_binary32)+instance Model H.Double where envType _ = envType (Proxy::Proxy IEEE_754_binary64)++-- Data Structures+instance Model a => Model [a] where envType _ = envType (Proxy::Proxy (List a))++instance Model a => Model (S.Seq a) where envType _ = envType (Proxy::Proxy (Array a))++instance (Model a,Model b) => Model (M.Map a b) where envType _ = envType (Proxy::Proxy (Z.Map a b))+-- instance {-# OVERLAPPING #-} (AsType a, AsType b) => AsType (App (App (Typ (Map A0 A1)) a) b) where asType _ = asType (undefined::(App (Typ [A0]) (App (App (Typ (A0, A1)) a) b)))+++-- ByteStrings+instance Model B.ByteString where envType _ = envType (Proxy::Proxy Bytes)+instance Model L.ByteString where envType _ = envType (Proxy::Proxy Bytes)+instance Model SBS.ShortByteString where envType _ = envType (Proxy::Proxy Bytes)++-- Texts++--  NOTE: When the kind of the type for which we define the model does not match that of the type we are mapping to we also need to define an AsType instance+instance Model Text where envType _ = envType (Proxy::Proxy (Z.BLOB Z.UTF8Encoding))+instance {-# OVERLAPPING #-} AsType (Typ Text) where asType _ = asType (H.undefined::Ana (Z.BLOB Z.UTF8Encoding))++instance Model UTF8Text where envType _ = envType (Proxy::Proxy (Z.BLOB Z.UTF8Encoding))+instance {-# OVERLAPPING #-} AsType (Typ UTF8Text) where asType _ = asType (H.undefined::Ana (Z.BLOB Z.UTF8Encoding))++instance Model UTF16Text where envType _ = envType (Proxy::Proxy (Z.BLOB Z.UTF16LEEncoding))+instance {-# OVERLAPPING #-} AsType (Typ UTF16Text) where asType _ = asType (H.undefined::Ana (Z.BLOB Z.UTF16LEEncoding))++-- Tuples+instance (Model a,Model b) => Model (a,b) where envType _ = envType (Proxy::Proxy (Tuple2 a b))++instance (Model a,Model b,Model c) => Model (a,b,c) where envType _ = envType (Proxy::Proxy (Tuple3 a b c))++instance (Model a,Model b,Model c,Model d) => Model (a,b,c,d) where envType _ = envType (Proxy::Proxy (Tuple4 a b c d))++instance (Model a1,Model a2,Model a3,Model a4,Model a5) => Model (a1,a2,a3,a4,a5) where envType _ = envType (Proxy::Proxy (Tuple5 a1 a2 a3 a4 a5))++instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6) => Model (a1,a2,a3,a4,a5,a6) where envType _ = envType (Proxy::Proxy (Tuple6 a1 a2 a3 a4 a5 a6))++instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7) => Model (a1,a2,a3,a4,a5,a6,a7) where envType _ = envType (Proxy::Proxy (Tuple7 a1 a2 a3 a4 a5 a6 a7))++instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7,Model a8) => Model (a1,a2,a3,a4,a5,a6,a7,a8) where envType _ = envType (Proxy::Proxy (Tuple8 a1 a2 a3 a4 a5 a6 a7 a8))++instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7,Model a8,Model a9) => Model (a1,a2,a3,a4,a5,a6,a7,a8,a9) where envType _ = envType (Proxy::Proxy (Tuple9 a1 a2 a3 a4 a5 a6 a7 a8 a9))+
+ src/ZM/Pretty.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+-- |Pretty instances for some basic Haskell types and for data type models+module ZM.Pretty (+    module Data.Model.Pretty,+    hex,+    unPrettyRef,+    prettyList,+    prettyTuple,+    ) where++import qualified Data.ByteString                as B+import qualified Data.ByteString.Lazy           as L+import qualified Data.ByteString.Short          as SBS+import           Data.Flat                      (UTF16Text (..), UTF8Text (..))+import           Data.Foldable                  (toList)+import           Data.Int+import           Data.List+import qualified Data.ListLike.String           as L+import qualified Data.Map                       as M+import           Data.Model.Pretty+import           Data.Ord+import qualified Data.Sequence                  as S+import qualified Data.Text                      as T+import qualified Data.Text.Encoding             as T+import           ZM.BLOB+import           ZM.Model               ()+import           ZM.Transform+import           ZM.Types+import           Data.Word+import           Numeric                        (readHex)+import           Text.ParserCombinators.ReadP   hiding (char)+import           Text.PrettyPrint.HughesPJClass+import           Text.Printf++-- |Convert the textual representation of a hash code to its equivalent value+unPrettyRef :: String -> SHAKE128_48 a+unPrettyRef ('K':code) = let [k1,k2,k3,k4,k5,k6] = readHexCode code in SHAKE128_48 k1 k2 k3 k4 k5 k6+--unPrettyRef :: String -> SHA3_256_6 a+--unPrettyRef ('S':code) = let [k1,k2,k3,k4,k5,k6] = readHexCode code in SHA3_256_6 k1 k2 k3 k4 k5 k6+unPrettyRef code = error $ "unPrettyRef: unknown code " ++ show code++-- |Display a Word in hexadecimal format+hex :: Word8 -> String+hex = printf "%02x"++-- |Display a list of Docs, as a tuple with spaced elements+-- +-- >>> prettyTuple (map pPrint [11,22,33::Word8])+-- (11, 22, 33)+prettyTuple :: [Doc] -> Doc+prettyTuple = parens . fsep . punctuate comma++-- |Display a list of Docs, with spaced elements+-- +-- >>> prettyList (map pPrint [11,22,33::Word8])+-- [11, 22, 33]+prettyList :: [Doc] -> Doc+--prettyList = brackets . hcat . punctuate comma+prettyList = brackets . fsep . punctuate comma++instance Pretty TypedDecodeException where+  pPrint (UnknownMetaModel m) = text "Unknown meta model" <> pPrint m+  pPrint (WrongType e a) = let et  = prettyShow e+                               at = prettyShow a+                           in text . unwords $ ["Was expecting type:\n",et,"\n\nBut the data has type:\n",at]+  pPrint (DecodeError e) = pPrint (show e)++instance Show a => Pretty (TypedValue a) where pPrint (TypedValue t v)= text (show v) <+> text "::" <+> pPrint t++-- TODO: merge with similar code in `model` package+instance Pretty AbsTypeModel where+  pPrint (TypeModel t e) = vspacedP [+    text "Type:"+    ,vcat [pPrint t <> text ":",pPrint (e,t)]+    -- ,vcat [pPrint t <> text ":",pPrint (declName <$> solveAll e t)]+    ,text "Environment:"+    ,pPrint e+    ]++instance {-# OVERLAPS #-} Pretty AbsEnv where+ -- pPrint e = vcat . map (\(h,adt) -> pPrint h <+> text "->" <+> pPrint (e,adt)) $ M.assocs e+ pPrint e = vspacedP . map (\(ref,adt) -> vcat [pPrint ref <> text ":",pPrint . CompactPretty $ (e,adt)]) . sortBy (comparing snd) $ M.assocs e+ --pPrint e = vspacedP . sortBy (comparing snd) . map (\(h,adt) -> (e,adt)) $ M.assocs e++instance {-# OVERLAPS #-} Pretty (AbsEnv,AbsType) where+  pPrint (env,t) = pPrint (declName <$> solveAll env t)++instance {-# OVERLAPS #-} Pretty (AbsEnv,AbsADT) where+  pPrint (env,adt) = pPrint . stringADT env $ adt++instance Pretty Identifier where pPrint = text . L.toString++instance {-# OVERLAPS #-} Pretty a => Pretty (String,ADTRef a) where+   pPrint (_,Var v) = varP v+   pPrint (n,Rec)   = text n+   pPrint (_,Ext r) = pPrint r++instance Pretty a => Pretty (ADTRef a) where+   pPrint (Var v) = varP v+   pPrint Rec     = char '\x21AB'+   pPrint (Ext r) = pPrint r++instance Pretty AbsRef where pPrint (AbsRef sha3) = pPrint sha3++instance Pretty a => Pretty (SHA3_256_6 a) where pPrint (SHA3_256_6 k1 k2 k3 k4 k5 k6) = char 'S' <> prettyWords [k1,k2,k3,k4,k5,k6]++instance Pretty a => Pretty (SHAKE128_48 a) where pPrint (SHAKE128_48 k1 k2 k3 k4 k5 k6) = char 'K' <> prettyWords [k1,k2,k3,k4,k5,k6]++--instance Pretty a => Pretty (SHAKE_256_6 a) where pPrint (SHA3_256_6 k1 k2 k3 k4 k5 k6) = char 'S' <> prettyWords [k1,k2,k3,k4,k5,k6]++prettyWords :: [Word8] -> Doc+prettyWords = text . concatMap hex++readHexCode :: String -> [Word8]+readHexCode = readCode []++readCode :: [Word8] -> String -> [Word8]+readCode bs [] = reverse bs+readCode bs s  = let (h,t) = splitAt 2 s+                  in readCode (rdHex h : bs) t++rdHex :: String -> Word8+rdHex s = let [(b,"")] = readP_to_S (readS_to_P readHex) s in b+-- instance Pretty a => Pretty (Array a) where pPrint (Array vs) = text "Array" <+> pPrint vs+-- instance Pretty a => Pretty (Array a) where pPrint (Array vs) = pPrint vs+instance Pretty a => Pretty (S.Seq a) where pPrint = pPrint . toList++instance Pretty a => Pretty (NonEmptyList a) where pPrint = pPrint . toList++instance (Pretty a,Pretty l) => Pretty (Label a l) where+   pPrint (Label a Nothing)  = pPrint a+   pPrint (Label _ (Just l)) = pPrint l++instance Pretty NoEncoding where pPrint = text . show++instance Pretty encoding => Pretty (BLOB encoding) where pPrint (BLOB enc bs) = text "BLOB" <+> pPrint enc <+> pPrint bs++instance {-# OVERLAPS #-} Pretty (BLOB UTF8Encoding) where pPrint = pPrint . T.decodeUtf8 . unblob++instance {-# OVERLAPS #-} Pretty (BLOB UTF16LEEncoding) where pPrint = pPrint . T.decodeUtf16LE . unblob++instance Pretty T.Text where pPrint = text . T.unpack+instance Pretty UTF8Text where pPrint (UTF8Text t)= pPrint t+instance Pretty UTF16Text where pPrint (UTF16Text t)= pPrint t++instance Pretty Word where pPrint = text . show+instance Pretty Word8 where pPrint = text . show+instance Pretty Word16 where pPrint = text . show+instance Pretty Word32 where pPrint = text . show+instance Pretty Word64 where pPrint = text . show+instance Pretty Int8 where pPrint = text . show+instance Pretty Int16 where pPrint = text . show+instance Pretty Int32 where pPrint = text . show+instance Pretty Int64 where pPrint = text . show++instance Pretty B.ByteString where pPrint = pPrint . B.unpack+instance Pretty L.ByteString where pPrint = pPrint . L.unpack+instance Pretty SBS.ShortByteString where pPrint = pPrint . SBS.unpack++instance (Pretty a,Pretty b) => Pretty (M.Map a b) where pPrint m = text "Map" <+> pPrint (M.assocs m)++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i) => Pretty (a, b, c, d, e, f, g, h, i) where+  pPrintPrec l _ (a, b, c, d, e, f, g, h, i) =+    prettyTuple+      [ pPrint0 l a+      , pPrint0 l b+      , pPrint0 l c+      , pPrint0 l d+      , pPrint0 l e+      , pPrint0 l f+      , pPrint0 l g+      , pPrint0 l h+      , pPrint0 l i+      ]++pPrint0 :: Pretty a => PrettyLevel -> a -> Doc+pPrint0 l = pPrintPrec l 0+
+ src/ZM/Pretty/Value.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE DeriveAnyClass            #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++-- |Pretty Instance for Value (displays a Value as the corresponding Haskell value)+module ZM.Pretty.Value () where++import qualified Data.ByteString                as B+import           Data.Char                      (chr)+import           Data.Flat+import           Data.Int+import           Data.Maybe+import           Data.Model+import qualified Data.Sequence                  as S+import           ZM.Abs+import           ZM.BLOB+import           ZM.Pretty+import           ZM.Type.Array          (Bytes)+import           ZM.Types+import           Data.Word+import           Data.ZigZag+import           Text.PrettyPrint.HughesPJClass+-- import Debug.Trace++default ()++-- |Pretty print a Value as the corresponding Haskell value+instance Pretty Value where+     pPrintPrec (PrettyLevel lev) _ = pp 0+       where -- TODO: fix precedence+         pp :: Int -> Value -> Doc+         pp l v@(Value t n bs vs) =+           let (complex,doc) = case prettyPrinter t of+                 --Nothing -> (False,[text $ "NOT FOUND "++ show t])+                 Nothing -> (not (null vs),text n : map (pp (l+1)) vs)+                 Just pr -> let (c,d) = pr v in (c,[d])++           in (if complex && l>0 then parens else id) (hsep $ (if null bs || lev == 0 then empty else (text (map (\b -> if+ b then '1' else '0') bs) <> char ':')) : doc) -- : if lev == 0 then empty else )++         ch (Value _ _ _ [w]) = chr $ wl_ w+         ch v = error (show v)++         wrd = int . wrd_++         wrd_ (Value _ ('V':n) _ _) = read n :: Int -- Word64?+         wrd_ v                              = error (unwords ["wrd_",show v])++         wrd2_ (Value _ _ _ [Value _ ('V':n) _ _]) = read n :: Int+         wrd2_ v = error (unwords ["wrd2_",show v])++         -- i :: forall a . Proxy a -> (AbsType, Value -> (Bool, Doc))+         -- i p = (absType p,\v -> (False,int . (zzDecode::(Bits a,Integral a) => Word64 -> a) . wl_ . p0 . p0 $ v))++         wl = text . show . (wl_::Value -> Word64)++         wl_ (Value _ _ _ [Value _ _ _ [Value _ _ _ [vl]]]) = fromIntegral . fst . foldl (\(t,e) n -> (t+n*2^e,e+7)) (0::Int,0::Int) . map wrd2_ . neList $ vl++         wl_ v = error (unwords ["wl_",show v])++         valList (Value _ "Cons" _ [h,t]) = h:valList t+         valList (Value _ "Nil"  _ [])    = []+         valList v                      = error (unwords ["valList",show v])++         neList (Value _ "Cons" _ [h,t]) = h:neList t+         neList (Value _ "Elem"  _ [e])  = [e]+         neList v                      = error (unwords ["neList",show v])++         arrList (Value _ "A0" _ []) = []+         arrList (Value _ ('A':n) _ vs) | length vs == read n + 1 = init vs ++ arrList (last vs)++         arr = arr_ (pp 0)+         ar = prettyList_ (pp 0)++         tup = prettyTuple_ (pp 0)++         p0 (Value _ _ _ [v]) = v++         tuple (Value _ _ _ vs) = (False,tup vs)++         prettyPrinter t = listToMaybe . map snd . filter fst . map (\(t2,p) -> (match t t2,p)) $ [+            (absType (Proxy::Proxy ()),\_ -> (False,text "()"))+           ,(absType (Proxy::Proxy Word8),\v -> (False,wrd v))+           ,(absType (Proxy::Proxy Word16),\v -> (False,wl v))+           ,(absType (Proxy::Proxy Word32),\v -> (False,wl v))+           ,(absType (Proxy::Proxy Word64),\v -> (False,wl v))+           ,(absType (Proxy::Proxy Word),\v -> (False,wl v))+           ,(absType (Proxy::Proxy Int8),\v -> (False,int . zzDecode . wrd_ . p0 . p0 $ v))+           ,(absType (Proxy::Proxy Int16),\v -> (False,int . fromIntegral . zzDecode16 . wl_ . p0 . p0 $ v))+           ,(absType (Proxy::Proxy Int32),\v -> (False,int . fromIntegral . zzDecode32 . wl_ . p0 . p0 $ v))+           ,(absType (Proxy::Proxy Int64),\v -> (False,int . fromIntegral . zzDecode64 . wl_ . p0 . p0 $ v))+           ,(absType (Proxy::Proxy Int),\v -> (False,int . fromIntegral . zzDecode64 . wl_ . p0 . p0 $ v))+           ,(absType (Proxy::Proxy Integer),\v -> (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))+           --,(absType (Proxy::Proxy Natural),\v -> (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))+           ,(absType (Proxy::Proxy Float),\v -> (False,float $ floatVal v)) -- (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))+           ,(absType (Proxy::Proxy Double),\v -> (False,double $ doubleVal v)) -- (False,int . fromIntegral . zzDecodeInteger . wl_ . p0 $ v))+           --,(absType (Proxy::Proxy Char),\v -> (False,text ['\'',ch v,'\'']))+           ,(absType (Proxy::Proxy Char),\v -> (False,pPrint (ch v)))+           --,(absType (Proxy::Proxy [Char]),\v -> (False,pPrint . map ch . valList $ v))+           ,(absType (Proxy::Proxy [Char]),\v -> (False,text . show . map ch . valList $ v))+           --,(absType (Proxy::Proxy ([Char])),\v -> (False,char '"' <> (text . map ch . valList $ v) <> char '"'))+           ,(absType (Proxy::Proxy [Any]),\v -> (False,ar (valList v)))+           ,(absType (Proxy::Proxy (NonEmptyList Any)),\v -> (False,ar (neList v)))+           ,(absType (Proxy::Proxy (S.Seq Char)),\v -> (False,pPrint . map ch . arrList $ v))+           ,(absType (Proxy::Proxy (S.Seq Any)),\v -> (False,arr (arrList v)))+           --,(absType (Proxy::Proxy (P.Array Char)),\v -> (False,pPrint . map ch . arrList $ v))+           ----,(absType (Proxy::Proxy (P.Array Any)),\v -> (True,arr (arrList v)))+           --,(absType (Proxy::Proxy (P.Array Any)),\v -> (False,arr (arrList v)))+           ,(absType (Proxy::Proxy Bytes),\v -> (False,pPrint . bytes $ v))+           ,(absType (Proxy::Proxy (BLOB UTF8Encoding)),utf8Text)+           ,(absType (Proxy::Proxy (BLOB UTF16LEEncoding)),utf16Text)+           ,(absType (Proxy::Proxy (Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any,Any)),tuple)+           ,(absType (Proxy::Proxy (Any,Any,Any,Any,Any,Any,Any,Any,Any)),tuple)+           ]+             where+               utf16Text bl = (False,pPrint . blob UTF16LEEncoding . blobBytes $ bl)+               utf8Text bl = (False,pPrint . blob UTF8Encoding . blobBytes $ bl)+               --utf8Text blob = (False,decText T.decodeUtf8 blob)+               -- decText dec = text . T.unpack . dec . blobBytes+               blobBytes b =let [_,bs] = valFields b in bytes bs+               bytes bs = let [_,vs] = valFields . head . valFields $ bs+                          in B.pack . map (fromIntegral . wrd_) . arrList $ vs++               --bits3 (Value {valName = "Bits3", valFields = bs}) = bits bs+               --bits4 (Value {valName = "Bits4", valFields = bs}) = bits bs+               bits8 (Value {valName = "Bits8", valFields = bs}) = bits bs+               --bits7 (Value {valName = "Bits7", valFields = bs}) = bits bs+               bits11 (Value {valName = "Bits11", valFields = bs}) = bits bs+               bits23 (Value {valName = "Bits23", valFields = bs}) = bits bs+               bits52 (Value {valName = "Bits52", valFields = bs}) = bits bs+               bits = map bit+               bit v = let [b] = valBits v in b+               -- floatVal (Value {valName = "IEEE_754_binary32"+               --                 ,valFields = [Value {valBits = [signVal]}+               --                              ,Value {valName = "MostSignificantFirst", valFields = [expVal]}+               --                              ,Value {valName = "MostSignificantFirst", valFields = [Value {valName = "Bits23"+               --                                                                                           ,valFields = [frac1,frac2,frac3]}]}]})+               --   = ieee signVal [bits8 expVal] [bits7 frac1,bits8 frac2,bits8 frac3] 127++               -- doubleVal (Value {valName = "IEEE_754_binary64"+               --                  ,valFields = [Value {valBits = [signVal]}+               --                               ,Value {valName = "MostSignificantFirst"+               --                                      ,valFields = [Value {valName = "Bits11"+               --                                                          ,valFields = [expVal1,expVal2]}]}+               --                               ,Value {valName = "MostSignificantFirst"+               --                                      ,valFields = [Value {valName = "Bits52"+               --                                                          ,valFields = [frac1,frac2,frac3,frac4,frac5,frac6,frac7]}]}]})+               --   = ieee signVal [bits3 expVal1,bits8 expVal2] [bits4 frac1,bits8 frac2,bits8 frac3,bits8 frac4,bits8 frac5,bits8 frac6,bits8 frac7] 1023++               floatVal (Value {valName = "IEEE_754_binary32"+                               ,valFields = [Value {valBits = [signVal]}+                                            ,msb -> expVal+                                            ,msb -> frac]})+                 = ieee signVal [bits8 expVal] [bits23 frac] 127++               doubleVal (Value {valName = "IEEE_754_binary64"+                                ,valFields = [Value {valBits = [signVal]}+                                            ,msb -> expVal+                                            ,msb -> frac]})+                 = ieee signVal [bits11 expVal] [bits52 frac] 1023++               ieee sign exps fracs expOff =+                   let signV = fromIntegral $ fromEnum sign+                       expV = fromIntegral $ bitsVal $ concat exps+                       fracBits = concat $ [True] : fracs+                       fracV = fromIntegral $ bitsVal fracBits+                       val = ((-1)**signV)*(fracV / (2 ^ (length fracBits -1)))*(2**(expV-expOff))+                   in val+               msb (Value {valName = "MostSignificantFirst", valFields = [v]}) = v++-- MSF bitsVal+-- bitsVal [True,False,True,False]+-- > 10+bitsVal :: [Bool] -> Int+bitsVal = fst . foldl (\(t,e) n -> (t+fromEnum n *2^e,e+1)) (0::Int,0::Int) . reverse++-- Used to match any type+data Any deriving (Generic,Model)++tAny :: AbsType+tAny = absType (Proxy:: Proxy Any)++match :: Type AbsRef -> Type AbsRef -> Bool+match (TypeApp f1 a1) (TypeApp f2 a2) = match f1 f2 && match a1 a2+match t1 t2 | t2 == tAny = True+            | otherwise = t1 == t2++-- arr_ f elems = hsep $ text "Array" : [prettyList f elems]+--arr_ :: Pretty b => (a -> b) -> [a] -> Doc+--arr_ f elems = hsep [prettyList_ f elems]+arr_ :: (a -> Doc) -> [a] -> Doc+arr_ = prettyList_++-- prettyList_ :: Pretty b => (a -> b) -> [a] -> Doc+-- prettyList_ f vs = pPrint $ map f vs+prettyList_ :: (a -> Doc) -> [a] -> Doc+prettyList_ f vs = prettyList $ map f vs++prettyTuple_ :: (a -> Doc) -> [a] -> Doc+prettyTuple_ f vs = prettyTuple $ map f vs++-- haskell Style+-- prettySeq sep1 sep2 f elems = char sep1 <> (hcat . intersperse (text ", ") . map f $ elems) <> char sep2+-- prettySeq sep1 sep2 f elems = char sep1 <> (hcat . intersperse (text ", ") . map f $ elems) <> char sep2++
+ src/ZM/Transform.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+-- |Utilities to operate on the absolute type model+module ZM.Transform (+    -- * Saturated ADTs+    MapTypeTree,+    typeTree,+    solvedADT,+    -- * Presentation+    stringADT,+    -- * Dependencies+    typeDefinition,+    adtDefinition,+    innerReferences,+    references,+    getADTRef+    ) where++import           Control.Monad.Trans.State+import           Data.Foldable             (toList)+import           Data.List+import qualified Data.Map                  as M+import           Data.Maybe+import           Data.Model.Util           (transitiveClosure)+import           ZM.Types+import           ZM.Util++-- |A map of fully applied types to the corresponding saturated constructor tree+type MapTypeTree = M.Map (Type AbsRef) (ConTree Identifier AbsRef)++-- |Return the map of types to saturated constructor trees corresponding to the type model+typeTree :: AbsTypeModel -> MapTypeTree+typeTree tm = execEnv (addType (typeEnv tm) (typeName tm))+ where+   -- |Insert in the env the saturated constructor trees corresponding to the passed type+   -- and any type nested in its definition+   addType absEnv t = do+     mct <- M.lookup t <$> get+     case mct of+       Nothing ->+         case declCons $ solvedADT absEnv t of+           Just ct -> do+             modify (M.insert t ct)+             -- Recursively on all saturated types inside the contructor tree+             mapM_ (addType absEnv) (conTreeTypeList ct)+           Nothing -> return ()+       Just _ -> return ()++-- | Return all the ADTs referred, directly or indirectly, by the provided type, and defined in the provided environment+typeDefinition :: AbsEnv -> AbsType -> Either String [AbsADT]+typeDefinition env t = mapSolve env . nub . concat <$> (mapM (absRecDeps env) . references $ t)++-- | Return all the ADTs referred, directly or indirectly, by the ADT identified by the provided reference, and defined in the provided environment+adtDefinition :: AbsEnv -> AbsRef -> Either String [AbsADT]+adtDefinition env t = mapSolve env <$> absRecDeps env t++-- |Return the list of references found in the ADT definition+innerReferences :: AbsADT -> [AbsRef]+innerReferences = nub . mapMaybe getADTRef . nub . toList++-- |Return the list of references found in the absolute type+references :: AbsType  -> [AbsRef]+references = nub . toList++absRecDeps :: AbsEnv -> AbsRef -> Either String [AbsRef]+absRecDeps env ref = either (Left . unlines) Right $ transitiveClosure getADTRef env ref++-- WHAT ABOUT REC?+-- |Return an external reference, if present+getADTRef :: ADTRef a -> Maybe a+getADTRef (Ext r) = Just r+getADTRef _       = Nothing++mapSolve :: (Ord k, Show k) => M.Map k b -> [k] -> [b]+mapSolve env = map (`solve` env)++-- stringADT :: AbsEnv -> AbsADT -> ADT LocalName Identifier (TypeRef LocalName)+-- stringADT env adt =+--   let name = declName adt+--   in ADT (LocalName name) (declNumParameters adt) ((solveS name <$>) <$> declCons adt)+--    where solveS _ (Var n) = TypVar n+--          solveS _ (Ext k) = TypRef . LocalName . declName . solve k $ env+--          solveS name Rec  = TypRef $ LocalName name++-- |Convert references in an absolute definition to their textual form (useful for display)+stringADT :: AbsEnv -> AbsADT -> ADT Identifier Identifier (TypeRef Identifier)+stringADT env adt =+  let name = declName adt+  in ADT name (declNumParameters adt) ((solveS name <$>) <$> declCons adt)+   where solveS _ (Var n) = TypVar n+         solveS _ (Ext k) = TypRef . declName . solve k $ env+         solveS name Rec  = TypRef name++-- |Convert a type to an equivalent concrete ADT whose variables have been substituted by the type parameters (e.g. Maybe Bool -> Maybe = Nothing | Just Bool)+solvedADT :: (Ord ref, Show ref) => M.Map ref (ADT name consName (ADTRef ref)) -> Type ref -> ADT name consName ref+solvedADT env at =+   let+     TypeN t ts = typeN at+     as = map typeA ts+     adt = solve t env+     name = declName adt+   in ADT name 0 (conTreeTypeMap (saturate t as) <$> declCons adt)++-- |Substitute variables in a type with the provided types+saturate :: ref -> [Type ref] -> Type (ADTRef ref) -> Type ref+saturate ref vs (TypeApp a b) = TypeApp (saturate ref vs a) (saturate ref vs b)+saturate _   vs (TypeCon (Var n)) = vs !! fromIntegral n -- Different!+saturate _    _  (TypeCon (Ext r)) = TypeCon r+saturate selfRef _  (TypeCon Rec) = TypeCon selfRef++-- saturate2 :: ref -> [ref] -> Type (ADTRef ref) -> Type ref+-- saturate2 ref vs t = subs ref vs <$> t+--   where+--     subs _       vars (Var n) = vars !! fromIntegral n+--     subs selfRef _    Rec     = selfRef+--     subs _       _    (Ext r) = r++++
+ src/ZM/Type/Array.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Array(Array,Bytes) where+import           Data.Flat.Filler+import           Data.Model+import           ZM.Type.Generate+import qualified ZM.Type.Words    as Z++{-|An Array.++@+Array a  = A0+         | A1 a (Array a)+         | A2 a a (Array a)+         ...+         | A255 a ... (Array a)+@+-}+data Array a+instance Model a => Model (Array a) where envType = useCT arrayCT++-- |A byte-aligned byte array+data Bytes = Bytes (PreAligned (Array Z.Word8)) deriving (Generic,Model)++instance Model Filler+instance Model a => Model (PreAligned a)
+ src/ZM/Type/BLOB.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+-- |Binary Large OBjects (BLOBs)+module ZM.Type.BLOB (+    BLOB(..),+    UTF8Encoding(..),+    UTF16LEEncoding(..),+    FlatEncoding(..),+    NoEncoding(..),+    ) where++import           Control.DeepSeq+import           Data.Flat+import           Data.Model+import           ZM.Type.Array++-- |A BLOB is binary value encoded according to a specified encoding (e.g. UTF8)+data BLOB encoding = BLOB {encoding::encoding,content::Bytes} deriving Generic+instance Model encoding => Model (BLOB encoding)++-- |UTF-8 Encoding+data UTF8Encoding = UTF8Encoding+  deriving (Eq, Ord, Show, NFData, Generic, Flat, Model)++-- |UTF-16 Little Endian Encoding+data UTF16LEEncoding = UTF16LEEncoding+  deriving (Eq, Ord, Show, NFData, Generic, Flat, Model)++-- |Flat encoding+data FlatEncoding = FlatEncoding deriving (Eq, Ord, Show, NFData, Generic, Flat, Model)++-- |Unspecified encoding+data NoEncoding = NoEncoding deriving (Eq, Ord, Show, NFData, Generic, Flat, Model)
+ src/ZM/Type/Bit.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Bit where+import Data.Flat+import Data.Model++-- | A Bit+data Bit = V0 | V1 deriving (Eq,Ord,Show,Generic,Flat,Model)
+ src/ZM/Type/Bits11.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Bits11 where+import ZM.Type.Bit+import Data.Flat+import Data.Model++data Bits11 =+       Bits11+         { bit0 :: Bit+         , bit1 :: Bit+         , bit2 :: Bit+         , bit3 :: Bit+         , bit4 :: Bit+         , bit5 :: Bit+         , bit6 :: Bit+         , bit7 :: Bit+         , bit8 :: Bit+         , bit9 :: Bit+         , bit10 :: Bit+         }+  deriving (Eq, Ord, Show, Generic, Flat, Model)
+ src/ZM/Type/Bits23.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Bits23 where+import ZM.Type.Bit+import Data.Flat+import Data.Model++data Bits23 =+       Bits23+         { bit0 :: Bit+         , bit1 :: Bit+         , bit2 :: Bit+         , bit3 :: Bit+         , bit4 :: Bit+         , bit5 :: Bit+         , bit6 :: Bit+         , bit7 :: Bit+         , bit8 :: Bit+         , bit9 :: Bit+         , bit10 :: Bit+         , bit11 :: Bit+         , bit12 :: Bit+         , bit13 :: Bit+         , bit14 :: Bit+         , bit15 :: Bit+         , bit16 :: Bit+         , bit17 :: Bit+         , bit18 :: Bit+         , bit19 :: Bit+         , bit20 :: Bit+         , bit21 :: Bit+         , bit22 :: Bit+         }+  deriving (Eq, Ord, Show, Generic, Model, Flat)
+ src/ZM/Type/Bits52.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Bits52 where+import ZM.Type.Bit+import Data.Flat+import Data.Model++data Bits52 =+       Bits52+         { bit0 :: Bit+         , bit1 :: Bit+         , bit2 :: Bit+         , bit3 :: Bit+         , bit4 :: Bit+         , bit5 :: Bit+         , bit6 :: Bit+         , bit7 :: Bit+         , bit8 :: Bit+         , bit9 :: Bit+         , bit10 :: Bit+         , bit11 :: Bit+         , bit12 :: Bit+         , bit13 :: Bit+         , bit14 :: Bit+         , bit15 :: Bit+         , bit16 :: Bit+         , bit17 :: Bit+         , bit18 :: Bit+         , bit19 :: Bit+         , bit20 :: Bit+         , bit21 :: Bit+         , bit22 :: Bit+         , bit23 :: Bit+         , bit24 :: Bit+         , bit25 :: Bit+         , bit26 :: Bit+         , bit27 :: Bit+         , bit28 :: Bit+         , bit29 :: Bit+         , bit30 :: Bit+         , bit31 :: Bit+         , bit32 :: Bit+         , bit33 :: Bit+         , bit34 :: Bit+         , bit35 :: Bit+         , bit36 :: Bit+         , bit37 :: Bit+         , bit38 :: Bit+         , bit39 :: Bit+         , bit40 :: Bit+         , bit41 :: Bit+         , bit42 :: Bit+         , bit43 :: Bit+         , bit44 :: Bit+         , bit45 :: Bit+         , bit46 :: Bit+         , bit47 :: Bit+         , bit48 :: Bit+         , bit49 :: Bit+         , bit50 :: Bit+         , bit51 :: Bit+         }+  deriving (Eq, Ord, Show, Generic, Flat, Model)
+ src/ZM/Type/Bits8.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Bits8 where+import ZM.Type.Bit+import Data.Flat+import Data.Model++data Bits8 =+       Bits8+         { bit0 :: Bit+         , bit1 :: Bit+         , bit2 :: Bit+         , bit3 :: Bit+         , bit4 :: Bit+         , bit5 :: Bit+         , bit6 :: Bit+         , bit7 :: Bit+         }+  deriving (Eq, Ord, Show, Generic, Flat, Model)
+ src/ZM/Type/Char.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Char where+import Data.Model++import ZM.Type.Words++-- |A Unicode Char+data Char = Char Word32 deriving (Eq, Ord, Show, Generic, Model)+
+ src/ZM/Type/Float32.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Float32(IEEE_754_binary32(..)) where++import           Data.Model+import           ZM.Type.Bits8+import           ZM.Type.Bits23+import           ZM.Type.Words++-- |An IEEE-754 Big Endian 32 bits Float+data IEEE_754_binary32 =+       IEEE_754_binary32+         { sign     :: Sign+         , exponent :: MostSignificantFirst Bits8+         , fraction :: MostSignificantFirst Bits23+         }+  deriving (Eq, Ord, Show, Generic, Model)+++-- Low Endian+-- data IEEE_754_binary32_LE =+--        IEEE_754_binary32_LE+--          { fractionLE :: LeastSignificantFirst Bits23+--          , exponentLE :: LeastSignificantFirst Bits8+--          , signLE     :: Sign+--          }+-- or data IEEE_754_binary32_LE = IEEE_754_binary32 Word64
+ src/ZM/Type/Float64.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Float64(IEEE_754_binary64(..)) where++import           Data.Model+import           ZM.Type.Bits11+import           ZM.Type.Bits52+import           ZM.Type.Words++-- |An IEEE-754 Big Endian 64 bits Float+data IEEE_754_binary64 =+       IEEE_754_binary64+         { sign :: Sign+         , exponent :: MostSignificantFirst Bits11+         , fraction :: MostSignificantFirst Bits52+         }+  deriving (Eq, Ord, Show, Generic, Model)+
+ src/ZM/Type/Generate.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+-- |Generate the large constructor trees of some primitive types (Array,Word8,Word7)+module ZM.Type.Generate (arrayCT, word8CT, word7CT) where++import Data.Model.Types++-- |Constructor Tree for:+-- data Array a = A0 | A1 a (Array a) .. | A255 a .. a (Array a)+arrayCT :: Maybe (ConTree String (TypeRef QualName))+arrayCT = Just (asACT $ mkCons 256)++asACT :: Cons -> ConTree String (TypeRef QualName)+asACT (P t1 t2) = ConTree (asACT t1) (asACT t2)+asACT (L 0) = Con "A0" (Left [])+asACT (L n) = let a = TypeCon $ TypVar 0+              in Con ("A"++show n) (Left $ replicate n a ++ [TypeApp (TypeCon (TypRef (QualName "" "" "Array"))) a])++--word8ADT = ADT {declName = "Word8", declNumParameters = 0, declCons = word8CT}++-- |Constructor Tree for:+-- data Word8 = V0 | V1 .. | V255+word8CT :: Maybe (ConTree String ref)+word8CT = Just (asWCT $ mkCons 256)++-- |Constructor Tree for:+-- data Word7 = V0 | V1 .. | V127+word7CT :: Maybe (ConTree String ref)+word7CT = Just (asWCT $ mkCons 128)++asWCT :: Cons -> ConTree String ref+asWCT (P t1 t2) = ConTree (asWCT t1) (asWCT t2)+asWCT (L n) = Con ("V"++show n) (Left [])++-- |A binary tree with integer leaves, used to represent constructor trees+data Cons = L Int | P Cons Cons deriving (Show)++-- |Generate a right heavier binary tree whose leaves are marked+-- with the position (starting with 0) of the corresponding constructor+-- in the list of constructors+mkCons :: Int -> Cons+mkCons = makeTree 0++makeTree :: Int -> Int -> Cons+makeTree p 1 = L p+makeTree p n = let (d,m) = n `divMod` 2+           in  P (makeTree p d) (makeTree (p+d) (d+m))
+ src/ZM/Type/List.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveTraversable #-}+module ZM.Type.List(List(..)) where++import           Control.DeepSeq+import           Data.Flat+import           Data.Model++-- |A list+data List a = Nil+             | Cons a (List a)+  deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable, Flat)++instance Model a => Model (List a)
+ src/ZM/Type/Map.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Map(Map) where+import           Data.Model+import           ZM.Type.List+import           ZM.Type.Tuples++-- |A Map is represented as a list of key and value couples+data Map a b = Map (List (Tuple2 a b)) deriving Generic++instance (Model a, Model b) => Model (Map a b)
+ src/ZM/Type/NonEmptyList.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveTraversable #-}+module ZM.Type.NonEmptyList(NonEmptyList(..),nonEmptyList) where++import           Control.DeepSeq+import           Data.Flat+import           Data.Model++-- |A list that contains at least one element+data NonEmptyList a = Elem a+                    | Cons a (NonEmptyList a)+  deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable, Flat)++instance Model a => Model (NonEmptyList a)++-- |Convert a list to a `NonEmptyList`, returns an error if the list is empty+nonEmptyList :: [a] -> NonEmptyList a+nonEmptyList []    = error "Cannot convert an empty list to NonEmptyList"+nonEmptyList [h]   = Elem h+nonEmptyList (h:t) = Cons h (nonEmptyList t)
+ src/ZM/Type/Tuples.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+module ZM.Type.Tuples (+    Tuple2(..),+    Tuple3(..),+    Tuple4(..),+    Tuple5(..),+    Tuple6(..),+    Tuple7(..),+    Tuple8(..),+    Tuple9(..)+    ) where++import           Data.Model++data Tuple2 a b = Tuple2 a b deriving (Eq, Ord, Show, Generic)+instance (Model a,Model b) => Model (Tuple2 a b)++data Tuple3 a b c = Tuple3 a b c deriving (Eq, Ord, Show, Generic)+instance (Model a,Model b,Model c) => Model (Tuple3 a b c)++data Tuple4 a b c d = Tuple4 a b c d deriving (Eq, Ord, Show, Generic)+instance (Model a,Model b,Model c,Model d) => Model (Tuple4 a b c d)++data Tuple5 a1 a2 a3 a4 a5 = Tuple5 a1 a2 a3 a4 a5 deriving (Eq, Ord, Show, Generic)+instance (Model a1,Model a2,Model a3,Model a4,Model a5) => Model (Tuple5 a1 a2 a3 a4 a5)++data Tuple6 a1 a2 a3 a4 a5 a6 = Tuple6 a1 a2 a3 a4 a5 a6 deriving (Eq, Ord, Show, Generic)+instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6) => Model (Tuple6 a1 a2 a3 a4 a5 a6)++data Tuple7 a1 a2 a3 a4 a5 a6 a7= Tuple7 a1 a2 a3 a4 a5 a6 a7 deriving (Eq, Ord, Show, Generic)+instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7) => Model (Tuple7 a1 a2 a3 a4 a5 a6 a7)++data Tuple8 a1 a2 a3 a4 a5 a6 a7 a8 = Tuple8 a1 a2 a3 a4 a5 a6 a7 a8 deriving (Eq, Ord, Show, Generic)+instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7,Model a8) => Model (Tuple8 a1 a2 a3 a4 a5 a6 a7 a8)++data Tuple9 a1 a2 a3 a4 a5 a6 a7 a8 a9 = Tuple9 a1 a2 a3 a4 a5 a6 a7 a8 a9 deriving (Eq, Ord, Show, Generic)+instance (Model a1,Model a2,Model a3,Model a4,Model a5,Model a6,Model a7,Model a8,Model a9) => Model (Tuple9 a1 a2 a3 a4 a5 a6 a7 a8 a9)
+ src/ZM/Type/Unit.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Unit where+import Data.Model++-- |The Unit type+data Unit = Unit deriving (Eq, Ord, Show, Generic, Model)
+ src/ZM/Type/Words.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module ZM.Type.Words (+    Sign(..),+    Word7(..),+    Word(..),+    Word8(..),+    Word16(..),+    Word32(..),+    Word64(..),+    Int(..),+    Int8(..),+    Int16(..),+    Int32(..),+    Int64(..),+    ZigZag(..),+    MostSignificantFirst(..),+    LeastSignificantFirst(..),+    ) where++import Prelude hiding (Word,Int)+import           Data.Flat+import           Data.Model+import           ZM.Type.NonEmptyList+import           ZM.Type.Generate+import qualified Data.Word             as H++{- |+An unsigned integer of arbitrary length encoded as a non empty list of Word7 words with least significant word first and, inside each word, most significant bit first.++Example:+3450 :: Word++Binary representation: 0000110101111010++Split in 7bits groups: 0011010(26) 1111010(122)++Reverse order of groups: Word (Cons V122 (Elem V26))++So Least Significant Byte first with Most Significant Bit first in every 7 bits group.+-}+data Word = Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))+  deriving (Eq, Ord, Show, Generic, Model)++data Word16 = Word16 Word+  deriving (Eq, Ord, Show, Generic, Model)++data Word32 = Word32 Word+  deriving (Eq, Ord, Show, Generic, Model)++data Word64 = Word64 Word+  deriving (Eq, Ord, Show, Generic, Model)++-- |A 7 bits unsigned integer+-- data Word7 = V0 .. V127+data Word7 = Word7 H.Word8 deriving (Eq, Ord, Show, Generic)+instance Model Word7 where envType = useCT word7CT++-- |An 8 bits unsigned integer+-- data Word8 = V0 | V1 .. | V255+data Word8 = Word8 H.Word8 deriving (Eq, Ord, Show, Generic)+instance Model Word8 where envType = useCT word8CT++data Int = Int (ZigZag Word) deriving (Eq, Ord, Show, Generic, Model)++data Int8 = Int8 (ZigZag Word8)+  deriving (Eq, Ord, Show, Generic, Model)++data Int16 = Int16 (ZigZag Word16)+  deriving (Eq, Ord, Show, Generic, Model)++data Int32 = Int32 (ZigZag Word32)+  deriving (Eq, Ord, Show, Generic, Model)++data Int64 = Int64 (ZigZag Word64)+  deriving (Eq, Ord, Show, Generic, Model)++-- |ZigZag encoding, map signed integers to unsigned integers+-- Positive integers are mapped to even unsigned values, negative integers to odd values:+-- 0 -> 0, -1 -> 1, 1 -> 2, -2 -> 3, 2 -> 4 ...+data ZigZag a = ZigZag a+  deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (ZigZag a)++data LeastSignificantFirst a = LeastSignificantFirst a+  deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (LeastSignificantFirst a)++data MostSignificantFirst a = MostSignificantFirst a+  deriving (Eq, Ord, Show, Generic, Flat)+instance Model a => Model (MostSignificantFirst a)++data Sign = Positive | Negative deriving (Eq, Ord, Show, Generic, Model, Flat)
+ src/ZM/Types.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveFoldable      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module ZM.Types (+    -- * Model+    module Data.Model.Types,+    AbsTypeModel,+    AbsType,+    AbsRef(..),+    absRef,+    AbsADT,+    AbsEnv,+    ADTRef(..),+    Identifier(..),+    UnicodeLetter(..),+    UnicodeLetterOrNumberOrLine(..),+    UnicodeSymbol(..),+    SHA3_256_6(..),+    SHAKE128_48(..),+    NonEmptyList(..),+    nonEmptyList,+    Word7,+    -- * Encodings+    FlatEncoding(..), UTF8Encoding(..), UTF16LEEncoding(..), NoEncoding(..)+    -- * Exceptions+    ,TypedDecoded,+    TypedDecodeException(..),+    -- *Other Re-exports+    NFData(),+    Flat,+    ZigZag(..),+    LeastSignificantFirst(..),+    MostSignificantFirst(..),+    Value(..),+    Label(..),+    label,+    ) where++import           Control.DeepSeq+import           Control.Exception+import qualified Data.ByteString              as B+import           Data.Char+import           Data.Digest.Keccak+import           Data.Flat+import           Data.Foldable                (toList)+import qualified Data.ListLike.String         as L+import qualified Data.Map                     as M+import           Data.Model hiding (Name)+import Data.Model.Types  hiding (Name)+import ZM.Model()+import           ZM.Type.BLOB+import           ZM.Type.NonEmptyList+import           ZM.Type.Words        (LeastSignificantFirst (..),+                                               MostSignificantFirst (..), Word7,+                                               ZigZag (..))+import           Data.Word++-- |An absolute type, a type identifier that depends only on the definition of the type+type AbsType = Type AbsRef++-- |A reference to an absolute data type definition, in the form of a hash of the data type definition itself+-- data AbsRef = AbsRef (SHA3_256_6 AbsADT) deriving (Eq, Ord, Show, NFData, Generic, Flat)+data AbsRef = AbsRef (SHAKE128_48 AbsADT) deriving (Eq, Ord, Show, NFData, Generic, Flat)++-- |Return the absolute reference of the given value+absRef :: Flat r => r -> AbsRef+absRef a = let [w1,w2,w3,w4,w5,w6] = B.unpack . shake_128 6 . flat $ a+           in AbsRef $ SHAKE128_48 w1 w2 w3 w4 w5 w6++-- absRef a = let [w1,w2,w3,w4,w5,w6] = B.unpack . sha3_256 6 . flat $ a+--            in AbsRef $ SHA3_256_6 w1 w2 w3 w4 w5 w6++-- |A hash of a value, the first 6 bytes of the value's SHA3-256 hash+data SHA3_256_6 a = SHA3_256_6 Word8 Word8 Word8 Word8 Word8 Word8+  deriving (Eq, Ord, Show, NFData, Generic, Flat)++-- |A hash of a value, the first 48 bits (6 bytes) of the value's SHAKE128 hash+data SHAKE128_48 a = SHAKE128_48 Word8 Word8 Word8 Word8 Word8 Word8+  deriving (Eq, Ord, Show, NFData, Generic, Flat)++-- CHECK: Same syntax for adt and constructor names+-- |An absolute data type definition, a definition that refers only to other absolute definitions+type AbsADT = ADT Identifier Identifier (ADTRef AbsRef)++-- |An absolute type model, an absolute type and its associated environment+type AbsTypeModel = TypeModel Identifier Identifier (ADTRef AbsRef) AbsRef++-- |An environments of absolute types+type AbsEnv = TypeEnv Identifier Identifier (ADTRef AbsRef) AbsRef++-- type ADTEnv = M.Map AbsRef AbsADT++-- |A reference inside an ADT to another ADT+data ADTRef r = Var Word8 -- ^Variable, standing for a type+              | Rec       -- ^Recursive reference to the ADT itself+              | Ext r     -- ^Reference to another ADT+  deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable ,Flat)++-- CHECK: Is it necessary to specify a syntax for identifiers?+-- |An Identifier, the name of an ADT+data Identifier = Name UnicodeLetter [UnicodeLetterOrNumberOrLine]+                | Symbol (NonEmptyList UnicodeSymbol)+                deriving (Eq, Ord, Show, NFData, Generic, Flat)++instance Flat [UnicodeLetterOrNumberOrLine]++instance L.StringLike Identifier where+  fromString = identifier+  toString (Name (UnicodeLetter h) t) = h : map (\(UnicodeLetterOrNumberOrLine s) -> s) t+  toString (Symbol l) = map (\(UnicodeSymbol s) -> s) . toList $ l++-- |A character that is either a `UnicodeLetter`, a `UnicodeNumber` or the special character '_'+data UnicodeLetterOrNumberOrLine = UnicodeLetterOrNumberOrLine Char deriving (Eq, Ord, Show, NFData, Generic, Flat)++{-|+A character that is included in one of the following Unicode classes:+UppercaseLetter+LowercaseLetter+TitlecaseLetter+ModifierLetter+OtherLetter+-}+data UnicodeLetter = UnicodeLetter Char deriving (Eq, Ord, Show, NFData, Generic, Flat)++{-|+A character that is included in one of the following Unicode classes:+DecimalNumber+LetterNumber+OtherNumber+-}+data UnicodeNumber = UnicodeNumber Char deriving (Eq, Ord, Show, NFData, Generic, Flat)++{-|+A character that is included in one of the following Unicode classes:+MathSymbol+CurrencySymbol+ModifierSymbol+OtherSymbol+-}+data UnicodeSymbol = UnicodeSymbol Char deriving (Eq, Ord, Show, NFData, Generic, Flat)++-- |Convert a string to corresponding Identifier or throw an error+identifier :: String -> Identifier+identifier [] = error "identifier cannot be empty"+identifier s@(h:t) = if isLetter h+                     then Name (asLetter h) (map asLetterOrNumber t)+--                     else Symbol (NE.map asSymbol s)+                       else Symbol (nonEmptyList $ map asSymbol s)++asSymbol :: Char -> UnicodeSymbol+asSymbol c | isSymbol c = UnicodeSymbol c+           | otherwise = error . unwords $ [show c,"is not an Unicode Symbol"]++asLetter :: Char -> UnicodeLetter+asLetter c | isLetter c = UnicodeLetter c+           | otherwise = error . unwords $ [show c,"is not an Unicode Letter"]++asLetterOrNumber :: Char -> UnicodeLetterOrNumberOrLine+asLetterOrNumber c | isLetter c || isNumber c || isAlsoOK c = UnicodeLetterOrNumberOrLine c+                   | otherwise = error . unwords $ [show c,"is not an Unicode Letter or Number"]+++-- CHECK: IS '_' REALLY NEEDED?+isAlsoOK :: Char -> Bool+isAlsoOK '_' = True+isAlsoOK _   = False++-- |A generic value (used for dynamic decoding)+data Value = Value {valType::AbsType -- Type+                   ,valName::String  -- Constructor name (duplicate info if we have abstype)+                   ,valBits::[Bool]  -- Bit encoding/constructor id+                   -- TODO: add field names (same info present in abstype)+                   ,valFields::[Value]  -- Values to which the constructor is applied, if any+                   } deriving  (Eq,Ord,Show,NFData, Generic, Flat)++-- |An optionally labeled value+data Label a label = Label a (Maybe label) deriving (Eq, Ord, Show, NFData, Generic, Flat)++label :: (Functor f, Ord k) => M.Map k a -> (a -> l) -> f k -> f (Label k l)+label env f o = (\ref -> Label ref (f <$> M.lookup ref env)) <$> o++type TypedDecoded a = Either TypedDecodeException a++-- |An exception thrown if the decoding of a type value fails+data TypedDecodeException = UnknownMetaModel AbsType+                            | WrongType {expectedType::AbsType,actualType::AbsType}+                            | DecodeError DecodeException deriving (Show,Eq,Ord)++instance Exception TypedDecodeException++-- newtype LocalName = LocalName Identifier deriving (Eq, Ord, Show, NFData, Generic, Flat)++-- Flat instances for data types in the 'model' package+instance (Flat adtName, Flat consName, Flat inRef, Flat exRef,Ord exRef) => Flat (TypeModel adtName consName inRef exRef)+instance (Flat a,Flat b,Flat c) => Flat (ADT a b c)+instance (Flat a,Flat b) => Flat (ConTree a b)+instance (Flat a,Flat b) => Flat [(a,Type b)]+instance Flat a => Flat [Type a]+instance Flat a => Flat (Type a)+instance Flat a => Flat (TypeRef a)++-- Model instances+instance (Model a,Model b,Model c) => Model (ADT a b c)+instance (Model a,Model b) => Model (ConTree a b)+instance Model a => Model (ADTRef a)+instance Model a => Model (Type a)+instance Model a => Model (TypeRef a)+instance (Model adtName, Model consName, Model inRef, Model exRef) => Model (TypeModel adtName consName inRef exRef)+instance Model Identifier+instance Model UnicodeLetter+instance Model UnicodeLetterOrNumberOrLine+instance Model UnicodeSymbol+instance Model a => Model (SHA3_256_6 a)+instance Model a => Model (SHAKE128_48 a)+instance Model AbsRef+instance Model a => Model (PostAligned a)+
+ src/ZM/Util.hs view
@@ -0,0 +1,24 @@+module ZM.Util(+  proxyOf+  -- *State Monad utilities+  ,runEnv+  ,execEnv+  ) where++import           Control.Monad.Trans.State+import qualified Data.Map                  as M+import           Data.Proxy++-- |Return the proxy for the type of the given value+proxyOf :: a -> Proxy a+proxyOf _ = Proxy ::Proxy a++----------- State Utils+-- |Run a State monad with an empty map as environment+runEnv :: State (M.Map k a1) a -> (a, M.Map k a1)+runEnv op = runState op M.empty++-- |Exec a State monad with an empty map as environment+execEnv :: State (M.Map k a1) a -> M.Map k a1+execEnv op = execState op M.empty+
+ stack.yaml view
@@ -0,0 +1,6 @@+resolver: lts-6.31+extra-deps:+- model-0.3+- flat-0.3+- mono-traversable-1.0.2+- cryptonite-0.22
+ stack710.yaml view
@@ -0,0 +1,6 @@+resolver: lts-6.31+extra-deps:+- model-0.3+- flat-0.3+- mono-traversable-1.0.2+- cryptonite-0.22
+ stack801.yaml view
@@ -0,0 +1,7 @@+resolver: lts-7.21++extra-deps:+- model-0.3+- flat-0.3+- mono-traversable-1.0.2+- cryptonite-0.22
+ stack802.yaml view
@@ -0,0 +1,7 @@+resolver: lts-8.11++extra-deps:+- model-0.3+- flat-0.3+- mono-traversable-1.0.2+- cryptonite-0.22
+ test/Info.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module Info where++import           Data.Int+import           ZM+import           Data.Word+import           Test.Data       hiding (Unit)+-- import           Test.Data.Flat  hiding (Unit)+import           Test.Data.Model()+import qualified Test.Data2      as Data2+import qualified Test.Data3      as Data3+import qualified Data.Sequence         as S++models = [+     typ (Proxy :: Proxy AbsADT)+    ,typ (Proxy :: Proxy Bool)+    ,typ (Proxy :: Proxy (List Bool))+    ,typ (Proxy :: Proxy (Data2.List Bool))+    ,typ (Proxy :: Proxy (Data3.List Bool))+    ,typ (Proxy :: Proxy (List (Data2.List (Data3.List Bool))))+    ,typ (Proxy :: Proxy (Forest2 Bool))+    ,typ (Proxy :: Proxy Char)+    ,typ (Proxy :: Proxy String)+    ,typ (Proxy :: Proxy Word)+    ,typ (Proxy :: Proxy Word8)+    ,typ (Proxy :: Proxy Word16)+    ,typ (Proxy :: Proxy Word32)+    ,typ (Proxy :: Proxy Word64)+    ,typ (Proxy :: Proxy Int)+    ,typ (Proxy :: Proxy Int8)+    ,typ (Proxy :: Proxy Int16)+    ,typ (Proxy :: Proxy Int32)+    ,typ (Proxy :: Proxy Int64)+    ,typ (Proxy :: Proxy Integer)+    ,typ (Proxy :: Proxy (S.Seq Bool))+    ,typ (Proxy :: Proxy (List Bool))+    ,typ (Proxy:: Proxy D2)+    ,typ (Proxy :: Proxy D4)+    ,typ (Proxy :: Proxy (Phantom ()))+    ,typ (Proxy :: Proxy (Either Bool ()))+    ,typ (Proxy :: Proxy (Either Bool Bool))+    ,typ (Proxy :: Proxy (RR Un () N))+    ,typ (Proxy :: Proxy (BLOB UTF8Encoding))+    ,typ (Proxy :: Proxy (BLOB UTF16LEEncoding))+    ]+  where typ = absTypeModel++codes = [TypeApp (TypeApp (TypeApp (TypeCon (AbsRef (SHAKE128_48 62 130 87 37 92 191))) (TypeCon (AbsRef (SHAKE128_48 220 38 233 217 0 71)))) (TypeCon (AbsRef (SHAKE128_48 220 38 233 217 0 71)))) (TypeApp (TypeCon (AbsRef (SHAKE128_48 7 177 176 69 172 60))) (TypeCon (AbsRef (SHAKE128_48 75 189 56 88 123 158))))+        ,TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 148 55 180 1 191 163))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeApp (TypeCon (AbsRef (SHAKE128_48 148 55 180 1 191 163))) (TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 144 198 49 59 57 208))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeCon (AbsRef (SHAKE128_48 6 109 181 42 241 69))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 184 205 19 24 113 152))) (TypeCon (AbsRef (SHAKE128_48 6 109 181 42 241 69)))+        ,TypeCon (AbsRef (SHAKE128_48 80 208 24 247 89 58))+        ,TypeCon (AbsRef (SHAKE128_48 177 244 106 73 200 248))+        ,TypeCon (AbsRef (SHAKE128_48 41 94 36 214 47 172))+        ,TypeCon (AbsRef (SHAKE128_48 36 18 121 156 153 241))+        ,TypeCon (AbsRef (SHAKE128_48 80 208 24 247 89 58))+        ,TypeCon (AbsRef (SHAKE128_48 251 148 203 77 78 222))+        ,TypeCon (AbsRef (SHAKE128_48 179 162 100 43 74 132))+        ,TypeCon (AbsRef (SHAKE128_48 61 172 107 212 250 156))+        ,TypeCon (AbsRef (SHAKE128_48 90 31 178 147 33 165))+        ,TypeCon (AbsRef (SHAKE128_48 251 148 203 77 78 222))+        ,TypeCon (AbsRef (SHAKE128_48 16 42 59 185 4 227))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 46 139 69 25 174 170))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeCon (AbsRef (SHAKE128_48 180 209 66 111 91 138))+        ,TypeCon (AbsRef (SHAKE128_48 179 88 47 48 3 203))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 204 16 207 144 173 119))) (TypeCon (AbsRef (SHAKE128_48 121 74 239 110 33 170)))+        ,TypeApp (TypeApp (TypeCon (AbsRef (SHAKE128_48 98 96 228 101 174 116))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))) (TypeCon (AbsRef (SHAKE128_48 121 74 239 110 33 170)))+        ,TypeApp (TypeApp (TypeCon (AbsRef (SHAKE128_48 98 96 228 101 174 116))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))+        ,TypeApp (TypeApp (TypeApp (TypeCon (AbsRef (SHAKE128_48 58 94 167 13 35 164))) (TypeCon (AbsRef (SHAKE128_48 116 153 36 195 148 43)))) (TypeCon (AbsRef (SHAKE128_48 121 74 239 110 33 170)))) (TypeCon (AbsRef (SHAKE128_48 182 24 14 79 250 138)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 241 57 212 117 31 218))) (TypeCon (AbsRef (SHAKE128_48 15 68 139 232 5 128)))+        ,TypeApp (TypeCon (AbsRef (SHAKE128_48 241 57 212 117 31 218))) (TypeCon (AbsRef (SHAKE128_48 193 183 198 207 63 81)))+        ]
+ test/Spec.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}++module Main where++import           Control.Exception+import qualified Data.ByteString       as B+import qualified Data.ByteString.Lazy  as L+import qualified Data.ByteString.Short as SBS+import           Data.Digest.Keccak+import           Data.Either+import           Data.Foldable+import           Data.Int+import           Data.List+import qualified Data.ListLike.String  as L+import qualified Data.Map              as M+import           Data.Maybe+import           Data.Model            hiding (Name)+import qualified Data.Sequence         as S+import qualified Data.Text             as T+import           ZM+import           Data.Word+import           Debug.Trace+import           Info+import           System.Exit           (exitFailure)+import           System.TimeIt+import           Test.Data             hiding (Cons, Unit)+import           Test.Data.Flat        hiding (Cons, Unit)+import           Test.Data.Model+import qualified Test.Data2            as Data2+import qualified Test.Data3            as Data3+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck as QC+import           Text.PrettyPrint++-- import Data.Timeless++main = mainTest+-- main = mainMakeTests+-- main = mainPerformance+-- main = mainShow++mainMakeTests = do+  let code = concat ["codes = [",intercalate "\n," $ map (show . typeName) models,"]"]+  putStrLn code+  exitFailure++mainPerformance = do+  print "Calculate codes"+  mapM_ (timeIt . evaluate . typeName) models+  print "Again"+  mapM_ (timeIt . evaluate . typeName) models+  exitFailure++mainShow = do+  -- prt (Proxy::Proxy Char)+  -- prt (Proxy::Proxy String)+  prt (Proxy::Proxy T.Text)+  prt (Proxy::Proxy (BLOB UTF8Encoding))+  -- prt (Proxy::Proxy (Array Word8))+  -- prtH (Proxy::Proxy (Bool,()))+  -- prt (Proxy::Proxy L.ByteString)+  -- prt (Proxy::Proxy T.Text)+  -- print $ tstDec (Proxy::Proxy L.ByteString) [2,11,22,0,1]+  -- print $ tstDec (Proxy::Proxy (Bool,Bool,Bool)) [128+32]+  -- print $ tstDec (Proxy::Proxy (List Bool)) [72]+  -- print . B.length . flat . timelessSimple $ True+  -- print . B.length . flat . timelessHash $ True+  -- print . B.length . flat . timelessExplicit $ True+  -- print "OK"+  -- prt $ tst (Proxy :: Proxy (List (Data2.List (Bool))))+  exitFailure++    where+      prt = putStrLn . prettyShow . CompactPretty . absTypeModel+      -- pshort = putStrLn . take 1000 . prettyShow++mainTest = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+          [ sha3DigestTests+          , shakeDigestTests+          , codesTests+          , consistentModelTests+          , mutuallyRecursiveTests+          , customEncodingTests+          , encodingTests+          , transformTests+          , identifiersTests+          --, timelessTests+          ]++sha3DigestTests = testGroup "SHA3 Digest Tests"+                [tst [] [0xa7, 0xff, 0xc6], tst [48, 49, 50, 51] [0x33, 0xbc, 0xc2]]+  where+    tst inp out = testCase (unwords ["SHA3", show inp]) $ B.pack out @?= sha3_256 3 (B.pack inp)++shakeDigestTests = testGroup "Shake Digest Tests"+                [tst [] [0x7f, 0x9c, 0x2b], tst [48, 49, 50, 51] [0x30, 0xc5, 0x1c]]+  where+    tst inp out = testCase (unwords ["Shake128", show inp]) $ shake_128 3 (B.pack inp) @?= B.pack out++codesTests = testGroup "Absolute Types Codes Tests" (map tst $ zip models codes)+  where+    tst (model,code) = testCase (unwords ["Code"]) $ code @?= typeName model++consistentModelTests = testGroup "TypeModel Consistency Tests" $ map tst models+ where+  tst tm = testCase (unwords ["Consistency"]) $ internalConsistency tm && externalConsistency tm @?= True++-- |Check internal consistency of absolute environment+-- all internal references are to entries in the env+internalConsistency at =+  let innerRefs = nub . catMaybes . concatMap (map extRef. toList) . typeADTs $ at+      envRefs = M.keys $ typeEnv at+  in innerRefs `subsetOf` envRefs++subsetOf a b = a \\ b == []++extRef (Ext ref) = Just ref+extRef _         = Nothing++-- |Check external consistency of absolute environment+-- the key of every ADT in the env is correct (same as calculated directly on the ADT)+externalConsistency = all (\(r,adt) -> absRef adt == r) . M.toList . typeEnv++mutuallyRecursiveTests = testGroup "Mutually Recursion Detection Tests" $ [+    tst (Proxy :: Proxy A0)+    ,tst (Proxy :: Proxy B0)+    ,tst (Proxy :: Proxy (Forest Bool))+    ] where+  tst :: forall a. (Model a) => Proxy a -> TestTree+  tst proxy =+    let r = absTypeModelMaybe proxy+    in testCase (unwords ["Mutual Recursion",show r]) $ isLeft r && (let Left e = r in isInfixOf "mutually recursive" e) @?= True++-- |Test all custom flat instances for conformity to their model+customEncodingTests = testGroup "Typed Unit Tests" [+  em (Proxy :: Proxy T.Text) (Proxy :: Proxy (BLOB UTF8Encoding))+  ,em (Proxy :: Proxy UTF8Text) (Proxy :: Proxy (BLOB UTF8Encoding))+  ,em (Proxy :: Proxy UTF16Text) (Proxy :: Proxy (BLOB UTF16LEEncoding))+  ,e ()+  ,e False+  ,e (Just True)+  ,e (Left True::Either Bool Char)+  ,e (Right ()::Either Bool ())+  ,e (False,'g')+  ,e [(False,'g')]+  ,e (M.fromList ([]::[(Bool,Bool)]))+  ,e (M.fromList [(False,'g')])+  ,e (M.fromList [(33::Int,"abc")])+  ,e (M.fromList [(33::Int,57::Word8),(44,77)])+  ,e $ B.pack []+  ,e $ B.pack [11,22]+  ,e $ L.pack []+  ,e $ L.pack (replicate 11 77)+  ,e $ SBS.pack []+  ,e $ SBS.pack [11,22]+  ,e an+  ,e aw+  ,e ab+  ,e $ seq an+  ,e $ seq ab+  ,e $ seq aw+  ,e $ seq ac+  ,e 'a'+  ,e 'k'+  -- ,e "\n"+  ,e "ab\ncd"+  ,e ac+  ,e $ blob NoEncoding [11::Word8,22,33]+  ,e $ blob UTF8Encoding [97::Word8,98,99]+  ,e $ blob UTF16LEEncoding ([0x24,0x00,0xAC,0x20,0x01,0xD8,0x37,0xDC]::[Word8]) -- $€𐐷+  ,e (T.pack "abc$€𐐷")+  ,e (UTF8Text $ T.pack "abc$€𐐷")+  ,e (UTF16Text $ T.pack "abc$€𐐷")+  ,e (False,True)+  ,e (False,True,44::Word8)+  ,e (False,True,44::Word8,True)+  ,e (False,True,44::Word8,True,False)+  ,e (False,True,44::Word8,True,False,False)+  ,e (False,True,44::Word8,True,False,False,44::Word8)+  ,e (False,True,44::Word8,True,False,False,44::Word8,())+  ,e (False,True,44::Word8,True,False,False,44::Word8,(),'a')+  ,e (33::Word)+  ,e (0::Word8)+  ,e (33::Word8)+  ,e (255::Word8)+  ,e (3333::Word16)+  ,e (333333::Word32)+  ,e (33333333::Word64)+  ,e (maxBound::Word64)+  ,e (-11111111::Int)+  ,e (11111111::Int)+  ,e (88::Int8)+  ,e (1616::Int16)+  ,e (32323232::Int32)+  ,e (6464646464::Int64)+  ,e (minBound::Int32)+  ,e (maxBound::Int32)+  ,e (minBound::Int64)+  ,e (maxBound::Int64)+  ,e (-88::Int8)+  ,e (-1616::Int16)+  ,e (-32323232::Int32)+  ,e (-6464646464::Int64)+  ,e (44323232123::Integer)+  ,e (-4323232123::Integer)+  ,e (12.123::Float)+  ,e (-57.238E-11::Float)+  ,e (12.123::Double)+  ,e (-57.238E-11::Double)+  ]++  where+    seq = S.fromList+    an = []::[()]+    aw = [0,128,127,255::Word8]+    ab = [False,True,False]+    ac = ['v','i','c']++    -- e :: forall a. (Prettier a, Flat a, Show a, Model a) => a -> TestTree+    -- e x = testCase (unwords ["Encoding",show x]) $ dynamicShow x @?= prettierShow x+    e :: forall a. (Pretty a, Flat a, Show a, Model a) => a -> TestTree+    e x = testCase (unwords ["Encoding",show x,prettyShow x,dynamicShow x]) $ dynamicShow x @?= prettyShow x+    em p1 p2 = testCase (unwords ["Model Mapping"]) $ absType p1 @?= absType p2++-- As previous test but using Arbitrary values+encodingTests = testGroup "Encoding Tests"+                  [ ce "()" (prop_encoding :: RT ())+                  , ce "Bool" (prop_encoding :: RT Bool)+                  , ce "Maybe Bool" (prop_encoding :: RT (Maybe Bool))+                  , ce "Word" (prop_encoding :: RT Word)+                  , ce "Word8" (prop_encoding :: RT Word8)+                  , ce "Word16" (prop_encoding :: RT Word16)+                  , ce "Word32" (prop_encoding :: RT Word32)+                  , ce "Word64" (prop_encoding :: RT Word64)+                  , ce "Int" (prop_encoding :: RT Int)+                  , ce "Int16" (prop_encoding :: RT Int16)+                  , ce "Int16" (prop_encoding :: RT Int16)+                  , ce "Int32" (prop_encoding :: RT Int32)+                  , ce "Int64" (prop_encoding :: RT Int64)+                  , ce "Integer" (prop_encoding :: RT Integer)+                  , ce "Char" (prop_encoding :: RT Char)+                  , ce "String" (prop_encoding :: RT String) -- too slow+                  , ce "[Maybe (Bool,Char)]" (prop_encoding :: RT ([Maybe (Bool,Char)]))+                  ]+  where+    ce n = QC.testProperty (unwords ["Encoding", n])++identifiersTests = testGroup "Identifier Tests" $ concat [+  testId "Tuple2" $ Name (UnicodeLetter 'T') [UnicodeLetterOrNumberOrLine 'u',UnicodeLetterOrNumberOrLine 'p',UnicodeLetterOrNumberOrLine 'l',UnicodeLetterOrNumberOrLine 'e',UnicodeLetterOrNumberOrLine '2']+  ,testId "abc" $ Name (UnicodeLetter 'a') [UnicodeLetterOrNumberOrLine 'b',UnicodeLetterOrNumberOrLine 'c']+  ,testId "<>" $ Symbol (Cons (UnicodeSymbol '<') (Elem (UnicodeSymbol '>')))+  ]+   where+    testId s i = [testCase (unwords ["identifier parse",s]) $ L.fromString s @?= i+                 ,testCase (unwords ["identifier roundtrip",s]) $ L.toString (L.fromString s::Identifier) @?= s]++transformTests = testGroup "Transform Tests" [+  testRecDeps (Proxy :: Proxy Bool) 1+  ,testRecDeps (Proxy :: Proxy (Bool,[Bool])) 3+  ]+  where+    testRecDeps proxy len =+      let tm = absTypeModel proxy+      in let Right deps = typeDefinition (typeEnv tm) (typeName tm) -- $ length (typeDefinition (typeEnv tm) (typeName tm)) @?= len+         in testCase (unwords ["recursiveDependencies",prettyShow $ typeName tm]) $ length deps @?= len++-- prop_encoding x = dynamicShow x == prettierShow x++prop_encoding :: forall a. (Pretty a,Flat a, Model a) => RT a+prop_encoding x = dynamicShow x == prettyShow x++dynamicShow :: forall a. (Flat a, Model a) => a -> String+dynamicShow a = prettyShow (let Right v = decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) in v)++type RT a = a -> Bool++-- timelessTests = t True+--   where+--     t n = testGroup (unwords ["Timeless",show n]) [+--       testCase "simple" (untimeless (timelessSimple n) @?= Right n)+--       ,testCase "hash" (untimeless (timelessHash n) @?= Right n)+--       ,testCase "explicit" (untimeless (timelessExplicit n) @?= Right n)+--       ]+++
+ test/Test/Data.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-}+{-+ A collection of data types used for testing.+-}+module Test.Data where++import Control.Exception+import           Data.Char+import           Data.Int+import           Data.Word++import           Data.Typeable+import           Data.Data+import           GHC.Generics+import           Data.Data+import qualified Test.Data2 as D2+import Data.Foldable+import GHC.Exts hiding (toList)++data Void deriving Generic++data X = X X deriving Generic++data Unit = Unit deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Un = Un {un::Bool} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data D2 = D2 Bool N deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data D4 = D4 Bool N Unit N3 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- Enumeration+data N3 = N1 | N2 | N3+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Enum)++data N = One+       | Two+       | Three+       | Four+       | Five+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum)++-- toForestD :: Forest a -> ForestD (Tr2 a)+ -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt))++-- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt))++toForest2 :: Forest a -> Forest2 a+toForest2 (Forest f) = Forest2 (ForestD $ fmap toTr f)++toTr :: Tr a -> TrD (Forest2 a) a+toTr (Tr a f) = TrD a (toForest2 f)++toTr2 :: Tr a -> Tr2 a+toTr2 (Tr a (Forest f)) = Tr2 (TrD a (ForestD $ fmap toTr2 f))++-- tying the recursive knot, equivalent to Forest/Tree+data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- First-order non mutually recursive+data ForestD t = ForestD (List t) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data TrD f a = TrD a f deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- Explicit mutually recursive+data Forest a = Forest (List (Tr a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Tr a = Tr a (Forest a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Words = Words Word8 Word16 Word32 Word64+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Ints = Ints Int8 Int16 Int32 Int64+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- non-recursive data type+data Various = V1 (Maybe Bool)+             -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N)+             | V2 Bool (Either Bool (Maybe Bool))+             | VF Float Double Double+             | VW Word Word8 Word16 Word32 Word64+             | VI Int Int8 Int16 Int32 Int64+             | VII Integer Integer Integer+              deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- Phantom type+data Phantom a = Phantom deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+++-- Recursive data types++data RR a b c = RN {rna::a, rnb::b ,rnc::c}+              | RA a (RR a a c) b+              | RAB a (RR c b a) b+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Expr = ValB Bool | Or Expr Expr | If Expr Expr Expr  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data List a = C a (List a)+            | N+  deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic ,Generic1,Functor,Foldable)++data ListS a = Nil | Cons a (ListS a)+  deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data, Generic ,Generic1)++-- non-regular Haskell datatypes like:+-- Binary instances but no Model+data Nest a = NilN | ConsN (a, Nest (a, a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data TN a = LeafT a | BranchT (TN (a,a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Bush a = NilB | ConsB (a, Bush (Bush a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- Perfectly balanced binary tree+data Perfect a = ZeroP a | SuccP (Perfect (Fork a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Fork a = Fork a a deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- non regular with higher-order kind parameters+-- no Binary/Model instances+data PerfectF f α = NilP | ConsP α (PerfectF f (f α)) deriving (Typeable,Generic) -- No Data++data Pr f g a = Pr (f a (g a))++data Higher f a = Higher (f a) deriving (Typeable,Generic,Data)++-- data Pr2 (f :: * -> *) a = Pr2 (f )++data Free f a = Pure a | Roll (f (Free f a)) deriving (Typeable,Generic)++-- mutual references+data A = A B | AA Int deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data B = B A | BB Char deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- recursive sets:+-- Prob: ghc will just explode on this+-- data MM1 = MM1 MM2 MM4 MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM0 = MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM2 = MM2 MM3 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM3 = MM3 MM4 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM4 = MM4 MM4 MM2 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM5 = MM5 Unit MM6 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+-- data MM6 = MM6 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data A0 = A0 B0 B0 D0 Bool+        | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool)+        deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data B0 = B0 C0 | B1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data C0 = C0 A0 | C1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data D0 = D0 E0 | D1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data E0 = E0 D0 | E1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Even = Zero | SuccE Odd+data Odd = SuccO Even++-- Existential types+-- data Fold a b = forall x. Fold (x -> a -> x) x (x -> b)++-- data Some :: (* -> *) -> * where+--   Some :: f a -> Some f++-- data Dict (c :: Constraint) where+--   Dict :: c => Dict c+data Direction = North | South | Center | East | West+               deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Stream a = Stream a (Stream a)+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Functor,Foldable,Traversable)++data Tree a = Node (Tree a) (Tree a) | Leaf a+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable)++-- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html+data Car = Car {+  serialNumber::Word64+  ,modelYear::Word16+  ,available::Bool+  ,code::CarModel+  ,someNumbers::[Int32]+  ,vehicleCode::String+  ,extras::[OptionalExtra]+  ,engine::Engine+  ,fuelFigures::[Consumption]+  ,performanceFigures :: [(OctaneRating,[Acceleration])]+  ,make::String+  ,carModel::String+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Acceleration = Acceleration {mph::Word16,seconds::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++type OctaneRating = Word8 -- minValue="90" maxValue="110"++data Consumption = Consumption {cSpeed::Word16,cMpg::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data CarModel = ModelA | ModelB | ModelC  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data OptionalExtra = SunRoof | SportsPack | CruiseControl deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Engine = Engine {+  capacity :: Word16+  ,numCylinders:: Word8+  ,maxRpm:: Word16 -- constant 9000+  ,manufacturerCode :: String+  ,fuel::String -- constant Petrol+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+
+ test/Test/Data/Flat.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UndecidableInstances ,DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts ,FlexibleInstances ,LambdaCase ,StandaloneDeriving #-}+module Test.Data.Flat(module Test.Data) where+import Data.Flat+import Data.Flat.Encoder+import Data.Flat.Decoder+import Test.Data+import Test.Data2.Flat()+import Data.Word+--import Data.Flat.Poke+import Data.Foldable+import Data.Int+import GHC.Generics++{-+Compilation times:+           encoderS specials cases |+| 7.10.3 | NO                      | 0:44 |+| 7.10.3 | YES                     | 0:39 |+| 8.0.1  | NO                      | 1:30 |+| 8.0.1  | YES                     | 1:30 |+| 8.0.2  | NO                      | 4:18 |+| 8.0.2  | YES                     | 4:18 |+-}++-- GHC 8.0.2 chokes on this+-- instance Flat A0+-- instance Flat B0+-- instance Flat C0+-- instance Flat D0+-- instance Flat E0++deriving instance Generic (a,b,c,d,e,f,g,h)+deriving instance Generic (a,b,c,d,e,f,g,h,i)+instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h) => Flat (a,b,c,d,e,f,g,h)+instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h,Flat i) => Flat (a,b,c,d,e,f,g,h,i)++instance Flat N+instance Flat Unit++instance Flat a => Flat (List a)++instance Flat Direction+instance Flat Words+instance Flat Ints+instance Flat Void++instance Flat N3+instance Flat Un++instance Flat a => Flat (ListS a)++instance Flat A+instance Flat B++instance Flat D2+instance Flat D4++instance Flat a => Flat (Phantom a)++-- Slow to compile+instance Flat Various++-- Custom instances+-- instance {-# OVERLAPPING #-} Flat (Tree (N,N,N)) --where+--   size (Node t1 t2) = 1 + size t1 + size t2+--   size (Leaf a) = 1 + size a++-- -57%+-- instance {-# OVERLAPPING #-} Flat [N] -- where size = foldl' (\s n -> s + 1 + size n) 1++-- instance {-# OVERLAPPING #-} Flat (N,N,N) -- where+  -- {-# INLINE size #-}+  -- size (n1,n2,n3) = size n1 + size n2 + size n3++-- -50%+-- instance {-# OVERLAPPING #-} Flat (N,N,N) where+--    {-# INLINE encode #-}+--    encode (n1,n2,n3) = wprim $ (Step 9) (encodeN n1 >=> encodeN n2 >=> encodeN n3)+-- {-# INLINE encodeN #-}+-- encodeN = \case+--     One -> eBitsF 2 0+--     Two ->  eBitsF 2 1+--     Three -> eBitsF 2 2+--     Four -> eBitsF 3 6+--     Five -> eBitsF 3 7+++-- instance (Flat a, Flat b, Flat c) => Flat (RR a b c)+-- instance Flat a => Flat (Perfect a)+-- instance Flat a => Flat (Fork a)+-- instance Flat a => Flat (Nest a)+--instance   Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode+-- instance Flat Expr++++--instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a)+++-- instance Flat a => Flat (Stream a)++{-+              |+    |+One Two               |+                Three     |+                      Four Five+ -}+-- instance {-# OVERLAPPABLE #-} Flat a => Flat (Tree a) where+--   encode (Node t1 t2) = eFalse <> encode t1 <> encode t2+--   encode (Leaf a) = eTrue <> encode a++-- instance {-# OVERLAPPING #-} Flat (Tree N) where+--   encode (Node t1 t2) = eFalse <> encode t1 <> encode t2+--   encode (Leaf a) = eTrue <> encode a++-- -- -34% (why?)+-- instance Flat N where+--   {-# INLINE encode #-}+--   encode = \case+--     One -> eBits 2 0+--     Two -> eBits 2 1+--     Three -> eBits 2 2+--     Four -> eBits 3 6+--     Five -> eBits 3 7++-- instance  {-# OVERLAPPING #-}  Flat (Tree N)+ -- where+ --  {-# INLINE decode #-}+ --  decode = do+ --    tag <- dBool+ --    if tag+ --      then Leaf <$> decode+ --      else Node <$> decode <*> decode++-- instance Flat N+ -- where+ --  {-# INLINE decode #-}+ --  decode = do+ --    tag <- dBool+ --    if tag+ --      then do+ --       tag <- dBool+ --       if tag+ --         then do+ --          tag <- dBool+ --          if tag+ --            then return Five+ --            else return Four+ --         else return Three+ --      else do+ --       tag <- dBool+ --       if tag+ --         then return Two+ --         else return One++  -- {-# INLINE size #-}+  -- size n s = s + case n of+  --   One -> 2 +  --   Two -> 2+  --   Three -> 2+  --   Four -> 3+  --   Five -> 3++-- instance Flat N where+-- instance {-# OVERLAPPING #-} Flat (Tree N) -- where++-- --   {-# INLINE encode #-}+--   encode (Node t1 t2) = Writer $ \s -> do+--     !s1 <- runWriter eFalse s+--     !s2 <- runWriter (encode t1) s1+--     s3 <- runWriter (encode t2) s2+--     return s3++  -- encode (Leaf a) = Writer $ \s -> do+  --   s1 <- runWriter eTrue s+  --   runWriter (encode a) s1++--   size (Node t1 t2) = 1 + size t1 + size t2+--   size (Leaf a) = 1 + size a++--instance Flat N+++
+ test/Test/Data/Model.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE StandaloneDeriving ,DeriveGeneric ,ScopedTypeVariables ,FlexibleContexts ,DeriveAnyClass #-}+module Test.Data.Model where++import           Data.Model+import           Test.Data+import qualified Test.Data2 as Data2+import qualified Test.Data3 as Data3+import Data.Word+import GHC.Generics+import Data.Proxy+import Data.Typeable++-- instance Model Word8+-- instance Model Words+-- instance Model Ints++-- instance Model ADT+-- instance Model MM0+-- instance Model MM1+-- instance Model MM2+-- instance Model MM3+-- instance Model MM4+-- instance Model MM5+-- instance Model MM6++instance Model Void+instance Model Unit++instance Model N3+instance Model N+instance Model Un+instance Model D2+instance Model D4+instance Model A0+instance Model B0+instance Model C0+instance Model D0+instance Model E0++--instance Model Various+instance Model a => Model (Phantom a)+instance Model a => Model (Data2.List a)+instance Model a => Model (Data3.List a)+instance Model a => Model (List a)+instance Model a => Model (ListS a)+instance Model a => Model (Tree a)+instance (Model a, Model b, Model c) => Model (RR a b c)+instance Model Expr+instance Model a => Model (Perfect a)+instance Model a => Model (Fork a)+instance Model a => Model (Forest a)+instance Model a => Model (Tr a)+instance Model t => Model (ForestD t)+instance (Model f,Model a) => Model (TrD f a)+instance Model a => Model (Forest2 a)+instance Model a => Model (Tr2 a)++-- Higher kind+-- instance (Model a,Model f) => Model (Higher f a)+-- instance (Model (f a),Typeable f,Model a) => Model (PerfectF f a)+-- instance (Model v,Model (f v),Model a) => Model (Free f a)+
+ test/Test/Data2.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-}+module Test.Data2 where++import           Data.Typeable+import           Data.Data+import           GHC.Generics++-- A definition with the same name of a definition in Test.Data, used to test for name clashes.a+data List a = Cons2 a (List a)+            | Nil2+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic ,Generic1)+
+ test/Test/Data2/Flat.hs view
@@ -0,0 +1,5 @@+module Test.Data2.Flat(module Test.Data2) where+import Data.Flat+import Test.Data2++instance Flat a => Flat (List a)
+ test/Test/Data3.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-}+module Test.Data3 where++import           Data.Typeable+import           Data.Data+import           GHC.Generics++-- A definition identical to the one in Test.Data, used to test for name clashes.+data List a = C a (List a)+            | N+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic ,Generic1)+
+ test/Test/Data3/Flat.hs view
@@ -0,0 +1,5 @@+module Test.Data3.Flat(module Test.Data3) where+import Data.Flat+import Test.Data3++instance Flat a => Flat (List a)
+ zm.cabal view
@@ -0,0 +1,111 @@+name: zm+version: 0.2+synopsis: Language independent, reproducible, absolute types+description:+    See the <http://github.com/tittoassini/zm online tutorial>.+homepage: http://github.com/tittoassini/zm+category: Data,Reflection+license:             BSD3+license-file:        LICENSE+author:              Pasqualino `Titto` Assini+maintainer:          tittoassini@gmail.com+copyright:           Copyright: (c) 2016 Pasqualino `Titto` Assini+cabal-version: >=1.10+build-type: Simple+Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2+extra-source-files:+    stack.yaml+    stack710.yaml+    stack801.yaml+    stack802.yaml+    README.md++source-repository head+    type: git+    location: https://github.com/tittoassini/zm++library+    +    if impl(ghcjs -any)+        build-depends:+            ghcjs-base >=0.2 && <0.3+    else+        build-depends:+            cryptonite >=0.22 && <0.23,+            memory >=0.13+    exposed-modules:+        Data.Digest.Keccak+        ZM+        ZM.Abs+        ZM.BLOB+        ZM.Type.Array+        ZM.Type.BLOB+        ZM.Type.Bit+        ZM.Type.Bits8+        ZM.Type.Bits11+        ZM.Type.Bits23+        ZM.Type.Bits52+        ZM.Type.Char+        ZM.Type.Float32+        ZM.Type.Float64+        ZM.Type.List+        ZM.Type.NonEmptyList+        ZM.Type.Map+        ZM.Type.Tuples+        ZM.Type.Unit+        ZM.Type.Words+        ZM.Dynamic+        ZM.Type.Generate+        ZM.Pretty+        ZM.Model+        ZM.Transform+        ZM.Types+        ZM.Util+        ZM.Pretty.Value+    build-depends:+        ListLike >=4.2.1,+        base >=4.8 && <5,+        bytestring >=0.10.6.0,+        containers >=0.5.6.2,+        deepseq >=1.4.1.1,+        flat >=0.3,+        model >=0.3,+        mtl >=2.2.1,+        pretty >=1.1.2.0,+        text >=1.2.2.1,+        transformers >=0.4.2.0+    js-sources:+        jsbits/sha3.js+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options: -O2 -funbox-strict-fields -Wall -fno-warn-orphans -fno-warn-name-shadowing++test-suite zm-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base >=4.8.2.0,+        containers >=0.5.6.2,+        bytestring >=0.10.6.0,+        text >=1.2.2.1,+        tasty >=0.11.2,+        tasty-hunit >=0.9.2,+        tasty-quickcheck >=0.8.4,+        pretty >=1.1.2.0,+        ListLike >=4.2.1,+        flat >=0.3,+        model >=0.3,+        zm >=0.1.3,+        timeit >=1.0.0.0+    default-language: Haskell2010+    hs-source-dirs: test+    other-modules:+        Info+        Test.Data+        Test.Data.Flat+        Test.Data.Model+        Test.Data2+        Test.Data2.Flat+        Test.Data3+        Test.Data3.Flat+    ghc-options: -threaded -rtsopts -with-rtsopts=-N