[project @ 1996-07-25 21:02:03 by partain]
[nofib.git] / real / grep / Main.lhs
1 > module Main where
2
3 > import Parsers
4 > import System -- 1.3 (partain)
5 > import IO--1.3
6
7 > infixr 8 +.+ , +.. , ..+
8 > infixl 7 <<< , <<*
9 > infixr 6 |||
10
11 > (+.+) = thn
12 > (..+) = xthn
13 > (+..) = thnx
14 > (|||) = alt
15 > (<<<) = using
16 > (<<*) = using2
17 > lit   :: Eq a => a -> Parser a a
18 > lit   = literal
19 > star  = rpt
20 > anyC  = satisfy (const True)
21 > butC cs = satisfy (not.(`elem` cs))
22 > noC   "" = [("","")]
23 > noC   _  = []
24
25 ----------------------------------------------------------------------
26
27 > main = getArgs >>= \ args -> parse_args args
28
29 > parse_args :: [String] -> IO ()
30 > parse_args (regexp: files) =
31 >       let acc = acceptor (fst(head(nnRegexp regexp)))
32 >           acc' = unlines . filter acc . lines
33 >       in
34 >           getContents >>= \ inp ->
35 >           putStr (acc' inp)
36 > parse_args _ =
37 >       getProgName >>= \progName ->
38 >       hPutStr stderr ("Usage: " ++ progName ++ " regexp\n")
39
40 {-
41   Atom          = character | "\\" character | "." | "\\(" Regexp "\\) .
42   ExtAtom       = Atom ["*" | "+" | "?"] .
43   Factor        = ExtAtom + .
44   Regexp        = Factor / "\\|" ["$"].
45 -}
46
47 > data NFANode 
48 >       = NFAChar Char NFANode
49 >       | NFAAny  NFANode
50 >       | NFAEps  [NFANode]
51 >       | NFAEnd  NFANode
52 >       | NFAFinal
53 >       | NFATable [(Char, NFANode)] [NFANode] [NFANode] Bool
54
55 NFAChar c next  - a state with arc on character c to next state
56 NFAAny next     - a state with arc on any character
57 NFAEps nexts    - a state with a set of epsilon transitions
58 NFAEnd          - a state with an arc if end of string is reached
59 NFAFinal        - a final state
60 NFATable charTrans anyTrans endTrans final
61                 - a state with character arcs according to charTrans,
62                   any character arcs according to anyTrans, end arcs
63                   according to endTrans, and a boolean flag indicating
64                   a final state
65
66 > nfaChar = NFAChar
67 > nfaAny  = NFAAny
68 > -- nfaEps  = NFAEps
69 > nfaEps  = mkTable [] [] [] False . epsClosure
70 > nfaEnd  = NFAEnd
71 > nfaFinal= NFAFinal
72
73 just wrappers for the NFANode constructors, 
74 modified such that epsilon transitions are compressed into tables
75
76 > mkTable pairs anys ends final []      = NFATable pairs anys ends final 
77 > mkTable pairs anys ends final (NFAChar c n:ns) = mkTable ((c,n):pairs) anys ends final ns
78 > mkTable pairs anys ends final (NFAAny n:ns) = mkTable pairs (n:anys) ends final ns
79 > mkTable pairs anys ends final (NFATable pairs' anys' ends' final':ns) = mkTable (pairs'++pairs) (anys'++anys) (ends'++ends) (final' || final) ns
80 > mkTable pairs anys ends final (NFAEnd n:ns) = mkTable pairs anys (n:ends) final ns
81 > mkTable pairs anys ends final (NFAFinal:ns) = mkTable pairs anys ends True ns
82 > mkTable _ _ _ _ _ = error "illegal argument to mkTable"
83
84 > type NFAproducer = NFANode -> NFANode
85
86 An NFAproducer takes a final state and produces the initial state of a
87 non-deterministic automaton.
88
89 > nnAtom :: Parser Char NFAproducer
90 > nnAtom =
91 >      lit '\\' ..+ lit '(' ..+ nnRegexp +.. lit '\\' +.. lit ')'
92 >  ||| lit '\\' ..+ butC "|()"   <<< nfaChar
93 >  ||| lit '.'                   <<< const NFAAny
94 >  ||| butC "\\.$"               <<< nfaChar
95 >  ||| lit '$' `followedBy` anyC <<< nfaChar
96
97 > nnExtAtom :: Parser Char NFAproducer
98 > nnExtAtom =
99 >      nnAtom +.+ opt (lit '*' <<< const (\ at final ->
100 >                                        let at_init = at (nfaEps [final, at_init])
101 >                                        in  nfaEps [at_init, final])
102 >               |||  lit '+' <<< const (\ at final ->
103 >                                        let at_init = at (nfaEps [final, at_init])
104 >                                        in  nfaEps [at_init])
105 >               |||  lit '?' <<< const (\ at final ->
106 >                                        let at_init = at (nfaEps [final])
107 >                                        in  nfaEps [final, at_init]))
108 >       <<< helper
109 >      where
110 >        helper (ea, []) = ea
111 >        helper (ea, [f]) = f ea
112
113 > nnFactor :: Parser Char NFAproducer
114 > nnFactor =
115 >      plus nnExtAtom   <<< foldr (.) id
116
117 > nnRegexp :: Parser Char NFAproducer
118 > nnRegexp =
119 >      nnFactor +.+ star (lit '\\' ..+ lit '|' ..+ nnFactor) +.+ opt (lit '$')
120 >       <<< helper
121 >      where
122 >        helper (ef, (efs, [])) = foldl combine ef efs
123 >        helper (ef, (efs, _ )) = foldl combine ef efs . nfaEnd
124 >        combine f1 f2 final = nfaEps [f1 final, f2 final]
125
126 Step function for the NFA interpreter.
127 Note if epsilon compression is removed above, all {- epsClosure -} must 
128 be uncommented!
129
130 > nfaStep states c = {- epsClosure -} (concat (map step states))
131 >   where
132 >     step (NFAChar c' n') | c == c' = [n']
133 >     step (NFAAny n') = [n']
134 >     step (NFATable pairs anys ends finals) = [ n' | (c',n') <- pairs, c == c' ] ++ anys
135 >     step _ = []
136
137 precondition: there are no epsilon cycles!
138
139 > epsClosure [] = []
140 > epsClosure (NFAEps ns:ns') = epsClosure (ns++ns')
141 > epsClosure (n:ns) = n:epsClosure ns
142
143 > acceptor :: NFAproducer -> String -> Bool
144 > acceptor nfa str = nfaRun ( {- epsClosure -} [nfa nfaFinal]) str
145
146 The NFA interpreter
147
148 > nfaRun :: [NFANode] -> String -> Bool
149 > nfaRun ns (c:cs) = nfaRun (nfaStep ns c) cs
150 > nfaRun ns [] = not (null ( {- epsClosure -} (concat (map step ns))))
151 >   where
152 >     step (NFAEnd n') = [n']
153 >     step (NFAFinal)  = [NFAFinal]
154 >     step (NFATable pairs anys ends True) = [NFAFinal]
155 >     step (NFATable pairs anys ends finals) = ends
156 >     step _           = []
157