diff options
| -rw-r--r-- | testsuite/tests/perf/compiler/T19695.hs | 136 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 5 |
2 files changed, 141 insertions, 0 deletions
diff --git a/testsuite/tests/perf/compiler/T19695.hs b/testsuite/tests/perf/compiler/T19695.hs new file mode 100644 index 0000000000..568389ad3b --- /dev/null +++ b/testsuite/tests/perf/compiler/T19695.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module T19695 where + +import Prelude +import Control.Monad (liftM) +import Control.Monad.Trans.RWS.Lazy +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Data.Monoid (Any (..)) +import Data.String (IsString (..)) +import Data.Char (toUpper, toLower, isAlpha) +import Data.List (intersperse) +import qualified Data.Map as Map +import GHC.Generics + +type Handler = ReaderT () IO +type MForm = RWST (Maybe ([(String, Text)], ()), (), ()) Any [Int] +type Text = ByteString + +data FormResult a = FormMissing + | FormFailure [Text] + | FormSuccess a + deriving Show +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing +instance Monoid m => Monoid (FormResult m) where + mempty = pure mempty +instance Semigroup m => Semigroup (FormResult m) where + x <> y = (<>) <$> x <*> y + +mreq :: MonadIO m => String -> MForm m (FormResult Text, ()) +mreq v = mhelper v (\_ _ -> FormFailure ["fail"]) FormSuccess +mcountry :: MonadIO m => String -> MForm m (FormResult CountryCode, ()) +mcountry v = mhelper v (\_ _ -> FormFailure ["fail"]) go where + go t = let + fanl f x= (f x , x) + m = Map.fromList $ map (fanl $ fromString . countryNameFromCode) [minBound..maxBound] + in maybe (FormFailure ["fail"]) FormSuccess $ Map.lookup t m + +askParams :: Monad m => MForm m (Maybe [(String, Text)]) +askParams = do + (x, _, _) <- ask + return $ liftM fst x + +mhelper + :: MonadIO m + => String + -> (() -> () -> FormResult b) + -> (Text -> FormResult b) + -> MForm m (FormResult b, ()) +mhelper v onMissing onFound = do + tell (Any True) + mp <- askParams + (res, x) <- case mp of + Nothing -> return (FormMissing, ()) + Just p -> do + return $ case lookup v p of + Nothing -> (onMissing () (), ()) + Just t -> (onFound t, ()) + return (res, x) + +data ShippingForm = ShippingForm + { shCustomerName :: CountryCode + , shCountry :: CountryCode + , shPostalCode :: CountryCode + , shAddress1 :: CountryCode + , shAddress2 :: CountryCode + , shCity :: CountryCode + , shCountyState :: CountryCode + , shContact :: CountryCode + , shTelephone :: CountryCode + , shNotificationEmail :: CountryCode + , shNotificationCountryCode :: CountryCode + , shNoOfPackages :: CountryCode + , shWeight :: CountryCode + , shGenerateCustomData :: CountryCode + , shTaxId :: CountryCode + , shServiceCode :: CountryCode + } deriving Show + +data Match = Match + +shippingForm :: Maybe ShippingForm + -> MForm Handler (FormResult ShippingForm) +shippingForm _ = do + customerName <- mcountry "Customer Name" + country <- mcountry "Country" + postalCode <- mcountry "Postal/Zip Code" + address1 <- mcountry "Address 1" + address2 <- mcountry "Address 2" + city <- mcountry "City" + countyState <- mcountry "County/State" + contact <- mcountry "Contact" + telephone <- mcountry "Telephone" + notificationEmail <- mcountry "Notification Email" + notificationText <- mcountry "Notification Text" + noOfPackages <- mcountry "No of Packages" + weight <- mcountry "Weight" + generateCustomData <- mcountry "Custom Data" + taxId <- mcountry "EORI" + serviceCode <- mcountry "Service" + return (ShippingForm <$> fst customerName + <*> fst country + <*> fst postalCode + <*> fst address1 + <*> fst address2 + <*> fst city + <*> fst countyState + <*> fst contact + <*> fst telephone + <*> fst notificationEmail + <*> fst notificationText + <*> fst noOfPackages + <*> fst weight + <*> fst generateCustomData + <*> fst taxId + <*> fst serviceCode + ) + +data CountryCode = CC + deriving (Eq,Read,Show,Enum,Bounded,Ord,Generic) + +countryNameFromCode:: CountryCode -> String +countryNameFromCode CC = "CC" diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 2044da0f90..6876060978 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -481,3 +481,8 @@ test ('T20049', [ collect_compiler_stats('bytes allocated',2) ], compile, ['']) + +test ('T19695', + [ collect_compiler_stats('bytes allocated',2)], + compile, + ['-v0 -O2']) |