-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathStrDsl.hs
170 lines (157 loc) · 7.38 KB
/
StrDsl.hs
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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
module StrDsl where
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Types
-- define the semantics
newtype T = Term String deriving (Show, Eq, Ord)
newtype X = Input String deriving (Show, Eq, Ord)
data S = Concat S S | LeftS S I | RightS S I | Substr S I I | Replace S I I S | Trim S | Repeat S I | Substitute S S S | ToText I | X X | T T | ConstStr String deriving (Show, Eq, Ord)
data I = Add I I | Sub I I | Find S S | Find2 S S I | Len S | Const Int deriving (Show, Eq, Ord)
data B = Equals S S | GreaterThan I I | GreaterThanOrEqual I I deriving (Show, Eq, Ord)
data E = S S | I I | B B | Placeholder deriving (Show, Eq, Ord)
-- more complicated operation types
data Op = ConcatOp | LeftSOp | RightSOp | TrimOp | RepeatOp | ToTextOp | AddOp | SubOp | FindOp | LenOp | EqualsOp | GreaterThanOp | GreaterThanOrEqualOp deriving (Show, Eq, Ord)
data Type = Es | Ei | Eb deriving (Show, Eq, Ord)
opToTypeMap :: (Op, Type) -> Map.Map Op [Type]
opToTypeMap (_, _) = Map.fromList [(ConcatOp, [Es, Es]), (LeftSOp, [Es, Ei]), (RightSOp, [Es, Ei]), (FindOp, [Ei, Ei])]
opList :: Op -> [Op]
opList _ = [ConcatOp, LeftSOp, RightSOp, FindOp, LenOp]
typeList :: Type -> [Type]
typeList _ = [Es, Ei, Eb]
isEofType :: (E, Type, Map.Map String V) -> Bool
isEofType (e,t, _) = case (e,t) of (S _, Es) -> True; (I _, Ei) -> True; (B _, Eb) -> True; _ -> False
-- convert regular to terminal type
convertVToEList :: (V, E) -> [E]
convertVToEList (v,_) =
case v of
Vs s -> map (\ch -> S (T (Term [ch]))) s
Vi i -> [I (Const i)]
_ -> []
-- handle unwrap op
handleUnwrapOp :: (Op, [E]) -> E
handleUnwrapOp (op, elist) =
case op of
ConcatOp -> case (head elist, last elist) of
(S x, S y) -> S (Concat x y)
_ -> Placeholder
LeftSOp -> case (head elist, last elist) of
(S x, I y) -> S (LeftS x y)
_ -> Placeholder
RightSOp -> case (head elist, last elist) of
(S x, I y) -> S (RightS x y)
_ -> Placeholder
TrimOp -> case head elist of
S x -> S (Trim x)
_ -> Placeholder
RepeatOp -> case (head elist, last elist) of
(S x, I y) -> S (Repeat x y)
_ -> Placeholder
ToTextOp -> case head elist of
I y -> S (ToText y)
_ -> Placeholder
AddOp -> case (head elist, last elist) of
(I x, I y) -> I (Add x y)
_ -> Placeholder
SubOp -> case (head elist, last elist) of
(I x, I y) -> I (Sub x y)
_ -> Placeholder
FindOp -> case (head elist, last elist) of
(S x, S y) -> I (Find x y)
_ -> Placeholder
LenOp -> case head elist of
(S x) -> I (Len x)
_ -> Placeholder
_ -> Placeholder
-- return all terminals
terminals :: ([([V], V)], [String], E) -> [E]
terminals (ioList, argList, _) =
let baseChars :: [String] = ["", " ", ",", ".", "!", "?", "(", ")", "[", "]", "<", ">", "{", "}", "-", "+", "_", "/", "$", "#", ":", ";", "@", "%", "0"] in
let baseInts :: [Int] = [0, 1, 2, 3, 99] in
let inputTermList :: [[E]] = map (\(inputVList,outputV) -> convertVToEList (outputV, Placeholder) ++ concatMap (\x -> convertVToEList (x, Placeholder)) inputVList) ioList in
-- return all terminals
let summedTerminals :: [E] = map (S . X . Input) argList ++ map (S . T . Term) baseChars ++ map (I . Const) baseInts ++ concat inputTermList in
Set.toList (Set.fromList summedTerminals)
-- eval function
evalE :: (E, Map.Map String V) -> V
evalE (expr, hm) =
case expr of
S s ->
case s of
Concat s1 s2 ->
let (Vs s1eval) = evalE (S s1, hm) in
let (Vs s2eval) = evalE (S s2, hm) in
Vs (s1eval ++ s2eval)
LeftS lefts i ->
let (Vs seval) = evalE (S lefts, hm) in
let (Vi ieval) = evalE (I i, hm) in
Vs (take ieval seval)
RightS rights i ->
let (Vs seval) = evalE (S rights, hm) in
let (Vi ieval) = evalE (I i, hm) in
Vs (drop (length seval - ieval) seval)
Trim trims ->
let (Vs seval) = evalE (S trims, hm) in
Vs (dropWhile (==' ') seval)
Repeat repeats i ->
let (Vs seval) = evalE (S repeats, hm) in
let (Vi ieval) = evalE (I i, hm) in
Vs (concat (replicate ieval seval))
ToText i ->
let (Vi ieval) = evalE (I i, hm) in
Vs (show ieval)
X (Input k) ->
case Map.lookup k hm of
Just (Vs seval) -> Vs seval
_ -> None
T (Term t) -> Vs t
_ -> None
I i ->
case i of
Add i1 i2 ->
let (Vi i1eval) = evalE (I i1, hm) in
let (Vi i2eval) = evalE (I i2, hm) in
Vi (i1eval + i2eval)
Sub i1 i2 ->
let (Vi i1eval) = evalE (I i1, hm) in
let (Vi i2eval) = evalE (I i2, hm) in
Vi (i1eval - i2eval)
Find s1 s2 ->
let (Vs s1eval) = evalE (S s1, hm) in
let (Vs s2eval) = evalE (S s2, hm) in
let val = findIndex (isPrefixOf s1eval) (tails s2eval) in
maybe None Vi val
Len s ->
let (Vs seval) = evalE (S s, hm) in
Vi (length seval)
Const i ->
Vi i
_ -> None
B b ->
case b of
Equals s1 s2 ->
let (Vs s1eval) = evalE (S s1, hm) in
let (Vs s2eval) = evalE (S s2, hm) in
Vb (s1eval == s2eval)
GreaterThan i1 i2 ->
let (Vi i1eval) = evalE (I i1, hm) in
let (Vi i2eval) = evalE (I i2, hm) in
Vb (i1eval > i2eval)
GreaterThanOrEqual i1 i2 ->
let (Vi i1eval) = evalE (I i1, hm) in
let (Vi i2eval) = evalE (I i2, hm) in
Vb (i1eval >= i2eval)
_ -> None
instance DSLExprUtils E where
getTerminals = terminals
eval = evalE
instance DSLOpList Op where
getOpList = opList
instance DSLTypeList Type where
getTypeList = typeList
instance DSLOpTypeMap Op Type where
getMap = opToTypeMap
instance DSLTypeCheck E Type where
isExprofType = isEofType
instance DSLOpConversion E Op where
convertOpExprListToExpr = handleUnwrapOp