1 module Matcher where

2

3 import Text.ParserCombinators.Parsec as Parsec

4 import qualified Text.ParserCombinators.Parsec.Token as P

5 import qualified List

6 import qualified Maybe

7 import Debug.Trace

8

9 type Env = [(Bool, String, Value)]

10

11 data AST = AstAtom String

12 | AstLiteral Literal

13 | AstBinding String AST

14 | AstDiscard

15 | AstObject [(AST, AST)]

16 | AstLet String AST

17 | AstApp AST AST

18 deriving (Eq, Ord)

19

20 data Literal = LitInt Integer

21 deriving (Eq, Ord)

22

23 data Value = VAtom String

24 | VLiteral Literal

25 | VBinding String Value

26 | VDiscard

27 | VObject [(Value, Closure)]

28 | VPrimitive Primitive

29 deriving (Eq, Ord)

30

31 data Primitive = Primitive String (Value -> Value)

32

33 data Closure = Closure Env AST

34 | Constant Value

35 deriving (Eq, Ord)

36

37 tngDef = P.LanguageDef

38 { P.commentStart = "\""

39 , P.commentEnd = "\""

40 , P.commentLine = ""

41 , P.nestedComments = False

42 , P.identStart = letter

43 , P.identLetter = alphaNum

44 , P.opStart = (oneOf ":!#$%&*+./<=>?@\\^|-~")

45 , P.opLetter = (oneOf ":!#$%&*+./<=>?@\\^|-~" <|> alphaNum)

46 , P.reservedNames = []

47 , P.reservedOpNames = []

48 , P.caseSensitive = True

49 }

50

51 tngTokenizer = P.makeTokenParser tngDef

52

53 whiteSpace = P.whiteSpace tngTokenizer

54 ident = P.identifier tngTokenizer

55 integer = P.integer tngTokenizer

56 punct s = do string s; whiteSpace; return ()

57 operator = P.operator tngTokenizer

58 comma = P.comma tngTokenizer

59

60 readAST = readApp

61 readApp = do (part : parts) <- sepBy1 readSimple whiteSpace; return $ foldl AstApp part parts

62 readSquare = try (do entries <- sepBy readMapEntry whiteSpace; return $ AstObject entries)

63 <|> try (do entries <- sepBy readApp comma; return $ buildList entries)

64 readMapEntry = do l <- readSimple; punct ":"; r <- readSimple; return (l, r)

65 readSimple = do punct "("; v <- readAST; punct ")"; return v

66 <|> do punct "["; m <- readSquare; punct "]"; return m

67 <|> do string "+"; i <- ident; readBinding i

68 <|> do punct "_"; return AstDiscard

69 <|> do i <- integer; return $ AstLiteral $ LitInt i

70 <|> do i <- ident; readLet i

71 readLet i = do punct "="; v <- readSimple; return $ AstLet i v

72 <|> (return $ AstAtom i)

73 readBinding i = do punct "@"; v <- readSimple; return $ AstBinding i v

74 <|> (return $ AstBinding i AstDiscard)

75

76 buildList [] = AstObject []

77 buildList (x:xs) = (AstAtom "cons" `AstApp` x) `AstApp` buildList xs

78

79 sepList s [] = ""

80 sepList s [x] = x

81 sepList s (x:xs) = x ++ s ++ sepList s xs

82

83 showClause (l, r) = show l ++ ": " ++ show r

84 showClauses clauses = sepList " " (map showClause clauses)

85

86 instance Show AST where

87 show v = showAST v

88

89 showAST (AstAtom s) = s

90 showAST (AstLiteral l) = show l

91 showAST (AstBinding s AstDiscard) = "+" ++ s

92 showAST (AstBinding s v) = "+" ++ s ++ "@" ++ show v

93 showAST (AstDiscard) = "_"

94 showAST (AstObject clauses) = "[" ++ showClauses clauses ++ "]"

95 showAST (AstLet s v) = s ++ "=" ++ show v

96 showAST (AstApp v1 v2) = "(" ++ show v1 ++ " " ++ show v2 ++ ")"

97

98 instance Show Literal where

99 show l = showLiteral l

100

101 showLiteral (LitInt i) = show i

102

103 instance Show Value where

104 show v = showValue v

105

106 showValue (VAtom s) = s

107 showValue (VLiteral l) = show l

108 showValue (VBinding s VDiscard) = "+" ++ s

109 showValue (VBinding s v) = "+" ++ s ++ "@" ++ show v

110 showValue (VDiscard) = "_"

111 showValue (VObject clauses) = "[" ++ showClauses clauses ++ "]"

112 showValue (VPrimitive p) = show p

