Ticket #1925: Segfault.hs

File Segfault.hs, 3.9 KB (added by Paczesiowa, 7 years ago)

code that segfaults

Line 
1module Main where
2
3import Text.ParserCombinators.Parsec
4import Text.ParserCombinators.Parsec.Language
5import qualified Text.ParserCombinators.Parsec.Token as P
6import Text.ParserCombinators.Parsec.Expr
7import Control.Monad
8import Data.List
9import Data.Maybe
10
11data Expr = Atom String | Numb Int | Var String | Struct String [Expr] deriving Show
12
13--Lexer
14lexer :: P.TokenParser ()
15lexer = P.makeTokenParser $ emptyDef { commentLine = "%" }
16
17lexeme :: CharParser () a -> CharParser () a
18lexeme = P.lexeme lexer
19
20parens :: CharParser () a -> CharParser () a
21parens = P.parens lexer
22
23brackets :: CharParser () a -> CharParser () a
24brackets = P.brackets lexer
25
26commaSep1 :: CharParser () a -> CharParser () [a]
27commaSep1 = P.commaSep1 lexer
28
29opChar :: CharParser () Char
30opChar = oneOf "!#$&*+-./:;<=>?\\^_~"
31
32reservedOp :: String -> CharParser () ()
33reservedOp p = do
34        string p
35        notFollowedBy opChar
36--
37
38atom :: CharParser () Expr
39atom = lexeme $ do
40        c <- lower
41        cs <- many alphaNum
42        return . Atom $ c:cs
43        <|>
44        (Atom . return) `liftM` char '!'
45
46var :: CharParser () Expr
47var = lexeme $ do
48        c <- upper
49        cs <- many alphaNum
50        return . Var $ c:cs
51
52numb :: CharParser () Expr
53numb = lexeme $ (Numb . read) `liftM` many1 digit
54
55struct :: CharParser () Expr -> CharParser () Expr
56struct e = do
57        c <- lower
58        cs <- many alphaNum
59        args <- parens $ commaSep1 e
60        return $ Struct (c:cs) args
61
62term :: CharParser () Expr -> CharParser () Expr
63term e = do choice
64                [ parens e
65                , numb
66                , var
67                , try $ struct e
68                , atom
69                ]
70
71data OpType = FX | XFX | XFY | YFX | XF deriving (Show, Eq)
72type Precedence = Int
73type Op = (Precedence, OpType, String)
74type ParsecOp = Operator Char () Expr
75
76type Operators = [[Op]]--it has exactly 1200 lists of type [Op]
77
78binary :: OpType -> Bool
79binary typ = typ `elem` [XFX, XFY, YFX]
80
81findOperator :: Op -> Operators -> Maybe Precedence
82findOperator (_, typ, name) ops = findIndex isJust $ map (findIndex p) ops
83        where p (_, t, x) = x == name && (binary t == binary typ)
84
85removeOperator :: Op -> Operators -> Operators
86removeOperator op ops = map (deleteBy p op) ops
87        where p (_, typ1, name1) (_, typ2, name2) = name1 == name2 && (binary typ1 == binary typ2)
88
89addOperator :: Op -> Operators -> Operators
90addOperator op@(precedence, _, _) ops = lowr ++ [op:same] ++ higher
91        where (lowr, (same:higher)) = splitAt (precedence-1) ops
92
93insertOperator :: Op -> Operators -> Operators
94insertOperator op@(precedence, _, _) ops =
95        if precedence == 0
96                then ops'
97                else addOperator op ops'
98        where ops' = removeOperator op ops
99
100noOperators :: Operators
101noOperators = 1200 `replicate` []
102
103baseOperators :: Operators
104baseOperators = foldl (flip insertOperator) noOperators $ concat $ 
105        zipWith f [(1200,XFX) , (1200,FX)   , (1000,XFY) , (700,XFX)                                      , (500,YFX) , (500,FX) , (400,YFX)]
106                  [[":-"]     , [":-","?-"] , [","]      , ["<","=","=..","=<","==","=\\=",">",">=","is"] , ["+","-"] , ["-"]    , ["*","/"]]
107        where f (prec, typ) ops = map (\x -> (prec, typ, x)) ops
108
109baseExpr :: CharParser () Expr
110baseExpr = buildExpressionParser (map (map toParsecOp) baseOperators) (term baseExpr)
111
112toParsecOp :: Op -> ParsecOp
113toParsecOp (_, typ, name) = parser
114        where aux = lexeme $ reservedOp name
115              binop = Infix $ aux >> return (\x y -> Struct name [x,y])
116              unop = aux >> (return $ \x -> Struct name [x])
117              parser = case typ of
118                        XFX -> binop AssocNone
119                        XFY -> binop AssocRight
120                        YFX -> binop AssocLeft
121                        FX -> Prefix unop
122                        XF -> Postfix unop
123
124main :: IO ()
125main = parseTest baseExpr "john(1)"