Data/Data.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Data
   4 -- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (local universal quantification)
  10 --
  11 -- \"Scrap your boilerplate\" --- Generic programming in Haskell.
  12 -- See <http://www.cs.vu.nl/boilerplate/>. This module provides
  13 -- the 'Data' class with its primitives for generic programming, along
  14 -- with instances for many datatypes. It corresponds to a merge between
  15 -- the previous "Data.Generics.Basics" and almost all of
  16 -- "Data.Generics.Instances". The instances that are not present
  17 -- in this module are available in "Data.Generics.Instances".
  18 --
  19 --
  20 -----------------------------------------------------------------------------
  21
  22 module Data.Data (
  23
  24         -- * Module Data.Typeable re-exported for convenience
  25         module Data.Typeable,
  26
  27         -- * The Data class for processing constructor applications
  28         Data(
  29                 gfoldl,         -- :: ... -> a -> c a
  30                 gunfold,        -- :: ... -> Constr -> c a
  31                 toConstr,       -- :: a -> Constr
  32                 dataTypeOf,     -- :: a -> DataType
  33                 dataCast1,      -- mediate types and unary type constructors
  34                 dataCast2,      -- mediate types and binary type constructors
  35                 -- Generic maps defined in terms of gfoldl
  36                 gmapT,
  37                 gmapQ,
  38                 gmapQl,
  39                 gmapQr,
  40                 gmapQi,
  41                 gmapM,
  42                 gmapMp,
  43                 gmapMo
  44             ),
  45
  46         -- * Datatype representations
  47         DataType,       -- abstract, instance of: Show
  48         -- ** Constructors
  49         mkDataType,     -- :: String   -> [Constr] -> DataType
  50         mkIntType,      -- :: String -> DataType
  51         mkFloatType,    -- :: String -> DataType
  52         mkStringType,   -- :: String -> DataType
  53         mkNorepType,    -- :: String -> DataType
  54         -- ** Observers
  55         dataTypeName,   -- :: DataType -> String
  56         DataRep(..),    -- instance of: Eq, Show
  57         dataTypeRep,    -- :: DataType -> DataRep
  58         -- ** Convenience functions
  59         repConstr,      -- :: DataType -> ConstrRep -> Constr
  60         isAlgType,      -- :: DataType -> Bool
  61         dataTypeConstrs,-- :: DataType -> [Constr]
  62         indexConstr,    -- :: DataType -> ConIndex -> Constr
  63         maxConstrIndex, -- :: DataType -> ConIndex
  64         isNorepType,    -- :: DataType -> Bool
  65
  66         -- * Data constructor representations
  67         Constr,         -- abstract, instance of: Eq, Show
  68         ConIndex,       -- alias for Int, start at 1
  69         Fixity(..),     -- instance of: Eq, Show
  70         -- ** Constructors
  71         mkConstr,       -- :: DataType -> String -> Fixity -> Constr
  72         mkIntConstr,    -- :: DataType -> Integer -> Constr
  73         mkFloatConstr,  -- :: DataType -> Double  -> Constr
  74         mkStringConstr, -- :: DataType -> String  -> Constr
  75         -- ** Observers
  76         constrType,     -- :: Constr   -> DataType
  77         ConstrRep(..),  -- instance of: Eq, Show
  78         constrRep,      -- :: Constr   -> ConstrRep
  79         constrFields,   -- :: Constr   -> [String]
  80         constrFixity,   -- :: Constr   -> Fixity
  81         -- ** Convenience function: algebraic data types
  82         constrIndex,    -- :: Constr   -> ConIndex
  83         -- ** From strings to constructors and vice versa: all data types
  84         showConstr,     -- :: Constr   -> String
  85         readConstr,     -- :: DataType -> String -> Maybe Constr
  86
  87         -- * Convenience functions: take type constructors apart
  88         tyconUQname,    -- :: String -> String
  89         tyconModule,    -- :: String -> String
  90
  91         -- * Generic operations defined in terms of 'gunfold'
  92         fromConstr,     -- :: Constr -> a
  93         fromConstrB,    -- :: ... -> Constr -> a
  94         fromConstrM     -- :: Monad m => ... -> Constr -> m a
  95
  96   ) where
  97
  98
  99 ------------------------------------------------------------------------------
 100
 101 import Prelude -- necessary to get dependencies right
 102
 103 import Data.Typeable
 104 import Data.Maybe
 105 import Control.Monad
 106
 107 -- Imports for the instances
 108 import Data.Typeable
 109 import Data.Int              -- So we can give Data instance for Int8, ...
 110 import Data.Word             -- So we can give Data instance for Word8, ...
 111 #ifdef __GLASGOW_HASKELL__
 112 import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio
 113 --import GHC.IOBase            -- So we can give Data instance for IO, Handle
 114 import GHC.Ptr               -- So we can give Data instance for Ptr
 115 import GHC.ForeignPtr        -- So we can give Data instance for ForeignPtr
 116 --import GHC.Stable            -- So we can give Data instance for StablePtr
 117 --import GHC.ST                -- So we can give Data instance for ST
 118 --import GHC.Conc              -- So we can give Data instance for MVar & Co.
 119 import GHC.Arr               -- So we can give Data instance for Array
 120 #else
 121 # ifdef __HUGS__
 122 import Hugs.Prelude( Ratio(..) )
 123 # endif
 124 import System.IO
 125 import Foreign.Ptr
 126 import Foreign.ForeignPtr
 127 import Foreign.StablePtr
 128 import Control.Monad.ST
 129 import Control.Concurrent
 130 import Data.Array
 131 import Data.IORef
 132 #endif
 133
 134 #include "Typeable.h"
 135
 136
 137
 138 ------------------------------------------------------------------------------
 139 --
 140 --      The Data class
 141 --
 142 ------------------------------------------------------------------------------
 143
 144 {- |
 145 The 'Data' class comprehends a fundamental primitive 'gfoldl' for
 146 folding over constructor applications, say terms. This primitive can
 147 be instantiated in several ways to map over the immediate subterms
 148 of a term; see the @gmap@ combinators later in this class.  Indeed, a
 149 generic programmer does not necessarily need to use the ingenious gfoldl
 150 primitive but rather the intuitive @gmap@ combinators.  The 'gfoldl'
 151 primitive is completed by means to query top-level constructors, to
 152 turn constructor representations into proper terms, and to list all
 153 possible datatype constructors.  This completion allows us to serve
 154 generic programming scenarios like read, show, equality, term generation.
 155
 156 The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with
 157 default definitions in terms of 'gfoldl', leaving open the opportunity
 158 to provide datatype-specific definitions.
 159 (The inclusion of the @gmap@ combinators as members of class 'Data'
 160 allows the programmer or the compiler to derive specialised, and maybe
 161 more efficient code per datatype.  /Note/: 'gfoldl' is more higher-order
 162 than the @gmap@ combinators.  This is subject to ongoing benchmarking
 163 experiments.  It might turn out that the @gmap@ combinators will be
 164 moved out of the class 'Data'.)
 165
 166 Conceptually, the definition of the @gmap@ combinators in terms of the
 167 primitive 'gfoldl' requires the identification of the 'gfoldl' function
 168 arguments.  Technically, we also need to identify the type constructor
 169 @c@ for the construction of the result type from the folded term type.
 170
 171 In the definition of @gmapQ@/x/ combinators, we use phantom type
 172 constructors for the @c@ in the type of 'gfoldl' because the result type
 173 of a query does not involve the (polymorphic) type of the term argument.
 174 In the definition of 'gmapQl' we simply use the plain constant type
 175 constructor because 'gfoldl' is left-associative anyway and so it is
 176 readily suited to fold a left-associative binary operation over the
 177 immediate subterms.  In the definition of gmapQr, extra effort is
 178 needed. We use a higher-order accumulation trick to mediate between
 179 left-associative constructor application vs. right-associative binary
 180 operation (e.g., @(:)@).  When the query is meant to compute a value
 181 of type @r@, then the result type withing generic folding is @r -> r@.
 182 So the result of folding is a function to which we finally pass the
 183 right unit.
 184
 185 With the @-XDeriveDataTypeable@ option, GHC can generate instances of the
 186 'Data' class automatically.  For example, given the declaration
 187
 188 > data T a b = C1 a b | C2 deriving (Typeable, Data)
 189
 190 GHC will generate an instance that is equivalent to
 191
 192 > instance (Data a, Data b) => Data (T a b) where
 193 >     gfoldl k z (C1 a b) = z C1 `k` a `k` b
 194 >     gfoldl k z C2       = z C2
 195 >
 196 >     gunfold k z c = case constrIndex c of
 197 >                         1 -> k (k (z C1))
 198 >                         2 -> z C2
 199 >
 200 >     toConstr (C1 _ _) = con_C1
 201 >     toConstr C2       = con_C2
 202 >
 203 >     dataTypeOf _ = ty_T
 204 >
 205 > con_C1 = mkConstr ty_T "C1" [] Prefix
 206 > con_C2 = mkConstr ty_T "C2" [] Prefix
 207 > ty_T   = mkDataType "Module.T" [con_C1, con_C2]
 208
 209 This is suitable for datatypes that are exported transparently.
 210
 211 -}
 212
 213 class Typeable a => Data a where
 214
 215   -- | Left-associative fold operation for constructor applications.
 216   --
 217   -- The type of 'gfoldl' is a headache, but operationally it is a simple
 218   -- generalisation of a list fold.
 219   --
 220   -- The default definition for 'gfoldl' is @'const' 'id'@, which is
 221   -- suitable for abstract datatypes with no substructures.
 222   gfoldl  :: (forall d b. Data d => c (d -> b) -> d -> c b)
 223                 -- ^ defines how nonempty constructor applications are
 224                 -- folded.  It takes the folded tail of the constructor
 225                 -- application and its head, i.e., an immediate subterm,
 226                 -- and combines them in some way.
 227           -> (forall g. g -> c g)
 228                 -- ^ defines how the empty constructor application is
 229                 -- folded, like the neutral \/ start element for list
 230                 -- folding.
 231           -> a
 232                 -- ^ structure to be folded.
 233           -> c a
 234                 -- ^ result, with a type defined in terms of @a@, but
 235                 -- variability is achieved by means of type constructor
 236                 -- @c@ for the construction of the actual result type.
 237
 238   -- See the 'Data' instances in this file for an illustration of 'gfoldl'.
 239
 240   gfoldl _ z = z
 241
 242   -- | Unfolding constructor applications
 243   gunfold :: (forall b r. Data b => c (b -> r) -> c r)
 244           -> (forall r. r -> c r)
 245           -> Constr
 246           -> c a
 247
 248   -- | Obtaining the constructor from a given datum.
 249   -- For proper terms, this is meant to be the top-level constructor.
 250   -- Primitive datatypes are here viewed as potentially infinite sets of
 251   -- values (i.e., constructors).
 252   toConstr   :: a -> Constr
 253
 254
 255   -- | The outer type constructor of the type
 256   dataTypeOf  :: a -> DataType
 257
 258
 259
 260 ------------------------------------------------------------------------------
 261 --
 262 -- Mediate types and type constructors
 263 --
 264 ------------------------------------------------------------------------------
 265
 266   -- | Mediate types and unary type constructors.
 267   -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined
 268   -- as 'gcast1'.
 269   --
 270   -- The default definition is @'const' 'Nothing'@, which is appropriate
 271   -- for non-unary type constructors.
 272   dataCast1 :: Typeable1 t
 273             => (forall d. Data d => c (t d))
 274             -> Maybe (c a)
 275   dataCast1 _ = Nothing
 276
 277   -- | Mediate types and binary type constructors.
 278   -- In 'Data' instances of the form @T a b@, 'dataCast2' should be
 279   -- defined as 'gcast2'.
 280   --
 281   -- The default definition is @'const' 'Nothing'@, which is appropriate
 282   -- for non-binary type constructors.
 283   dataCast2 :: Typeable2 t
 284             => (forall d e. (Data d, Data e) => c (t d e))
 285             -> Maybe (c a)
 286   dataCast2 _ = Nothing
 287
 288
 289
 290 ------------------------------------------------------------------------------
 291 --
 292 --      Typical generic maps defined in terms of gfoldl
 293 --
 294 ------------------------------------------------------------------------------
 295
 296
 297   -- | A generic transformation that maps over the immediate subterms
 298   --
 299   -- The default definition instantiates the type constructor @c@ in the
 300   -- type of 'gfoldl' to an identity datatype constructor, using the
 301   -- isomorphism pair as injection and projection.
 302   gmapT :: (forall b. Data b => b -> b) -> a -> a
 303
 304   -- Use an identity datatype constructor ID (see below)
 305   -- to instantiate the type constructor c in the type of gfoldl,
 306   -- and perform injections ID and projections unID accordingly.
 307   --
 308   gmapT f x0 = unID (gfoldl k ID x0)
 309     where
 310       k (ID c) x = ID (c (f x))
 311
 312
 313   -- | A generic query with a left-associative binary operator
 314   gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
 315   gmapQl o r f = unCONST . gfoldl k z
 316     where
 317       k c x = CONST $ (unCONST c) `o` f x
 318       z _   = CONST r
 319
 320   -- | A generic query with a right-associative binary operator
 321   gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
 322   gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0
 323     where
 324       k (Qr c) x = Qr (\r -> c (f x `o` r))
 325
 326
 327   -- | A generic query that processes the immediate subterms and returns a list
 328   -- of results.  The list is given in the same order as originally specified
 329   -- in the declaratoin of the data constructors.
 330   gmapQ :: (forall d. Data d => d -> u) -> a -> [u]
 331   gmapQ f = gmapQr (:) [] f
 332
 333
 334   -- | A generic query that processes one child by index (zero-based)
 335   gmapQi :: Int -> (forall d. Data d => d -> u) -> a -> u
 336   gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q }
 337     where
 338       k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)
 339       z _           = Qi 0 Nothing
 340
 341
 342   -- | A generic monadic transformation that maps over the immediate subterms
 343   --
 344   -- The default definition instantiates the type constructor @c@ in
 345   -- the type of 'gfoldl' to the monad datatype constructor, defining
 346   -- injection and projection using 'return' and '>>='.
 347   gmapM   :: Monad m => (forall d. Data d => d -> m d) -> a -> m a
 348
 349   -- Use immediately the monad datatype constructor
 350   -- to instantiate the type constructor c in the type of gfoldl,
 351   -- so injection and projection is done by return and >>=.
 352   --
 353   gmapM f = gfoldl k return
 354     where
 355       k c x = do c' <- c
 356                  x' <- f x
 357                  return (c' x')
 358
 359
 360   -- | Transformation of at least one immediate subterm does not fail
 361   gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
 362
 363 {-
 364
 365 The type constructor that we use here simply keeps track of the fact
 366 if we already succeeded for an immediate subterm; see Mp below. To
 367 this end, we couple the monadic computation with a Boolean.
 368
 369 -}
 370
 371   gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) ->
 372                 if b then return x' else mzero
 373     where
 374       z g = Mp (return (g,False))
 375       k (Mp c) y
 376         = Mp ( c >>= \(h, b) ->
 377                  (f y >>= \y' -> return (h y', True))
 378                  `mplus` return (h y, b)
 379              )
 380
 381   -- | Transformation of one immediate subterm with success
 382   gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
 383
 384 {-
 385
 386 We use the same pairing trick as for gmapMp,
 387 i.e., we use an extra Bool component to keep track of the
 388 fact whether an immediate subterm was processed successfully.
 389 However, we cut of mapping over subterms once a first subterm
 390 was transformed successfully.
 391
 392 -}
 393
 394   gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) ->
 395                 if b then return x' else mzero
 396     where
 397       z g = Mp (return (g,False))
 398       k (Mp c) y
 399         = Mp ( c >>= \(h,b) -> if b
 400                         then return (h y, b)
 401                         else (f y >>= \y' -> return (h y',True))
 402                              `mplus` return (h y, b)
 403              )
 404
 405
 406 -- | The identity type constructor needed for the definition of gmapT
 407 newtype ID x = ID { unID :: x }
 408
 409
 410 -- | The constant type constructor needed for the definition of gmapQl
 411 newtype CONST c a = CONST { unCONST :: c }
 412
 413
 414 -- | Type constructor for adding counters to queries
 415 data Qi q a = Qi Int (Maybe q)
 416
 417
 418 -- | The type constructor used in definition of gmapQr
 419 newtype Qr r a = Qr { unQr  :: r -> r }
 420
 421
 422 -- | The type constructor used in definition of gmapMp
 423 newtype Mp m x = Mp { unMp :: m (x, Bool) }
 424
 425
 426
 427 ------------------------------------------------------------------------------
 428 --
 429 --      Generic unfolding
 430 --
 431 ------------------------------------------------------------------------------
 432
 433
 434 -- | Build a term skeleton
 435 fromConstr :: Data a => Constr -> a
 436 fromConstr = fromConstrB undefined
 437
 438
 439 -- | Build a term and use a generic function for subterms
 440 fromConstrB :: Data a
 441             => (forall d. Data d => d)
 442             -> Constr
 443             -> a
 444 fromConstrB f = unID . gunfold k z
 445  where
 446   k c = ID (unID c f)
 447   z = ID
 448
 449
 450 -- | Monadic variation on 'fromConstrB'
 451 fromConstrM :: (Monad m, Data a)
 452             => (forall d. Data d => m d)
 453             -> Constr
 454             -> m a
 455 fromConstrM f = gunfold k z
 456  where
 457   k c = do { c' <- c; b <- f; return (c' b) }
 458   z = return
 459
 460
 461
 462 ------------------------------------------------------------------------------
 463 --
 464 --      Datatype and constructor representations
 465 --
 466 ------------------------------------------------------------------------------
 467
 468
 469 --
 470 -- | Representation of datatypes.
 471 -- A package of constructor representations with names of type and module.
 472 --
 473 data DataType = DataType
 474                         { tycon   :: String
 475                         , datarep :: DataRep
 476                         }
 477
 478               deriving Show
 479
 480
 481 -- | Representation of constructors
 482 data Constr = Constr
 483                         { conrep    :: ConstrRep
 484                         , constring :: String
 485                         , confields :: [String] -- for AlgRep only
 486                         , confixity :: Fixity   -- for AlgRep only
 487                         , datatype  :: DataType
 488                         }
 489
 490 instance Show Constr where
 491  show = constring
 492
 493
 494 -- | Equality of constructors
 495 instance Eq Constr where
 496   c == c' = constrRep c == constrRep c'
 497
 498
 499 -- | Public representation of datatypes
 500 data DataRep = AlgRep [Constr]
 501              | IntRep
 502              | FloatRep
 503              | StringRep
 504              | NoRep
 505
 506             deriving (Eq,Show)
 507 -- The list of constructors could be an array, a balanced tree, or others.
 508
 509
 510 -- | Public representation of constructors
 511 data ConstrRep = AlgConstr    ConIndex
 512                | IntConstr    Integer
 513                | FloatConstr  Double
 514                | StringConstr String
 515
 516                deriving (Eq,Show)
 517
 518
 519 -- | Unique index for datatype constructors,
 520 -- counting from 1 in the order they are given in the program text.
 521 type ConIndex = Int
 522
 523
 524 -- | Fixity of constructors
 525 data Fixity = Prefix
 526             | Infix     -- Later: add associativity and precedence
 527
 528             deriving (Eq,Show)
 529
 530
 531 ------------------------------------------------------------------------------
 532 --
 533 --      Observers for datatype representations
 534 --
 535 ------------------------------------------------------------------------------
 536
 537
 538 -- | Gets the type constructor including the module
 539 dataTypeName :: DataType -> String
 540 dataTypeName = tycon
 541
 542
 543
 544 -- | Gets the public presentation of a datatype
 545 dataTypeRep :: DataType -> DataRep
 546 dataTypeRep = datarep
 547
 548
 549 -- | Gets the datatype of a constructor
 550 constrType :: Constr -> DataType
 551 constrType = datatype
 552
 553
 554 -- | Gets the public presentation of constructors
 555 constrRep :: Constr -> ConstrRep
 556 constrRep = conrep
 557
 558
 559 -- | Look up a constructor by its representation
 560 repConstr :: DataType -> ConstrRep -> Constr
 561 repConstr dt cr =
 562       case (dataTypeRep dt, cr) of
 563         (AlgRep cs, AlgConstr i)      -> cs !! (i-1)
 564         (IntRep,    IntConstr i)      -> mkIntConstr dt i
 565         (FloatRep,  FloatConstr f)    -> mkFloatConstr dt f
 566         (StringRep, StringConstr str) -> mkStringConstr dt str
 567         _ -> error "repConstr"
 568
 569
 570
 571 ------------------------------------------------------------------------------
 572 --
 573 --      Representations of algebraic data types
 574 --
 575 ------------------------------------------------------------------------------
 576
 577
 578 -- | Constructs an algebraic datatype
 579 mkDataType :: String -> [Constr] -> DataType
 580 mkDataType str cs = DataType
 581                         { tycon   = str
 582                         , datarep = AlgRep cs
 583                         }
 584
 585
 586 -- | Constructs a constructor
 587 mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
 588 mkConstr dt str fields fix =
 589         Constr
 590                 { conrep    = AlgConstr idx
 591                 , constring = str
 592                 , confields = fields
 593                 , confixity = fix
 594                 , datatype  = dt
 595                 }
 596   where
 597     idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
 598                      showConstr c == str ]
 599
 600
 601 -- | Gets the constructors of an algebraic datatype
 602 dataTypeConstrs :: DataType -> [Constr]
 603 dataTypeConstrs dt = case datarep dt of
 604                         (AlgRep cons) -> cons
 605                         _ -> error "dataTypeConstrs"
 606
 607
 608 -- | Gets the field labels of a constructor.  The list of labels
 609 -- is returned in the same order as they were given in the original
 610 -- constructor declaration.
 611 constrFields :: Constr -> [String]
 612 constrFields = confields
 613
 614
 615 -- | Gets the fixity of a constructor
 616 constrFixity :: Constr -> Fixity
 617 constrFixity = confixity
 618
 619
 620
 621 ------------------------------------------------------------------------------
 622 --
 623 --      From strings to constr's and vice versa: all data types
 624 --
 625 ------------------------------------------------------------------------------
 626
 627
 628 -- | Gets the string for a constructor
 629 showConstr :: Constr -> String
 630 showConstr = constring
 631
 632
 633 -- | Lookup a constructor via a string
 634 readConstr :: DataType -> String -> Maybe Constr
 635 readConstr dt str =
 636       case dataTypeRep dt of
 637         AlgRep cons -> idx cons
 638         IntRep      -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
 639         FloatRep    -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
 640         StringRep   -> Just (mkStringConstr dt str)
 641         NoRep       -> Nothing
 642   where
 643
 644     -- Read a value and build a constructor
 645     mkReadCon :: Read t => (t -> Constr) -> Maybe Constr
 646     mkReadCon f = case (reads str) of
 647                     [(t,"")] -> Just (f t)
 648                     _ -> Nothing
 649
 650     -- Traverse list of algebraic datatype constructors
 651     idx :: [Constr] -> Maybe Constr
 652     idx cons = let fit = filter ((==) str . showConstr) cons
 653                 in if fit == []
 654                      then Nothing
 655                      else Just (head fit)
 656
 657
 658 ------------------------------------------------------------------------------
 659 --
 660 --      Convenience funtions: algebraic data types
 661 --
 662 ------------------------------------------------------------------------------
 663
 664
 665 -- | Test for an algebraic type
 666 isAlgType :: DataType -> Bool
 667 isAlgType dt = case datarep dt of
 668                  (AlgRep _) -> True
 669                  _ -> False
 670
 671
 672 -- | Gets the constructor for an index (algebraic datatypes only)
 673 indexConstr :: DataType -> ConIndex -> Constr
 674 indexConstr dt idx = case datarep dt of
 675                         (AlgRep cs) -> cs !! (idx-1)
 676                         _           -> error "indexConstr"
 677
 678
 679 -- | Gets the index of a constructor (algebraic datatypes only)
 680 constrIndex :: Constr -> ConIndex
 681 constrIndex con = case constrRep con of
 682                     (AlgConstr idx) -> idx
 683                     _ -> error "constrIndex"
 684
 685
 686 -- | Gets the maximum constructor index of an algebraic datatype
 687 maxConstrIndex :: DataType -> ConIndex
 688 maxConstrIndex dt = case dataTypeRep dt of
 689                         AlgRep cs -> length cs
 690                         _            -> error "maxConstrIndex"
 691
 692
 693
 694 ------------------------------------------------------------------------------
 695 --
 696 --      Representation of primitive types
 697 --
 698 ------------------------------------------------------------------------------
 699
 700
 701 -- | Constructs the 'Int' type
 702 mkIntType :: String -> DataType
 703 mkIntType = mkPrimType IntRep
 704
 705
 706 -- | Constructs the 'Float' type
 707 mkFloatType :: String -> DataType
 708 mkFloatType = mkPrimType FloatRep
 709
 710
 711 -- | Constructs the 'String' type
 712 mkStringType :: String -> DataType
 713 mkStringType = mkPrimType StringRep
 714
 715
 716 -- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType'
 717 mkPrimType :: DataRep -> String -> DataType
 718 mkPrimType dr str = DataType
 719                         { tycon   = str
 720                         , datarep = dr
 721                         }
 722
 723
 724 -- Makes a constructor for primitive types
 725 mkPrimCon :: DataType -> String -> ConstrRep -> Constr
 726 mkPrimCon dt str cr = Constr
 727                         { datatype  = dt
 728                         , conrep    = cr
 729                         , constring = str
 730                         , confields = error "constrFields"
 731                         , confixity = error "constrFixity"
 732                         }
 733
 734
 735 mkIntConstr :: DataType -> Integer -> Constr
 736 mkIntConstr dt i = case datarep dt of
 737                   IntRep -> mkPrimCon dt (show i) (IntConstr i)
 738                   _ -> error "mkIntConstr"
 739
 740
 741 mkFloatConstr :: DataType -> Double -> Constr
 742 mkFloatConstr dt f = case datarep dt of
 743                     FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
 744                     _ -> error "mkFloatConstr"
 745
 746
 747 mkStringConstr :: DataType -> String -> Constr
 748 mkStringConstr dt str = case datarep dt of
 749                        StringRep -> mkPrimCon dt str (StringConstr str)
 750                        _ -> error "mkStringConstr"
 751
 752
 753 ------------------------------------------------------------------------------
 754 --
 755 --      Non-representations for non-presentable types
 756 --
 757 ------------------------------------------------------------------------------
 758
 759
 760 -- | Constructs a non-representation for a non-presentable type
 761 mkNorepType :: String -> DataType
 762 mkNorepType str = DataType
 763                         { tycon   = str
 764                         , datarep = NoRep
 765                         }
 766
 767
 768 -- | Test for a non-representable type
 769 isNorepType :: DataType -> Bool
 770 isNorepType dt = case datarep dt of
 771                    NoRep -> True
 772                    _ -> False
 773
 774
 775
 776 ------------------------------------------------------------------------------
 777 --
 778 --      Convenience for qualified type constructors
 779 --
 780 ------------------------------------------------------------------------------
 781
 782
 783 -- | Gets the unqualified type constructor:
 784 -- drop *.*.*... before name
 785 --
 786 tyconUQname :: String -> String
 787 tyconUQname x = let x' = dropWhile (not . (==) '.') x
 788                  in if x' == [] then x else tyconUQname (tail x')
 789
 790
 791 -- | Gets the module of a type constructor:
 792 -- take *.*.*... before name
 793 tyconModule :: String -> String
 794 tyconModule x = let (a,b) = break ((==) '.') x
 795                  in if b == ""
 796                       then b
 797                       else a ++ tyconModule' (tail b)
 798   where
 799     tyconModule' y = let y' = tyconModule y
 800                       in if y' == "" then "" else ('.':y')
 801
 802
 803
 804
 805 ------------------------------------------------------------------------------
 806 ------------------------------------------------------------------------------
 807 --
 808 --      Instances of the Data class for Prelude-like types.
 809 --      We define top-level definitions for representations.
 810 --
 811 ------------------------------------------------------------------------------
 812
 813
 814 falseConstr :: Constr
 815 falseConstr  = mkConstr boolDataType "False" [] Prefix
 816 trueConstr :: Constr
 817 trueConstr   = mkConstr boolDataType "True"  [] Prefix
 818
 819 boolDataType :: DataType
 820 boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr]
 821
 822 instance Data Bool where
 823   toConstr False = falseConstr
 824   toConstr True  = trueConstr
 825   gunfold _ z c  = case constrIndex c of
 826                      1 -> z False
 827                      2 -> z True
 828                      _ -> error "gunfold"
 829   dataTypeOf _ = boolDataType
 830
 831
 832 ------------------------------------------------------------------------------
 833
 834 charType :: DataType
 835 charType = mkStringType "Prelude.Char"
 836
 837 instance Data Char where
 838   toConstr x = mkStringConstr charType [x]
 839   gunfold _ z c = case constrRep c of
 840                     (StringConstr [x]) -> z x
 841                     _ -> error "gunfold"
 842   dataTypeOf _ = charType
 843
 844
 845 ------------------------------------------------------------------------------
 846
 847 floatType :: DataType
 848 floatType = mkFloatType "Prelude.Float"
 849
 850 instance Data Float where
 851   toConstr x = mkFloatConstr floatType (realToFrac x)
 852   gunfold _ z c = case constrRep c of
 853                     (FloatConstr x) -> z (realToFrac x)
 854                     _ -> error "gunfold"
 855   dataTypeOf _ = floatType
 856
 857
 858 ------------------------------------------------------------------------------
 859
 860 doubleType :: DataType
 861 doubleType = mkFloatType "Prelude.Double"
 862
 863 instance Data Double where
 864   toConstr = mkFloatConstr floatType
 865   gunfold _ z c = case constrRep c of
 866                     (FloatConstr x) -> z x
 867                     _ -> error "gunfold"
 868   dataTypeOf _ = doubleType
 869
 870
 871 ------------------------------------------------------------------------------
 872
 873 intType :: DataType
 874 intType = mkIntType "Prelude.Int"
 875
 876 instance Data Int where
 877   toConstr x = mkIntConstr intType (fromIntegral x)
 878   gunfold _ z c = case constrRep c of
 879                     (IntConstr x) -> z (fromIntegral x)
 880                     _ -> error "gunfold"
 881   dataTypeOf _ = intType
 882
 883
 884 ------------------------------------------------------------------------------
 885
 886 integerType :: DataType
 887 integerType = mkIntType "Prelude.Integer"
 888
 889 instance Data Integer where
 890   toConstr = mkIntConstr integerType
 891   gunfold _ z c = case constrRep c of
 892                     (IntConstr x) -> z x
 893                     _ -> error "gunfold"
 894   dataTypeOf _ = integerType
 895
 896
 897 ------------------------------------------------------------------------------
 898
 899 int8Type :: DataType
 900 int8Type = mkIntType "Data.Int.Int8"
 901
 902 instance Data Int8 where
 903   toConstr x = mkIntConstr int8Type (fromIntegral x)
 904   gunfold _ z c = case constrRep c of
 905                     (IntConstr x) -> z (fromIntegral x)
 906                     _ -> error "gunfold"
 907   dataTypeOf _ = int8Type
 908
 909
 910 ------------------------------------------------------------------------------
 911
 912 int16Type :: DataType
 913 int16Type = mkIntType "Data.Int.Int16"
 914
 915 instance Data Int16 where
 916   toConstr x = mkIntConstr int16Type (fromIntegral x)
 917   gunfold _ z c = case constrRep c of
 918                     (IntConstr x) -> z (fromIntegral x)
 919                     _ -> error "gunfold"
 920   dataTypeOf _ = int16Type
 921
 922
 923 ------------------------------------------------------------------------------
 924
 925 int32Type :: DataType
 926 int32Type = mkIntType "Data.Int.Int32"
 927
 928 instance Data Int32 where
 929   toConstr x = mkIntConstr int32Type (fromIntegral x)
 930   gunfold _ z c = case constrRep c of
 931                     (IntConstr x) -> z (fromIntegral x)
 932                     _ -> error "gunfold"
 933   dataTypeOf _ = int32Type
 934
 935
 936 ------------------------------------------------------------------------------
 937
 938 int64Type :: DataType
 939 int64Type = mkIntType "Data.Int.Int64"
 940
 941 instance Data Int64 where
 942   toConstr x = mkIntConstr int64Type (fromIntegral x)
 943   gunfold _ z c = case constrRep c of
 944                     (IntConstr x) -> z (fromIntegral x)
 945                     _ -> error "gunfold"
 946   dataTypeOf _ = int64Type
 947
 948
 949 ------------------------------------------------------------------------------
 950
 951 wordType :: DataType
 952 wordType = mkIntType "Data.Word.Word"
 953
 954 instance Data Word where
 955   toConstr x = mkIntConstr wordType (fromIntegral x)
 956   gunfold _ z c = case constrRep c of
 957                     (IntConstr x) -> z (fromIntegral x)
 958                     _ -> error "gunfold"
 959   dataTypeOf _ = wordType
 960
 961
 962 ------------------------------------------------------------------------------
 963
 964 word8Type :: DataType
 965 word8Type = mkIntType "Data.Word.Word8"
 966
 967 instance Data Word8 where
 968   toConstr x = mkIntConstr word8Type (fromIntegral x)
 969   gunfold _ z c = case constrRep c of
 970                     (IntConstr x) -> z (fromIntegral x)
 971                     _ -> error "gunfold"
 972   dataTypeOf _ = word8Type
 973
 974
 975 ------------------------------------------------------------------------------
 976
 977 word16Type :: DataType
 978 word16Type = mkIntType "Data.Word.Word16"
 979
 980 instance Data Word16 where
 981   toConstr x = mkIntConstr word16Type (fromIntegral x)
 982   gunfold _ z c = case constrRep c of
 983                     (IntConstr x) -> z (fromIntegral x)
 984                     _ -> error "gunfold"
 985   dataTypeOf _ = word16Type
 986
 987
 988 ------------------------------------------------------------------------------
 989
 990 word32Type :: DataType
 991 word32Type = mkIntType "Data.Word.Word32"
 992
 993 instance Data Word32 where
 994   toConstr x = mkIntConstr word32Type (fromIntegral x)
 995   gunfold _ z c = case constrRep c of
 996                     (IntConstr x) -> z (fromIntegral x)
 997                     _ -> error "gunfold"
 998   dataTypeOf _ = word32Type
 999
