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
|
module Main where
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import System.Console.Readline
import System.Exit
import System.IO
import qualified Data.Map.Strict as Map
import AST
import Simplify
import Parser
import PrettyPrint
import Debug
trimlr :: String -> String
trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace
findstr :: String -> String -> Maybe Int
findstr pat topsub = go topsub 0
where len = length pat
go :: String -> Int -> Maybe Int
go "" _ = Nothing
go sub i = if take len sub == pat then Just i else go (tail sub) (i+1)
mayberead :: Read a => String -> Maybe a
mayberead s =
let r = reads s
ok = if null r then False else null $ snd $ head r
v = fst $ head r
in if ok then Just v else Nothing
readrule :: String -> IO (AST,AST)
readrule line = do
let (patstr',(repstr')) = break (=='|') line
patstr = desugar $ trimlr patstr'
repstr = desugar $ trimlr $ tail repstr'
if null repstr'
then die $ "No pipe separator found: " ++ line
else do
let mpat = mayberead patstr :: Maybe AST
mrep = mayberead repstr :: Maybe AST
when (isNothing mpat) $ die $ "Could not parse pattern! (from '" ++ patstr ++ "')"
when (isNothing mrep) $ die $ "Could not parse replacement! (from '" ++ repstr ++ "')"
return (fromJust mpat,fromJust mrep)
desugar :: String -> String
desugar "" = ""
desugar ('{':cs) =
let midx = findIndex (=='}') cs
idx = fromJust midx
termcap = head cs == '{' && length cs > idx+1 && cs !! (idx+1) == '}'
endidx = if termcap then idx+1 else idx
after = drop (endidx+1) cs
name' = if termcap then tail $ take (endidx-1) cs else take endidx cs
name = map (\c -> if c == '\\' || c == '"' then '_' else c) name'
in if isNothing midx
then '{':desugar cs
else if termcap
then let mcolonidx = findIndex (==':') name
colonidx = fromJust mcolonidx
precolon = take colonidx name
postcolon = drop (colonidx+1) name
stub = case postcolon of
"Number" -> "Number 42"
"Variable" -> "Variable \"\""
_ -> trace postcolon undefined
in if isNothing mcolonidx
then "(CaptureTerm \"" ++ name ++ "\")" ++ desugar after
else "(CaptureConstr \"" ++ precolon ++ "\" (" ++ stub ++ "))" ++ desugar after
else "(Capture \"" ++ name ++ "\")" ++ desugar after
desugar (':':cs) =
let midx = findIndex (==':') cs
endidx = fromJust midx
after = drop (endidx+1) cs
name = map (\c -> if c == '\\' || c == '"' then '_' else c) $ take endidx cs
in if isNothing midx
then ':':desugar cs
else "Apply \"" ++ name ++ "\" " ++ desugar after
desugar (c:cs) = c : desugar cs
readrules :: Handle -> IO (Map.Map String [(AST,AST)])
readrules handle = liftM (uncurry fixincludes) $ go "general" Map.empty Map.empty
where
go :: String -- current section
-> Map.Map String [String] -- sections still to be included (#+)
-> Map.Map String [(AST,AST)] -- current rules db
-> IO (Map.Map String [(AST,AST)],Map.Map String [String]) -- (rules db,includes)
go sect includes db = hIsEOF handle >>= \eof -> if eof then return (db,includes) else do
line <- hGetLine handle
case take 3 line of
"" -> go sect includes db
"-- " -> go sect includes db
"## " -> go (trimlr $ drop 3 line) includes db
"#+ " -> go sect (Map.insertWith (++) sect [trimlr $ drop 3 line] includes) db
_ -> readrule (trimlr line) >>= \rule -> go sect includes (Map.insertWith (flip (++)) sect [rule] db)
fixincludes :: Map.Map String [(AST,AST)] -- rules db
-> Map.Map String [String] -- to be included sections
-> Map.Map String [(AST,AST)] -- resulting rules db
fixincludes topdb includes = Map.foldlWithKey insertincludes topdb includes
where
insertincludes :: Map.Map String [(AST,AST)] -- db
-> String -- section
-> [String] -- sections to be included
-> Map.Map String [(AST,AST)] -- resulting db
insertincludes db sect incls =
foldl (\db' incl -> insertinclude db' sect incl) db incls
where insertinclude db' sect' incl = Map.insertWith (++) sect' (fromJust $ Map.lookup incl db') db'
printrules :: [(AST,AST)] -> IO ()
printrules db = sequence_ $ foldl (\l (pat,sub) -> l ++ [print pat,putStr " -> ",print sub]) [] db
repl :: Map.Map String [(AST,AST)] -> IO ()
repl db = do
mline <- readline "> "
case mline of
Nothing -> return () -- EOF
Just "" -> repl db
Just line -> do
addHistory line
let eexpr = parseExpression line
either (putStrLn . ("Error: "++)) handleExpression eexpr
repl db
where
generaldb = fromJust $ Map.lookup "general" db
sanitisedb = fromJust $ Map.lookup "sanitise" db
displaydb = fromJust $ Map.lookup "display" db
handleExpression expr = do
putStrLn $ prettyPrint expr
let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb]
putStrLn $ prettyPrint sim
main :: IO ()
main = do
rulesdb <- withFile "rules.txt" ReadMode readrules
--sequence_ $ Map.foldlWithKey (\l sect rules -> putStrLn ("## "++sect) : printrules rules : putStrLn "" : l) [] rulesdb
repl rulesdb
|