113

114 instance Eq Primitive where

115 (Primitive n1 _) == (Primitive n2 _) = n1 == n2

116

117 instance Ord Primitive where

118 (Primitive n1 _) `compare` (Primitive n2 _) = n1 `compare` n2

119

120 instance Show Primitive where

121 show (Primitive name _) = "#<" ++ name ++ ">"

122

123 instance Show Closure where

124 show (Closure e v) = showEnv e ++ show v

125 show (Constant v) = show v

126

127 showEnvEntry (False, n, v) = n ++ "->" ++ show v

128 showEnvEntry (True, n, v) = n

129 showEnv [] = ""

130 showEnv bindings = "{" ++ sepList ", " (map showEnvEntry bindings) ++ "} "

131

132 parseASTFromString = parse (do whiteSpace; v <- readAST; eof; return v) ""

133

134 readTng s = case parseASTFromString s of

135 Right v -> v

136 Left err -> error $ "Parse error: " ++ show err

137

138 ---------------------------------------------------------------------------

139

140 eLookup s [] defval = defval

141 eLookup s ((_, n, v):bs) defval = if n == s then v else eLookup s bs defval

142 lookupVal s bs = eLookup s bs (eLookup s baseEnv (VAtom s))

143

144 -- match pattern value -> maybe bindings

145 match (VAtom a) (VAtom b) = if a == b then Just [] else Nothing

146 match (VLiteral a) (VLiteral b) = if a == b then Just [] else Nothing

147 match (VBinding n p) v = do bs <- match p v; return ((False, n, v) : bs)

148 match (VDiscard) v = Just []

149 match (VObject patternClauses) (VObject valueClauses) =

150 foldr bindingUnion (Just []) $ map (match1 valueClauses) patternClauses

151 where bindingUnion j1 j2 = do b1 <- j1; b2 <- j2; return (b1 ++ b2)

152 match (VPrimitive (Primitive n1 _)) (VPrimitive (Primitive n2 _)) = if n1 == n2 then Just [] else Nothing

153 match _ _ = Nothing

154

155 firstThat p [] = Nothing

156 firstThat p (x:xs) = case p x of

157 Nothing -> firstThat p xs

158 j -> j

159

160 match1 valueClauses (pval, ppat) =

161 firstThat firstMatch valueClauses

162 where firstMatch (vpat, vval) =

163 do bs' <- match vpat pval

