darcs - INblobs

1 {-|

2 Module : Functional.Parser

3 Copyright : (c) Miguel VilaÃ§a 2007

5 Maintainer : jmvilaca@di.uminho.pt

6 Stability : experimental

7 Portability : portable

10 Small Functional Language: Parser

12 -}

13 module Functional.Parser (parse) where

15 import Functional.Language

16 import Data.Char

19 parse :: String -> Either FuncLang String

20 parse str =

21 case filter (nul.snd) res of

22 [(term, _)] -> Left term

23 _ -> case res of

24 [] -> Right "Null result"

25 l -> Right $ "Ambiguous parsing.\n" ++ show l

26 where res = reads $ map f str

27 f c | isControl c = ' '

28 | otherwise = c

29 nul = all (\c -> isControl c || isSpace c)

31 instance Read FuncLang where

32 -- readsPrec :: Int -> String -> [(a, String)]

33 readsPrec d str =

34 map (\(v,s) -> (Var v,s)) (readVar str) -- variables

35 ++ readParen (d > abst_prec) -- abstraction - allow [x,y]t

36 (\r -> [(vs t, r4) |

37 ("[",r2) <- lex r,

38 (vs,r3) <- readVars r2,

39 (t,r4) <- readsPrec (abst_prec+1) r3 ]) str

40 ++ readParen (d > app_prec)

41 (\r -> [(Appl t u, r2) |

42 (t,r1) <- readsPrec (app_prec+1) r,

43 (u,r2) <- readsPrec (app_prec+1) r1 ]) str

44 ++ readTerminal TT "tt" str

45 ++ readTerminal FF "ff" str

46 ++ readParen (d > iter_prec) -- iterbool

47 (\r -> [(IterBool v f b, r8) |

48 ("iterbool",r1) <- lex r,

49 ("(",r2) <- lex r1,

50 (v,r3) <- readsPrec 0 r2,

51 (",",r4) <- lex r3,

52 (f,r5) <- readsPrec 0 r4,

53 (",",r6) <- lex r5,

54 (b,r7) <- readsPrec 0 r6,

55 (")",r8) <- lex r7]) str

56 ++ readTerminal Zero "0" str

57 ++ readParen (d > const_prec) -- suc

58 (\r -> [(Succ m, r4) |

59 ("suc",r1) <- lex r,

60 ("(",r2) <- lex r1,

61 (m,r3) <- readsPrec 0 r2,

62 (")",r4) <- lex r3]) str

63 ++ readParen (d > iter_prec) -- iternat

64 (\r -> [(IterNat x s z t, r8) |

65 ("iternat",r1) <- lex r,

66 ("(",r2) <- lex r1,

67 (Abst x s,r3) <- readsPrec 0 r2,

68 (",",r4) <- lex r3,

69 (z,r5) <- readsPrec 0 r4,

70 (",",r6) <- lex r5,

71 (t,r7) <- readsPrec 0 r6,

72 (")",r8) <- lex r7]) str

73 ++ readTerminal Nil "nil" str

74 ++ readParen (d > const_prec) -- cons

75 (\r -> [(Cons a as, r6) |

76 ("cons(",r1) <- lex r,

77 ("(",r2) <- lex r1,

78 (a,r3) <- readsPrec 0 r2,

79 (",",r4) <- lex r3,

80 (as,r5) <- readsPrec 0 r4,

81 (")",r6) <- lex r5]) str

82 ++ readParen (d > iter_prec) -- iterlist

83 (\r -> [(IterList x y c n l, r8) |

84 ("iterlist",r1) <- lex r,

85 ("(",r2) <- lex r1,

86 (Abst x (Abst y c),r3) <- readsPrec 0 r2,

87 (",",r4) <- lex r3,

88 (n,r5) <- readsPrec 0 r4,

89 (",",r6) <- lex r5,

90 (l,r7) <- readsPrec 0 r6,

91 (")",r8) <- lex r7]) str

92 where

93 abst_prec = 5

94 app_prec = 5

95 terminal_prec = 10

96 iter_prec = 10

97 const_prec = 10

98 readTerminal term symb str =

99 readParen (d > terminal_prec)

100 (\r -> [(term,t) |

101 (symb1,t) <- lex r, symb1 == symb]) str

102 readVar str =

103 readParen False

104 (\r -> [(v,t) |

105 (v,t) <- lex r, isVariable v]) str

106 readVars str =

107 [ (Abst v, r1) | (v,r) <- readVar str

108 , ("]",r1) <- lex r]

109 ++

110 [ (Abst v . lv, r2)

111 | (v,r) <- readVar str

112 , (",",r1) <- lex r

113 , (lv, r2) <- readVars r1]

114

115 reservedWords :: [String]

116 reservedWords = ["tt","ff","iterbool","0","suc","iternat","nil","cons","iterlist"]

117

118 isVariable :: String -> Bool

119 isVariable str =

120 not (null str)

121 && str `notElem` reservedWords

122 && all isAlphaNum str

123 && not (isDigit $ head str)

124

125

126 -- Examples

127

128 str = " [x,y,z,a,b]("

129 ++ "(iterbool(x,y,tt) iterlist([x,y]y (x (a z)), (a z), nil) )"

130 ++ "(iternat([x]x,x,0) iterbool(y,y,tt)))"

131

132 term = Left $ Abst "x" $ Abst "y" $ Abst "z" $ Abst "a" $ Abst "b" $

133 Appl

134 (Appl (IterBool x y TT)

135 (IterList "x" "y" (Appl y $ Appl x $ Appl a z) (Appl a z) Nil)

136 )

137 (Appl (IterNat "x" x x Zero)

138 (IterBool y y TT)

139 )

140

141 x = Var "x"

142 y = Var "y"

143 z = Var "z"

144 a = Var "a"

145