syb 0.6 → 0.7
raw patch · 13 files changed
+1669/−1667 lines, 13 filesdep ~base
Dependency ranges changed: base
Files
- src/Data/Generics/Instances.hs +190/−188
- syb.cabal +1/−1
- tests/Bits.hs +225/−225
- tests/CompanyDatatypes.hs +39/−39
- tests/Encode.hs +88/−88
- tests/Ext1.hs +128/−128
- tests/GRead.hs +45/−45
- tests/GRead2.hs +75/−75
- tests/Perm.hs +139/−139
- tests/Reify.hs +413/−413
- tests/Typecase1.hs +58/−58
- tests/Typecase2.hs +61/−61
- tests/XML.hs +207/−207
src/Data/Generics/Instances.hs view
@@ -1,188 +1,190 @@-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-}--------------------------------------------------------------------------------- |--- Module : Data.Generics.Instances--- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the LICENSE file)------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable (uses Data.Data)------ \"Scrap your boilerplate\" --- Generic programming in Haskell--- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module--- contains thirteen 'Data' instances which are considered dubious (either--- because the types are abstract or just not meant to be traversed).--- Instances in this module might change or disappear in future releases--- of this package.------ (This module does not export anything. It really just defines instances.)-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Generics.Instances () where----------------------------------------------------------------------------------import Data.Data--#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Handle -- So we can give Data instance for Handle-#else-import GHC.IOBase -- So we can give Data instance for IO, Handle-#endif-import GHC.Stable -- So we can give Data instance for StablePtr-import GHC.ST -- So we can give Data instance for ST-import GHC.Conc -- So we can give Data instance for TVar-import Data.IORef -- So we can give Data instance for IORef-import Control.Concurrent -- So we can give Data instance for MVar-#else-# ifdef __HUGS__-import Hugs.Prelude( Ratio(..) )-# endif-import System.IO-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.StablePtr-import Control.Monad.ST-#endif---- Version compatibility issues caused by #2760-myMkNoRepType :: String -> DataType-#if __GLASGOW_HASKELL__ >= 611-myMkNoRepType = mkNoRepType-#else-myMkNoRepType = mkNorepType-#endif--------------------------------------------------------------------------------------- Instances of the Data class for Prelude-like types.--- We define top-level definitions for representations.---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Instances of abstract datatypes (6)---------------------------------------------------------------------------------instance Data TypeRep where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep"-----------------------------------------------------------------------------------instance Data TyCon where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon"----------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ < 709-deriving instance Typeable DataType-#endif--instance Data DataType where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType"-----------------------------------------------------------------------------------instance Data Handle where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle"-----------------------------------------------------------------------------------instance Typeable a => Data (StablePtr a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Data ThreadId where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId"-#endif------------------------------------------------------------------------------------ Dubious instances (7)---------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (TVar a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar"-#endif-----------------------------------------------------------------------------------instance Typeable a => Data (MVar a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (STM a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.Conc.STM"-#endif-----------------------------------------------------------------------------------instance (Typeable s, Typeable a) => Data (ST s a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.ST.ST"-----------------------------------------------------------------------------------instance Typeable a => Data (IORef a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef"-----------------------------------------------------------------------------------instance Typeable a => Data (IO a) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO"--------------------------------------------------------------------------------------- A last resort for functions-----instance (Data a, Data b) => Data (a -> b) where- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = myMkNoRepType "Prelude.(->)"- dataCast2 f = gcast2 f-+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Instances +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Data) +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module +-- contains thirteen 'Data' instances which are considered dubious (either +-- because the types are abstract or just not meant to be traversed). +-- Instances in this module might change or disappear in future releases +-- of this package. +-- +-- (This module does not export anything. It really just defines instances.) +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Generics.Instances () where + +------------------------------------------------------------------------------ + +import Data.Data + +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle -- So we can give Data instance for Handle +#else +import GHC.IOBase -- So we can give Data instance for IO, Handle +#endif +import GHC.Stable -- So we can give Data instance for StablePtr +import GHC.ST -- So we can give Data instance for ST +import GHC.Conc -- So we can give Data instance for TVar +import Data.IORef -- So we can give Data instance for IORef +import Control.Concurrent -- So we can give Data instance for MVar +#else +# ifdef __HUGS__ +import Hugs.Prelude( Ratio(..) ) +# endif +import System.IO +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.StablePtr +import Control.Monad.ST +#endif + +-- Version compatibility issues caused by #2760 +myMkNoRepType :: String -> DataType +#if __GLASGOW_HASKELL__ >= 611 +myMkNoRepType = mkNoRepType +#else +myMkNoRepType = mkNorepType +#endif + + +------------------------------------------------------------------------------ +-- +-- Instances of the Data class for Prelude-like types. +-- We define top-level definitions for representations. +-- +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- Instances of abstract datatypes (6) +------------------------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ < 801 +instance Data TypeRep where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" +#endif + + +------------------------------------------------------------------------------ + +instance Data TyCon where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" + + +------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ < 709 +deriving instance Typeable DataType +#endif + +instance Data DataType where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType" + + +------------------------------------------------------------------------------ + +instance Data Handle where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle" + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (StablePtr a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr" + + +------------------------------------------------------------------------------ + +#ifdef __GLASGOW_HASKELL__ +instance Data ThreadId where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId" +#endif + + +------------------------------------------------------------------------------ +-- Dubious instances (7) +------------------------------------------------------------------------------ + +#ifdef __GLASGOW_HASKELL__ +instance Typeable a => Data (TVar a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar" +#endif + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (MVar a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar" + + +------------------------------------------------------------------------------ + +#ifdef __GLASGOW_HASKELL__ +instance Typeable a => Data (STM a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.Conc.STM" +#endif + + +------------------------------------------------------------------------------ + +instance (Typeable s, Typeable a) => Data (ST s a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.ST.ST" + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (IORef a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef" + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (IO a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO" + +------------------------------------------------------------------------------ + +-- +-- A last resort for functions +-- + +instance (Data a, Data b) => Data (a -> b) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Prelude.(->)" + dataCast2 f = gcast2 f +
syb.cabal view
@@ -1,5 +1,5 @@ name: syb -version: 0.6 +version: 0.7 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes
tests/Bits.hs view
@@ -1,225 +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.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)))))+{-# 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/CompanyDatatypes.hs view
@@ -1,39 +1,39 @@-{-# OPTIONS -fglasgow-exts #-}--module CompanyDatatypes where--import Data.Generics (Data, Typeable)---- The organisational structure of a company--data Company = C [Dept] deriving (Eq, Show, Typeable, Data)-data Dept = D Name Manager [Unit] deriving (Eq, Show, Typeable, Data)-data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data)-data Employee = E Person Salary deriving (Eq, Show, Typeable, Data)-data Person = P Name Address deriving (Eq, Show, Typeable, Data)-data Salary = S Float deriving (Eq, Show, Typeable, Data)-type Manager = Employee-type Name = String-type Address = String---- An illustrative company-genCom :: Company-genCom = C [D "Research" laemmel [PU joost, PU marlow],- D "Strategy" blair []]---- A typo for the sake of testing equality;--- (cf. lammel vs. laemmel)-genCom' :: Company-genCom' = C [D "Research" lammel [PU joost, PU marlow],- D "Strategy" blair []]--lammel, laemmel, joost, marlow, blair :: Employee-lammel = E (P "Lammel" "Amsterdam") (S 8000)-laemmel = E (P "Laemmel" "Amsterdam") (S 8000)-joost = E (P "Joost" "Amsterdam") (S 1000)-marlow = E (P "Marlow" "Cambridge") (S 2000)-blair = E (P "Blair" "London") (S 100000)---- Some more test data-person1 = P "Lazy" "Home"-dept1 = D "Useless" (E person1 undefined) []+{-# OPTIONS -fglasgow-exts #-} + +module CompanyDatatypes where + +import Data.Generics (Data, Typeable) + +-- The organisational structure of a company + +data Company = C [Dept] deriving (Eq, Show, Typeable, Data) +data Dept = D Name Manager [Unit] deriving (Eq, Show, Typeable, Data) +data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data) +data Employee = E Person Salary deriving (Eq, Show, Typeable, Data) +data Person = P Name Address deriving (Eq, Show, Typeable, Data) +data Salary = S Float deriving (Eq, Show, Typeable, Data) +type Manager = Employee +type Name = String +type Address = String + +-- An illustrative company +genCom :: Company +genCom = C [D "Research" laemmel [PU joost, PU marlow], + D "Strategy" blair []] + +-- A typo for the sake of testing equality; +-- (cf. lammel vs. laemmel) +genCom' :: Company +genCom' = C [D "Research" lammel [PU joost, PU marlow], + D "Strategy" blair []] + +lammel, laemmel, joost, marlow, blair :: Employee +lammel = E (P "Lammel" "Amsterdam") (S 8000) +laemmel = E (P "Laemmel" "Amsterdam") (S 8000) +joost = E (P "Joost" "Amsterdam") (S 1000) +marlow = E (P "Marlow" "Cambridge") (S 2000) +blair = E (P "Blair" "London") (S 100000) + +-- Some more test data +person1 = P "Lazy" "Home" +dept1 = D "Useless" (E person1 undefined) []
tests/Encode.hs view
@@ -1,88 +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 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) }+{-# 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,128 +1,128 @@-{-# 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)))))+{-# 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,75 +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 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 }+{-# 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,139 +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.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))))+{-# 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,207 +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.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))))+{-# 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))))