th.hs

-- This is tested with haskell-src-exts-1.19.1
{-#LANGUAGE MagicHash, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
-- BangPatterns, ScopedTypeVariables, ViewPatterns, KindSignatures


import Language.Haskell.TH.Syntax
  ( Exp(..), Pat(..), Stmt(..), Type(..), Dec(..),
    Range(..), Lit(..), Kind(..),
    Body(..), Guard(..), Con(..), Match(..),
    Name(..), mkName, NameFlavour(..), NameSpace(..),
    Clause(..), Pragma(..), FamFlavour(..),
    Pred(..), TyVarBndr(..),
    Foreign, Callconv(..), FunDep(..),
    Safety(..), Strict(..), OccName(..), ModName(..))
-- testing-feat
import Test.Feat
import Test.Feat.Modifiers
import Control.Enumerable
-- template-haskell
-- import Language.Haskell.TH.Syntax.Internals(OccName(OccName), ModName(ModName), PkgName)
import Language.Haskell.TH.Ppr(pprint,Ppr)
-- haskell-src-meta
-- import Language.Haskell.Meta(toExp)
-- haskell-src-exts
import qualified Language.Haskell.Exts as E
-- quickcheck
import Test.QuickCheck hiding (NonEmpty, (><))
--base
import Data.Typeable(Typeable)
import Data.Ord
import Data.List
-- smallcheck

-- import Test.SmallCheck.Series hiding (Nat)
-- import Test.SmallCheck


main = testOptions defOptions{oMaxCounter=Just 10} prop_parses

type Ex = (E.Exp E.SrcSpanInfo)


-- Haskell parser
myParse :: String -> E.ParseResult Ex
myParse = E.parseWithMode E.defaultParseMode{E.extensions =
     (map E.EnableExtension [E.ExplicitForAll, E.ConstraintKinds])
{-    [ E.BangPatterns
    , E.ScopedTypeVariables
    , E.ViewPatterns
    , E.KindSignatures
    , E.ExplicitForAll
    , E.TypeFamilies
    ]-}
    }

-- | Newtype to make error reporting look nicer
newtype PPR a = PPR a

instance (Show a, Ppr a) => Show (PPR a) where
  show (PPR a) = show a ++ "\n" ++ pprint a ++ "\n" ++errormsg a where
    errormsg x = case myParse (pprint x) of
      E.ParseFailed _ s -> s
      E.ParseOk _     -> "OK"
instance Enumerable a => Enumerable (PPR a) where
  enumerate = share (c1 PPR) 

-- | Every pretty-printer result should be par
prop_parses (PPR e) = case myParse $ pprint (e :: Exp) of
  E.ParseOk _       -> True
  E.ParseFailed _ s -> False

{-

-- Currently both of these spit out a lot of errors unless we disable a few of the
-- buggier constructors (which we have done below).
test_parsesAll = ioAll 15 report_parses
-- | Test (at most) 10000 values of each size up to size 100.
test_parsesBounded = ioBounded 10000 100 report_parses

test_parsesBounded' = ioFeat (boundedWith enumerate 1000) report_parses

report_parses e = case prop_parsesM e of
    Nothing -> return ()
    Just s  -> do
               putStrLn "Failure:"
               putStrLn (pprint e)
               print e
               putStrLn s
               putStrLn ""

prop_parsesM e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of
  E.ParseOk _       -> Nothing
  E.ParseFailed _ s -> Just s


test_cycleAll = ioAll 15 report_cycle
test_cycleBounded = ioBounded 10000 100 report_cycle
report_cycle e = case prop_cycle e of
    Nothing       -> return ()
    Just (ee,ex)  -> do
               putStrLn "Failure:"
               putStrLn (pprint ex)
               print ex
               putStrLn (E.prettyPrint  ee)
               putStrLn ""

-- Round-trip property: TH -> String -> HSE -> TH
-- Uses haskell-src-meta for HSE -> TH
prop_cycle :: Exp -> Maybe (E.Exp,Exp)
prop_cycle e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of
  E.ParseOk hse       -> if e == toExp hse then Nothing else Just $ (hse, toExp hse)
  E.ParseFailed _ s   -> Nothing -- Parse failures do not count as errors!






-}



-- These statements are always expressions
newtype ExpStmt = ExpStmt Exp deriving Typeable

-- Declarations allowed in where clauses
newtype WhereDec = WhereDec{unWhere :: Dec} deriving Typeable

-- Lowecase names
newtype LcaseN = LcaseN {lcased :: Name} deriving Typeable
-- Uppercase names
newtype UpcaseName = UpcaseName {ucased :: Name} deriving Typeable
newtype BindN = BindN Name deriving Typeable


newtype CPair a b = CPair {cPair :: (a,b)} deriving Typeable

instance (Enumerable a,Enumerable b) => Enumerable (CPair a b) where
  enumerate = datatype [c1 CPair]

instance Enumerable Exp where
  enumerate = datatype
      [c1 $ VarE . lcased
      ,c1 $ ConE . ucased
      ,c1 LitE
      ,c2 AppE
      ,c1 $ \(ExpStmt a,o)   -> InfixE (Just a) (either ConE VarE o) Nothing
      ,c1 $ \(ExpStmt a,o)   -> InfixE Nothing  (either ConE VarE o) (Just a)
      ,c1 $ \(a,o,b) -> InfixE (Just a) (either ConE VarE o) (Just b)
    --  ,c3 $ \a o b -> UInfixE a (VarE o) b
    --  ,c3 $ \a o b -> UInfixE a (ConE o) b
    --  ,c1 ParensE
      ,c2 $ LamE . nonEmpty
      ,c1 $ \(x1,x2,xs) -> TupE (x1:x2:xs)
    --  ,c1 UnboxedTupE
      ,c3 CondE
      ,c1 $ \(d,ds,e) -> LetE (map unWhere $ d:ds) e -- DISABLED BUGGY EMPTY LETS
      ,c1 $ \(e,NonEmpty m) -> CaseE e m
      ,c1 $ \(ExpStmt e,ss) -> DoE (ss ++ [NoBindS e])
      ,c1 $ (\((p,e),(CPair (xs,e'))) -> CompE ([BindS p e] ++ xs ++ [NoBindS e']))
    --  ,c1 ArithSeqE -- BUGGY!
      ,c1 ListE
    --  ,c2 SigE -- BUGGY!
      ,c1 $ \(e,x) -> RecConE e $ map unCase (nonEmpty x)
      ,c1 $ \(e,fe) -> RecUpdE e $ map unCase (nonEmpty fe)
      ]

unCase (LcaseN n,e) = (n,e)

instance Enumerable ExpStmt where
  enumerate = datatype
      [ c1 $ ExpStmt . VarE
      , c1 $ ExpStmt . ConE
      -- , c1 $ ExpStmt . LitE
      , c1 $ \(e1,e2) -> ExpStmt (AppE e1 e2)
      -- , c1 $ ExpStmt . LitE
      -- , c1 parS
      -- Removed paralell comprehensions
      ]


instance Enumerable Pat where
  enumerate = datatype
      [ c1 LitP
      , c1 $ \(BindN n) -> VarP n
      , c1 TupP
      , c1 $ \(UpcaseName n,ps) -> ConP n ps
      , c1 $ \(p1,UpcaseName n,p2) -> InfixP p1 n p2
      , c1 TildeP
    --  , c1 $ \(LcaseN n) -> BangP $ VarP n
      , c1 $ \(BindN n,p) -> AsP n p
      , c0 WildP
      , c1 $ \(UpcaseName e,x) -> RecP e (map (\(BindN n, p) -> (n,p)) (nonEmpty x))
      , c1 ListP
    --  , c2 SigP -- BUGGY!
    --  , c2 ViewP -- BUGGY!
      ]


-- deriveEnumerable ''Match  -- Should remove decs
instance Enumerable Match where
 enumerate = datatype
      [c3 $ \x y ds -> Match x y (map unWhere ds)
      ]

instance Enumerable Stmt where
  enumerate = datatype
      [ c2 BindS
      , c1 $ \(d) -> LetS $ map unWhere $ nonEmpty d
      , c1 $ NoBindS
      -- , c1 parS
      -- Removed paralell comprehensions
      ]



instance Enumerable Name where
 enumerate = datatype [ c2 Name ]



instance Enumerable Type where
 enumerate = datatype cType where
  cType =
    [c3 $ (\(x) -> ForallT (map (PlainTV . lcased) $ nonEmpty x))
    ,c1 $ \(BindN a) -> VarT a
    ,c1 $ \(UpcaseName a) -> ConT a
    ,c1 $ \n -> TupleT (abs n)
    ,c0 ArrowT
    ,c0 ListT
    ,c2 AppT
    -- ,c2 SigT -- BUGGY!
    ]



-- deriveEnumerable ''Dec

instance Enumerable WhereDec where
  enumerate = datatype
    [ c1 $ \(n,c)  -> WhereDec $ FunD n (nonEmpty c)
    , c1 $ \(n,p,wds) -> WhereDec $ ValD n p (map unWhere wds)
    , c1 $ \(BindN a,b)     -> WhereDec $ SigD a b
    -- , c1 $ WhereDec . PragmaD -- Removed pragmas
    -- , c1 parS -- Removed paralell comprehensions
    ]




instance Enumerable Lit where
  enumerate = datatype
    [ c1 StringL
    , c1 CharL    -- TODO: Fair char generation
    , c1 $ IntegerL . nat
    -- , c1 RationalL -- BUGGY!
    -- Removed primitive litterals
    ]
  
instance Enumerable Clause where
  enumerate = datatype
    [c3 $ \ps bs ds -> Clause ps bs (map unWhere ds)]





-- deriveEnumerable ''Pred
--cPred =
--  [ c2 ClassP
--  , c2 EqualP
--  ]
--instance Enumerable Pred where
--  enumerate = datatype cPred


-- deriveEnumerable ''TyVarBndr
instance Enumerable TyVarBndr where
  enumerate = datatype
    [ c1 PlainTV
    , c2 KindedTV
    ]


--cKind =
--  [c0 StarK
--  ,c2 ArrowK
--  ]
--instance Enumerable Kind where
--  enumerate = datatype cKind


instance Enumerable Body where
 enumerate = datatype
    [ c1 NormalB
    , c1 $ \(x) -> GuardedB (nonEmpty x)
    -- Removed primitive litterals
    ]
  
instance Enumerable Guard where
 enumerate = datatype
   [c1 $ NormalG
   ,c1 $ \(s) -> PatG (nonEmpty s)
   ]

instance Enumerable Callconv where
  enumerate = datatype [c0 CCall, c0 StdCall]




instance Enumerable Safety where
  enumerate = datatype 
    [c0 Unsafe, c0 Safe, c0 Interruptible]


--cStrict = [c0 IsStrict, c0 NotStrict, c0 Unpacked]
--instance Enumerable Strict where
--  enumerate = datatype cStrict

--cInlineSpec = [c3 $ InlineSpec)]
--instance Enumerable InlineSpec where
--  enumerate = datatype cInlineSpec

instance Enumerable OccName where
  enumerate = datatype
   [ c0 $ OccName "Con"
   , c0 $ OccName "var"
   ]

instance Enumerable BindN where
  enumerate = datatype
    [c0 $ BindN $ Name (OccName "var") NameS]

instance Enumerable LcaseN where
  enumerate = datatype 
    [c1 $ \nf -> LcaseN $ Name (OccName "var") nf]

instance Enumerable UpcaseName where
  enumerate = datatype
    [c1 $ \nf -> UpcaseName $ Name (OccName "Con") nf]

instance Enumerable ModName where
  enumerate = datatype
    [c0 $ ModName "M", c0 $ ModName "C.M"]

instance Enumerable Range where
  enumerate = datatype 
    [ c1 FromR
    , c2 FromThenR
    , c2 FromToR
    , c3 FromThenToR
    ]


instance Enumerable NameFlavour where
  enumerate = datatype
    [c1 NameQ
--    , c3 NameG
--    , \(I# x) -> NameU x
--    , \(I# x) -> NameL x
    , c0 NameS
    ]


-- main = test_parsesBounded
-- or test_parsesAll, but that takes much longer to find bugs