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 
   42 
   43 
   44 
   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 
   56 
   57 
   58 
   59 
   60 
   61 
   62 
   63 
   64 
   65 
   66   nfaChar = NFAChar
   67   nfaAny  = NFAAny
   68   -- nfaEps  = NFAEps
   69   nfaEps  = mkTable [] [] [] False . epsClosure
   70   nfaEnd  = NFAEnd
   71   nfaFinal= NFAFinal
   72 
   73 
   74 
   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 
   87 
   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 
  127 
  128 
  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 
  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 
  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