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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
{
module Main (main) where
import {- "containers" -} Data.Set (Set)
import {- "containers" -} qualified Data.Set as Set
import {- "text" -} Data.Text (Text)
import {- "text" -} qualified Data.Text as Text
import {- "text" -} qualified Data.Text.Read as Text
import {- "base" -} Control.Arrow hiding (arr)
import {- "base" -} Control.Monad (forM_, when)
import {- "base" -} Control.Monad.Fail (MonadFail)
import {- "base" -} qualified Control.Monad.Fail as Fail (MonadFail (..))
import {- "base" -} Numeric.Natural
import {- "base" -} System.Exit
}
%wrapper "monadUserState-strict-text"
%token "Token integer"
%typeclass "Integral integer, Read integer, Show integer"
-- ugh
$digit = 0-9
$unidigit = 1-9
@number = [0] | $unidigit $digit*
tokens :-
$white+ { skip }
@number { \(_, _, _, s) len -> case Text.decimal (Text.take len s) of
Left e -> Fail.fail e
Right (n, txt)
| Text.null txt -> pure $ TokenInt n
| otherwise -> Fail.fail "got incomplete prefix " }
[a-z]+ { \(_, _, _, s) len -> do
let name = Text.take len s
alexSeenVar name
pure $ TokenVar name }
[\+] { mk0ary TokenAdd }
[\-] { mk0ary TokenSub }
[\*] { mk0ary TokenMul }
[\/] { mk0ary TokenDiv }
[\^] { mk0ary TokenPow }
[\(] { mk0ary TokenLPar }
[\)] { mk0ary TokenRPar }
{
mk0ary :: (Read integer, Integral integer) => Token integer -> AlexInput -> Int -> Alex (Token integer)
mk0ary tok _ _ = pure tok
data AlexUserState
= AlexUserState {
ausVars :: Set Text
} deriving (Eq, Read, Show)
alexSeenVar :: Text -> Alex ()
alexSeenVar txt = do
AlexUserState { ausVars = set } <- alexGetUserState
alexSetUserState $ AlexUserState { ausVars = txt `Set.insert` set }
alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState { ausVars = Set.empty }
data Token integer
= TokenInt integer
| TokenVar Text
| TokenLPar
| TokenRPar
| TokenPow
| TokenDiv
| TokenMul
| TokenSub
| TokenAdd
| EOF
deriving (Eq, Read, Show)
alexEOF :: (Read integer, Integral integer) => Alex (Token integer)
alexEOF = pure EOF
instance MonadFail Alex where
fail s = Alex . const $ Left s
evalAlex :: Text -> Alex t -> Either String (AlexUserState, t)
evalAlex txt alex = right (first getUserState) $ f state where
f = unAlex alex
getUserState AlexState { alex_ust = userState } = userState
state = AlexState
{ alex_bytes = []
, alex_pos = alexStartPos
, alex_inp = txt
, alex_chr = '\n'
, alex_ust = alexInitUserState
, alex_scd = 0 }
scanAll :: (Eq integer, Integral integer, Read integer, Show integer) => Alex [Token integer]
scanAll = alexMonadScan >>= \result -> case result of
EOF -> pure []
tok -> (tok :) <$> scanAll
tests :: [(Text, Set Text, [Token Natural])]
tests = [ (Text.pack "x*y/(x^3+y^3)"
, Set.fromList [x, y]
, [TokenVar x, TokenMul, TokenVar y, TokenDiv, TokenLPar, TokenVar x, TokenPow, TokenInt 3, TokenAdd, TokenVar y, TokenPow, TokenInt 3, TokenRPar])] where
x = Text.pack "x"
y = Text.pack "y"
main :: IO ()
main = do
forM_ tests $ \(txt, vars, toks) -> do
case evalAlex txt scanAll of
Right (AlexUserState { ausVars = tokVars }, tokList)
| tokVars == vars && toks == tokList -> pure ()
| otherwise -> do
when (toks /= tokList) $ do
putStrLn $ "got " <> show tokList
putStrLn $ "wanted " <> show toks
when (tokVars /= vars) $ do
putStrLn $ "got " <> show tokVars
putStrLn $ "wanted " <> show vars
exitFailure
Left errorString -> do
putStrLn $ "got error " <> errorString
exitFailure
exitSuccess
}
|
