forked from pepeiborra/haskell-src-exts-util
-
Notifications
You must be signed in to change notification settings - Fork 0
/
CheckIsAtom.hs
69 lines (56 loc) · 2.82 KB
/
CheckIsAtom.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- For a description of this program see http://neilmitchell.blogspot.co.uk/2018/02/atomic-expressions-generically.html
module Main(main) where
-- Note that 1 vs -1 is one of the few things that matters!!!
import Language.Haskell.Exts
import Language.Haskell.Exts.Util
import Control.Monad
import Data.Data
import System.Random
import System.IO
import Control.Exception
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
let modes = defaultParseMode{extensions = map EnableExtension [minBound .. maxBound]}
checkAtomicity (fmap void . parseExpWithMode modes) $ \x -> App () x x
checkAtomicity (fmap void . parseTypeWithMode modes) $ \x -> TyApp () x x
checkAtomicity (fmap void . parsePatWithMode modes) $ \x -> PApp () (UnQual () $ Ident () "Foo") [x,x]
deriving instance Eq a => Eq (ParseResult a)
checkAtomicity :: forall a . (Pretty a, Eq a, Show a, Data a) => Brackets a => (String -> ParseResult a) -> (a -> a) -> IO ()
checkAtomicity parse wrap =
forM_ (dataTypeConstrs $ dataTypeOf (undefined :: a)) $ \ctor -> do
putStr $ show (typeOf (undefined :: a)) ++ " " ++ show ctor ++ " ... "
ans <- replicateM 10000 $ do
handle (\LimitReached -> return False) $ do
x :: a <- fromConstrM (mkValue 50) ctor
if parse (prettyPrint x) /= ParseOk x then
return False
else do
let seemsAtomic = parse (prettyPrint $ wrap x) == ParseOk (wrap x)
let saysAtomic = isAtom x
when (not seemsAtomic && isAtom x) $
putStrLn $ unlines $
[""
,"DISAGREE!:"
," " ++ prettyPrint x
," " ++ show x
," isAtom = " ++ show saysAtomic]
return $ seemsAtomic == saysAtomic
putStrLn $ "agreed for " ++ show (length $ filter id ans)
randomElem :: [a] -> IO a
randomElem xs = do
when (null xs) $ fail "General.Extra.randomElem called with empty list, can't pick a random element"
i <- randomRIO (0, length xs - 1)
return $ xs !! i
data LimitReached = LimitReached deriving Show
instance Exception LimitReached
mkValue :: forall a . Data a => Int -> IO a
mkValue depth
| Just x <- cast "aA1:+-" = randomElem x
| Just x <- cast [-1 :: Int, 1] = randomElem x
| Just x <- cast [-1 :: Integer, 1] = randomElem x
| AlgRep cs <- dataTypeRep $ dataTypeOf (undefined :: a) =
if depth <= 0 then throwIO LimitReached else fromConstrM (mkValue $ depth - 1) =<< randomElem cs
| otherwise = error $ "mkDefault doesn't know how to generate value of type " ++ show (typeOf (undefined :: a))