Commit 31c312eb authored by thomie's avatar thomie

Testsuite: delete Windows line endings [skip ci] (#11631)

parent d3cf2a9b
{-# 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
{-# 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
{-# 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 }
------------------------------------------------------------------------------
{-# 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 }
------------------------------------------------------------------------------
{-# 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
{-# 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
{-# 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
{-# 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
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)
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)
{-# 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
{-# 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]