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
123
124
125

--- This module implements a parser for programs and formulas in the
--- SMT-LIB2 syntax. It is based on the system library `Parser`
--- which defines functional logic parsing combinators.

module XFD.SMTLib.NDParser where

import Parser
import XFD.SMTLib.Scanner
import XFD.SMTLib.Types
import XFD.SMTLib.Build

type ParseError = String

parse :: String -> Either ParseError CmdResponse
parse s = let ts  = scan s
              val free
              parseResult = parseCmdResult val ts == []
          in case parseResult of
            False -> Left "incomplete parse"
            True  -> Right val

parseCmdResult :: ParserRep CmdResponse Token
parseCmdResult = (
         parseCmdCheckSatResponse
    <||> parseCmdGetValueResponse
    -- <||> parseCmdGetModelResponse
    <||> parseCmdGenResponse
    ) rsp <*> terminal EOF >>> rsp
  where rsp free

parseCmdCheckSatResponse :: ParserRep CmdResponse Token
parseCmdCheckSatResponse = parseCheckSatResponse csr >>> CmdCheckSatResponse csr
  where csr free

parseCheckSatResponse :: ParserRep CheckSatResponse Token
parseCheckSatResponse =  terminal KW_sat      >>> Sat
                    <||> terminal KW_unsat    >>> Unsat
                    <||> terminal KW_unknown  >>> Unknown

-- GetValueResponse
parseCmdGetValueResponse :: ParserRep CmdResponse Token
parseCmdGetValueResponse = parseGetValueResponse gvr >>> CmdGetValueResponse gvr
  where gvr free

parseGetValueResponse :: ParserRep GetValueResponse Token
parseGetValueResponse =  terminal LParen
                     <*> mSome (\_ -> parseValuePair) vp
                     <*> terminal RParen >>> vp
  where vp free

parseValuePair :: ParserRep ValuationPair Token
parseValuePair =  terminal LParen
              <*> parseTerm t1
              <*> parseTerm t2
              <*> terminal RParen >>> ValuationPair t1 t2
  where t1, t2 free

-- Terms
parseTerm :: ParserRep Term Token
parseTerm = parseTSPC <||> parseTQId

parseTSPC :: ParserRep Term Token
parseTSPC = terminal (Number n) >>> termSpecConstNum n
  where n free

parseTQId :: ParserRep Term Token
parseTQId = terminal (Id name) >>> termQIdent name
  where name free


parseCmdGenResponse :: ParserRep CmdResponse Token
parseCmdGenResponse = parseGenResponse gr >>> CmdGenResponse gr
  where gr free

parseGenResponse :: ParserRep GenResponse Token
parseGenResponse = parseErrorResponse

parseErrorResponse :: ParserRep GenResponse Token
parseErrorResponse = terminal LParen
                 <*> terminal KW_error
                 <*> parseString s
                 <*> terminal RParen >>> Error s
  where s free

parseString :: ParserRep String Token
parseString = terminal (Str s) >>> s
  where s free


-- new star and some parser
mStar :: (() -> ParserRep rep token) -> ParserRep [rep] token
mStar p =    (p ()) x <*> (mStar p) xs >>> (x:xs)
       <||> empty               >>> []         where x,xs free

mSome :: (() -> ParserRep rep token) -> ParserRep [rep] token
mSome p = (p ()) x <*> (mStar p) xs >>> (x:xs)        where x,xs free



-- model responses are no longer used; parsers are kept here in case they might
-- be used again
parseCmdGetModelResponse :: ParserRep CmdResponse Token
parseCmdGetModelResponse = parseGetModelResponse gmr >>> CmdGetModelResponse gmr
  where gmr free

parseGetModelResponse :: ParserRep GetModelResponse Token
parseGetModelResponse = terminal LParen
                    <*> terminal KW_model
                    <*> mStar (\_ -> parseModelResponse) mr
                    <*> terminal RParen >>> mr
  where mr free

parseModelResponse :: ParserRep ModelResponse Token
parseModelResponse = parseFunDef fd >>> MRDefineFun fd
  where fd free

parseFunDef :: ParserRep FunDef Token
parseFunDef = terminal LParen
          <*> terminal KW_defineFun
          <*> terminal (Id name)
          <*> terminal LParen <*> terminal RParen
          <*> terminal (Id sort)
          <*> parseTerm t
          <*> terminal RParen >>> (FunDef name [] (SortId (ISymbol sort)) t)
  where name, sort, t free