1000
1001 ------------------------------------------------------------------------------
1002
1003 word64Type :: DataType
1004 word64Type = mkIntType "Data.Word.Word64"
1005
1006 instance Data Word64 where
1007   toConstr x = mkIntConstr word64Type (fromIntegral x)
1008   gunfold _ z c = case constrRep c of
1009                     (IntConstr x) -> z (fromIntegral x)
1010                     _ -> error "gunfold"
1011   dataTypeOf _ = word64Type
1012
1013
1014 ------------------------------------------------------------------------------
1015
1016 ratioConstr :: Constr
1017 ratioConstr = mkConstr ratioDataType ":%" [] Infix
1018
1019 ratioDataType :: DataType
1020 ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr]
1021
1022 instance (Data a, Integral a) => Data (Ratio a) where
1023   gfoldl k z (a :% b) = z (:%) `k` a `k` b
1024   toConstr _ = ratioConstr
1025   gunfold k z c | constrIndex c == 1 = k (k (z (:%)))
1026   gunfold _ _ _ = error "gunfold"
1027   dataTypeOf _  = ratioDataType
1028
1029
1030 ------------------------------------------------------------------------------
1031
1032 nilConstr :: Constr
1033 nilConstr    = mkConstr listDataType "[]" [] Prefix
1034 consConstr :: Constr
1035 consConstr   = mkConstr listDataType "(:)" [] Infix
1036
1037 listDataType :: DataType
1038 listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]
1039
1040 instance Data a => Data [a] where
1041   gfoldl _ z []     = z []
1042   gfoldl f z (x:xs) = z (:) `f` x `f` xs
1043   toConstr []    = nilConstr
1044   toConstr (_:_) = consConstr
1045   gunfold k z c = case constrIndex c of
1046                     1 -> z []
1047                     2 -> k (k (z (:)))
1048                     _ -> error "gunfold"
1049   dataTypeOf _ = listDataType
1050   dataCast1 f  = gcast1 f
1051
1052 --
1053 -- The gmaps are given as an illustration.
1054 -- This shows that the gmaps for lists are different from list maps.
1055 --
1056   gmapT  _   []     = []
1057   gmapT  f   (x:xs) = (f x:f xs)
1058   gmapQ  _   []     = []
1059   gmapQ  f   (x:xs) = [f x,f xs]
1060   gmapM  _   []     = return []
1061   gmapM  f   (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
1062
1063
1064 ------------------------------------------------------------------------------
1065
1066 nothingConstr :: Constr
1067 nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix
1068 justConstr :: Constr
1069 justConstr    = mkConstr maybeDataType "Just"    [] Prefix
1070
1071 maybeDataType :: DataType
1072 maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr]
1073
1074 instance Data a => Data (Maybe a) where
1075   gfoldl _ z Nothing  = z Nothing
1076   gfoldl f z (Just x) = z Just `f` x
1077   toConstr Nothing  = nothingConstr
1078   toConstr (Just _) = justConstr
1079   gunfold k z c = case constrIndex c of
1080                     1 -> z Nothing
1081                     2 -> k (z Just)
1082                     _ -> error "gunfold"
1083   dataTypeOf _ = maybeDataType
1084   dataCast1 f  = gcast1 f
1085
1086
1087 ------------------------------------------------------------------------------
1088
1089 ltConstr :: Constr
1090 ltConstr         = mkConstr orderingDataType "LT" [] Prefix
1091 eqConstr :: Constr
1092 eqConstr         = mkConstr orderingDataType "EQ" [] Prefix
1093 gtConstr :: Constr
1094 gtConstr         = mkConstr orderingDataType "GT" [] Prefix
1095
1096 orderingDataType :: DataType
1097 orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr]
1098
1099 instance Data Ordering where
1100   gfoldl _ z LT  = z LT
1101   gfoldl _ z EQ  = z EQ
1102   gfoldl _ z GT  = z GT
1103   toConstr LT  = ltConstr
1104   toConstr EQ  = eqConstr
1105   toConstr GT  = gtConstr
1106   gunfold _ z c = case constrIndex c of
1107                     1 -> z LT
1108                     2 -> z EQ
1109                     3 -> z GT
1110                     _ -> error "gunfold"
1111   dataTypeOf _ = orderingDataType
1112
1113
1114 ------------------------------------------------------------------------------
1115
1116 leftConstr :: Constr
1117 leftConstr     = mkConstr eitherDataType "Left"  [] Prefix
1118
1119 rightConstr :: Constr
1120 rightConstr    = mkConstr eitherDataType "Right" [] Prefix
1121
1122 eitherDataType :: DataType
1123 eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr]
1124
1125 instance (Data a, Data b) => Data (Either a b) where
1126   gfoldl f z (Left a)   = z Left  `f` a
1127   gfoldl f z (Right a)  = z Right `f` a
1128   toConstr (Left _)  = leftConstr
1129   toConstr (Right _) = rightConstr
1130   gunfold k z c = case constrIndex c of
1131                     1 -> k (z Left)
1132                     2 -> k (z Right)
1133                     _ -> error "gunfold"
1134   dataTypeOf _ = eitherDataType
1135   dataCast2 f  = gcast2 f
1136
1137
1138 ------------------------------------------------------------------------------
1139
1140
1141 --
1142 -- A last resort for functions
1143 --
1144
1145 instance (Data a, Data b) => Data (a -> b) where
1146   toConstr _   = error "toConstr"
1147   gunfold _ _  = error "gunfold"
1148   dataTypeOf _ = mkNorepType "Prelude.(->)"
1149   dataCast2 f  = gcast2 f
1150
1151
1152 ------------------------------------------------------------------------------
1153
1154 tuple0Constr :: Constr
1155 tuple0Constr = mkConstr tuple0DataType "()" [] Prefix
1156
1157 tuple0DataType :: DataType
1158 tuple0DataType = mkDataType "Prelude.()" [tuple0Constr]
1159
1160 instance Data () where
1161   toConstr ()   = tuple0Constr
1162   gunfold _ z c | constrIndex c == 1 = z ()
1163   gunfold _ _ _ = error "gunfold"
1164   dataTypeOf _  = tuple0DataType
1165
1166
1167 ------------------------------------------------------------------------------
1168
1169 tuple2Constr :: Constr
1170 tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix
1171
1172 tuple2DataType :: DataType
1173 tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr]
1174
1175 instance (Data a, Data b) => Data (a,b) where
1176   gfoldl f z (a,b) = z (,) `f` a `f` b
1177   toConstr (_,_) = tuple2Constr
1178   gunfold k z c | constrIndex c == 1 = k (k (z (,)))
1179   gunfold _ _ _ = error "gunfold"
1180   dataTypeOf _  = tuple2DataType
1181   dataCast2 f   = gcast2 f
1182
1183
1184 ------------------------------------------------------------------------------
1185
1186 tuple3Constr :: Constr
1187 tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix
1188
1189 tuple3DataType :: DataType
1190 tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr]
1191
1192 instance (Data a, Data b, Data c) => Data (a,b,c) where
1193   gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c
1194   toConstr (_,_,_) = tuple3Constr
1195   gunfold k z c | constrIndex c == 1 = k (k (k (z (,,))))
1196   gunfold _ _ _ = error "gunfold"
1197   dataTypeOf _  = tuple3DataType
1198
1199
1200 ------------------------------------------------------------------------------
1201
1202 tuple4Constr :: Constr
1203 tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix
1204
1205 tuple4DataType :: DataType
1206 tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr]
1207
1208 instance (Data a, Data b, Data c, Data d)
1209          => Data (a,b,c,d) where
1210   gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d
1211   toConstr (_,_,_,_) = tuple4Constr
1212   gunfold k z c = case constrIndex c of
1213                     1 -> k (k (k (k (z (,,,)))))
1214                     _ -> error "gunfold"
1215   dataTypeOf _ = tuple4DataType
1216
1217
1218 ------------------------------------------------------------------------------
1219
1220 tuple5Constr :: Constr
1221 tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix
1222
1223 tuple5DataType :: DataType
1224 tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr]
1225
1226 instance (Data a, Data b, Data c, Data d, Data e)
1227          => Data (a,b,c,d,e) where
1228   gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e
1229   toConstr (_,_,_,_,_) = tuple5Constr
1230   gunfold k z c = case constrIndex c of
1231                     1 -> k (k (k (k (k (z (,,,,))))))
1232                     _ -> error "gunfold"
1233   dataTypeOf _ = tuple5DataType
1234
1235
1236 ------------------------------------------------------------------------------
1237
1238 tuple6Constr :: Constr
1239 tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix
1240
1241 tuple6DataType :: DataType
1242 tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr]
1243
1244 instance (Data a, Data b, Data c, Data d, Data e, Data f)
1245          => Data (a,b,c,d,e,f) where
1246   gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f'
1247   toConstr (_,_,_,_,_,_) = tuple6Constr
1248   gunfold k z c = case constrIndex c of
1249                     1 -> k (k (k (k (k (k (z (,,,,,)))))))
1250                     _ -> error "gunfold"
1251   dataTypeOf _ = tuple6DataType
1252
1253
1254 ------------------------------------------------------------------------------
1255
1256 tuple7Constr :: Constr
1257 tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix
1258
1259 tuple7DataType :: DataType
1260 tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr]
1261
1262 instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)
1263          => Data (a,b,c,d,e,f,g) where
1264   gfoldl f z (a,b,c,d,e,f',g) =
1265     z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g
1266   toConstr  (_,_,_,_,_,_,_) = tuple7Constr
1267   gunfold k z c = case constrIndex c of
1268                     1 -> k (k (k (k (k (k (k (z (,,,,,,))))))))
1269                     _ -> error "gunfold"
1270   dataTypeOf _ = tuple7DataType
1271
1272
1273 ------------------------------------------------------------------------------
1274
1275 instance Typeable a => Data (Ptr a) where
1276   toConstr _   = error "toConstr"
1277   gunfold _ _  = error "gunfold"
1278   dataTypeOf _ = mkNorepType "GHC.Ptr.Ptr"
1279
1280
1281 ------------------------------------------------------------------------------
1282
1283 instance Typeable a => Data (ForeignPtr a) where
1284   toConstr _   = error "toConstr"
1285   gunfold _ _  = error "gunfold"
1286   dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr"
1287
1288
1289 ------------------------------------------------------------------------------
1290 -- The Data instance for Array preserves data abstraction at the cost of
1291 -- inefficiency. We omit reflection services for the sake of data abstraction.
1292 instance (Typeable a, Data b, Ix a) => Data (Array a b)
1293  where
1294   gfoldl f z a = z (listArray (bounds a)) `f` (elems a)
1295   toConstr _   = error "toConstr"
1296   gunfold _ _  = error "gunfold"
1297   dataTypeOf _ = mkNorepType "Data.Array.Array"
1298