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