Testsuite: delete Windows line endings [skip ci] (#11631)
authorThomas Miedema <thomasmiedema@gmail.com>
Mon, 22 Feb 2016 20:31:24 +0000 (21:31 +0100)
committerThomas Miedema <thomasmiedema@gmail.com>
Tue, 23 Feb 2016 10:57:32 +0000 (11:57 +0100)
12 files changed:
testsuite/tests/typecheck/should_run/T1735.hs
testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs
testsuite/tests/typecheck/should_run/T1735_Help/Context.hs
testsuite/tests/typecheck/should_run/T1735_Help/Instances.hs
testsuite/tests/typecheck/should_run/T1735_Help/Main.hs
testsuite/tests/typecheck/should_run/T1735_Help/State.hs
testsuite/tests/typecheck/should_run/T1735_Help/Xml.hs
testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs
testsuite/tests/typecheck/should_run/TcRun038_B.hs
testsuite/tests/typecheck/should_run/tcrun032.hs
testsuite/tests/typecheck/should_run/tcrun038.hs
testsuite/tests/typecheck/should_run/tcrun039.hs

index a8d453c..8a23c9e 100644 (file)
@@ -1,61 +1,61 @@
-{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,\r
-             ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts,\r
-             MultiParamTypeClasses, GeneralizedNewtypeDeriving,\r
-             DeriveDataTypeable,\r
-             OverlappingInstances, UndecidableInstances, CPP #-}\r
-\r
-module Main (main) where\r
-\r
-import T1735_Help.Basics\r
-import T1735_Help.Xml\r
-\r
-data YesNo = Yes | No\r
-    deriving (Eq, Show, Typeable)\r
-instance Sat (ctx YesNo) => Data ctx YesNo where\r
-    toConstr _ Yes = yesConstr\r
-    toConstr _ No  = noConstr\r
-    gunfold _ _ z c  = case constrIndex c of\r
-                           1 -> z Yes\r
-                           2 -> z No\r
-                           _ -> error "Foo"\r
-    dataTypeOf _ _ = yesNoDataType\r
-yesConstr :: Constr\r
-yesConstr = mkConstr yesNoDataType "Yes" [] Prefix\r
-noConstr :: Constr\r
-noConstr = mkConstr yesNoDataType "No" [] Prefix\r
-yesNoDataType :: DataType\r
-yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]\r
-\r
-newtype MyList a = MkMyList { unMyList :: [a] }\r
-    deriving (Show, Eq, Typeable)\r
-instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)\r
-      => Data ctx (MyList a) where\r
-    gfoldl _ f z x  = z MkMyList `f` unMyList x\r
-    toConstr _ (MkMyList _) = mkMyListConstr\r
-    gunfold _ k z c  = case constrIndex c of\r
-                           1 -> k (z MkMyList)\r
-                           _ -> error "Foo"\r
-    dataTypeOf _ _ = myListDataType\r
-mkMyListConstr :: Constr\r
-mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix\r
-myListDataType :: DataType\r
-myListDataType = mkDataType "MyList" [mkMyListConstr]\r
-\r
-#ifdef FOO\r
-rigidTests :: Maybe (Maybe [YesNo])\r
-rigidTests =\r
- mkTest [Elem "No"  []] (Just [No])\r
-#endif\r
-\r
-rigidManualTests :: Maybe (Maybe (MyList YesNo))\r
-rigidManualTests =\r
- mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))\r
-\r
-mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)\r
-mkTest es v = case fromXml es of\r
-                  v' | v == v'   -> Nothing\r
-                     | otherwise -> Just v'\r
-\r
-main :: IO ()\r
-main = print rigidManualTests\r
-\r
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+             ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts,
+             MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+             DeriveDataTypeable,
+             OverlappingInstances, UndecidableInstances, CPP #-}
+
+module Main (main) where
+
+import T1735_Help.Basics
+import T1735_Help.Xml
+
+data YesNo = Yes | No
+    deriving (Eq, Show, Typeable)
+instance Sat (ctx YesNo) => Data ctx YesNo where
+    toConstr _ Yes = yesConstr
+    toConstr _ No  = noConstr
+    gunfold _ _ z c  = case constrIndex c of
+                           1 -> z Yes
+                           2 -> z No
+                           _ -> error "Foo"
+    dataTypeOf _ _ = yesNoDataType
+yesConstr :: Constr
+yesConstr = mkConstr yesNoDataType "Yes" [] Prefix
+noConstr :: Constr
+noConstr = mkConstr yesNoDataType "No" [] Prefix
+yesNoDataType :: DataType
+yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]
+
+newtype MyList a = MkMyList { unMyList :: [a] }
+    deriving (Show, Eq, Typeable)
+instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)
+      => Data ctx (MyList a) where
+    gfoldl _ f z x  = z MkMyList `f` unMyList x
+    toConstr _ (MkMyList _) = mkMyListConstr
+    gunfold _ k z c  = case constrIndex c of
+                           1 -> k (z MkMyList)
+                           _ -> error "Foo"
+    dataTypeOf _ _ = myListDataType
+mkMyListConstr :: Constr
+mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix
+myListDataType :: DataType
+myListDataType = mkDataType "MyList" [mkMyListConstr]
+
+#ifdef FOO
+rigidTests :: Maybe (Maybe [YesNo])
+rigidTests =
+ mkTest [Elem "No"  []] (Just [No])
+#endif
+
+rigidManualTests :: Maybe (Maybe (MyList YesNo))
+rigidManualTests =
+ mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))
+
+mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)
+mkTest es v = case fromXml es of
+                  v' | v == v'   -> Nothing
+                     | otherwise -> Just v'
+
+main :: IO ()
+main = print rigidManualTests
+
index d444db7..62dac43 100644 (file)
-{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types,\r
-    KindSignatures, EmptyDataDecls, MultiParamTypeClasses, CPP #-}\r
-\r
-{-\r
-\r
-(C) 2004--2005 Ralf Laemmel, Simon D. Foster\r
-\r
-This module approximates Data.Generics.Basics.\r
-\r
--}\r
-\r
-\r
-module T1735_Help.Basics (\r
-\r
- module Data.Typeable,\r
- module T1735_Help.Context,\r
- module T1735_Help.Basics\r
-\r
-) where\r
-\r
-import Data.Typeable\r
-import T1735_Help.Context\r
-\r
-\r
-------------------------------------------------------------------------------\r
--- The ingenious Data class\r
-\r
-class (Typeable a, Sat (ctx a)) => Data ctx a\r
-\r
-   where\r
-\r
-     gfoldl :: Proxy ctx\r
-            -> (forall b c. Data ctx b => w (b -> c) -> b -> w c)\r
-            -> (forall g. g -> w g)\r
-            -> a -> w a\r
-\r
-     -- Default definition for gfoldl\r
-     -- which copes immediately with basic datatypes\r
-     --\r
-     gfoldl _ _ z = z\r
-\r
-     gunfold :: Proxy ctx\r
-             -> (forall b r. Data ctx b => c (b -> r) -> c r)\r
-             -> (forall r. r -> c r)\r
-             -> Constr\r
-             -> c a\r
-\r
-     toConstr :: Proxy ctx -> a -> Constr\r
-\r
-     dataTypeOf :: Proxy ctx -> a -> DataType\r
-\r
-     -- incomplete implementation\r
-\r
-     gunfold _ _ _ _ = undefined\r
-\r
-     dataTypeOf _ _ = undefined\r
-\r
-     -- | Mediate types and unary type constructors\r
-     dataCast1 :: Typeable t\r
-               => Proxy ctx\r
-               -> (forall b. Data ctx b => w (t b))\r
-               -> Maybe (w a)\r
-     dataCast1 _ _ = Nothing\r
-\r
-     -- | Mediate types and binary type constructors\r
-     dataCast2 :: Typeable t\r
-               => Proxy ctx\r
-               -> (forall b c. (Data ctx b, Data ctx c) => w (t b c))\r
-               -> Maybe (w a)\r
-     dataCast2 _ _ = Nothing\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
-\r
--- Generic transformations\r
-\r
-type GenericT ctx = forall a. Data ctx a => a -> a\r
-\r
-\r
--- Generic map for transformations\r
-\r
-gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx\r
-\r
-gmapT ctx f x = unID (gfoldl ctx k ID x)\r
-  where\r
-    k (ID g) y = ID (g (f y))\r
-\r
-\r
--- The identity type constructor\r
-\r
-newtype ID x = ID { unID :: x }\r
-\r
-\r
-------------------------------------------------------------------------------\r
-\r
--- Generic monadic transformations\r
-\r
-type GenericM m ctx = forall a. Data ctx a => a -> m a\r
-\r
--- Generic map for monadic transformations\r
-\r
-gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx\r
-gmapM ctx f = gfoldl ctx k return\r
-    where k c x = do c' <- c\r
-                     x' <- f x\r
-                     return (c' x')\r
-\r
-\r
-------------------------------------------------------------------------------\r
-\r
--- Generic queries\r
-\r
-type GenericQ ctx r = forall a. Data ctx a => a -> r\r
-\r
-\r
--- Map for queries\r
-\r
-gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r]\r
-gmapQ ctx f = gmapQr ctx (:) [] f\r
-\r
-gmapQr :: Data ctx a\r
-       => Proxy ctx\r
-       -> (r' -> r -> r)\r
-       -> r\r
-       -> GenericQ ctx r'\r
-       -> a\r
-       -> r\r
-gmapQr ctx o r f x = unQr (gfoldl ctx k (const (Qr id)) x) r\r
-  where\r
-    k (Qr g) y = Qr (\s -> g (f y `o` s))\r
-\r
--- The type constructor used in definition of gmapQr\r
-newtype Qr r a = Qr { unQr  :: r -> r }\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Generic unfolding\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
-\r
--- | Build a term skeleton\r
-fromConstr :: Data ctx a => Proxy ctx -> Constr -> a\r
-fromConstr ctx = fromConstrB ctx undefined\r
-\r
--- | Build a term and use a generic function for subterms\r
-fromConstrB :: Data ctx a\r
-            => Proxy ctx\r
-            -> (forall b. Data ctx b => b)\r
-            -> Constr\r
-            -> a\r
-fromConstrB ctx f = unID . gunfold ctx k z\r
- where\r
-  k c = ID (unID c f)\r
-  z = ID\r
-\r
-\r
-\r
--- | Monadic variation on \"fromConstrB\"\r
-fromConstrM :: (Monad m, Data ctx a)\r
-            => Proxy ctx\r
-            -> (forall b. Data ctx b => m b)\r
-            -> Constr\r
-            -> m a\r
-fromConstrM ctx f = gunfold ctx k z\r
- where\r
-  k c = do { c' <- c; b <- f; return (c' b) }\r
-  z = return\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Datatype and constructor representations\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
---\r
--- | Representation of datatypes.\r
--- | A package of constructor representations with names of type and module.\r
--- | The list of constructors could be an array, a balanced tree, or others.\r
---\r
-data DataType = DataType\r
-                        { tycon   :: String\r
-                        , datarep :: DataRep\r
-                        }\r
-\r
-              deriving Show\r
-\r
-\r
--- | Representation of constructors\r
-data Constr = Constr\r
-                        { conrep    :: ConstrRep\r
-                        , constring :: String\r
-                        , confields :: [String] -- for AlgRep only\r
-                        , confixity :: Fixity   -- for AlgRep only\r
-                        , datatype  :: DataType\r
-                        }\r
-\r
-instance Show Constr where\r
- show = constring\r
-\r
-\r
--- | Equality of constructors\r
-instance Eq Constr where\r
-  c == c' = constrRep c == constrRep c'\r
-\r
-\r
--- | Public representation of datatypes\r
-data DataRep = AlgRep [Constr]\r
-             | IntRep\r
-             | FloatRep\r
-             | StringRep\r
-             | NoRep\r
-\r
-            deriving (Eq,Show)\r
-\r
-\r
--- | Public representation of constructors\r
-data ConstrRep = AlgConstr    ConIndex\r
-               | IntConstr    Integer\r
-               | FloatConstr  Double\r
-               | StringConstr String\r
-\r
-               deriving (Eq,Show)\r
-\r
-\r
---\r
--- | Unique index for datatype constructors.\r
--- | Textual order is respected. Starts at 1.\r
---\r
-type ConIndex = Int\r
-\r
-\r
--- | Fixity of constructors\r
-data Fixity = Prefix\r
-            | Infix  -- Later: add associativity and precedence\r
-\r
-            deriving (Eq,Show)\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Observers for datatype representations\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Gets the type constructor including the module\r
-dataTypeName :: DataType -> String\r
-dataTypeName = tycon\r
-\r
-\r
-\r
--- | Gets the public presentation of datatypes\r
-dataTypeRep :: DataType -> DataRep\r
-dataTypeRep = datarep\r
-\r
-\r
--- | Gets the datatype of a constructor\r
-constrType :: Constr -> DataType\r
-constrType = datatype\r
-\r
-\r
--- | Gets the public presentation of constructors\r
-constrRep :: Constr -> ConstrRep\r
-constrRep = conrep\r
-\r
-\r
--- | Look up a constructor by its representation\r
-repConstr :: DataType -> ConstrRep -> Constr\r
-repConstr dt cr =\r
-      case (dataTypeRep dt, cr) of\r
-        (AlgRep cs, AlgConstr i)      -> cs !! (i-1)\r
-        (IntRep,    IntConstr i)      -> mkIntConstr dt i\r
-        (FloatRep,  FloatConstr f)    -> mkFloatConstr dt f\r
-        (StringRep, StringConstr str) -> mkStringConstr dt str\r
-        _ -> error "repConstr"\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Representations of algebraic data types\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Constructs an algebraic datatype\r
-mkDataType :: String -> [Constr] -> DataType\r
-mkDataType str cs = DataType\r
-                        { tycon   = str\r
-                        , datarep = AlgRep cs\r
-                        }\r
-\r
-\r
--- | Constructs a constructor\r
-mkConstr :: DataType -> String -> [String] -> Fixity -> Constr\r
-mkConstr dt str fields fix =\r
-        Constr\r
-                { conrep    = AlgConstr idx\r
-                , constring = str\r
-                , confields = fields\r
-                , confixity = fix\r
-                , datatype  = dt\r
-                }\r
-  where\r
-    idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],\r
-                     showConstr c == str ]\r
-\r
-\r
--- | Gets the constructors\r
-dataTypeConstrs :: DataType -> [Constr]\r
-dataTypeConstrs dt = case datarep dt of\r
-                        (AlgRep cons) -> cons\r
-                        _ -> error "dataTypeConstrs"\r
-\r
-\r
--- | Gets the field labels of a constructor\r
-constrFields :: Constr -> [String]\r
-constrFields = confields\r
-\r
-\r
--- | Gets the fixity of a constructor\r
-constrFixity :: Constr -> Fixity\r
-constrFixity = confixity\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- From strings to constr's and vice versa: all data types\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Gets the string for a constructor\r
-showConstr :: Constr -> String\r
-showConstr = constring\r
-\r
-\r
--- | Lookup a constructor via a string\r
-readConstr :: DataType -> String -> Maybe Constr\r
-readConstr dt str =\r
-      case dataTypeRep dt of\r
-        AlgRep cons -> idx cons\r
-        IntRep      -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))\r
-        FloatRep    -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))\r
-        StringRep   -> Just (mkStringConstr dt str)\r
-        NoRep       -> Nothing\r
-  where\r
-\r
-    -- Read a value and build a constructor\r
-    mkReadCon :: Read t => (t -> Constr) -> Maybe Constr\r
-    mkReadCon f = case (reads str) of\r
-                    [(t,"")] -> Just (f t)\r
-                    _ -> Nothing\r
-\r
-    -- Traverse list of algebraic datatype constructors\r
-    idx :: [Constr] -> Maybe Constr\r
-    idx cons = let fit = filter ((==) str . showConstr) cons\r
-                in if fit == []\r
-                     then Nothing\r
-                     else Just (head fit)\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Convenience funtions: algebraic data types\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Test for an algebraic type\r
-isAlgType :: DataType -> Bool\r
-isAlgType dt = case datarep dt of\r
-                 (AlgRep _) -> True\r
-                 _ -> False\r
-\r
-\r
--- | Gets the constructor for an index\r
-indexConstr :: DataType -> ConIndex -> Constr\r
-indexConstr dt idx = case datarep dt of\r
-                        (AlgRep cs) -> cs !! (idx-1)\r
-                        _           -> error "indexConstr"\r
-\r
-\r
--- | Gets the index of a constructor\r
-constrIndex :: Constr -> ConIndex\r
-constrIndex con = case constrRep con of\r
-                    (AlgConstr idx) -> idx\r
-                    _ -> error "constrIndex"\r
-\r
-\r
--- | Gets the maximum constructor index\r
-maxConstrIndex :: DataType -> ConIndex\r
-maxConstrIndex dt = case dataTypeRep dt of\r
-                        AlgRep cs -> length cs\r
-                        _         -> error "maxConstrIndex"\r
-\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Representation of primitive types\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Constructs the Int type\r
-mkIntType :: String -> DataType\r
-mkIntType = mkPrimType IntRep\r
-\r
-\r
--- | Constructs the Float type\r
-mkFloatType :: String -> DataType\r
-mkFloatType = mkPrimType FloatRep\r
-\r
-\r
--- | Constructs the String type\r
-mkStringType :: String -> DataType\r
-mkStringType = mkPrimType StringRep\r
-\r
-\r
--- | Helper for mkIntType, mkFloatType, mkStringType\r
-mkPrimType :: DataRep -> String -> DataType\r
-mkPrimType dr str = DataType\r
-                        { tycon   = str\r
-                        , datarep = dr\r
-                        }\r
-\r
-\r
--- Makes a constructor for primitive types\r
-mkPrimCon :: DataType -> String -> ConstrRep -> Constr\r
-mkPrimCon dt str cr = Constr\r
-                        { datatype  = dt\r
-                        , conrep    = cr\r
-                        , constring = str\r
-                        , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"]\r
-                        , confixity = error "constrFixity"\r
-                        }\r
-\r
-\r
-mkIntConstr :: DataType -> Integer -> Constr\r
-mkIntConstr dt i = case datarep dt of\r
-                  IntRep -> mkPrimCon dt (show i) (IntConstr i)\r
-                  _ -> error "mkIntConstr"\r
-\r
-\r
-mkFloatConstr :: DataType -> Double -> Constr\r
-mkFloatConstr dt f = case datarep dt of\r
-                    FloatRep -> mkPrimCon dt (show f) (FloatConstr f)\r
-                    _ -> error "mkFloatConstr"\r
-\r
-\r
-mkStringConstr :: DataType -> String -> Constr\r
-mkStringConstr dt str = case datarep dt of\r
-                       StringRep -> mkPrimCon dt str (StringConstr str)\r
-                       _ -> error "mkStringConstr"\r
-\r
-\r
-------------------------------------------------------------------------------\r
---\r
--- Non-representations for non-presentable types\r
---\r
-------------------------------------------------------------------------------\r
-\r
-\r
--- | Constructs a non-representation\r
-mkNorepType :: String -> DataType\r
-mkNorepType str = DataType\r
-                        { tycon   = str\r
-                        , datarep = NoRep\r
-                        }\r
-\r
-\r
--- | Test for a non-representable type\r
-isNorepType :: DataType -> Bool\r
-isNorepType dt = case datarep dt of\r
-                   NoRep -> True\r
-                   _ -> False\r
-\r
+{-# 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
+
+
+------------------------------------------------------------------------------
+-- 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 :: Typeable t
+               => Proxy ctx
+               -> (forall b. Data ctx b => w (t b))
+               -> Maybe (w a)
+     dataCast1 _ _ = Nothing
+
+     -- | Mediate types and binary type constructors
+     dataCast2 :: Typeable 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
+
index 25b9df9..df74312 100644 (file)
@@ -1,57 +1,57 @@
-{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-}\r
-\r
-{-\r
-\r
-(C) 2004 Ralf Laemmel\r
-\r
-Context parameterisation and context passing.\r
-\r
--}\r
-\r
-\r
-module T1735_Help.Context\r
-\r
-where\r
-\r
-------------------------------------------------------------------------------\r
-\r
---\r
--- The Sat class from John Hughes' "Restricted Data Types in Haskell"\r
---\r
-\r
-class Sat a\r
-  where\r
-    dict :: a\r
-\r
-\r
-------------------------------------------------------------------------------\r
-\r
--- No context\r
-\r
-data NoCtx a\r
-\r
-noCtx :: NoCtx ()\r
-noCtx = undefined\r
-\r
-instance Sat (NoCtx a) where dict = undefined\r
-\r
-\r
-------------------------------------------------------------------------------\r
-\r
--- Pair context\r
-\r
-data PairCtx l r a\r
-   = PairCtx { leftCtx  :: l a\r
-             , rightCtx :: r a }\r
-\r
-pairCtx :: l () -> r () -> PairCtx l r ()\r
-pairCtx _ _ = undefined\r
-\r
-instance (Sat (l a), Sat (r a))\r
-      => Sat (PairCtx l r a)\r
-  where\r
-    dict = PairCtx { leftCtx  = dict\r
-                   , rightCtx = dict }\r
-\r
-\r
-------------------------------------------------------------------------------\r
+{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-}
+
+{-
+
+(C) 2004 Ralf Laemmel
+
+Context parameterisation and context passing.
+
+-}
+
+
+module T1735_Help.Context
+
+where
+
+------------------------------------------------------------------------------
+
+--
+-- The Sat class from John Hughes' "Restricted Data Types in Haskell"
+--
+
+class Sat a
+  where
+    dict :: a
+
+
+------------------------------------------------------------------------------
+
+-- No context
+
+data NoCtx a
+
+noCtx :: NoCtx ()
+noCtx = undefined
+
+instance Sat (NoCtx a) where dict = undefined
+
+
+------------------------------------------------------------------------------
+
+-- Pair context
+
+data PairCtx l r a
+   = PairCtx { leftCtx  :: l a
+             , rightCtx :: r a }
+
+pairCtx :: l () -> r () -> PairCtx l r ()
+pairCtx _ _ = undefined
+
+instance (Sat (l a), Sat (r a))
+      => Sat (PairCtx l r a)
+  where
+    dict = PairCtx { leftCtx  = dict
+                   , rightCtx = dict }
+
+
+------------------------------------------------------------------------------
index 6a62613..8d9a20e 100644 (file)
@@ -1,41 +1,41 @@
-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses,\r
-             UndecidableInstances, OverlappingInstances, CPP #-}\r
-{-# OPTIONS_GHC -fno-warn-orphans #-}\r
--- This is a module full of orphans, so don't warn about them\r
-\r
-module T1735_Help.Instances () where\r
-\r
-import T1735_Help.Basics\r
-import Data.Typeable\r
-\r
-charType :: DataType\r
-charType = mkStringType "Prelude.Char"\r
-\r
-instance Sat (ctx Char) =>\r
-         Data ctx Char where\r
-  toConstr _ x = mkStringConstr charType [x]\r
-  gunfold _ _ z c = case constrRep c of\r
-                      (StringConstr [x]) -> z x\r
-                      _ -> error "gunfold Char"\r
-  dataTypeOf _ _ = charType\r
-\r
-nilConstr :: Constr\r
-nilConstr    = mkConstr listDataType "[]" [] Prefix\r
-consConstr :: Constr\r
-consConstr   = mkConstr listDataType "(:)" [] Infix\r
-listDataType :: DataType\r
-listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]\r
-\r
-instance (Sat (ctx [a]), Data ctx a) =>\r
-         Data ctx [a] where\r
-  gfoldl _ _ z []     = z []\r
-  gfoldl _ f z (x:xs) = z (:) `f` x `f` xs\r
-  toConstr _ []    = nilConstr\r
-  toConstr _ (_:_) = consConstr\r
-  gunfold _ k z c = case constrIndex c of\r
-                      1 -> z []\r
-                      2 -> k (k (z (:)))\r
-                      _ -> error "gunfold List"\r
-  dataTypeOf _ _ = listDataType\r
-  dataCast1 _ f = gcast1 f\r
-\r
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses,
+             UndecidableInstances, OverlappingInstances, CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- This is a module full of orphans, so don't warn about them
+
+module T1735_Help.Instances () where
+
+import T1735_Help.Basics
+import Data.Typeable
+
+charType :: DataType
+charType = mkStringType "Prelude.Char"
+
+instance Sat (ctx Char) =>
+         Data ctx Char where
+  toConstr _ x = mkStringConstr charType [x]
+  gunfold _ _ z c = case constrRep c of
+                      (StringConstr [x]) -> z x
+                      _ -> error "gunfold Char"
+  dataTypeOf _ _ = charType
+
+nilConstr :: Constr
+nilConstr    = mkConstr listDataType "[]" [] Prefix
+consConstr :: Constr
+consConstr   = mkConstr listDataType "(:)" [] Infix
+listDataType :: DataType
+listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]
+
+instance (Sat (ctx [a]), Data ctx a) =>
+         Data ctx [a] where
+  gfoldl _ _ z []     = z []
+  gfoldl _ f z (x:xs) = z (:) `f` x `f` xs
+  toConstr _ []    = nilConstr
+  toConstr _ (_:_) = consConstr
+  gunfold _ k z c = case constrIndex c of
+                      1 -> z []
+                      2 -> k (k (z (:)))
+                      _ -> error "gunfold List"
+  dataTypeOf _ _ = listDataType
+  dataCast1 _ f = gcast1 f
+
index 0a6e1c5..0c59d44 100644 (file)
@@ -1,62 +1,62 @@
-\r
-{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,\r
-             PatternSignatures, GADTs, RankNTypes, FlexibleContexts,\r
-             MultiParamTypeClasses, GeneralizedNewtypeDeriving,\r
-             DeriveDataTypeable,\r
-             OverlappingInstances, UndecidableInstances, CPP #-}\r
-\r
-module Main (main) where\r
-\r
-import SYBWC.Basics\r
-import Xml\r
-\r
-data YesNo = Yes | No\r
-    deriving (Eq, Show, Typeable)\r
-instance Sat (ctx YesNo) => Data ctx YesNo where\r
-    toConstr _ Yes = yesConstr\r
-    toConstr _ No  = noConstr\r
-    gunfold _ _ z c  = case constrIndex c of\r
-                           1 -> z Yes\r
-                           2 -> z No\r
-                           _ -> error "Foo"\r
-    dataTypeOf _ _ = yesNoDataType\r
-yesConstr :: Constr\r
-yesConstr = mkConstr yesNoDataType "Yes" [] Prefix\r
-noConstr :: Constr\r
-noConstr = mkConstr yesNoDataType "No" [] Prefix\r
-yesNoDataType :: DataType\r
-yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]\r
-\r
-newtype MyList a = MkMyList { unMyList :: [a] }\r
-    deriving (Show, Eq, Typeable)\r
-instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)\r
-      => Data ctx (MyList a) where\r
-    gfoldl _ f z x  = z MkMyList `f` unMyList x\r
-    toConstr _ (MkMyList _) = mkMyListConstr\r
-    gunfold _ k z c  = case constrIndex c of\r
-                           1 -> k (z MkMyList)\r
-                           _ -> error "Foo"\r
-    dataTypeOf _ _ = myListDataType\r
-mkMyListConstr :: Constr\r
-mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix\r
-myListDataType :: DataType\r
-myListDataType = mkDataType "MyList" [mkMyListConstr]\r
-\r
-#ifdef FOO\r
-rigidTests :: Maybe (Maybe [YesNo])\r
-rigidTests =\r
- mkTest [Elem "No"  []] (Just [No])\r
-#endif\r
-\r
-rigidManualTests :: Maybe (Maybe (MyList YesNo))\r
-rigidManualTests =\r
- mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))\r
-\r
-mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)\r
-mkTest es v = case fromXml es of\r
-                  v' | v == v'   -> Nothing\r
-                     | otherwise -> Just v'\r
-\r
-main :: IO ()\r
-main = print rigidManualTests\r
-\r
+
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+             PatternSignatures, GADTs, RankNTypes, FlexibleContexts,
+             MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+             DeriveDataTypeable,
+             OverlappingInstances, UndecidableInstances, CPP #-}
+
+module Main (main) where
+
+import SYBWC.Basics
+import Xml
+
+data YesNo = Yes | No
+    deriving (Eq, Show, Typeable)
+instance Sat (ctx YesNo) => Data ctx YesNo where
+    toConstr _ Yes = yesConstr
+    toConstr _ No  = noConstr
+    gunfold _ _ z c  = case constrIndex c of
+                           1 -> z Yes
+                           2 -> z No
+                           _ -> error "Foo"
+    dataTypeOf _ _ = yesNoDataType
+yesConstr :: Constr
+yesConstr = mkConstr yesNoDataType "Yes" [] Prefix
+noConstr :: Constr
+noConstr = mkConstr yesNoDataType "No" [] Prefix
+yesNoDataType :: DataType
+yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]
+
+newtype MyList a = MkMyList { unMyList :: [a] }
+    deriving (Show, Eq, Typeable)
+instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)
+      => Data ctx (MyList a) where
+    gfoldl _ f z x  = z MkMyList `f` unMyList x
+    toConstr _ (MkMyList _) = mkMyListConstr
+    gunfold _ k z c  = case constrIndex c of
+                           1 -> k (z MkMyList)
+                           _ -> error "Foo"
+    dataTypeOf _ _ = myListDataType
+mkMyListConstr :: Constr
+mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix
+myListDataType :: DataType
+myListDataType = mkDataType "MyList" [mkMyListConstr]
+
+#ifdef FOO
+rigidTests :: Maybe (Maybe [YesNo])
+rigidTests =
+ mkTest [Elem "No"  []] (Just [No])
+#endif
+
+rigidManualTests :: Maybe (Maybe (MyList YesNo))
+rigidManualTests =
+ mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))
+
+mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)
+mkTest es v = case fromXml es of
+                  v' | v == v'   -> Nothing
+                     | otherwise -> Just v'
+
+main :: IO ()
+main = print rigidManualTests
+
index d696af7..44078ae 100644 (file)
@@ -1,28 +1,28 @@
-\r
-module T1735_Help.State where\r
-\r
-import Control.Monad (ap, liftM)\r
-\r
-\r
-newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }\r
-\r
-instance Monad m => Monad (StateT s m) where\r
-    return a = StateT $ \s -> return (a, s)\r
-    m >>= k  = StateT $ \s -> do\r
-        ~(a, s') <- runStateT m s\r
-        runStateT (k a) s'\r
-    fail str = StateT $ \_ -> fail str\r
-\r
-instance Monad m => Functor (StateT s m) where\r
-    fmap = liftM\r
-\r
-instance Monad m => Applicative (StateT s m) where\r
-    pure  = return\r
-    (<*>) = ap\r
-\r
-get :: Monad m => StateT s m s\r
-get = StateT $ \s -> return (s, s)\r
-\r
-put :: Monad m => s -> StateT s m ()\r
-put s = StateT $ \_ -> return ((), s)\r
-\r
+
+module T1735_Help.State where
+
+import Control.Monad (ap, liftM)
+
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+instance Monad m => Monad (StateT s m) where
+    return a = StateT $ \s -> return (a, s)
+    m >>= k  = StateT $ \s -> do
+        ~(a, s') <- runStateT m s
+        runStateT (k a) s'
+    fail str = StateT $ \_ -> fail str
+
+instance Monad m => Functor (StateT s m) where
+    fmap = liftM
+
+instance Monad m => Applicative (StateT s m) where
+    pure  = return
+    (<*>) = ap
+
+get :: Monad m => StateT s m s
+get = StateT $ \s -> return (s, s)
+
+put :: Monad m => s -> StateT s m ()
+put s = StateT $ \_ -> return ((), s)
+
index b641c6a..01cc393 100644 (file)
-{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,\r
-             GADTs, RankNTypes, FlexibleContexts, TypeSynonymInstances,\r
-             MultiParamTypeClasses, DeriveDataTypeable, PatternGuards,\r
-             OverlappingInstances, UndecidableInstances, CPP #-}\r
-\r
-module T1735_Help.Xml (Element(..), Xml, fromXml) where\r
-\r
-import T1735_Help.Basics\r
-import T1735_Help.Instances ()\r
-import T1735_Help.State\r
-\r
-data Element = Elem String [Element]\r
-             | CData String\r
-             | Attr String String\r
-\r
-fromXml :: Xml a => [Element] -> Maybe a\r
-fromXml xs = case readXml xs of\r
-             Just (_, v) -> return v\r
-             Nothing -> error "XXX"\r
-\r
-class (Data XmlD a) => Xml a where\r
-    toXml :: a -> [Element]\r
-    toXml = defaultToXml\r
-\r
-    readXml :: [Element] -> Maybe ([Element], a)\r
-    readXml = defaultReadXml\r
-\r
-    readXml' :: [Element] -> Maybe ([Element], a)\r
-    readXml' = defaultReadXml'\r
-\r
-instance (Data XmlD t, Show t) => Xml t\r
-\r
-data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }\r
-\r
-xmlProxy :: Proxy XmlD\r
-xmlProxy = error "xmlProxy"\r
-\r
-instance Xml t => Sat (XmlD t) where\r
-    dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }\r
-\r
-defaultToXml :: Xml t => t -> [Element]\r
-defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]\r
-\r
-transparentToXml :: Xml t => t -> [Element]\r
-transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x\r
-\r
--- Don't do any defaulting here, as these functions can be implemented\r
--- differently by the user. We do the defaulting elsewhere instead.\r
--- The t' type is thus not used.\r
-\r
-defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)\r
-defaultReadXml es = readXml' es\r
-\r
-defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)\r
-defaultReadXml' = readXmlWith readVersionedElement\r
-\r
-readXmlWith :: Xml t\r
-            => (Element -> Maybe t)\r
-            -> [Element]\r
-            -> Maybe ([Element], t)\r
-readXmlWith f es = case es of\r
-                       e : es' ->\r
-                           case f e of\r
-                               Just v -> Just (es', v)\r
-                               Nothing -> Nothing\r
-                       [] ->\r
-                           Nothing\r
-\r
-readVersionedElement :: forall t . Xml t => Element -> Maybe t\r
-readVersionedElement e = readElement e\r
-\r
-readElement :: forall t . Xml t => Element -> Maybe t\r
-readElement (Elem n es) = res\r
-    where resType :: t\r
-          resType = typeNotValue resType\r
-          resDataType = dataTypeOf xmlProxy resType\r
-          con = readConstr resDataType n\r
-          res = case con of\r
-                Just c -> f c\r
-                Nothing -> Nothing\r
-          f c =     let m :: Maybe ([Element], t)\r
-                        m = constrFromElements c es\r
-                    in case m of\r
-                           Just ([], x) -> Just x\r
-                           _ -> Nothing\r
-readElement _ = Nothing\r
-\r
-constrFromElements :: forall t . Xml t\r
-                   => Constr -> [Element] -> Maybe ([Element], t)\r
-constrFromElements c es\r
- = do let st = ReadState { xmls = es }\r
-          m :: ReadM Maybe t\r
-          m = fromConstrM xmlProxy (readMXmlD dict) c\r
-      -- XXX Should we flip the result order?\r
-      (x, st') <- runStateT m st\r
-      return (xmls st', x)\r
-\r
-type ReadM m = StateT ReadState m\r
-\r
-data ReadState = ReadState {\r
-                     xmls :: [Element]\r
-                 }\r
-\r
-getXmls :: Monad m => ReadM m [Element]\r
-getXmls = do st <- get\r
-             return $ xmls st\r
-\r
-putXmls :: Monad m => [Element] -> ReadM m ()\r
-putXmls xs = do st <- get\r
-                put $ st { xmls = xs }\r
-\r
-readMXml :: Xml a => ReadM Maybe a\r
-readMXml\r
- = do xs <- getXmls\r
-      case readXml xs of\r
-          Nothing -> fail "Cannot read value"\r
-          Just (xs', v) ->\r
-              do putXmls xs'\r
-                 return v\r
-\r
-typeNotValue :: Xml a => a -> a\r
-typeNotValue t = error ("Type used as value: " ++ typeName)\r
-    where typeName = dataTypeName (dataTypeOf xmlProxy t)\r
-\r
--- The Xml [a] context is a bit scary, but if we don't have it then\r
--- GHC complains about overlapping instances\r
-\r
-instance (Xml a {-, Xml [a] -}) => Xml [a] where\r
-    toXml = concatMap toXml\r
-    readXml = f [] []\r
-        where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)\r
-              f acc_xs acc_vs (x:xs) = case readXml [x] of\r
-                                           Just ([], v) ->\r
-                                               f acc_xs (v:acc_vs) xs\r
-                                           _ ->\r
-                                               f (x:acc_xs) acc_vs xs\r
-\r
-instance Xml String where\r
-    toXml x = [CData x]\r
-    readXml = readXmlWith f\r
-        where f (CData x) = Just x\r
-              f _ = Nothing\r
-\r
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+             GADTs, RankNTypes, FlexibleContexts, TypeSynonymInstances,
+             MultiParamTypeClasses, DeriveDataTypeable, PatternGuards,
+             OverlappingInstances, UndecidableInstances, CPP #-}
+
+module T1735_Help.Xml (Element(..), Xml, fromXml) where
+
+import T1735_Help.Basics
+import T1735_Help.Instances ()
+import T1735_Help.State
+
+data Element = Elem String [Element]
+             | CData String
+             | Attr String String
+
+fromXml :: Xml a => [Element] -> Maybe a
+fromXml xs = case readXml xs of
+             Just (_, v) -> return v
+             Nothing -> error "XXX"
+
+class (Data XmlD a) => Xml a where
+    toXml :: a -> [Element]
+    toXml = defaultToXml
+
+    readXml :: [Element] -> Maybe ([Element], a)
+    readXml = defaultReadXml
+
+    readXml' :: [Element] -> Maybe ([Element], a)
+    readXml' = defaultReadXml'
+
+instance (Data XmlD t, Show t) => Xml t
+
+data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }
+
+xmlProxy :: Proxy XmlD
+xmlProxy = error "xmlProxy"
+
+instance Xml t => Sat (XmlD t) where
+    dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }
+
+defaultToXml :: Xml t => t -> [Element]
+defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]
+
+transparentToXml :: Xml t => t -> [Element]
+transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x
+
+-- Don't do any defaulting here, as these functions can be implemented
+-- differently by the user. We do the defaulting elsewhere instead.
+-- The t' type is thus not used.
+
+defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)
+defaultReadXml es = readXml' es
+
+defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)
+defaultReadXml' = readXmlWith readVersionedElement
+
+readXmlWith :: Xml t
+            => (Element -> Maybe t)
+            -> [Element]
+            -> Maybe ([Element], t)
+readXmlWith f es = case es of
+                       e : es' ->
+                           case f e of
+                               Just v -> Just (es', v)
+                               Nothing -> Nothing
+                       [] ->
+                           Nothing
+
+readVersionedElement :: forall t . Xml t => Element -> Maybe t
+readVersionedElement e = readElement e
+
+readElement :: forall t . Xml t => Element -> Maybe t
+readElement (Elem n es) = res
+    where resType :: t
+          resType = typeNotValue resType
+          resDataType = dataTypeOf xmlProxy resType
+          con = readConstr resDataType n
+          res = case con of
+                Just c -> f c
+                Nothing -> Nothing
+          f c =     let m :: Maybe ([Element], t)
+                        m = constrFromElements c es
+                    in case m of
+                           Just ([], x) -> Just x
+                           _ -> Nothing
+readElement _ = Nothing
+
+constrFromElements :: forall t . Xml t
+                   => Constr -> [Element] -> Maybe ([Element], t)
+constrFromElements c es
+ = do let st = ReadState { xmls = es }
+          m :: ReadM Maybe t
+          m = fromConstrM xmlProxy (readMXmlD dict) c
+      -- XXX Should we flip the result order?
+      (x, st') <- runStateT m st
+      return (xmls st', x)
+
+type ReadM m = StateT ReadState m
+
+data ReadState = ReadState {
+                     xmls :: [Element]
+                 }
+
+getXmls :: Monad m => ReadM m [Element]
+getXmls = do st <- get
+             return $ xmls st
+
+putXmls :: Monad m => [Element] -> ReadM m ()
+putXmls xs = do st <- get
+                put $ st { xmls = xs }
+
+readMXml :: Xml a => ReadM Maybe a
+readMXml
+ = do xs <- getXmls
+      case readXml xs of
+          Nothing -> fail "Cannot read value"
+          Just (xs', v) ->
+              do putXmls xs'
+                 return v
+
+typeNotValue :: Xml a => a -> a
+typeNotValue t = error ("Type used as value: " ++ typeName)
+    where typeName = dataTypeName (dataTypeOf xmlProxy t)
+
+-- The Xml [a] context is a bit scary, but if we don't have it then
+-- GHC complains about overlapping instances
+
+instance (Xml a {-, Xml [a] -}) => Xml [a] where
+    toXml = concatMap toXml
+    readXml = f [] []
+        where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
+              f acc_xs acc_vs (x:xs) = case readXml [x] of
+                                           Just ([], v) ->
+                                               f acc_xs (v:acc_vs) xs
+                                           _ ->
+                                               f (x:acc_xs) acc_vs xs
+
+instance Xml String where
+    toXml x = [CData x]
+    readXml = readXmlWith f
+        where f (CData x) = Just x
+              f _ = Nothing
+
index 1b5cbfe..ff56059 100644 (file)
@@ -1,82 +1,82 @@
-{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, \r
-      FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances,\r
-      TypeSynonymInstances, GeneralizedNewtypeDeriving #-}\r
------------------------------------------------------------------------------\r
--- |\r
--- Module      :  HSX.XMLGenerator\r
--- Copyright   :  (c) Niklas Broberg 2008\r
--- License     :  BSD-style (see the file LICENSE.txt)\r
--- \r
--- Maintainer  :  Niklas Broberg, niklas.broberg@chalmers.se\r
--- Stability   :  experimental\r
--- Portability :  requires newtype deriving and MPTCs with fundeps\r
---\r
--- The class and monad transformer that forms the basis of the literal XML\r
--- syntax translation. Literal tags will be translated into functions of\r
--- the GenerateXML class, and any instantiating monads with associated XML\r
--- types can benefit from that syntax.\r
------------------------------------------------------------------------------\r
-module T4809_XMLGenerator where\r
-\r
-import Control.Applicative\r
-import Control.Monad\r
-import Control.Monad.Trans\r
-import Control.Monad.Cont  (MonadCont)\r
-import Control.Monad.Error (MonadError)\r
-import Control.Monad.Reader(MonadReader)\r
-import Control.Monad.Writer(MonadWriter)\r
-import Control.Monad.State (MonadState)\r
-import Control.Monad.RWS   (MonadRWS)\r
-import Control.Monad (MonadPlus(..),liftM)\r
-\r
-----------------------------------------------\r
--- General XML Generation\r
-\r
--- | The monad transformer that allows a monad to generate XML values.\r
-newtype XMLGenT m a = XMLGenT (m a)\r
-  deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,\r
-            MonadState s, MonadRWS r w s, MonadCont, MonadError e)\r
-\r
-instance Monad m => Applicative (XMLGenT m) where\r
-  pure  = return\r
-  (<*>) = ap\r
-\r
-instance Monad m => Alternative (XMLGenT m) where\r
-\r
--- | un-lift.\r
-unXMLGenT :: XMLGenT m a -> m a\r
-unXMLGenT   (XMLGenT ma) =  ma\r
-\r
-instance MonadTrans XMLGenT where\r
- lift = XMLGenT\r
-\r
-type Name = (Maybe String, String)\r
-\r
--- | Generate XML values in some XMLGenerator monad.\r
-class Monad m => XMLGen m where\r
- type XML m\r
- data Child m\r
- genElement  :: Name -> [XMLGenT m [Int]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)\r
- genEElement :: Name -> [XMLGenT m [Int]]                          -> XMLGenT m (XML m)\r
- genEElement n ats = genElement n ats []\r
-\r
--- | Embed values as child nodes of an XML element. The parent type will be clear\r
--- from the context so it is not mentioned.\r
-class XMLGen m => EmbedAsChild m c where\r
- asChild :: c -> XMLGenT m [Child m]\r
-\r
-instance (MonadIO m, EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where\r
- asChild m = do\r
-      liftIO $ putStrLn "EmbedAsChild m (XMLGenT n c)"\r
-      a <- m\r
-      asChild a\r
-\r
-instance (MonadIO m, EmbedAsChild m c) => EmbedAsChild m [c] where\r
-  asChild cs = \r
-      do liftIO $ putStrLn "EmbedAsChild m [c]"\r
-         liftM concat . mapM asChild $ cs\r
-\r
-instance (MonadIO m, XMLGen m) => EmbedAsChild m (Child m) where\r
- asChild c = \r
-     do liftIO $ putStrLn "EmbedAsChild m (Child m)"\r
-        return . return $ c \r
+{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,
+      FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances,
+      TypeSynonymInstances, GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HSX.XMLGenerator
+-- Copyright   :  (c) Niklas Broberg 2008
+-- License     :  BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer  :  Niklas Broberg, niklas.broberg@chalmers.se
+-- Stability   :  experimental
+-- Portability :  requires newtype deriving and MPTCs with fundeps
+--
+-- The class and monad transformer that forms the basis of the literal XML
+-- syntax translation. Literal tags will be translated into functions of
+-- the GenerateXML class, and any instantiating monads with associated XML
+-- types can benefit from that syntax.
+-----------------------------------------------------------------------------
+module T4809_XMLGenerator where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Cont  (MonadCont)
+import Control.Monad.Error (MonadError)
+import Control.Monad.Reader(MonadReader)
+import Control.Monad.Writer(MonadWriter)
+import Control.Monad.State (MonadState)
+import Control.Monad.RWS   (MonadRWS)
+import Control.Monad (MonadPlus(..),liftM)
+
+----------------------------------------------
+-- General XML Generation
+
+-- | The monad transformer that allows a monad to generate XML values.
+newtype XMLGenT m a = XMLGenT (m a)
+  deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
+            MonadState s, MonadRWS r w s, MonadCont, MonadError e)
+
+instance Monad m => Applicative (XMLGenT m) where
+  pure  = return
+  (<*>) = ap
+
+instance Monad m => Alternative (XMLGenT m) where
+
+-- | un-lift.
+unXMLGenT :: XMLGenT m a -> m a
+unXMLGenT   (XMLGenT ma) =  ma
+
+instance MonadTrans XMLGenT where
+ lift = XMLGenT
+
+type Name = (Maybe String, String)
+
+-- | Generate XML values in some XMLGenerator monad.
+class Monad m => XMLGen m where
+ type XML m
+ data Child m
+ genElement  :: Name -> [XMLGenT m [Int]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)
+ genEElement :: Name -> [XMLGenT m [Int]]                          -> XMLGenT m (XML m)
+ genEElement n ats = genElement n ats []
+
+-- | Embed values as child nodes of an XML element. The parent type will be clear
+-- from the context so it is not mentioned.
+class XMLGen m => EmbedAsChild m c where
+ asChild :: c -> XMLGenT m [Child m]
+
+instance (MonadIO m, EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where
+ asChild m = do
+      liftIO $ putStrLn "EmbedAsChild m (XMLGenT n c)"
+      a <- m
+      asChild a
+
+instance (MonadIO m, EmbedAsChild m c) => EmbedAsChild m [c] where
+  asChild cs =
+      do liftIO $ putStrLn "EmbedAsChild m [c]"
+         liftM concat . mapM asChild $ cs
+
+instance (MonadIO m, XMLGen m) => EmbedAsChild m (Child m) where
+ asChild c =
+     do liftIO $ putStrLn "EmbedAsChild m (Child m)"
+        return . return $ c
index 994348b..131b693 100644 (file)
@@ -1,13 +1,13 @@
 {-# LANGUAGE FlexibleContexts #-}
-\r
-module TcRun038_B where\r
-\r
-class Foo a where\r
-  op :: a -> Int\r
-\r
--- Note the (Foo Int) constraint here; and the fact\r
--- that there is no (Foo Int) instance in this module\r
--- It's in the importing module!\r
-\r
-bar :: Foo Int => Int -> Int\r
-bar x = op x + 7\r
+
+module TcRun038_B where
+
+class Foo a where
+  op :: a -> Int
+
+-- Note the (Foo Int) constraint here; and the fact
+-- that there is no (Foo Int) instance in this module
+-- It's in the importing module!
+
+bar :: Foo Int => Int -> Int
+bar x = op x + 7
index 8aa4363..5609a9f 100644 (file)
@@ -1,20 +1,20 @@
 
-{-# LANGUAGE UndecidableInstances #-}\r
-\r
--- This tests the recursive-dictionary stuff.\r
-\r
-module Main where\r
-\r
-data Fix f = In (f (Fix f)) \r
-\r
-instance Show (f (Fix f)) => Show (Fix f) where\r
-  show (In x) = "In " ++ show x        -- No parens, but never mind\r
-\r
-instance Eq (f (Fix f)) => Eq (Fix f) where\r
-  (In x) == (In y) = x==y\r
-\r
-data L x = Nil | Cons Int x  deriving( Show, Eq )\r
-\r
-main = do { print (In Nil); \r
-           print (In Nil == In Nil) }\r
-\r
+{-# LANGUAGE UndecidableInstances #-}
+
+-- This tests the recursive-dictionary stuff.
+
+module Main where
+
+data Fix f = In (f (Fix f))
+
+instance Show (f (Fix f)) => Show (Fix f) where
+  show (In x) = "In " ++ show x -- No parens, but never mind
+
+instance Eq (f (Fix f)) => Eq (Fix f) where
+  (In x) == (In y) = x==y
+
+data L x = Nil | Cons Int x  deriving( Show, Eq )
+
+main = do { print (In Nil);
+            print (In Nil == In Nil) }
+
index 26337cd..04c7d83 100644 (file)
@@ -1,8 +1,8 @@
-module Main where\r
-\r
-import TcRun038_B( Foo(..), bar )\r
-\r
-instance Foo Int where\r
-  op x = x+1\r
-\r
-main = print (bar (3::Int))\r
+module Main where
+
+import TcRun038_B( Foo(..), bar )
+
+instance Foo Int where
+  op x = x+1
+
+main = print (bar (3::Int))
index 916d533..eabe015 100644 (file)
@@ -1,22 +1,22 @@
 {-# LANGUAGE GADTs, ExplicitForAll #-}
-\r
--- Test for GADTs and implication constraints\r
-\r
-module Main where\r
-\r
-data T a where\r
-  MkT :: Num a => a -> T a\r
-\r
-f :: Read a => T a -> String -> a\r
-f (MkT n) s = n + read s\r
-\r
-----------------\r
-data GADT a where\r
-  MkG :: Num a => a -> GADT [a]\r
-\r
-g :: forall b. Read b => GADT b -> String -> b\r
-g (MkG n) s = -- Here we know Read [b]\r
-             n : (read s)\r
-\r
-main = do print (f (MkT (3::Int)) "4")\r
-          print (g (MkG (3::Int)) "[4,5]")\r
+
+-- Test for GADTs and implication constraints
+
+module Main where
+
+data T a where
+  MkT :: Num a => a -> T a
+
+f :: Read a => T a -> String -> a
+f (MkT n) s = n + read s
+
+----------------
+data GADT a where
+  MkG :: Num a => a -> GADT [a]
+
+g :: forall b. Read b => GADT b -> String -> b
+g (MkG n) s = -- Here we know Read [b]
+              n : (read s)
+
+main = do print (f (MkT (3::Int)) "4")
+          print (g (MkG (3::Int)) "[4,5]")