remove the last bits of the ghc/ subdir

4 files changed, 223 insertions, 0 deletions

diff --git a/quickcheck/HeaderInfoTests.hs b/quickcheck/HeaderInfoTests.hs
new file mode 100644
index 0000000000..6f8bef6239
--- /dev/null
+++ b/quickcheck/HeaderInfoTests.hs
@@ -0,0 +1,129 @@
+module HeaderInfoTests
+    ( prop_optionsIdentity
+    , prop_languageParse
+    , prop_languageError
+    ) where
+
+import Test.QuickCheck
+import Test.QuickCheck.Batch
+import Data.Char
+
+import Control.Monad
+import System.IO.Unsafe
+
+import HeaderInfo
+import StringBuffer
+import SrcLoc
+
+import Language.Haskell.Extension
+
+newtype CmdOptions = CmdOptions {cmdOptions :: [String]}
+    deriving Show
+
+instance Arbitrary CmdOptions where
+    arbitrary = resize 30 $ liftM CmdOptions arbitrary
+    coarbitrary = undefined
+
+instance Arbitrary Char where
+    arbitrary = elements $ ['a'..'z']++['A'..'Z']
+    coarbitrary = undefined
+
+data Options = Options
+             | Options_GHC
+               deriving Show
+
+instance Arbitrary Options where
+    arbitrary = elements [Options,Options_GHC]
+    coarbitrary = undefined
+
+-- Test that OPTIONS are correctly extracted from a buffer
+-- with comments and garbage.
+prop_optionsIdentity lowercase options cmds
+    = not (null cmds) ==>
+      all (all (not.null).cmdOptions) cmds ==>
+      concatMap cmdOptions cmds == map unLoc (getOptions buffer "somefile")
+    where buffer = unsafePerformIO $ stringToStringBuffer str
+          str = concatMap mkPragma cmds ++
+                "\n @#@# garbage #@#@ \n"
+          mkPragma (CmdOptions cmd)
+              = unlines [ "-- Pragma: "
+                        , unwords $ ["{-#", pragma]++cmd++["#-}"]
+                        , "{- End of pragma -}" ]
+          pragma = (if lowercase then map toLower else map toUpper) $ 
+                   case options of
+                     Options -> "OPTIONS"
+                     Options_GHC -> "OPTIONS_GHC"
+
+newtype Extensions = Extensions [Extension]
+    deriving Show
+
+instance Arbitrary Extensions where
+    arbitrary = resize 30 $ liftM Extensions arbitrary
+    coarbitrary = undefined
+
+extensions :: [Extension]
+extensions = [ OverlappingInstances
+             , UndecidableInstances
+             , IncoherentInstances
+             , RecursiveDo
+             , ParallelListComp
+             , MultiParamTypeClasses
+             , NoMonomorphismRestriction
+             , FunctionalDependencies
+             , Rank2Types
+             , RankNTypes
+             , PolymorphicComponents
+             , ExistentialQuantification
+             , ScopedTypeVariables
+             , ImplicitParams
+             , FlexibleContexts
+             , FlexibleInstances
+             , EmptyDataDecls
+             , CPP
+             , TypeSynonymInstances
+             , TemplateHaskell
+             , ForeignFunctionInterface
+             , InlinePhase
+             , ContextStack
+             , Arrows
+             , Generics
+             , NoImplicitPrelude
+             , NamedFieldPuns
+             , PatternGuards
+             , GeneralizedNewtypeDeriving
+             , ExtensibleRecords
+             , RestrictedTypeSynonyms
+             , HereDocuments ]
+
+-- derive Enum for Extension?
+instance Arbitrary Extension where
+    arbitrary = elements extensions
+    coarbitrary = undefined
+
+-- Test that we can parse all known extensions.
+prop_languageParse lowercase (Extensions exts)
+    = not (null exts) ==>
+      not (isBottom (getOptions buffer "somefile"))
+    where buffer = unsafePerformIO $ stringToStringBuffer str
+          str = unlines [ "-- Pragma: "
+                        , unwords $ ["{-#", pragma, ppExts exts "" , "#-}"]
+                        , "{- End of pragma -}"
+                        , "garbage#@$#$" ]
+          ppExts [e] = shows e
+          ppExts (x:xs) = shows x . showChar ',' . ppExts xs
+          ppExts [] = id
+          pragma = (if lowercase then map toLower else map toUpper)
+                   "LANGUAGE"
+
+-- Test that invalid extensions cause exceptions.
+prop_languageError lowercase ext
+    = not (null ext) ==>
+      ext `notElem` map show extensions ==>
+      isBottom (foldr seq () (getOptions buffer "somefile"))
+    where buffer = unsafePerformIO $ stringToStringBuffer str
+          str = unlines [ "-- Pragma: "
+                        , unwords $ ["{-#", pragma, ext , "#-}"]
+                        , "{- End of pragma -}"
+                        , "garbage#@$#$" ]
+          pragma = (if lowercase then map toLower else map toUpper)
+                   "LANGUAGE"
diff --git a/quickcheck/README b/quickcheck/README
new file mode 100644
index 0000000000..251bc807e0
--- /dev/null
+++ b/quickcheck/README
@@ -0,0 +1,9 @@
+QuickCheck for the GHC library.
+
+Requirements:
+  stage2 of ghc.
+
+Usage:
+  ./run.sh
+  ./run.sh debug       # runs quickCheck in debug mode.
+  ./run.sh ghci [file] # loads [file] with the stage2 compiler.
diff --git a/quickcheck/RunTests.hs b/quickcheck/RunTests.hs
new file mode 100644
index 0000000000..4aabb48584
--- /dev/null
+++ b/quickcheck/RunTests.hs
@@ -0,0 +1,62 @@
+module RunTests where
+
+import Test.QuickCheck.Batch hiding (runTests)
+import System.Exit
+import System.Environment
+
+import HeaderInfoTests as HI
+
+runUnitTests :: Bool -> IO ()
+runUnitTests debug = exitWith =<< performTests debug
+
+performTests :: Bool -> IO ExitCode
+performTests debug =
+    do e1 <- exeTests "HeaderInfo" opts
+                   [ run HI.prop_optionsIdentity
+                   , run HI.prop_languageParse
+                   , run HI.prop_languageError ]
+       return (foldr1 cat [e1])
+    where opts = TestOptions 100 10 debug
+          cat (e@(ExitFailure _)) _ = e
+          cat _ e = e
+
+exeTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ExitCode
+exeTests name scale actions =
+    do putStr (rjustify 25 name ++ " : ")
+       tr 1 actions [] 0 False
+    where
+      rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
+      tr n [] xs c e = do
+                     putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
+                     mapM_ fa xs
+                     if e
+                        then return (ExitFailure 1)
+                        else return ExitSuccess
+      tr n (action:actions) others c e =
+          do r <- action scale
+             case r of
+               (TestOk _ m _)
+                   -> do { putStr "." ;
+                           tr (n+1) actions others (c+m) e }
+               (TestExausted s m ss)
+                   -> do { putStr "?" ;
+                           tr (n+1) actions others (c+m) e }
+               (TestAborted e)
+                   -> do { print e;
+                           putStr "*" ;
+                           tr (n+1) actions others c True }
+               (TestFailed f num)
+                   -> do { putStr "#" ;
+                           tr (n+1) actions ((f,n,num):others) (c+num) True }
+      fa :: ([String],Int,Int) -> IO ()
+      fa (f,n,no) =
+          do putStr "\n"
+             putStr ("    ** test "
+                     ++ show (n  :: Int)
+                     ++ " of "
+                     ++ name
+                     ++ " failed with the binding(s)\n")
+             sequence_ [putStr ("    **   " ++ v ++ "\n")
+                        | v <- f ]
+             putStr "\n"
+
diff --git a/quickcheck/run.sh b/quickcheck/run.sh
new file mode 100644
index 0000000000..cff728abee
--- /dev/null
+++ b/quickcheck/run.sh
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+# I suck at bash scripting. Please feel free to make this code better.
+
+Root=../compiler
+
+ExtraOptions="-cpp -fglasgow-exts -package ghc"
+
+HC=$Root/stage2/ghc-inplace
+
+Debug="False"
+
+if [ "$1" == "debug" ]
+  then
+    Debug="True"
+fi
+
+if [ "$1" == "ghci" ]
+  then
+    $HC --interactive $ExtraOptions $2
+  else
+    $HC --interactive -e "runUnitTests $Debug" $ExtraOptions RunTests.hs
+fi
\ No newline at end of file