syb 0.4.3 → 0.4.4
raw patch · 11 files changed
+1440/−1385 lines, 11 files
Files
- syb.cabal +1/−1
- tests/Bits.hs +225/−214
- tests/Encode.hs +88/−81
- tests/Ext1.hs +128/−124
- tests/GRead.hs +45/−45
- tests/GRead2.hs +75/−66
- tests/Perm.hs +139/−127
- tests/Reify.hs +413/−413
- tests/Typecase1.hs +58/−58
- tests/Typecase2.hs +61/−61
- tests/XML.hs +207/−195
syb.cabal view
@@ -1,5 +1,5 @@ name: syb-version: 0.4.3+version: 0.4.4 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes
tests/Bits.hs view
@@ -1,214 +1,225 @@-{-# OPTIONS -fglasgow-exts #-} - -module Bits (tests) where - -{- - -This test exercices some oldies of generic programming, namely -encoding terms as bit streams and decoding these bit streams in turn -to obtain terms again. (This sort of function might actually be useful -for serialisation and sending companies and other terms over the -internet.) - -Here is how it works. - -A constuctor is encoded as a bit stream. To this end, we encode the -index of the constructor as a binary number of a fixed length taking -into account the maximum index for the type at hand. (Similarly, we -could view the list of constructors as a binary tree, and then encode -a constructor as the path to the constructor in this tree.) If there -is just a single constructor, as for newtypes, for example, then the -computed bit stream is empty. - -Otherwise we just recurse into subterms. - -Well, we need to handle basic datatypes in a special way. We observe -such basic datatypes by testing the maximum index to be 0 for the -datatype at hand. An efficient encoding should be tuned per basic -datatype. The following solution is generic, but it wastes space. -That is, we turn the basic value into a string relying on the general -Data API. This string can now be encoded by first converting it into a -list of bit streams at the term level, which can then be easily -encoded as a single bit stream (because lists and bits can be -encoded). - --} - -import Test.HUnit - -import Data.Generics -import Data.Char -import Data.Maybe -import Control.Monad -import CompanyDatatypes - - - ------------------------------------------------------------------------------ - - - --- | We need bits and bit streams. -data Bit = Zero | One deriving (Show, Eq, Typeable, Data) -type Bin = [Bit] - - - ------------------------------------------------------------------------------ - - - --- Compute length of bit stream for a natural -lengthNat :: Int -> Int -lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1))) - - --- Encode a natural as a bit stream -varNat2bin :: Int -> Bin -varNat2bin 0 = [] -varNat2bin x = - ( ( if even x then Zero else One ) - : varNat2bin (x `div` 2) - ) - - --- Encode a natural as a bit stream of fixed length -fixedNat2bin :: Int -> Int -> Bin -fixedNat2bin 0 0 = [] -fixedNat2bin p x | p>0 = - ( ( if even x then Zero else One ) - : fixedNat2bin (p - 1) (x `div` 2) - ) - - --- Decode a natural -bin2nat :: Bin -> Int -bin2nat [] = 0 -bin2nat (Zero : bs) = 2 * (bin2nat bs) -bin2nat (One : bs) = 2 * (bin2nat bs) + 1 - - - ------------------------------------------------------------------------------ - - - --- | Generically map terms to bit streams -showBin :: Data t => t -> Bin - -showBin t - = if isAlgType myDataType - then con2bin ++ concat (gmapQ showBin t) - else showBin base - - where - - -- The datatype for introspection - myDataType = dataTypeOf t - - -- Obtain the maximum index for the type at hand - max :: Int - max = maxConstrIndex myDataType - - -- Obtain the index for the constructor at hand - idx :: Int - idx = constrIndex (toConstr t) - - -- Map basic values to strings, then to lists of bit streams - base = map (varNat2bin . ord) (showConstr (toConstr t)) - - -- Map constructors to bit streams of fixed length - con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1) - - ------------------------------------------------------------------------------ - - - --- | A monad on bit streams -data ReadB a = ReadB (Bin -> (Maybe a, Bin)) -unReadB (ReadB f) = f - - --- It's a monad. -instance Monad ReadB where - return a = ReadB (\bs -> (Just a, bs)) - (ReadB c) >>= f = ReadB (\bs -> case c bs of - (Just a, bs') -> unReadB (f a) bs' - (Nothing, bs') -> (Nothing, bs') - ) - - --- It's a bit monad with 0 and +. -instance MonadPlus ReadB where - mzero = ReadB (\bs -> (Nothing, bs)) - (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of - (Just a, bs') -> (Just a, bs') - (Nothing, _) -> g bs - ) - - --- Read a few bits -readB :: Int -> ReadB Bin -readB x = ReadB (\bs -> if length bs >= x - then (Just (take x bs), drop x bs) - else (Nothing, bs) - ) - - - ------------------------------------------------------------------------------ - - - --- | Generically map bit streams to terms -readBin :: Data t => ReadB t -readBin = result - where - - -- The worker, which we also use as type argument - result = if isAlgType myDataType - - then do bin <- readB (lengthNat (max - 1)) - fromConstrM readBin (bin2con bin) - - else do str <- readBin - con <- str2con (map (chr . bin2nat) str) - return (fromConstr con) - - -- Determine result type - myDataType = dataTypeOf (getArg result) - where - getArg :: ReadB a -> a - getArg = undefined - - -- Obtain the maximum index for the type at hand - max :: Int - max = maxConstrIndex myDataType - - -- Convert a bit stream into a constructor - bin2con :: Bin -> Constr - bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) - - -- Convert string to constructor; could fail - str2con :: String -> ReadB Constr - str2con = maybe mzero return - . readConstr myDataType - - - ------------------------------------------------------------------------------ - - - -tests = ( showBin True - , ( showBin [True] - , ( showBin (1::Int) - , ( showBin "1" - , ( showBin genCom - , ( geq genCom genCom' - )))))) ~=? output - where - genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company - -output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True))))) +{-# OPTIONS -fglasgow-exts #-}++module Bits (tests) where++{-+ +This test exercices some oldies of generic programming, namely+encoding terms as bit streams and decoding these bit streams in turn+to obtain terms again. (This sort of function might actually be useful+for serialisation and sending companies and other terms over the+internet.)++Here is how it works.++A constuctor is encoded as a bit stream. To this end, we encode the+index of the constructor as a binary number of a fixed length taking+into account the maximum index for the type at hand. (Similarly, we+could view the list of constructors as a binary tree, and then encode+a constructor as the path to the constructor in this tree.) If there+is just a single constructor, as for newtypes, for example, then the+computed bit stream is empty.++Otherwise we just recurse into subterms.++Well, we need to handle basic datatypes in a special way. We observe+such basic datatypes by testing the maximum index to be 0 for the+datatype at hand. An efficient encoding should be tuned per basic+datatype. The following solution is generic, but it wastes space.+That is, we turn the basic value into a string relying on the general+Data API. This string can now be encoded by first converting it into a+list of bit streams at the term level, which can then be easily+encoded as a single bit stream (because lists and bits can be+encoded).++-}++import Test.HUnit++import Data.Generics+import Data.Char+import Data.Maybe+import Control.Applicative (Alternative(..), Applicative(..))+import Control.Monad+import CompanyDatatypes++++-----------------------------------------------------------------------------++++-- | We need bits and bit streams.+data Bit = Zero | One deriving (Show, Eq, Typeable, Data)+type Bin = [Bit]++++-----------------------------------------------------------------------------++++-- Compute length of bit stream for a natural+lengthNat :: Int -> Int+lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1)))+++-- Encode a natural as a bit stream+varNat2bin :: Int -> Bin+varNat2bin 0 = []+varNat2bin x =+ ( ( if even x then Zero else One )+ : varNat2bin (x `div` 2)+ ) +++-- Encode a natural as a bit stream of fixed length+fixedNat2bin :: Int -> Int -> Bin+fixedNat2bin 0 0 = []+fixedNat2bin p x | p>0 =+ ( ( if even x then Zero else One )+ : fixedNat2bin (p - 1) (x `div` 2)+ ) +++-- Decode a natural+bin2nat :: Bin -> Int+bin2nat [] = 0+bin2nat (Zero : bs) = 2 * (bin2nat bs)+bin2nat (One : bs) = 2 * (bin2nat bs) + 1++++-----------------------------------------------------------------------------++++-- | Generically map terms to bit streams+showBin :: Data t => t -> Bin++showBin t+ = if isAlgType myDataType+ then con2bin ++ concat (gmapQ showBin t)+ else showBin base++ where++ -- The datatype for introspection+ myDataType = dataTypeOf t++ -- Obtain the maximum index for the type at hand+ max :: Int+ max = maxConstrIndex myDataType++ -- Obtain the index for the constructor at hand+ idx :: Int+ idx = constrIndex (toConstr t)++ -- Map basic values to strings, then to lists of bit streams+ base = map (varNat2bin . ord) (showConstr (toConstr t))++ -- Map constructors to bit streams of fixed length+ con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1)+++-----------------------------------------------------------------------------++++-- | A monad on bit streams+data ReadB a = ReadB (Bin -> (Maybe a, Bin))+unReadB (ReadB f) = f++instance Functor ReadB where+ fmap = liftM++instance Applicative ReadB where+ pure = return+ (<*>) = ap++instance Alternative ReadB where+ (<|>) = mplus+ empty = mzero++-- It's a monad.+instance Monad ReadB where+ return a = ReadB (\bs -> (Just a, bs))+ (ReadB c) >>= f = ReadB (\bs -> case c bs of+ (Just a, bs') -> unReadB (f a) bs'+ (Nothing, bs') -> (Nothing, bs')+ )+++-- It's a bit monad with 0 and +.+instance MonadPlus ReadB where+ mzero = ReadB (\bs -> (Nothing, bs))+ (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of+ (Just a, bs') -> (Just a, bs')+ (Nothing, _) -> g bs+ )+++-- Read a few bits+readB :: Int -> ReadB Bin+readB x = ReadB (\bs -> if length bs >= x+ then (Just (take x bs), drop x bs)+ else (Nothing, bs)+ )++++-----------------------------------------------------------------------------++++-- | Generically map bit streams to terms+readBin :: Data t => ReadB t+readBin = result+ where++ -- The worker, which we also use as type argument+ result = if isAlgType myDataType++ then do bin <- readB (lengthNat (max - 1))+ fromConstrM readBin (bin2con bin)++ else do str <- readBin+ con <- str2con (map (chr . bin2nat) str)+ return (fromConstr con)++ -- Determine result type+ myDataType = dataTypeOf (getArg result)+ where+ getArg :: ReadB a -> a+ getArg = undefined++ -- Obtain the maximum index for the type at hand+ max :: Int+ max = maxConstrIndex myDataType++ -- Convert a bit stream into a constructor + bin2con :: Bin -> Constr+ bin2con bin = indexConstr myDataType ((bin2nat bin) + 1)++ -- Convert string to constructor; could fail+ str2con :: String -> ReadB Constr+ str2con = maybe mzero return+ . readConstr myDataType++++-----------------------------------------------------------------------------++++tests = ( showBin True+ , ( showBin [True]+ , ( showBin (1::Int)+ , ( showBin "1"+ , ( showBin genCom+ , ( geq genCom genCom' + )))))) ~=? output+ where+ genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company++output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True)))))
tests/Encode.hs view
@@ -1,81 +1,88 @@-{-# OPTIONS -fglasgow-exts #-} - --- A bit more test code for the 2nd boilerplate paper. --- These are downscaled versions of library functionality or real test cases. --- We just wanted to typecheck the fragments as shown in the paper. - -module Encode () where - -import Data.Generics - -data Bit = Zero | One - ------------------------------------------------------------------------------- --- Sec. 3.2 - -data2bits :: Data a => a -> [Bit] -data2bits t = encodeCon (dataTypeOf t) (toConstr t) - ++ concat (gmapQ data2bits t) - --- The encoder for constructors -encodeCon :: DataType -> Constr -> [Bit] -encodeCon ty con = natToBin (max-1) (idx-1) - where - max = maxConstrIndex ty - idx = constrIndex con - - -natToBin :: Int -> Int -> [Bit] -natToBin = undefined - ------------------------------------------------------------------------------- --- Sec. 3.3 - -data State -- Abstract -initState :: State -encodeCon' :: DataType -> Constr - -> State -> (State, [Bit]) - -initState = undefined -encodeCon' = undefined - -data2bits' :: Data a => a -> [Bit] -data2bits' t = snd (show_bin t initState) - -show_bin :: Data a => a -> State -> (State, [Bit]) -show_bin t st = (st2, con_bits ++ args_bits) - where - (st1, con_bits) = encodeCon' (dataTypeOf t) - (toConstr t) st - (st2, args_bits) = foldr do_arg (st1,[]) - enc_args - - enc_args :: [State -> (State,[Bit])] - enc_args = gmapQ show_bin t - - do_arg fn (st,bits) = (st', bits' ++ bits) - where - (st', bits') = fn st - - ------------------------------------------------------------------------------- --- Sec. 3.3 cont'd - -data EncM a -- The encoder monad -instance Monad EncM - where - return = undefined - c >>= f = undefined - -runEnc :: EncM () -> [Bit] -emitCon :: DataType -> Constr -> EncM () - -runEnc = undefined -emitCon = undefined - -data2bits'' :: Data a => a -> [Bit] -data2bits'' t = runEnc (emit t) - -emit :: Data a => a -> EncM () -emit t = do { emitCon (dataTypeOf t) (toConstr t) - ; sequence_ (gmapQ emit t) } +{-# OPTIONS -fglasgow-exts #-}++-- A bit more test code for the 2nd boilerplate paper.+-- These are downscaled versions of library functionality or real test cases.+-- We just wanted to typecheck the fragments as shown in the paper.++module Encode () where++import Control.Applicative (Applicative(..))+import Control.Monad (ap, liftM)+import Data.Generics++data Bit = Zero | One++------------------------------------------------------------------------------+-- Sec. 3.2++data2bits :: Data a => a -> [Bit]+data2bits t = encodeCon (dataTypeOf t) (toConstr t)+ ++ concat (gmapQ data2bits t)++-- The encoder for constructors+encodeCon :: DataType -> Constr -> [Bit]+encodeCon ty con = natToBin (max-1) (idx-1)+ where+ max = maxConstrIndex ty+ idx = constrIndex con+++natToBin :: Int -> Int -> [Bit]+natToBin = undefined++------------------------------------------------------------------------------+-- Sec. 3.3++data State -- Abstract+initState :: State+encodeCon' :: DataType -> Constr+ -> State -> (State, [Bit])++initState = undefined+encodeCon' = undefined++data2bits' :: Data a => a -> [Bit]+data2bits' t = snd (show_bin t initState)++show_bin :: Data a => a -> State -> (State, [Bit])+show_bin t st = (st2, con_bits ++ args_bits)+ where+ (st1, con_bits) = encodeCon' (dataTypeOf t)+ (toConstr t) st+ (st2, args_bits) = foldr do_arg (st1,[])+ enc_args++ enc_args :: [State -> (State,[Bit])]+ enc_args = gmapQ show_bin t++ do_arg fn (st,bits) = (st', bits' ++ bits)+ where+ (st', bits') = fn st+++------------------------------------------------------------------------------+-- Sec. 3.3 cont'd++data EncM a -- The encoder monad+instance Functor EncM where+ fmap = liftM+instance Applicative EncM where+ pure = return+ (<*>) = ap+instance Monad EncM+ where+ return = undefined+ c >>= f = undefined++runEnc :: EncM () -> [Bit]+emitCon :: DataType -> Constr -> EncM ()++runEnc = undefined+emitCon = undefined++data2bits'' :: Data a => a -> [Bit]+data2bits'' t = runEnc (emit t)++emit :: Data a => a -> EncM ()+emit t = do { emitCon (dataTypeOf t) (toConstr t) + ; sequence_ (gmapQ emit t) }
tests/Ext1.hs view
@@ -1,124 +1,128 @@-{-# OPTIONS -fglasgow-exts #-} - -module Ext1 (tests) where - -{- - -This example records some experiments with polymorphic datatypes. - --} - -import Test.HUnit - -import Data.Generics -import GHC.Base - - --- Unsafe coerce -unsafeCoerce :: a -> b -unsafeCoerce = unsafeCoerce# - - --- Handy type constructors -newtype ID x = ID { unID :: x } -newtype CONST c a = CONST { unCONST :: c } - - --- Extension of a query with a para. poly. list case -extListQ' :: Data d - => (d -> q) - -> (forall d. [d] -> q) - -> d -> q -extListQ' def ext d = - if isList d - then ext (unsafeCoerce d) - else def d - - --- Test extListQ' -foo1 :: Data d => d -> Int -foo1 = const 0 `extListQ'` length -t1 = foo1 True -- should count as 0 -t2 = foo1 [True,True] -- should count as 2 - - --- Infeasible extension of a query with a data-polymorphic list case -extListQ'' :: Data d - => (d -> q) - -> (forall d. Data d => [d] -> q) - -> d -> q -extListQ'' def ext d = - if isList d - then undefined -- hard to avoid an ambiguous type - else def d - - --- Test extListQ from Data.Generics.Aliases -foo2 :: Data a => a -> Int -foo2 = const 0 `ext1Q` list - where - list :: Data a => [a] -> Int - list l = foldr (+) 0 $ map glength l - -t3 = foo2 (True,True) -- should count as 0 -t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 - - --- Customisation for lists without type cast -foo3 :: Data a => a -> Int -foo3 x = if isList x - then foldr (+) 0 $ gmapListQ glength x - else 0 - -t5 = foo3 (True,True) -- should count as 0 -t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 - - --- Test for list datatype -isList :: Data a => a -> Bool -isList x = typeRepTyCon (typeOf x) == - typeRepTyCon (typeOf (undefined::[()])) - - --- Test for nil -isNil :: Data a => a -> Bool -isNil x = toConstr x == toConstr ([]::[()]) - - --- Test for cons -isCons :: Data a => a -> Bool -isCons x = toConstr x == toConstr (():[]) - - --- gmapQ for polymorphic lists -gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q] -gmapListQ f x = - if not $ isList x - then error "gmapListQ" - else if isNil x - then [] - else if isCons x - then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x ) - else error "gmapListQ" - - --- Build nil -mkNil :: Data a => a -mkNil = fromConstr $ toConstr ([]::[()]) - - --- Build cons -mkCons :: Data a => a -mkCons = fromConstr $ toConstr ((undefined:undefined)::[()]) - - --- Main function for testing -tests = ( t1 - , ( t2 - , ( t3 - , ( t4 - , ( t5 - , ( t6 - )))))) ~=? output - -output = (0,(2,(0,(4,(0,4))))) +{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE CPP #-}++module Ext1 (tests) where++{-++This example records some experiments with polymorphic datatypes.++-}++import Test.HUnit++import Data.Generics+#if MIN_VERSION_base(4,8,0)+import GHC.Base hiding(foldr)+#else+import GHC.Base+#endif++-- Unsafe coerce+unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce#+++-- Handy type constructors+newtype ID x = ID { unID :: x }+newtype CONST c a = CONST { unCONST :: c }+++-- Extension of a query with a para. poly. list case+extListQ' :: Data d+ => (d -> q)+ -> (forall d. [d] -> q)+ -> d -> q+extListQ' def ext d =+ if isList d+ then ext (unsafeCoerce d)+ else def d +++-- Test extListQ'+foo1 :: Data d => d -> Int+foo1 = const 0 `extListQ'` length+t1 = foo1 True -- should count as 0+t2 = foo1 [True,True] -- should count as 2+++-- Infeasible extension of a query with a data-polymorphic list case+extListQ'' :: Data d+ => (d -> q)+ -> (forall d. Data d => [d] -> q)+ -> d -> q+extListQ'' def ext d =+ if isList d+ then undefined -- hard to avoid an ambiguous type+ else def d +++-- Test extListQ from Data.Generics.Aliases+foo2 :: Data a => a -> Int+foo2 = const 0 `ext1Q` list+ where+ list :: Data a => [a] -> Int+ list l = foldr (+) 0 $ map glength l++t3 = foo2 (True,True) -- should count as 0+t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4+++-- Customisation for lists without type cast+foo3 :: Data a => a -> Int+foo3 x = if isList x+ then foldr (+) 0 $ gmapListQ glength x+ else 0++t5 = foo3 (True,True) -- should count as 0+t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4+++-- Test for list datatype+isList :: Data a => a -> Bool+isList x = typeRepTyCon (typeOf x) ==+ typeRepTyCon (typeOf (undefined::[()]))+++-- Test for nil+isNil :: Data a => a -> Bool+isNil x = toConstr x == toConstr ([]::[()])+++-- Test for cons+isCons :: Data a => a -> Bool+isCons x = toConstr x == toConstr (():[])+++-- gmapQ for polymorphic lists+gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]+gmapListQ f x =+ if not $ isList x + then error "gmapListQ"+ else if isNil x+ then []+ else if isCons x+ then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )+ else error "gmapListQ"+++-- Build nil+mkNil :: Data a => a+mkNil = fromConstr $ toConstr ([]::[()])+++-- Build cons+mkCons :: Data a => a+mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])+++-- Main function for testing+tests = ( t1+ , ( t2+ , ( t3+ , ( t4+ , ( t5+ , ( t6+ )))))) ~=? output++output = (0,(2,(0,(4,(0,4)))))
tests/GRead.hs view
@@ -1,45 +1,45 @@-{-# OPTIONS -fglasgow-exts #-} - -module GRead (tests) where - -{- - -The following examples achieve branch coverage for the various -productions in the definition of gread. Also, negative test cases are -provided; see str2 and str3. Also, the potential of heading or -trailing spaces as well incomplete parsing of the input is exercised; -see str5. - --} - -import Test.HUnit - -import Data.Generics - -str1 = "(True)" -- reads fine as a Bool -str2 = "(Treu)" -- invalid constructor -str3 = "True" -- lacks parentheses -str4 = "(1)" -- could be an Int -str5 = "( 2 ) ..." -- could be an Int with some trailing left-over -str6 = "([])" -- test empty list -str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" - -tests = show ( ( [ gread str1, - gread str2, - gread str3 - ] - , [ gread str4, - gread str5 - ] - , [ gread str6, - gread str7 - ] - ) - :: ( [[(Bool, String)]] - , [[(Int, String)]] - , [[([Int], String)]] - ) - ) ~=? output - -output = show - ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) +{-# OPTIONS -fglasgow-exts #-}++module GRead (tests) where++{-++The following examples achieve branch coverage for the various+productions in the definition of gread. Also, negative test cases are+provided; see str2 and str3. Also, the potential of heading or+trailing spaces as well incomplete parsing of the input is exercised;+see str5.++-}++import Test.HUnit++import Data.Generics++str1 = "(True)" -- reads fine as a Bool+str2 = "(Treu)" -- invalid constructor+str3 = "True" -- lacks parentheses+str4 = "(1)" -- could be an Int+str5 = "( 2 ) ..." -- could be an Int with some trailing left-over+str6 = "([])" -- test empty list+str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")"++tests = show ( ( [ gread str1,+ gread str2,+ gread str3+ ]+ , [ gread str4,+ gread str5+ ]+ , [ gread str6,+ gread str7+ ]+ )+ :: ( [[(Bool, String)]]+ , [[(Int, String)]]+ , [[([Int], String)]]+ )+ ) ~=? output++output = show+ ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]])
tests/GRead2.hs view
@@ -1,66 +1,75 @@-{-# OPTIONS -fglasgow-exts #-} - -module GRead2 () where - -{- - -For the discussion in the 2nd boilerplate paper, -we favour some simplified generic read, which is checked to compile. -For the full/real story see Data.Generics.Text. - --} - -import Data.Generics - -gread :: Data a => String -> Maybe a -gread input = runDec input readM - --- The decoder monad -newtype DecM a = D (String -> Maybe (String, a)) - -instance Monad DecM where - return a = D (\s -> Just (s,a)) - (D m) >>= k = D (\s -> - case m s of - Nothing -> Nothing - Just (s1,a) -> let D n = k a - in n s1) - -runDec :: String -> DecM a -> Maybe a -runDec input (D m) = do (_,x) <- m input - return x - -parseConstr :: DataType -> DecM Constr -parseConstr ty = D (\s -> - match s (dataTypeConstrs ty)) - where - match :: String -> [Constr] - -> Maybe (String, Constr) - match _ [] = Nothing - match input (con:cons) - | take n input == showConstr con - = Just (drop n input, con) - | otherwise - = match input cons - where - n = length (showConstr con) - - -readM :: forall a. Data a => DecM a -readM = read - where - read :: DecM a - read = do { let val = argOf read - ; let ty = dataTypeOf val - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> readM) con } - -argOf :: c a -> a -argOf = undefined - -yareadM :: forall a. Data a => DecM a -yareadM = do { let ty = dataTypeOf (undefined::a) - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> yareadM) con } +{-# OPTIONS -fglasgow-exts #-}++module GRead2 () where++{-++For the discussion in the 2nd boilerplate paper,+we favour some simplified generic read, which is checked to compile.+For the full/real story see Data.Generics.Text.++-}++import Control.Applicative (Applicative(..))+import Control.Monad (ap, liftM)+import Data.Generics++gread :: Data a => String -> Maybe a+gread input = runDec input readM++-- The decoder monad+newtype DecM a = D (String -> Maybe (String, a))++instance Functor DecM where+ fmap = liftM++instance Applicative DecM where+ pure = return+ (<*>) = ap++instance Monad DecM where+ return a = D (\s -> Just (s,a))+ (D m) >>= k = D (\s ->+ case m s of+ Nothing -> Nothing+ Just (s1,a) -> let D n = k a+ in n s1)+ +runDec :: String -> DecM a -> Maybe a+runDec input (D m) = do (_,x) <- m input+ return x++parseConstr :: DataType -> DecM Constr+parseConstr ty = D (\s ->+ match s (dataTypeConstrs ty))+ where+ match :: String -> [Constr]+ -> Maybe (String, Constr)+ match _ [] = Nothing+ match input (con:cons)+ | take n input == showConstr con+ = Just (drop n input, con)+ | otherwise+ = match input cons+ where+ n = length (showConstr con)+++readM :: forall a. Data a => DecM a+readM = read+ where+ read :: DecM a+ read = do { let val = argOf read+ ; let ty = dataTypeOf val+ ; constr <- parseConstr ty+ ; let con::a = fromConstr constr+ ; gmapM (\_ -> readM) con }++argOf :: c a -> a+argOf = undefined++yareadM :: forall a. Data a => DecM a+yareadM = do { let ty = dataTypeOf (undefined::a)+ ; constr <- parseConstr ty+ ; let con::a = fromConstr constr+ ; gmapM (\_ -> yareadM) con }
tests/Perm.hs view
@@ -1,127 +1,139 @@-{-# OPTIONS -fglasgow-exts #-} - -module Perm (tests) where - -{- - -This module illustrates permutation phrases. -Disclaimer: this is a perhaps naive, certainly undebugged example. - --} - -import Test.HUnit - -import Control.Monad -import Data.Generics - ---------------------------------------------------------------------------- --- We want to read terms of type T3 regardless of the order T1 and T2. ---------------------------------------------------------------------------- - -data T1 = T1 deriving (Show, Eq, Typeable, Data) -data T2 = T2 deriving (Show, Eq, Typeable, Data) -data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) - - ---------------------------------------------------------------------------- --- A silly monad that we use to read lists of constructor strings. ---------------------------------------------------------------------------- - --- Type constructor -newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) } - - - --- Run a computation -runReadT x y = case unReadT x y of - Just ([],y) -> Just y - _ -> Nothing - --- Read one string -readT :: ReadT String -readT = ReadT (\x -> if null x - then Nothing - else Just (tail x, head x) - ) - --- ReadT is a monad! -instance Monad ReadT where - return x = ReadT (\y -> Just (y,x)) - c >>= f = ReadT (\x -> case unReadT c x of - Nothing -> Nothing - Just (x', a) -> unReadT (f a) x' - ) - --- ReadT also accommodates mzero and mplus! -instance MonadPlus ReadT where - mzero = ReadT (const Nothing) - f `mplus` g = ReadT (\x -> case unReadT f x of - Nothing -> unReadT g x - y -> y - ) - - ---------------------------------------------------------------------------- --- A helper type to appeal to predicative type system. ---------------------------------------------------------------------------- - -newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } - - ---------------------------------------------------------------------------- --- The function that reads and copes with all permutations. ---------------------------------------------------------------------------- - -buildT :: forall a. Data a => ReadT a -buildT = result - - where - result = do str <- readT - con <- string2constr str - ske <- return $ fromConstr con - fs <- return $ gmapQ buildT' ske - perm [] fs ske - - -- Determine type of data to be constructed - myType = myTypeOf result - where - myTypeOf :: forall a. ReadT a -> a - myTypeOf = undefined - - -- Turn string into constructor - string2constr str = maybe mzero - return - (readConstr (dataTypeOf myType) str) - - -- Specialise buildT per kid type - buildT' :: forall a. Data a => a -> GenM - buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) - - -- The permutation exploration function - perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a - perm [] [] a = return a - perm fs [] a = perm [] fs a - perm fs (f:fs') a = ( - do a' <- gmapMo (unGenM f) a - perm fs fs' a' - ) - `mplus` - ( - do guard (not (null fs')) - perm (f:fs) fs' a - ) - - ---------------------------------------------------------------------------- --- The main function for testing ---------------------------------------------------------------------------- - -tests = - ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine - , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine - , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine - , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine - , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail - ))))) ~=? output - -output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) +{-# OPTIONS -fglasgow-exts #-}++module Perm (tests) where++{-++This module illustrates permutation phrases.+Disclaimer: this is a perhaps naive, certainly undebugged example.++-}++import Test.HUnit++import Control.Applicative (Alternative(..), Applicative(..))+import Control.Monad+import Data.Generics++---------------------------------------------------------------------------+-- We want to read terms of type T3 regardless of the order T1 and T2.+---------------------------------------------------------------------------++data T1 = T1 deriving (Show, Eq, Typeable, Data)+data T2 = T2 deriving (Show, Eq, Typeable, Data)+data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data)+++---------------------------------------------------------------------------+-- A silly monad that we use to read lists of constructor strings.+---------------------------------------------------------------------------++-- Type constructor+newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) }++++-- Run a computation+runReadT x y = case unReadT x y of+ Just ([],y) -> Just y+ _ -> Nothing++-- Read one string+readT :: ReadT String+readT = ReadT (\x -> if null x+ then Nothing+ else Just (tail x, head x)+ )++instance Functor ReadT where+ fmap = liftM++instance Applicative ReadT where+ pure = return+ (<*>) = ap++instance Alternative ReadT where+ (<|>) = mplus+ empty = mzero++-- ReadT is a monad!+instance Monad ReadT where+ return x = ReadT (\y -> Just (y,x))+ c >>= f = ReadT (\x -> case unReadT c x of+ Nothing -> Nothing+ Just (x', a) -> unReadT (f a) x'+ )++-- ReadT also accommodates mzero and mplus!+instance MonadPlus ReadT where+ mzero = ReadT (const Nothing)+ f `mplus` g = ReadT (\x -> case unReadT f x of+ Nothing -> unReadT g x+ y -> y+ )+++---------------------------------------------------------------------------+-- A helper type to appeal to predicative type system.+---------------------------------------------------------------------------++newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a }+++---------------------------------------------------------------------------+-- The function that reads and copes with all permutations.+---------------------------------------------------------------------------++buildT :: forall a. Data a => ReadT a+buildT = result++ where+ result = do str <- readT+ con <- string2constr str+ ske <- return $ fromConstr con+ fs <- return $ gmapQ buildT' ske+ perm [] fs ske++ -- Determine type of data to be constructed+ myType = myTypeOf result+ where+ myTypeOf :: forall a. ReadT a -> a+ myTypeOf = undefined++ -- Turn string into constructor+ string2constr str = maybe mzero+ return+ (readConstr (dataTypeOf myType) str)++ -- Specialise buildT per kid type+ buildT' :: forall a. Data a => a -> GenM+ buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a))++ -- The permutation exploration function+ perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a+ perm [] [] a = return a+ perm fs [] a = perm [] fs a+ perm fs (f:fs') a = (+ do a' <- gmapMo (unGenM f) a+ perm fs fs' a'+ )+ `mplus`+ (+ do guard (not (null fs'))+ perm (f:fs) fs' a+ )+++---------------------------------------------------------------------------+-- The main function for testing+---------------------------------------------------------------------------++tests =+ ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine+ , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine+ , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine+ , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine+ , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail+ ))))) ~=? output++output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))
tests/Reify.hs view
@@ -1,413 +1,413 @@-{-# OPTIONS -fglasgow-exts #-} - -module Reify (tests) where - -{- - -The following examples illustrate the reification facilities for type -structure. Most notably, we generate shallow terms using the depth of -types and constructors as means to steer the generation. - --} - -import Test.HUnit - -import Data.Maybe -import Data.Generics -import Control.Monad.State -import CompanyDatatypes - - - ------------------------------------------------------------------------------- --- --- Encoding types as values; some other way. --- ------------------------------------------------------------------------------- - -{- - -This group provides a style of encoding types as values and using -them. This style is seen as an alternative to the pragmatic style used -in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined" -to denote a type argument. This pragmatic style suffers from lack -of robustness: one feels tempted to pattern match on undefineds. -Maybe Data.Typeable.typeOf etc. should be rewritten accordingly. - --} - - --- | Type as values to stipulate use of undefineds -type TypeVal a = a -> () - - --- | The value that denotes a type -typeVal :: TypeVal a -typeVal = const () - - --- | Test for type equivalence -sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool -sameType tva tvb = typeOf (type2val tva) == - typeOf (type2val tvb) - - --- | Map a value to its type -val2type :: a -> TypeVal a -val2type _ = typeVal - - --- | Stipulate this idiom! -type2val :: TypeVal a -> a -type2val _ = undefined - - --- | Constrain a type -withType :: a -> TypeVal a -> a -withType x _ = x - - --- | The argument type of a function -argType :: (a -> b) -> TypeVal a -argType _ = typeVal - - --- | The result type of a function -resType :: (a -> b) -> TypeVal b -resType _ = typeVal - - --- | The parameter type of type constructor -paraType :: t a -> TypeVal a -paraType _ = typeVal - - --- Type functions, --- i.e., functions mapping types to values --- -type TypeFun a r = TypeVal a -> r - - - --- Generic type functions, --- i.e., functions mapping types to values --- -type GTypeFun r = forall a. Data a => TypeFun a r - - - --- | Extend a type function -extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r -extType f x = maybe f id (cast x) - - - ------------------------------------------------------------------------------- --- --- Mapping operators to map over type structure --- ------------------------------------------------------------------------------- - - --- | Query all constructors of a given type - -gmapType :: ([(Constr,r')] -> r) - -> GTypeFun (Constr -> r') - -> GTypeFun r - -gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a) - = - o $ zip cons query - - where - - -- All constructors of the given type - cons :: [Constr] - cons = if isAlgType $ dataTypeOf $ type2val t - then dataTypeConstrs $ dataTypeOf $ type2val t - else [] - - -- Query constructors - query :: [r'] - query = map (f t) cons - - --- | Query all subterm types of a given constructor - -gmapConstr :: ([r] -> r') - -> GTypeFun r - -> GTypeFun (Constr -> r') - -gmapConstr (o::[r] -> r') f (t::TypeVal a) c - = - o $ query - - where - - -- Term for the given constructor - term :: a - term = fromConstr c - - -- Query subterm types - query :: [r] - query = gmapQ (f . val2type) term - - --- | Compute arity of a given constructor -constrArity :: GTypeFun (Constr -> Int) -constrArity t c = glength $ withType (fromConstr c) t - - --- | Query all immediate subterm types of a given type -gmapSubtermTypes :: (Data a, Typeable r) - => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r -gmapSubtermTypes o (r::r) f (t::TypeVal a) - = - reduce (concat (map (gmapQ (query . val2type)) terms)) - (GTypeFun' f) - - where - - -- All constructors of the given type - cons :: [Constr] - cons = if isAlgType $ dataTypeOf $ type2val t - then dataTypeConstrs $ dataTypeOf $ type2val t - else [] - - -- Terms for all constructors - terms :: [a] - terms = map fromConstr cons - - -- Query a subterm type - query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r) - query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f))) - - -- Constant out given type - disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r - disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r - - -- Reduce all subterm types - reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r - reduce [] _ = r - reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g)) - - --- First-class polymorphic variation on GTypeFun -newtype GTypeFun' r = GTypeFun' (GTypeFun r) -unGTypeFun' (GTypeFun' f) = f - - --- | Query all immediate subterm types. --- There is an extra argument to \"constant out\" the type at hand. --- This can be used to avoid cycles. - -gmapSubtermTypesConst :: (Data a, Typeable r) - => (r -> r -> r) - -> r - -> GTypeFun r - -> TypeVal a - -> r -gmapSubtermTypesConst o (r::r) f (t::TypeVal a) - = - gmapSubtermTypes o r f' t - where - f' :: GTypeFun r - f' = f `extType` \(_::TypeVal a) -> r - - --- Count all distinct subterm types -gcountSubtermTypes :: Data a => TypeVal a -> Int -gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1) - - --- | A simplied variation on gmapSubtermTypes. --- Weakness: no awareness of doubles. --- Strength: easy to comprehend as it uses gmapType and gmapConstr. - -_gmapSubtermTypes :: (Data a, Typeable r) - => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r -_gmapSubtermTypes o (r::r) f - = - gmapType otype (gmapConstr oconstr f) - - where - - otype :: [(Constr,r)] -> r - otype = foldr (\x y -> snd x `o` y) r - - oconstr :: [r] -> r - oconstr = foldr o r - - ------------------------------------------------------------------------------- --- --- Some reifying relations on types --- ------------------------------------------------------------------------------- - - --- | Reachability relation on types, i.e., --- test if nodes of type @a@ are reachable from nodes of type @b@. --- The relation is defined to be reflexive. - -reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool -reachableType (a::TypeVal a) (b::TypeVal b) - = - or [ sameType a b - , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b - ] - - --- | Depth of a datatype as the constructor with the minimum depth. --- The outermost 'Nothing' denotes a type without constructors. --- The innermost 'Nothing' denotes potentially infinite. - -depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int)) -depthOfType p (t::TypeVal a) - = - gmapType o f t - - where - - o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int) - o l = if null l then Nothing else Just (foldr1 min' l) - - f :: GTypeFun (Constr -> Maybe Int) - f = depthOfConstr p' - - -- Specific minimum operator - min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int) - min' x (_, Nothing) = x - min' (_, Nothing) x = x - min' (c, Just i) (c', Just i') | i <= i' = (c, Just i) - min' (c, Just i) (c', Just i') = (c', Just i') - - -- Updated predicate for unblocked types - p' :: GTypeFun Bool - p' = p `extType` \(_::TypeVal a) -> False - - --- | Depth of a constructor. --- Depth is viewed as the maximum depth of all subterm types + 1. --- 'Nothing' denotes potentially infinite. - -depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int) -depthOfConstr p (t::TypeVal a) c - = - gmapConstr o f t c - - where - - o :: [Maybe Int] -> Maybe Int - o = inc' . foldr max' (Just 0) - - f :: GTypeFun (Maybe Int) - f t' = if p t' - then - case depthOfType p t' of - Nothing -> Just 0 - Just (_, x) -> x - else Nothing - - -- Specific maximum operator - max' Nothing _ = Nothing - max' _ Nothing = Nothing - max' (Just i) (Just i') | i >= i' = Just i - max' (Just i) (Just i') = Just i' - - -- Specific increment operator - inc' Nothing = Nothing - inc' (Just i) = Just (i+1) - - ------------------------------------------------------------------------------- --- --- Build a shallow term --- ------------------------------------------------------------------------------- - -shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b) -shallowTerm cust - = result - where - result :: forall b. Data b => b - -- Need a type signature here to bring 'b' into scope - result = maybe gdefault id cust - where - - -- The worker, also used for type disambiguation - gdefault :: b - gdefault = case con of - Just (con, Just _) -> fromConstrB (shallowTerm cust) con - _ -> error "no shallow term!" - - -- The type to be constructed - typeVal :: TypeVal b - typeVal = val2type gdefault - - -- The most shallow constructor if any - con :: Maybe (Constr, Maybe Int) - con = depthOfType (const True) typeVal - - - --- For testing shallowTerm -shallowTermBase :: GenericR Maybe -shallowTermBase = Nothing - `extR` Just (1.23::Float) - `extR` Just ("foo"::String) - - - --- Sample datatypes -data T1 = T1a deriving (Typeable, Data) -- just a constant -data T2 = T2 T1 deriving (Typeable, Data) -- little detour -data T3 = T3a T3 | T3b T2 deriving (Typeable, Data) -- recursive case -data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters - - - --- Sample type arguments -t0 = typeVal :: TypeVal Int -t1 = typeVal :: TypeVal T1 -t2 = typeVal :: TypeVal T2 -t3 = typeVal :: TypeVal T3 -t4 = typeVal :: TypeVal T4 -tCompany = typeVal :: TypeVal Company -tPerson = typeVal :: TypeVal Person -tEmployee = typeVal :: TypeVal Employee -tDept = typeVal :: TypeVal Dept - - - --- Test cases -test0 = t1 `reachableType` t1 -- True -test1 = t1 `reachableType` t2 -- True -test2 = t2 `reachableType` t1 -- False -test3 = t1 `reachableType` t3 -test4 = tPerson `reachableType` tCompany -test5 = gcountSubtermTypes tPerson -test6 = gcountSubtermTypes tEmployee -test7 = gcountSubtermTypes tDept -test8 = shallowTerm shallowTermBase :: Person -test9 = shallowTerm shallowTermBase :: Employee -test10 = shallowTerm shallowTermBase :: Dept - - - -tests = ( test0 - , ( test1 - , ( test2 - , ( test3 - , ( test4 - , ( test5 - , ( test6 - , ( test7 - , ( test8 - , ( test9 - , ( test10 - ))))))))))) ~=? output - -output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo", - (E (P "foo" "foo") (S 1.23), - D "foo" (E (P "foo" "foo") (S 1.23)) [])))))))))) +{-# OPTIONS -fglasgow-exts #-}++module Reify (tests) where++{-++The following examples illustrate the reification facilities for type+structure. Most notably, we generate shallow terms using the depth of+types and constructors as means to steer the generation.++-}++import Test.HUnit++import Data.Maybe+import Data.Generics+import Control.Monad.State+import CompanyDatatypes++++------------------------------------------------------------------------------+--+-- Encoding types as values; some other way.+--+------------------------------------------------------------------------------++{-++This group provides a style of encoding types as values and using+them. This style is seen as an alternative to the pragmatic style used+in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"+to denote a type argument. This pragmatic style suffers from lack+of robustness: one feels tempted to pattern match on undefineds.+Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.++-}+++-- | Type as values to stipulate use of undefineds+type TypeVal a = a -> ()+++-- | The value that denotes a type+typeVal :: TypeVal a+typeVal = const ()+++-- | Test for type equivalence+sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool+sameType tva tvb = typeOf (type2val tva) ==+ typeOf (type2val tvb)+++-- | Map a value to its type+val2type :: a -> TypeVal a+val2type _ = typeVal+++-- | Stipulate this idiom!+type2val :: TypeVal a -> a+type2val _ = undefined+++-- | Constrain a type+withType :: a -> TypeVal a -> a+withType x _ = x+++-- | The argument type of a function+argType :: (a -> b) -> TypeVal a+argType _ = typeVal+++-- | The result type of a function+resType :: (a -> b) -> TypeVal b+resType _ = typeVal+++-- | The parameter type of type constructor+paraType :: t a -> TypeVal a+paraType _ = typeVal+++-- Type functions,+-- i.e., functions mapping types to values+--+type TypeFun a r = TypeVal a -> r++++-- Generic type functions,+-- i.e., functions mapping types to values+--+type GTypeFun r = forall a. Data a => TypeFun a r++++-- | Extend a type function+extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r+extType f x = maybe f id (cast x)++++------------------------------------------------------------------------------+--+-- Mapping operators to map over type structure+--+------------------------------------------------------------------------------+++-- | Query all constructors of a given type++gmapType :: ([(Constr,r')] -> r)+ -> GTypeFun (Constr -> r')+ -> GTypeFun r++gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)+ =+ o $ zip cons query++ where++ -- All constructors of the given type+ cons :: [Constr]+ cons = if isAlgType $ dataTypeOf $ type2val t+ then dataTypeConstrs $ dataTypeOf $ type2val t+ else []++ -- Query constructors+ query :: [r']+ query = map (f t) cons+++-- | Query all subterm types of a given constructor++gmapConstr :: ([r] -> r')+ -> GTypeFun r+ -> GTypeFun (Constr -> r')++gmapConstr (o::[r] -> r') f (t::TypeVal a) c+ =+ o $ query++ where++ -- Term for the given constructor+ term :: a+ term = fromConstr c++ -- Query subterm types+ query :: [r]+ query = gmapQ (f . val2type) term+++-- | Compute arity of a given constructor+constrArity :: GTypeFun (Constr -> Int)+constrArity t c = glength $ withType (fromConstr c) t+++-- | Query all immediate subterm types of a given type+gmapSubtermTypes :: (Data a, Typeable r)+ => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r+gmapSubtermTypes o (r::r) f (t::TypeVal a)+ =+ reduce (concat (map (gmapQ (query . val2type)) terms))+ (GTypeFun' f)++ where++ -- All constructors of the given type+ cons :: [Constr]+ cons = if isAlgType $ dataTypeOf $ type2val t+ then dataTypeConstrs $ dataTypeOf $ type2val t+ else []++ -- Terms for all constructors+ terms :: [a]+ terms = map fromConstr cons++ -- Query a subterm type+ query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)+ query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))++ -- Constant out given type+ disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r+ disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r++ -- Reduce all subterm types+ reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r+ reduce [] _ = r+ reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))+++-- First-class polymorphic variation on GTypeFun+newtype GTypeFun' r = GTypeFun' (GTypeFun r)+unGTypeFun' (GTypeFun' f) = f+++-- | Query all immediate subterm types.+-- There is an extra argument to \"constant out\" the type at hand.+-- This can be used to avoid cycles.++gmapSubtermTypesConst :: (Data a, Typeable r)+ => (r -> r -> r)+ -> r+ -> GTypeFun r+ -> TypeVal a+ -> r+gmapSubtermTypesConst o (r::r) f (t::TypeVal a)+ =+ gmapSubtermTypes o r f' t+ where+ f' :: GTypeFun r+ f' = f `extType` \(_::TypeVal a) -> r+++-- Count all distinct subterm types+gcountSubtermTypes :: Data a => TypeVal a -> Int+gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)+++-- | A simplied variation on gmapSubtermTypes.+-- Weakness: no awareness of doubles.+-- Strength: easy to comprehend as it uses gmapType and gmapConstr.++_gmapSubtermTypes :: (Data a, Typeable r)+ => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r+_gmapSubtermTypes o (r::r) f+ =+ gmapType otype (gmapConstr oconstr f)++ where++ otype :: [(Constr,r)] -> r+ otype = foldr (\x y -> snd x `o` y) r++ oconstr :: [r] -> r+ oconstr = foldr o r+++------------------------------------------------------------------------------+--+-- Some reifying relations on types+--+------------------------------------------------------------------------------+++-- | Reachability relation on types, i.e.,+-- test if nodes of type @a@ are reachable from nodes of type @b@.+-- The relation is defined to be reflexive.++reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool+reachableType (a::TypeVal a) (b::TypeVal b)+ =+ or [ sameType a b+ , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b+ ]+++-- | Depth of a datatype as the constructor with the minimum depth.+-- The outermost 'Nothing' denotes a type without constructors.+-- The innermost 'Nothing' denotes potentially infinite.++depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))+depthOfType p (t::TypeVal a)+ =+ gmapType o f t++ where++ o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)+ o l = if null l then Nothing else Just (foldr1 min' l)++ f :: GTypeFun (Constr -> Maybe Int)+ f = depthOfConstr p'++ -- Specific minimum operator+ min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)+ min' x (_, Nothing) = x+ min' (_, Nothing) x = x+ min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)+ min' (c, Just i) (c', Just i') = (c', Just i')++ -- Updated predicate for unblocked types+ p' :: GTypeFun Bool+ p' = p `extType` \(_::TypeVal a) -> False+++-- | Depth of a constructor.+-- Depth is viewed as the maximum depth of all subterm types + 1.+-- 'Nothing' denotes potentially infinite.++depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)+depthOfConstr p (t::TypeVal a) c+ =+ gmapConstr o f t c++ where++ o :: [Maybe Int] -> Maybe Int+ o = inc' . foldr max' (Just 0)++ f :: GTypeFun (Maybe Int)+ f t' = if p t'+ then+ case depthOfType p t' of+ Nothing -> Just 0+ Just (_, x) -> x+ else Nothing++ -- Specific maximum operator+ max' Nothing _ = Nothing+ max' _ Nothing = Nothing+ max' (Just i) (Just i') | i >= i' = Just i+ max' (Just i) (Just i') = Just i'++ -- Specific increment operator+ inc' Nothing = Nothing+ inc' (Just i) = Just (i+1)+++------------------------------------------------------------------------------+--+-- Build a shallow term+--+------------------------------------------------------------------------------++shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b)+shallowTerm cust+ = result+ where+ result :: forall b. Data b => b+ -- Need a type signature here to bring 'b' into scope+ result = maybe gdefault id cust+ where++ -- The worker, also used for type disambiguation+ gdefault :: b+ gdefault = case con of+ Just (con, Just _) -> fromConstrB (shallowTerm cust) con+ _ -> error "no shallow term!"++ -- The type to be constructed+ typeVal :: TypeVal b+ typeVal = val2type gdefault++ -- The most shallow constructor if any+ con :: Maybe (Constr, Maybe Int)+ con = depthOfType (const True) typeVal++++-- For testing shallowTerm+shallowTermBase :: GenericR Maybe+shallowTermBase = Nothing+ `extR` Just (1.23::Float)+ `extR` Just ("foo"::String)++++-- Sample datatypes+data T1 = T1a deriving (Typeable, Data) -- just a constant+data T2 = T2 T1 deriving (Typeable, Data) -- little detour+data T3 = T3a T3 | T3b T2 deriving (Typeable, Data) -- recursive case+data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters++++-- Sample type arguments+t0 = typeVal :: TypeVal Int+t1 = typeVal :: TypeVal T1+t2 = typeVal :: TypeVal T2+t3 = typeVal :: TypeVal T3+t4 = typeVal :: TypeVal T4+tCompany = typeVal :: TypeVal Company+tPerson = typeVal :: TypeVal Person+tEmployee = typeVal :: TypeVal Employee+tDept = typeVal :: TypeVal Dept++++-- Test cases+test0 = t1 `reachableType` t1 -- True+test1 = t1 `reachableType` t2 -- True+test2 = t2 `reachableType` t1 -- False+test3 = t1 `reachableType` t3+test4 = tPerson `reachableType` tCompany+test5 = gcountSubtermTypes tPerson+test6 = gcountSubtermTypes tEmployee+test7 = gcountSubtermTypes tDept+test8 = shallowTerm shallowTermBase :: Person+test9 = shallowTerm shallowTermBase :: Employee+test10 = shallowTerm shallowTermBase :: Dept++++tests = ( test0+ , ( test1+ , ( test2+ , ( test3+ , ( test4+ , ( test5+ , ( test6+ , ( test7+ , ( test8+ , ( test9+ , ( test10+ ))))))))))) ~=? output++output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo",+ (E (P "foo" "foo") (S 1.23),+ D "foo" (E (P "foo" "foo") (S 1.23)) []))))))))))
tests/Typecase1.hs view
@@ -1,59 +1,59 @@-{-# OPTIONS -fglasgow-exts #-} - -module Typecase1 (tests) where - -{- - -This test demonstrates type case as it lives in Data.Typeable. -We define a function f that converts typeables into strings in some way. -Note: we only need Data.Typeable. Say: Dynamics are NOT involved. - --} - -import Test.HUnit - -import Data.Typeable -import Data.Maybe - --- Some datatype. -data MyTypeable = MyCons String deriving (Show, Typeable) - --- --- Some function that performs type case. --- -f :: (Show a, Typeable a) => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) - - where - - -- do something with ints - int :: Int -> String - int a = "got an int, incremented: " ++ show (a + 1) - - -- do something with floats - float :: Float -> String - float a = "got a float, multiplied by .42: " ++ show (a * 0.42) - - -- do something with my typeables - mytys :: MyTypeable -> String - mytys a = "got a term: " ++ show a - - -- do something with all other typeables - others = "got something else: " ++ show a - - --- --- Test the type case --- -tests = ( f (41::Int) - , f (88::Float) - , f (MyCons "42") - , f True) ~=? output - -output = ( "got an int, incremented: 42" - , "got a float, multiplied by .42: 36.96" - , "got a term: MyCons \"42\"" +{-# OPTIONS -fglasgow-exts #-}++module Typecase1 (tests) where++{-++This test demonstrates type case as it lives in Data.Typeable.+We define a function f that converts typeables into strings in some way.+Note: we only need Data.Typeable. Say: Dynamics are NOT involved.++-}++import Test.HUnit++import Data.Typeable+import Data.Maybe++-- Some datatype.+data MyTypeable = MyCons String deriving (Show, Typeable)++--+-- Some function that performs type case.+--+f :: (Show a, Typeable a) => a -> String+f a = (maybe (maybe (maybe others+ mytys (cast a) )+ float (cast a) )+ int (cast a) )++ where++ -- do something with ints+ int :: Int -> String+ int a = "got an int, incremented: " ++ show (a + 1)++ -- do something with floats+ float :: Float -> String+ float a = "got a float, multiplied by .42: " ++ show (a * 0.42)++ -- do something with my typeables+ mytys :: MyTypeable -> String+ mytys a = "got a term: " ++ show a++ -- do something with all other typeables+ others = "got something else: " ++ show a+++--+-- Test the type case+--+tests = ( f (41::Int)+ , f (88::Float)+ , f (MyCons "42")+ , f True) ~=? output++output = ( "got an int, incremented: 42"+ , "got a float, multiplied by .42: 36.96"+ , "got a term: MyCons \"42\"" , "got something else: True")
tests/Typecase2.hs view
@@ -1,61 +1,61 @@-{-# OPTIONS -fglasgow-exts #-} - -module Typecase2 (tests) where - -{- - -This test provides a variation on typecase1.hs. -This time, we use generic show as defined for all instances of Data. -Thereby, we get rid of the Show constraint in our functions. -So we only keep a single constraint: the one for class Data. - --} - -import Test.HUnit - -import Data.Generics -import Data.Maybe - --- Some datatype. -data MyData = MyCons String deriving (Typeable, Data) - --- --- Some function that performs type case. --- -f :: Data a => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) - - where - - -- do something with ints - int :: Int -> String - int a = "got an int, incremented: " ++ show (a + 1) - - -- do something with floats - float :: Float -> String - float a = "got a float, multiplied by .42: " ++ show (a * 0.42) - - -- do something with my data - mytys :: MyData -> String - mytys a = "got my data: " ++ gshow a - - -- do something with all other data - others = "got something else: " ++ gshow a - - --- --- Test the type case --- -tests = ( f (41::Int) - , f (88::Float) - , f (MyCons "42") - , f True) ~=? output - -output = ( "got an int, incremented: 42" - , "got a float, multiplied by .42: 36.96" - , "got my data: (MyCons \"42\")" - , "got something else: (True)") - +{-# OPTIONS -fglasgow-exts #-}++module Typecase2 (tests) where++{-++This test provides a variation on typecase1.hs.+This time, we use generic show as defined for all instances of Data.+Thereby, we get rid of the Show constraint in our functions.+So we only keep a single constraint: the one for class Data.++-}++import Test.HUnit++import Data.Generics+import Data.Maybe++-- Some datatype.+data MyData = MyCons String deriving (Typeable, Data)++--+-- Some function that performs type case.+--+f :: Data a => a -> String+f a = (maybe (maybe (maybe others+ mytys (cast a) )+ float (cast a) )+ int (cast a) )++ where++ -- do something with ints+ int :: Int -> String+ int a = "got an int, incremented: " ++ show (a + 1)++ -- do something with floats+ float :: Float -> String+ float a = "got a float, multiplied by .42: " ++ show (a * 0.42)++ -- do something with my data+ mytys :: MyData -> String+ mytys a = "got my data: " ++ gshow a++ -- do something with all other data+ others = "got something else: " ++ gshow a+++--+-- Test the type case+--+tests = ( f (41::Int)+ , f (88::Float)+ , f (MyCons "42")+ , f True) ~=? output++output = ( "got an int, incremented: 42"+ , "got a float, multiplied by .42: 36.96"+ , "got my data: (MyCons \"42\")"+ , "got something else: (True)")+
tests/XML.hs view
@@ -1,195 +1,207 @@-{-# OPTIONS -fglasgow-exts #-} - -module XML (tests) where - -{- - -This example illustrates XMLish services -to trealise (say, "serialise") heterogenous -Haskell data as homogeneous tree structures -(say, XMLish elements) and vice versa. - --} - -import Test.HUnit - -import Control.Monad -import Data.Maybe -import Data.Generics -import CompanyDatatypes - - --- HaXml-like types for XML elements -data Element = Elem Name [Attribute] [Content] - deriving (Show, Eq, Typeable, Data) - -data Content = CElem Element - | CString Bool CharData - -- ^ bool is whether whitespace is significant - | CRef Reference - | CMisc Misc - deriving (Show, Eq, Typeable, Data) - -type CharData = String - - --- In this simple example we disable some parts of XML -type Attribute = () -type Reference = () -type Misc = () - - --- Trealisation -data2content :: Data a => a -> [Content] -data2content = element - `ext1Q` list - `extQ` string - `extQ` float - - where - - -- Handle an element - element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x))) - [] -- no attributes - (concat (gmapQ data2content x)))] - - -- A special case for lists - list :: Data a => [a] -> [Content] - list = concat . map data2content - - -- A special case for strings - string :: String -> [Content] - string x = [CString True x] - - -- A special case for floats - float :: Float -> [Content] - float x = [CString True (show x)] - - --- De-trealisation -content2data :: forall a. Data a => ReadX a -content2data = result - - where - - -- Case-discriminating worker - result = element - `ext1R` list - `extR` string - `extR` float - - - -- Determine type of data to be constructed - myType = myTypeOf result - where - myTypeOf :: forall a. ReadX a -> a - myTypeOf = undefined - - -- Handle an element - element = do c <- readX - case c of - (CElem (Elem x as cs)) - | as == [] -- no attributes - && x == (tyconUQname (dataTypeName (dataTypeOf myType))) - -> alts cs - _ -> mzero - - - -- A special case for lists - list :: forall a. Data a => ReadX [a] - list = ( do h <- content2data - t <- list - return (h:t) ) - `mplus` return [] - - -- Fold over all alternatives, say constructors - alts cs = foldr (mplus . recurse cs) mzero shapes - - -- Possible top-level shapes - shapes = map fromConstr consOf - - -- Retrieve all constructors of the requested type - consOf = dataTypeConstrs - $ dataTypeOf - $ myType - - -- Recurse into subterms - recurse cs x = maybe mzero - return - (runReadX (gmapM (const content2data) x) cs) - - -- A special case for strings - string :: ReadX String - string = do c <- readX - case c of - (CString _ x) -> return x - _ -> mzero - - -- A special case for floats - float :: ReadX Float - float = do c <- readX - case c of - (CString _ x) -> return (read x) - _ -> mzero - - - ------------------------------------------------------------------------------ --- --- An XML-hungry parser-like monad --- ------------------------------------------------------------------------------ - --- Type constructor -newtype ReadX a = - ReadX { unReadX :: [Content] - -> Maybe ([Content], a) } - --- Run a computation -runReadX x y = case unReadX x y of - Just ([],y) -> Just y - _ -> Nothing - --- Read one content particle -readX :: ReadX Content -readX = ReadX (\x -> if null x - then Nothing - else Just (tail x, head x) - ) - --- ReadX is a monad! -instance Monad ReadX where - return x = ReadX (\y -> Just (y,x)) - c >>= f = ReadX (\x -> case unReadX c x of - Nothing -> Nothing - Just (x', a) -> unReadX (f a) x' - ) - --- ReadX also accommodates mzero and mplus! -instance MonadPlus ReadX where - mzero = ReadX (const Nothing) - f `mplus` g = ReadX (\x -> case unReadX f x of - Nothing -> unReadX g x - y -> y - ) - - - ------------------------------------------------------------------------------ --- --- Main function for testing --- ------------------------------------------------------------------------------ - -tests = ( genCom - , ( data2content genCom - , ( zigzag person1 :: Maybe Person - , ( zigzag genCom :: Maybe Company - , ( zigzag genCom == Just genCom - ))))) ~=? output - where - -- Trealise back and forth - zigzag :: Data a => a -> Maybe a - zigzag = runReadX content2data . data2content - -output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True)))) +{-# OPTIONS -fglasgow-exts #-}++module XML (tests) where++{-++This example illustrates XMLish services+to trealise (say, "serialise") heterogenous+Haskell data as homogeneous tree structures+(say, XMLish elements) and vice versa.++-}++import Test.HUnit++import Control.Applicative (Alternative(..), Applicative(..))+import Control.Monad+import Data.Maybe+import Data.Generics+import CompanyDatatypes+++-- HaXml-like types for XML elements+data Element = Elem Name [Attribute] [Content]+ deriving (Show, Eq, Typeable, Data)++data Content = CElem Element+ | CString Bool CharData+ -- ^ bool is whether whitespace is significant+ | CRef Reference+ | CMisc Misc+ deriving (Show, Eq, Typeable, Data)++type CharData = String+++-- In this simple example we disable some parts of XML+type Attribute = ()+type Reference = ()+type Misc = ()+++-- Trealisation+data2content :: Data a => a -> [Content]+data2content = element+ `ext1Q` list+ `extQ` string + `extQ` float++ where++ -- Handle an element+ element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))+ [] -- no attributes + (concat (gmapQ data2content x)))]++ -- A special case for lists+ list :: Data a => [a] -> [Content]+ list = concat . map data2content++ -- A special case for strings+ string :: String -> [Content]+ string x = [CString True x]++ -- A special case for floats+ float :: Float -> [Content]+ float x = [CString True (show x)]+++-- De-trealisation+content2data :: forall a. Data a => ReadX a+content2data = result++ where+ + -- Case-discriminating worker+ result = element+ `ext1R` list+ `extR` string+ `extR` float+++ -- Determine type of data to be constructed+ myType = myTypeOf result+ where+ myTypeOf :: forall a. ReadX a -> a+ myTypeOf = undefined++ -- Handle an element+ element = do c <- readX+ case c of+ (CElem (Elem x as cs))+ | as == [] -- no attributes+ && x == (tyconUQname (dataTypeName (dataTypeOf myType)))+ -> alts cs+ _ -> mzero+++ -- A special case for lists+ list :: forall a. Data a => ReadX [a]+ list = ( do h <- content2data+ t <- list+ return (h:t) )+ `mplus` return []++ -- Fold over all alternatives, say constructors+ alts cs = foldr (mplus . recurse cs) mzero shapes++ -- Possible top-level shapes+ shapes = map fromConstr consOf++ -- Retrieve all constructors of the requested type+ consOf = dataTypeConstrs+ $ dataTypeOf + $ myType++ -- Recurse into subterms+ recurse cs x = maybe mzero+ return+ (runReadX (gmapM (const content2data) x) cs)++ -- A special case for strings+ string :: ReadX String+ string = do c <- readX+ case c of+ (CString _ x) -> return x+ _ -> mzero++ -- A special case for floats+ float :: ReadX Float+ float = do c <- readX+ case c of+ (CString _ x) -> return (read x)+ _ -> mzero++++-----------------------------------------------------------------------------+--+-- An XML-hungry parser-like monad+--+-----------------------------------------------------------------------------++-- Type constructor+newtype ReadX a =+ ReadX { unReadX :: [Content]+ -> Maybe ([Content], a) }++-- Run a computation+runReadX x y = case unReadX x y of + Just ([],y) -> Just y+ _ -> Nothing++-- Read one content particle+readX :: ReadX Content+readX = ReadX (\x -> if null x + then Nothing+ else Just (tail x, head x)+ )++instance Functor ReadX where+ fmap = liftM++instance Applicative ReadX where+ pure = return+ (<*>) = ap++instance Alternative ReadX where+ (<|>) = mplus+ empty = mzero++-- ReadX is a monad!+instance Monad ReadX where+ return x = ReadX (\y -> Just (y,x))+ c >>= f = ReadX (\x -> case unReadX c x of+ Nothing -> Nothing+ Just (x', a) -> unReadX (f a) x'+ )++-- ReadX also accommodates mzero and mplus!+instance MonadPlus ReadX where+ mzero = ReadX (const Nothing)+ f `mplus` g = ReadX (\x -> case unReadX f x of+ Nothing -> unReadX g x+ y -> y+ )++++-----------------------------------------------------------------------------+--+-- Main function for testing+--+-----------------------------------------------------------------------------++tests = ( genCom+ , ( data2content genCom+ , ( zigzag person1 :: Maybe Person+ , ( zigzag genCom :: Maybe Company+ , ( zigzag genCom == Just genCom+ ))))) ~=? output+ where + -- Trealise back and forth+ zigzag :: Data a => a -> Maybe a+ zigzag = runReadX content2data . data2content++output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))