1 {-# LANGUAGE FlexibleContexts #-} |
1 {-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} |
2 module PascalBasics where |
2 module PascalBasics where |
3 |
3 |
4 import Text.Parsec.Combinator |
4 import Text.Parsec.Combinator |
5 import Text.Parsec.Char |
5 import Text.Parsec.Char |
6 import Text.Parsec.Prim |
6 import Text.Parsec.Prim |
7 import Text.Parsec.Token |
7 import Text.Parsec.Token |
8 import Text.Parsec.Language |
8 import Text.Parsec.Language |
9 import Data.Char |
9 import Data.Char |
|
10 import Control.Monad |
|
11 import Data.Functor.Identity |
10 |
12 |
|
13 char' :: Char -> Parsec String u () |
|
14 char' = void . char |
|
15 |
|
16 string' :: String -> Parsec String u () |
|
17 string' = void . string |
|
18 |
|
19 builtin :: [String] |
11 builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"] |
20 builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"] |
12 |
21 |
|
22 pascalLanguageDef :: GenLanguageDef String u Identity |
13 pascalLanguageDef |
23 pascalLanguageDef |
14 = emptyDef |
24 = emptyDef |
15 { commentStart = "(*" |
25 { commentStart = "(*" |
16 , commentEnd = "*)" |
26 , commentEnd = "*)" |
17 , commentLine = "//" |
27 , commentLine = "//" |
29 , "cdecl", "external", "if", "then", "else" |
39 , "cdecl", "external", "if", "then", "else" |
30 ] -- ++ builtin |
40 ] -- ++ builtin |
31 , caseSensitive = False |
41 , caseSensitive = False |
32 } |
42 } |
33 |
43 |
34 preprocessorSwitch :: Stream s m Char => ParsecT s u m String |
44 preprocessorSwitch :: Stream String Identity Char => Parsec String u String |
35 preprocessorSwitch = do |
45 preprocessorSwitch = do |
36 try $ string "{$" |
46 try $ string' "{$" |
37 s <- manyTill (noneOf "\n") $ char '}' |
47 s <- manyTill (noneOf "\n") $ char '}' |
38 return s |
48 return s |
39 |
49 |
|
50 caseInsensitiveString :: Stream String Identity Char => String -> Parsec String u String |
40 caseInsensitiveString s = do |
51 caseInsensitiveString s = do |
41 mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s |
52 mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s |
42 return s |
53 return s |
43 |
54 |
|
55 pas :: GenTokenParser String u Identity |
44 pas = patch $ makeTokenParser pascalLanguageDef |
56 pas = patch $ makeTokenParser pascalLanguageDef |
45 where |
57 where |
46 patch tp = tp {stringLiteral = stringL} |
58 patch tp = tp {stringLiteral = stringL} |
47 |
59 |
|
60 comment :: Stream String Identity Char => Parsec String u String |
48 comment = choice [ |
61 comment = choice [ |
49 char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') |
62 char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') |
50 , (try $ string "(*") >> manyTill anyChar (try $ string "*)") |
63 , (try $ string "(*") >> manyTill anyChar (try $ string "*)") |
51 , (try $ string "//") >> manyTill anyChar (try newline) |
64 , (try $ string "//") >> manyTill anyChar (try newline) |
52 ] |
65 ] |
53 |
66 |
|
67 comments :: Parsec String u () |
54 comments = do |
68 comments = do |
55 spaces |
69 spaces |
56 skipMany $ do |
70 skipMany $ do |
57 preprocessorSwitch <|> comment |
71 void $ preprocessorSwitch <|> comment |
58 spaces |
72 spaces |
59 |
73 |
|
74 stringL :: Parsec String u String |
60 stringL = do |
75 stringL = do |
61 (char '\'') |
76 char' '\'' |
62 s <- (many $ noneOf "'") |
77 s <- (many $ noneOf "'") |
63 (char '\'') |
78 char' '\'' |
64 ss <- many $ do |
79 ss <- many $ do |
65 (char '\'') |
80 char' '\'' |
66 s' <- (many $ noneOf "'") |
81 s' <- (many $ noneOf "'") |
67 (char '\'') |
82 char' '\'' |
68 return $ '\'' : s' |
83 return $ '\'' : s' |
69 comments |
84 comments |
70 return $ concat (s:ss) |
85 return $ concat (s:ss) |