testing-feat-1.1.1.1: examples/haskell-src-exts/hse.hs
{-# Language TemplateHaskell #-}
import Test.Feat
-- import Test.Feat.Class
import Test.Feat.Modifiers
import Test.Feat.Driver
import Control.Enumerable
import Language.Haskell.Exts
import Language.Haskell.Exts.Syntax
import Control.Exception as Ex
-- Welcome to the automatic HSE tester!
-- Things to try while youre here:
-- switch between Exp/Module/Decl etc. as TestParse
-- to discover bugs in the various entry-points of the grammar.
-- TODOs: add some newtypes and modifiers to deal with syntax type invariants
-- (such as only enumerating non-empty do-expressions with a statement as last expression).
--
-- Catalogue and report all the bugs found.
--
-- Fix the round-trip
main = do
main_parse -- Test the parsable property
main_round -- Test the round-trip property
-- Everything produced by the pretty printer is parseable.
type TestParse = Exp SrcSpanInfo -- Type to be tested
main_parse = do
res <- test prop_parse
mapM (putStr . rep_parse) res
rep_parse :: TestParse -> String
rep_parse e = case myParse $ prettyPrint e of
ParseOk e' -> const "" (e' `asTypeOf` e)
ParseFailed _ err -> unlines
[(show $ fmap (const ()) e)
,(prettyPrint e)
,err]
prop_parse :: TestParse -> Bool
prop_parse e = case myParse $ prettyPrint e of
ParseOk e' -> const True (e' `asTypeOf` e)
ParseFailed _ err -> False
-- Everything which is produced by the pretty printer parses back to itself
type TestRoundtrip = Exp SrcSpanInfo
main_round = do
res <- testOptions defOptions{oBounded = (Just 10000)} prop_trip
mapM (putStr . rep_trip) res
-- Tests a "roundtrip and a half"
-- parse (print e) == parse (print (parse (print e)))
-- Ignores parsing errors
prop_trip :: TestRoundtrip -> Bool
prop_trip e = case roundAndAhalf e of
ParseOk (e', e'') -> eq e' e''
ParseFailed _ err -> True
eq :: TestRoundtrip -> TestRoundtrip -> Bool
eq a b = fmap (const ()) a == fmap (const ()) b
rep_trip :: TestRoundtrip -> String
rep_trip e = case roundAndAhalf e of
ParseOk (e', e'') -> unlines [
"Original:",
show (fmap (const ()) e),
prettyPrint e,
"",
"One print/parse round:",
show (fmap (const ()) e'),
prettyPrint e',
"",
"Two print/parse round:",
show (fmap (const ()) e''),
prettyPrint e''
]
ParseFailed _ err -> unlines
[(show $ fmap (const ()) e)
,(prettyPrint e)
,err]
roundAndAhalf :: TestRoundtrip -> ParseResult (TestRoundtrip, TestRoundtrip)
roundAndAhalf e = do
e' <- myParse $ prettyPrint e
e'' <- myParse $ prettyPrint e'
return (e', e'')
{-
-- Everything which is produced by the pretty printer and is parseable is
-- semantically euivalent to the original.
-- The pretty printer doesnt fail, for testing the enumerators.
type TestPrint = Module
prop_print :: Pretty a => a -> Bool
prop_print e = length (prettyPrint e) >= 0
rep_print :: (Show a, Pretty a) => a -> IO ()
rep_print e = Ex.catch
(prop_print e `seq` return ())
(\err -> do
putStrLn (show e)
if show (err::SomeException) == "user interrupt" then undefined else return ()
putStrLn $ show (err::SomeException)
putStrLn "")
-}
-- Parse with all extensions
myParse :: Parseable a => String -> ParseResult a
myParse = parseWithMode defaultParseMode{
extensions = [ e |e@(EnableExtension _) <- knownExtensions]
}
sureParse :: Parseable a => String -> a
sureParse s = case myParse s of
ParseOk a -> a
ParseFailed _ err -> error err
parse_print :: (Parseable a, Pretty a) => String -> (a,String)
parse_print s = let a = sureParse s in (a,prettyPrint a)
instance Enumerable SrcSpanInfo where
enumerate = datatype [c0 $ SrcSpanInfo (SrcSpan "M.hs" 0 0 0 0) []]
-- Uncomment the dExcluding line to enable known bugs
(let
buggy1 =
dExcluding 'UnboxedSingleCon .
dAll
buggy2 =
dExcluding 'PQuasiQuote .
dAll
buggy3 =
dExcept 'Tuple [| c3 (\a b c -> Tuple a b (nonEmpty c))|] .
dExcept 'TupleSection [| c3 (\a b c -> TupleSection a b (nonEmpty c))|] .
dExcept 'LCase [| c2 (\a -> LCase a . nonEmpty) |] .
dExcept 'Do [| c3 $ \a ss e -> Do a (ss ++ [Qualifier a e]) |] .
dExcept 'Var [| c2 (\a b -> Var a (nonSpecial b)) |] .
dExcept 'Con [| c2 (\a b -> Con a (nonSpecial b)) |] .
dExcept 'Lambda [| c3 (\a b c -> Lambda a (nonEmpty b) c) |] .
dExcept 'RecUpdate [| c3 (\a b c -> RecUpdate a b (nonEmpty c)) |] .
dExcept 'ListComp [| c3 (\a b c -> ListComp a b (nonEmpty c)) |] .
dExcluding 'TypeApp .
dExcluding 'GenPragma . -- Seems genuinly buggy
dExcluding 'TypQuote .
dExcluding 'VarQuote .
dExcluding 'BracketExp .
dExcluding 'MDo .
dExcluding 'IPVar . -- What is this?
dExcluding 'QuasiQuote .
dExcluding 'XPcdata .
dExcluding 'XExpTag .
dExcluding 'XChildTag .
dExcluding 'OverloadedLabel .
dExcept 'XPcdata [| c2 $ \a -> XPcdata a . nonEmpty |] .
dExcept 'MultiIf [| c2 $ \a -> MultiIf a . nonEmpty |] .
dAll
fixdecs =
dExcluding 'DeprPragmaDecl .
dExcluding 'WarnPragmaDecl .
dExcluding 'SpliceDecl .
dExcept 'TypeSig [| c3 (\a b c -> TypeSig a (nonEmpty b) c) |] .
dExcept 'InfixDecl [| c4 $ \a b c -> InfixDecl a b c . nonEmpty |] .
dExcept 'CompletePragma [| c3 $ \a b c -> CompletePragma a (nonEmpty b) c|] .
dAll
fixlit =
dExcluding 'PrimWord .
dExcluding 'PrimInt . -- Buggy?
--dExcept 'PrimWord [| c2 (\a x -> PrimWord a (toInteger (x :: Word)) (show x)) |] .
dExcept 'Int [| c2 (\a x -> Int a (toInteger (x :: Word)) (show x)) |] .
dAll
fixType =
dExcept 'TyUnboxedSum [| c2 (\a b -> TyUnboxedSum a (nonEmpty b))|] .
dExcluding 'TyQuasiQuote .
dAll
in fmap concat $ mapM deriveEnumerable' [
dExcluding 'XmlHybrid $ dExcluding 'XmlPage $ dAll ''Module,
-- dAll ''SrcLoc,
dExcluding 'AnnModulePragma $ dExcluding 'LanguagePragma
-- dExcept 'LanguagePragma [|c2 $ \x -> LanguagePragma x . nonEmpty|]
$ dAll ''ModulePragma,
dAll ''ImportDecl,
fixdecs ''Decl,
dAll ''Tool,
dAll ''QName,
dAll ''ImportSpec,
dAll ''Annotation,
fixType ''Type,
dAll ''Activation,
dAll ''Rule,
dAll ''CallConv,
dAll ''Safety,
buggy2 ''Pat,
dAll ''Rhs,
dAll ''Binds,
dAll ''Match,
buggy3 ''Exp,
dAll ''Assoc,
dAll ''Op,
dAll ''Asst,
dAll ''InstDecl,
dAll ''TyVarBind,
dAll ''FunDep,
dAll ''ClassDecl,
dAll ''DataOrNew,
dAll ''Kind,
dAll ''GadtDecl,
dAll ''QualConDecl,
buggy1 ''SpecialCon,
dAll ''Boxed,
dAll ''RuleVar,
dAll ''XName,
dAll ''PXAttr,
dAll ''RPat,
dAll ''PatField,
dAll ''GuardedRhs,
dAll ''IPBind,
dAll ''XAttr,
dExcluding 'IdSplice $ dAll ''Splice,
dAll ''Bracket,
dAll ''QualStmt,
dAll ''FieldUpdate,
dAll ''QOp,
dAll ''Stmt,
dAll ''Alt,
fixlit ''Literal,
dAll ''IPName,
dAll ''ConDecl,
dAll ''RPatOp,
-- dAll ''GuardedAlts,
dAll ''BangType,
-- dAll ''GuardedAlt,
dAll ''TypeEqn,
dAll ''Sign,
dAll ''Role,
dAll ''Promoted,
dAll ''PatternSynDirection,
dAll ''Overlap,
dAll ''Namespace,
dAll ''BooleanFormula,
dAll ''ImportSpecList,
dAll ''DeclHead,
dAll ''ResultSig,
dAll ''InjectivityInfo,
dAll ''Context,
dAll ''Deriving,
dAll ''InstRule,
dAll ''Unpackedness,
dAll ''FieldDecl,
dAll ''InstHead,
dAll ''DerivStrategy,
dAll ''MaybePromotedName
])
instance Enumerable a => Enumerable (ModuleHead a) where
enumerate = datatype [c1 $ \a -> ModuleHead a (ModuleName a "M") Nothing Nothing]
instance Enumerable a => Enumerable (ExportSpec a) where
enumerate = datatype [ c2 $ \a -> EVar a . nonSpecial
, c3 $ \a x -> EAbs a x . nonSpecial
-- , c1 $ EThingAll . nonSpecial
-- , c2 $ EThingWith . nonSpecial
, c2 $ EModuleContents
]
-- newtype Upper = Upper {upper :: QName}
-- instance Enumerable Upper where
-- enumerate = datatype [c2 Qual
newtype NonSpecialName a = NonSpecialName {nonSpecial :: QName a}
instance Enumerable a => Enumerable (NonSpecialName a) where
enumerate = datatype [fmap NonSpecialName $ c3 Qual
,fmap NonSpecialName $ c2 UnQual
]
instance Enumerable a => Enumerable (ModuleName a) where
enumerate = datatype
[ c1 $ \a -> ModuleName a "M"
, c1 $ \a -> ModuleName a "C.M"
]
-- Will probably need to be broken into constructor/variable/symbol names
instance Enumerable a => Enumerable (Name a) where
enumerate = datatype
[ c1 $ \a -> Ident a "C"
, c1 $ \a -> Ident a "v"
-- , c0 $ Symbol "*"
]
instance Enumerable a => Enumerable (CName a) where
enumerate = datatype
[ c1 $ \a -> VarName a (Ident a "v")
, c1 $ \a -> ConName a (Ident a "C")
]
instance Enumerable SrcLoc where
enumerate = datatype
[ c0 (SrcLoc "File.hs" 0 0)]