164 bs'' <- match (forcePattern ppat) (reduce vval bs')

165 return bs''

166

167 forcePattern clo = reduce clo []

168

169 reduce (Closure env v) bs = eval (bs ++ env) v

170 reduce (Constant v) bs = v

171

172 eval bs o =

173 case o of

174 AstAtom s -> lookupVal s bs

175 AstLiteral l -> VLiteral l

176 AstBinding s v -> VBinding s (eval bs v)

177 AstDiscard -> VDiscard

178 AstObject clauses -> VObject $ map evalClause clauses

179 where evalClause (patexp, val) = (pat, maybeClose pat bs val)

180 where pat = eval bs patexp

181 AstLet s v -> result

182 where result = eval bs' v

183 bs' = (True, s, result) : bs

184 AstApp rator rand -> applyTng bs (eval bs rator) (eval bs rand)

185

186 maybeClose pat bs o =

187 case patBound pat of

188 [] -> Constant $ eval bs o

189 _ -> Closure bs o

190

191 patBound (VAtom s) = []

192 patBound (VLiteral l) = []

193 patBound (VBinding s p) = [s] ++ patBound p

194 patBound (VDiscard) = []

195 patBound (VObject clauses) = concatMap clauseBound clauses

196 where clauseBound (_, clo) = patBound $ forcePattern clo

197 patBound (VPrimitive (Primitive n _)) = []

198

199 dnu function value = error $ "DNU: " ++ show function ++ " " ++ show value

200

201 applyTng bs function@(VObject patternClauses) value =

202 case firstThat matches patternClauses of

203 Nothing -> dnu function value

204 Just result -> result

205 where matches (ppat, pval) = case match ppat value of

206 Nothing -> Nothing

207 Just bs' -> Just $ reduce pval bs'

208 applyTng bs function@(VPrimitive (Primitive _ f)) value = f value

209 applyTng bs function value = dnu function value

210

211 ---------------------------------------------------------------------------

212

213 infix 4 <: -- accepts strictly more values

214 infix 4 <=: -- either <: or =:

215 infix 4 =: -- is essentially "the same" pattern

216

217 (=:) = patEqv

218 (<:) = stricter

219 p1 <=: p2 = (p1 <: p2) || (p1 =: p2)

220

221 p1 `overlaps` p2 = (p1 <: p2) || (p1 =: p2) || (p2 <: p1)

222

223 patEqv (VAtom s1) (VAtom s2) = s1 == s2

224 patEqv (VLiteral l1) (VLiteral l2) = l1 == l2

225 patEqv (VDiscard) (VDiscard) = True

226 patEqv (VBinding s p1) p2 = patEqv p1 p2

227 patEqv p1 (VBinding s p2) = patEqv p1 p2

228 patEqv (VObject c1) (VObject c2) = clausesMatchBy c1 c2 && clausesMatchBy c2 c1

229 patEqv (VPrimitive (Primitive n1 _)) (VPrimitive (Primitive n2 _)) = n1 == n2

230 patEqv _ _ = False

231

232 clauseEqv (v1, p1) (v2, p2) = (v1 `patEqv` v2) && (forcePattern p1 `patEqv` forcePattern p2)

233

234 clausesMatchBy c1 c2 = null $ remaining

235 where remaining = foldl removeClauses c2 c1

236 removeClauses cs c = filter (not . clauseEqv c) cs

237

238 stricter (VBinding s p1) p2 = stricter p1 p2

239 stricter p1 (VBinding s p2) = stricter p1 p2

240 stricter a b | a == b = False

241 stricter _ (VDiscard) = True

242 stricter (VObject c1) (VObject c2) = any (surviveAfterRemoving c2) c1 &&

243 not (any (surviveAfterRemoving c1) c2)

244 where surviveAfterRemoving clausesToRemove clause =

245 not $ any (`clauseStricterOrEqv` clause) clausesToRemove

246 stricter _ _ = False

247

248 clauseStricterOrEqv c1 c2 = (c1 `clauseStricter` c2) || (c1 `clauseEqv` c2)

249

250 clauseStricter (v1, p1) (v2, p2) = ((v1 `valEqv` v2) && (p1' `stricter` p2')) ||

251 ((v1 `coStricter` v2) && ((p1' `stricter` p2') ||

252 (p1' `patEqv` p2')))

253 where v1 `coStricter` v2 = (v2 `stricter` v1)

254 v1 `valEqv` v2 = (v1 `patEqv` v2)

255 p1' = forcePattern p1

256 p2' = forcePattern p2

257

258 ---------------------------------------------------------------------------

259

260 infix 4 <::

261 infix 4 <=::

262 infix 4 =::

263

264 a <:: b = (eval' a) <: (eval' b)

265 a <=:: b = (eval' a) <=: (eval' b)

266 a =:: b = (eval' a) =: (eval' b)

267

268 data Failure = Failure { lhs :: Value, rhs :: Value, expected :: Bool, got :: Bool }

269 deriving (Show)

270 strictFailures = Maybe.mapMaybe fails tests

271 where fails (lhs, rhs, expected) = let result = (lhs <:: rhs) in

272 if result == expected

273 then Nothing

274 else Just $ Failure { lhs = eval' lhs,

275 rhs = eval' rhs,

276 expected = expected,

277 got = result }

278 tests = [("cons _ (cons _ _)", "cons (cons _ _) _", False),

279 ("cons _ (cons _ _)", "cons _ _", True),

280 ("cons _ _", "cons _ (cons _ _)", False),

281 ("[]", "[]", False),

282 ("[]", "cons _ _", False),

283 ("cons _ _", "cons _ _", False),

284 ("cons +a +b", "cons +c +d", False),

285 ("[First: _]", "[First: _ Rest: _]", False),

286 ("[A: _ B: _]", "[B: _ A: _]", False),

287 ("[A: _ B: _]", "[A: _]", True),

288 ("[A: _ B: _]", "[C: _]", False),

289 ("[A: _ B: _]", "[C: _ A: _]", False),

290 ("[First: _ Rest: _]", "[First: _]", True)]

291

292 ---------------------------------------------------------------------------

293

294 eval' exp = eval [] (readTng exp)

295

296 baseEnv = [ def "cons" "[+car: [+cdr: [First: car Rest: cdr]]]"

297 , def "map" "[+f: loop=[(cons +a +d): (cons (f a) (loop d)) +x: x]]"

298 , defPrim "add" $ \(VLiteral (LitInt i)) -> p $ \(VLiteral (LitInt j)) -> VLiteral (LitInt (i + j))

299 ]

300 where def nm exp = def' nm $ eval' exp

301 def' nm val = (False, nm, val)

302 p fn = VPrimitive $ Primitive "(anon)" fn

303 defPrim nm fn = def' nm $ VPrimitive $ Primitive nm fn