diff options
Diffstat (limited to 'testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs')
| -rw-r--r-- | testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs | 492 |
1 files changed, 492 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs new file mode 100644 index 0000000000..c7fad91395 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types,
+ KindSignatures, EmptyDataDecls, MultiParamTypeClasses, CPP #-}
+
+{-
+
+(C) 2004--2005 Ralf Laemmel, Simon D. Foster
+
+This module approximates Data.Generics.Basics.
+
+-}
+
+
+module T1735_Help.Basics (
+
+ module Data.Typeable,
+ module T1735_Help.Context,
+ module T1735_Help.Basics
+
+) where
+
+import Data.Typeable
+import T1735_Help.Context
+
+#ifdef __HADDOCK__
+data Proxy
+#else
+data Proxy (a :: * -> *)
+#endif
+
+------------------------------------------------------------------------------
+-- The ingenious Data class
+
+class (Typeable a, Sat (ctx a)) => Data ctx a
+
+ where
+
+ gfoldl :: Proxy ctx
+ -> (forall b c. Data ctx b => w (b -> c) -> b -> w c)
+ -> (forall g. g -> w g)
+ -> a -> w a
+
+ -- Default definition for gfoldl
+ -- which copes immediately with basic datatypes
+ --
+ gfoldl _ _ z = z
+
+ gunfold :: Proxy ctx
+ -> (forall b r. Data ctx b => c (b -> r) -> c r)
+ -> (forall r. r -> c r)
+ -> Constr
+ -> c a
+
+ toConstr :: Proxy ctx -> a -> Constr
+
+ dataTypeOf :: Proxy ctx -> a -> DataType
+
+ -- incomplete implementation
+
+ gunfold _ _ _ _ = undefined
+
+ dataTypeOf _ _ = undefined
+
+ -- | Mediate types and unary type constructors
+ dataCast1 :: Typeable1 t
+ => Proxy ctx
+ -> (forall b. Data ctx b => w (t b))
+ -> Maybe (w a)
+ dataCast1 _ _ = Nothing
+
+ -- | Mediate types and binary type constructors
+ dataCast2 :: Typeable2 t
+ => Proxy ctx
+ -> (forall b c. (Data ctx b, Data ctx c) => w (t b c))
+ -> Maybe (w a)
+ dataCast2 _ _ = Nothing
+
+
+
+------------------------------------------------------------------------------
+
+-- Generic transformations
+
+type GenericT ctx = forall a. Data ctx a => a -> a
+
+
+-- Generic map for transformations
+
+gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx
+
+gmapT ctx f x = unID (gfoldl ctx k ID x)
+ where
+ k (ID g) y = ID (g (f y))
+
+
+-- The identity type constructor
+
+newtype ID x = ID { unID :: x }
+
+
+------------------------------------------------------------------------------
+
+-- Generic monadic transformations
+
+type GenericM m ctx = forall a. Data ctx a => a -> m a
+
+-- Generic map for monadic transformations
+
+gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx
+gmapM ctx f = gfoldl ctx k return
+ where k c x = do c' <- c
+ x' <- f x
+ return (c' x')
+
+
+------------------------------------------------------------------------------
+
+-- Generic queries
+
+type GenericQ ctx r = forall a. Data ctx a => a -> r
+
+
+-- Map for queries
+
+gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r]
+gmapQ ctx f = gmapQr ctx (:) [] f
+
+gmapQr :: Data ctx a
+ => Proxy ctx
+ -> (r' -> r -> r)
+ -> r
+ -> GenericQ ctx r'
+ -> a
+ -> r
+gmapQr ctx o r f x = unQr (gfoldl ctx k (const (Qr id)) x) r
+ where
+ k (Qr g) y = Qr (\s -> g (f y `o` s))
+
+-- The type constructor used in definition of gmapQr
+newtype Qr r a = Qr { unQr :: r -> r }
+
+
+
+------------------------------------------------------------------------------
+--
+-- Generic unfolding
+--
+------------------------------------------------------------------------------
+
+
+
+-- | Build a term skeleton
+fromConstr :: Data ctx a => Proxy ctx -> Constr -> a
+fromConstr ctx = fromConstrB ctx undefined
+
+-- | Build a term and use a generic function for subterms
+fromConstrB :: Data ctx a
+ => Proxy ctx
+ -> (forall b. Data ctx b => b)
+ -> Constr
+ -> a
+fromConstrB ctx f = unID . gunfold ctx k z
+ where
+ k c = ID (unID c f)
+ z = ID
+
+
+
+-- | Monadic variation on \"fromConstrB\"
+fromConstrM :: (Monad m, Data ctx a)
+ => Proxy ctx
+ -> (forall b. Data ctx b => m b)
+ -> Constr
+ -> m a
+fromConstrM ctx f = gunfold ctx k z
+ where
+ k c = do { c' <- c; b <- f; return (c' b) }
+ z = return
+
+
+
+------------------------------------------------------------------------------
+--
+-- Datatype and constructor representations
+--
+------------------------------------------------------------------------------
+
+
+--
+-- | Representation of datatypes.
+-- | A package of constructor representations with names of type and module.
+-- | The list of constructors could be an array, a balanced tree, or others.
+--
+data DataType = DataType
+ { tycon :: String
+ , datarep :: DataRep
+ }
+
+ deriving Show
+
+
+-- | Representation of constructors
+data Constr = Constr
+ { conrep :: ConstrRep
+ , constring :: String
+ , confields :: [String] -- for AlgRep only
+ , confixity :: Fixity -- for AlgRep only
+ , datatype :: DataType
+ }
+
+instance Show Constr where
+ show = constring
+
+
+-- | Equality of constructors
+instance Eq Constr where
+ c == c' = constrRep c == constrRep c'
+
+
+-- | Public representation of datatypes
+data DataRep = AlgRep [Constr]
+ | IntRep
+ | FloatRep
+ | StringRep
+ | NoRep
+
+ deriving (Eq,Show)
+
+
+-- | Public representation of constructors
+data ConstrRep = AlgConstr ConIndex
+ | IntConstr Integer
+ | FloatConstr Double
+ | StringConstr String
+
+ deriving (Eq,Show)
+
+
+--
+-- | Unique index for datatype constructors.
+-- | Textual order is respected. Starts at 1.
+--
+type ConIndex = Int
+
+
+-- | Fixity of constructors
+data Fixity = Prefix
+ | Infix -- Later: add associativity and precedence
+
+ deriving (Eq,Show)
+
+
+------------------------------------------------------------------------------
+--
+-- Observers for datatype representations
+--
+------------------------------------------------------------------------------
+
+
+-- | Gets the type constructor including the module
+dataTypeName :: DataType -> String
+dataTypeName = tycon
+
+
+
+-- | Gets the public presentation of datatypes
+dataTypeRep :: DataType -> DataRep
+dataTypeRep = datarep
+
+
+-- | Gets the datatype of a constructor
+constrType :: Constr -> DataType
+constrType = datatype
+
+
+-- | Gets the public presentation of constructors
+constrRep :: Constr -> ConstrRep
+constrRep = conrep
+
+
+-- | Look up a constructor by its representation
+repConstr :: DataType -> ConstrRep -> Constr
+repConstr dt cr =
+ case (dataTypeRep dt, cr) of
+ (AlgRep cs, AlgConstr i) -> cs !! (i-1)
+ (IntRep, IntConstr i) -> mkIntConstr dt i
+ (FloatRep, FloatConstr f) -> mkFloatConstr dt f
+ (StringRep, StringConstr str) -> mkStringConstr dt str
+ _ -> error "repConstr"
+
+
+
+------------------------------------------------------------------------------
+--
+-- Representations of algebraic data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs an algebraic datatype
+mkDataType :: String -> [Constr] -> DataType
+mkDataType str cs = DataType
+ { tycon = str
+ , datarep = AlgRep cs
+ }
+
+
+-- | Constructs a constructor
+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
+mkConstr dt str fields fix =
+ Constr
+ { conrep = AlgConstr idx
+ , constring = str
+ , confields = fields
+ , confixity = fix
+ , datatype = dt
+ }
+ where
+ idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
+ showConstr c == str ]
+
+
+-- | Gets the constructors
+dataTypeConstrs :: DataType -> [Constr]
+dataTypeConstrs dt = case datarep dt of
+ (AlgRep cons) -> cons
+ _ -> error "dataTypeConstrs"
+
+
+-- | Gets the field labels of a constructor
+constrFields :: Constr -> [String]
+constrFields = confields
+
+
+-- | Gets the fixity of a constructor
+constrFixity :: Constr -> Fixity
+constrFixity = confixity
+
+
+
+------------------------------------------------------------------------------
+--
+-- From strings to constr's and vice versa: all data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Gets the string for a constructor
+showConstr :: Constr -> String
+showConstr = constring
+
+
+-- | Lookup a constructor via a string
+readConstr :: DataType -> String -> Maybe Constr
+readConstr dt str =
+ case dataTypeRep dt of
+ AlgRep cons -> idx cons
+ IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
+ FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
+ StringRep -> Just (mkStringConstr dt str)
+ NoRep -> Nothing
+ where
+
+ -- Read a value and build a constructor
+ mkReadCon :: Read t => (t -> Constr) -> Maybe Constr
+ mkReadCon f = case (reads str) of
+ [(t,"")] -> Just (f t)
+ _ -> Nothing
+
+ -- Traverse list of algebraic datatype constructors
+ idx :: [Constr] -> Maybe Constr
+ idx cons = let fit = filter ((==) str . showConstr) cons
+ in if fit == []
+ then Nothing
+ else Just (head fit)
+
+
+------------------------------------------------------------------------------
+--
+-- Convenience funtions: algebraic data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Test for an algebraic type
+isAlgType :: DataType -> Bool
+isAlgType dt = case datarep dt of
+ (AlgRep _) -> True
+ _ -> False
+
+
+-- | Gets the constructor for an index
+indexConstr :: DataType -> ConIndex -> Constr
+indexConstr dt idx = case datarep dt of
+ (AlgRep cs) -> cs !! (idx-1)
+ _ -> error "indexConstr"
+
+
+-- | Gets the index of a constructor
+constrIndex :: Constr -> ConIndex
+constrIndex con = case constrRep con of
+ (AlgConstr idx) -> idx
+ _ -> error "constrIndex"
+
+
+-- | Gets the maximum constructor index
+maxConstrIndex :: DataType -> ConIndex
+maxConstrIndex dt = case dataTypeRep dt of
+ AlgRep cs -> length cs
+ _ -> error "maxConstrIndex"
+
+
+
+------------------------------------------------------------------------------
+--
+-- Representation of primitive types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs the Int type
+mkIntType :: String -> DataType
+mkIntType = mkPrimType IntRep
+
+
+-- | Constructs the Float type
+mkFloatType :: String -> DataType
+mkFloatType = mkPrimType FloatRep
+
+
+-- | Constructs the String type
+mkStringType :: String -> DataType
+mkStringType = mkPrimType StringRep
+
+
+-- | Helper for mkIntType, mkFloatType, mkStringType
+mkPrimType :: DataRep -> String -> DataType
+mkPrimType dr str = DataType
+ { tycon = str
+ , datarep = dr
+ }
+
+
+-- Makes a constructor for primitive types
+mkPrimCon :: DataType -> String -> ConstrRep -> Constr
+mkPrimCon dt str cr = Constr
+ { datatype = dt
+ , conrep = cr
+ , constring = str
+ , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"]
+ , confixity = error "constrFixity"
+ }
+
+
+mkIntConstr :: DataType -> Integer -> Constr
+mkIntConstr dt i = case datarep dt of
+ IntRep -> mkPrimCon dt (show i) (IntConstr i)
+ _ -> error "mkIntConstr"
+
+
+mkFloatConstr :: DataType -> Double -> Constr
+mkFloatConstr dt f = case datarep dt of
+ FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
+ _ -> error "mkFloatConstr"
+
+
+mkStringConstr :: DataType -> String -> Constr
+mkStringConstr dt str = case datarep dt of
+ StringRep -> mkPrimCon dt str (StringConstr str)
+ _ -> error "mkStringConstr"
+
+
+------------------------------------------------------------------------------
+--
+-- Non-representations for non-presentable types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs a non-representation
+mkNorepType :: String -> DataType
+mkNorepType str = DataType
+ { tycon = str
+ , datarep = NoRep
+ }
+
+
+-- | Test for a non-representable type
+isNorepType :: DataType -> Bool
+isNorepType dt = case datarep dt of
+ NoRep -> True
+ _ -> False
+
|