Ticket #15519: Main.hs

File Main.hs, 2.7 KB (added by sgraf, 15 months ago)

Variant of Main.hs I used for debugging

Line 
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE Strict            #-}
3{-# LANGUAGE BangPatterns      #-}
4{-# LANGUAGE DeriveGeneric     #-}
5
6module Main where
7
8import qualified Data.Set  as Set
9import qualified Data.Text as Text
10
11import Data.Set              (Set)
12import Data.Text             (Text)
13import System.IO             (BufferMode (NoBuffering), hSetBuffering, stdout)
14import Control.DeepSeq       (NFData)
15import GHC.Generics          (Generic)
16import Control.Exception     (evaluate)
17import System.CPUTime        (getCPUTime)
18import Control.DeepSeq       (force)
19import System.Environment    (getArgs)
20
21
22--------------------------------
23-- === Running benchmarks === --
24--------------------------------
25
26iters :: Int
27iters = 100000000
28
29src1 :: Text
30src1 = Text.replicate iters "tttt"
31
32data Grammar a
33    = Tokens !(Set a) !(a -> Bool)
34    | Many   !(Grammar a)
35    | X      !(Grammar a)
36
37instance Ord a => Semigroup (Grammar a) where
38    Tokens s f <> Tokens s' g = Tokens (s <> s') $ \c -> f c || g c
39    {-# INLINE (<>) #-}
40
41token :: Eq a => a -> Grammar a
42token = \a -> Tokens (Set.singleton a) (a ==)
43{-# INLINE token #-}
44
45many :: Grammar a -> Grammar a
46many = Many
47{-# INLINE many #-}
48
49data Result
50    = Success Text Text
51    | Fail
52    deriving (Show, Generic)
53
54instance NFData Result
55
56
57native :: Text -> Maybe Text
58native src = out where
59    tst = \c -> c == 't' || c == 'e' || c == 's' || c == 't'
60    rs  = Text.takeWhile tst src
61    out = Just rs
62   
63runTokenParser :: Grammar Char -> Text -> Result
64runTokenParser = \grammar stream -> case grammar of
65    Tokens _ tst -> let
66        head = Text.head stream
67        in if tst head
68            then Success (Text.tail stream) (Text.singleton head)
69            else Fail
70    Many (Tokens _ tst) -> let
71        (!consumed, !rest) = Text.span tst stream
72        in Success rest consumed
73    X !grammar -> runTokenParser grammar stream
74
75
76
77test0 :: Text -> Result
78test0 src = let
79    s1 = token 't'
80    p  = many s1
81    in runTokenParser p src
82{-# NOINLINE test0 #-}
83
84testGrammar1 :: Grammar Char
85testGrammar1 = let
86    s1 = token 't'
87    in many s1
88{-# INLINE testGrammar1 #-}
89
90test1 :: Text -> Result
91test1 = runTokenParser testGrammar1
92{-# NOINLINE test1 #-}
93
94test2 :: Text -> Result
95test2 src = let
96    s1 = token 't'
97    p  = X (many s1)
98    in runTokenParser p src
99{-# NOINLINE test2 #-}
100
101
102
103main :: IO ()
104main = do
105    (a:_) <- getArgs
106    let option = read a :: Int
107    hSetBuffering stdout NoBuffering
108    let f = case option of
109            0 -> test0
110            1 -> test1
111            2 -> test2
112    srcx <- evaluate $ force src1
113    t1 <- getCPUTime
114    evaluate $ force $ f srcx
115    t2 <- getCPUTime
116    print $ (fromIntegral (t2 - t1) / 1000000000)
117    pure ()