From 526912f3f19c4f8f3138636b4788de3de97f3170 Mon Sep 17 00:00:00 2001 From: "jpm@cs.uu.nl" Date: Mon, 18 Oct 2010 13:51:15 +0000 Subject: [PATCH] Update GHC.Generics to new generic programming library --- GHC/Bool.hs-boot | 7 ++ GHC/Generics.hs | 272 +++++++++++++++++++++++++++++++++++++++++++++++++++++ GHC/Types.hs-boot | 15 +++ 3 files changed, 294 insertions(+) create mode 100644 GHC/Bool.hs-boot create mode 100644 GHC/Types.hs-boot diff --git a/GHC/Bool.hs-boot b/GHC/Bool.hs-boot new file mode 100644 index 0000000..aab8f17 --- /dev/null +++ b/GHC/Bool.hs-boot @@ -0,0 +1,7 @@ + +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Bool where + +data Bool = False | True + diff --git a/GHC/Generics.hs b/GHC/Generics.hs index 6c97085..8b0efef 100644 --- a/GHC/Generics.hs +++ b/GHC/Generics.hs @@ -1,3 +1,5 @@ +{- + {-# OPTIONS_GHC -XNoImplicitPrelude -XTypeOperators #-} module GHC.Generics where @@ -10,3 +12,273 @@ data (:+:) a b = Inl a | Inr b data (:*:) a b = a :*: b #endif +-} + +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -XEmptyDataDecls #-} +{-# OPTIONS_GHC -XMultiParamTypeClasses #-} +{-# OPTIONS_GHC -XTypeSynonymInstances #-} +{-# OPTIONS_GHC -XTypeOperators #-} +{-# OPTIONS_GHC -XKindSignatures #-} + +module GHC.Generics ( + -- * Generic representation types + V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) + , (:+:)(..), (:*:)(..), (:.:)(..) + + -- ** Synonyms for convenience + , Rec0, Par0, R, P + , D1, C1, S1, D, C, S + + -- * Meta-information + , Datatype(..), Constructor(..), Selector(..), NoSelector + , Fixity(..), Associativity(..), Arity(..), prec + + -- * Representable type classes + , Representable0(..), Representable1(..) + +{- + -- * Representations for base types + , Rep0Char, Rep0Int, Rep0Float + , Rep0Maybe, Rep1Maybe + , Rep0List, Rep1List +-} + ) where + +import {-# SOURCE #-} GHC.Types -- ([](..), Int, Char) +import {-# SOURCE #-} GHC.Bool (Bool(..)) + +-------------------------------------------------------------------------------- +-- Representation types +-------------------------------------------------------------------------------- + +-- | Void: used for datatypes without constructors +data V1 p + +-- | Unit: used for constructors without arguments +data U1 p = U1 + +-- | Used for marking occurrences of the parameter +newtype Par1 p = Par1 { unPar1 :: p } + + +-- | Recursive calls of kind * -> * +newtype Rec1 f p = Rec1 { unRec1 :: f p } + +-- | Constants, additional parameters and recursion of kind * +newtype K1 i c p = K1 { unK1 :: c } + +-- | Meta-information (constructor names, etc.) +newtype M1 i c f p = M1 { unM1 :: f p } + +-- | Sums: encode choice between constructors +infixr 5 :+: +data (:+:) f g p = L1 (f p) | R1 (g p) + +-- | Products: encode multiple arguments to constructors +infixr 6 :*: +data (:*:) f g p = f p :*: g p + +-- | Composition of functors +infixr 7 :.: +newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } + +-- | Tag for K1: recursion (of kind *) +data R +-- | Tag for K1: parameters (other than the last) +data P + +-- | Type synonym for encoding recursion (of kind *) +type Rec0 = K1 R +-- | Type synonym for encoding parameters (other than the last) +type Par0 = K1 P + +-- | Tag for M1: datatype +data D +-- | Tag for M1: constructor +data C +-- | Tag for M1: record selector +data S + +-- | Type synonym for encoding meta-information for datatypes +type D1 = M1 D + +-- | Type synonym for encoding meta-information for constructors +type C1 = M1 C + +-- | Type synonym for encoding meta-information for record selectors +type S1 = M1 S + + +-- | Class for datatypes that represent datatypes +class Datatype d where + -- | The name of the datatype (unqualified) + datatypeName :: t d (f :: * -> *) a -> [Char] + -- | The fully-qualified name of the module where the type is declared + moduleName :: t d (f :: * -> *) a -> [Char] + + +-- | Class for datatypes that represent records +class Selector s where + -- | The name of the selector + selName :: t s (f :: * -> *) a -> [Char] + +-- | Used for constructor fields without a name +data NoSelector + +instance Selector NoSelector where selName _ = "" + +-- | Class for datatypes that represent data constructors +class Constructor c where + -- | The name of the constructor + conName :: t c (f :: * -> *) a -> [Char] + + -- | The fixity of the constructor + conFixity :: t c (f :: * -> *) a -> Fixity + conFixity _ = Prefix + + -- | Marks if this constructor is a record + conIsRecord :: t c (f :: * -> *) a -> Bool + conIsRecord _ = False + + -- | Marks if this constructor is a tuple, + -- returning arity >=0 if so, <0 if not + conIsTuple :: t c (f :: * -> *) a -> Arity + conIsTuple _ = NoArity + + +-- | Datatype to represent the arity of a tuple. +data Arity = NoArity | Arity Int +-- deriving (Eq, Show, Ord, Read) +-- TODO: Add these instances to the Prelude + +-- | Datatype to represent the fixity of a constructor. An infix +-- | declaration directly corresponds to an application of 'Infix'. +data Fixity = Prefix | Infix Associativity Int +-- deriving (Eq, Show, Ord, Read) +-- TODO: Add these instances to the Prelude + +-- | Get the precedence of a fixity value. +prec :: Fixity -> Int +prec Prefix = I# 10# +prec (Infix _ n) = n + +-- | Datatype to represent the associativy of a constructor +data Associativity = LeftAssociative + | RightAssociative + | NotAssociative +-- deriving (Eq, Show, Ord, Read) +-- TODO: Add these instances to the Prelude + + +-- | Representable types of kind * +class Representable0 a rep where + -- | Convert from the datatype to its representation + from0 :: a -> rep x + -- | Convert from the representation to the datatype + to0 :: rep x -> a + +-- | Representable types of kind * -> * +class Representable1 f rep where + -- | Convert from the datatype to its representation + from1 :: f a -> rep a + -- | Convert from the representation to the datatype + to1 :: rep a -> f a + +-------------------------------------------------------------------------------- +-- Representation for base types +-------------------------------------------------------------------------------- + +-- Representation types +{- +type Rep1Par1 = Par1 +instance Representable1 Par1 Rep1Par1 where + from1 = id + to1 = id + +type Rep1Rec1 f = Rec1 f +instance Representable1 (Rec1 f) (Rep1Rec1 f) where + from1 = id + to1 = id +-} +-- Kind * + +{- +type Rep0Char = Rec0 Char +instance Representable0 Char Rep0Char where + from0 = K1 + to0 = unK1 + +type Rep0Int = Rec0 Int +instance Representable0 Int Rep0Int where + from0 = K1 + to0 = unK1 + +type Rep0Float = Rec0 Float +instance Representable0 Float Rep0Float where + from0 = K1 + to0 = unK1 + +-- etc... + +-- Kind * -> * + +data Maybe_ +data Nothing_ +data Just_ + +instance Datatype Maybe_ where + datatypeName _ = "Maybe" + moduleName _ = "Representation" + +instance Constructor Nothing_ where + conName _ = "Nothing" + +instance Constructor Just_ where + conName _ = "Just" + +type Rep0Maybe a = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ (Par0 a)) +instance Representable0 (Maybe a) (Rep0Maybe a) where + from0 Nothing = M1 (L1 (M1 U1)) + from0 (Just x) = M1 (R1 (M1 (K1 x))) + to0 (M1 (L1 (M1 U1))) = Nothing + to0 (M1 (R1 (M1 (K1 x)))) = Just x + +type Rep1Maybe = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ Par1) +instance Representable1 Maybe Rep1Maybe where + from1 Nothing = M1 (L1 (M1 U1)) + from1 (Just x) = M1 (R1 (M1 (Par1 x))) + to1 (M1 (L1 (M1 U1))) = Nothing + to1 (M1 (R1 (M1 (Par1 x)))) = Just x + + +data List__ +data Nil__ +data Cons__ + +instance Datatype [a] where + datatypeName _ = "[]" + moduleName _ = "Data.List" + +instance Constructor Nil__ where conName _ = "[]" +instance Constructor Cons__ where + conName _ = ":" + conFixity _ = Infix RightAssociative 5 + +type Rep0List a = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par0 a :*: Rec0 [a]))) +instance Representable0 [a] (Rep0List a) where + from0 [] = M1 (L1 (M1 U1)) + from0 (h:t) = M1 (R1 (M1 (K1 h :*: K1 t))) + to0 (M1 (L1 (M1 U1))) = [] + to0 (M1 (R1 (M1 (K1 h :*: K1 t)))) = h : t + +type Rep1List = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par1 :*: Rec1 []))) +instance Representable1 [] Rep1List where + from1 [] = M1 (L1 (M1 U1)) + from1 (h:t) = M1 (R1 (M1 (Par1 h :*: Rec1 t))) + to1 (M1 (L1 (M1 U1))) = [] + to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = h : t + +-- etc... +-} + diff --git a/GHC/Types.hs-boot b/GHC/Types.hs-boot new file mode 100644 index 0000000..25f88c4 --- /dev/null +++ b/GHC/Types.hs-boot @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.Types where + +import GHC.Prim + + +infixr 5 : + +data [] a = [] | a : [a] + +data Char = C# Char# + +data Int = I# Int# + -- 1.7.10.4