module ReadGrammar where

import CFG

import Data.List(intersperse)
import System.IO
import System.Environment (getArgs)

data LitGrm = LitGrm { LitGrm -> Maybe String
start :: Maybe String, LitGrm -> [(String, [[String]])]
rules :: [(String, [[String]])], LitGrm -> [[String]]
rhss :: [[String]] }

readGrammar :: Monad m => [String] -> m (Maybe String, [ProductionRule])
readGrammar :: [String] -> m (Maybe String, [ProductionRule])
readGrammar [String]
lines = do
  LitGrm
startLhsRhssPairList <- State -> [String] -> m LitGrm
forall (m :: * -> *). Monad m => State -> [String] -> m LitGrm
rep State
NoState [String]
lines
  let startsymbol :: Maybe String
startsymbol = LitGrm -> Maybe String
start LitGrm
startLhsRhssPairList
  let lhsRhssPairList :: [(String, [[String]])]
lhsRhssPairList = LitGrm -> [(String, [[String]])]
rules LitGrm
startLhsRhssPairList
  let nonterminals :: [String]
nonterminals = ((String, [[String]]) -> String)
-> [(String, [[String]])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [[String]]) -> String
forall a b. (a, b) -> a
fst [(String, [[String]])]
lhsRhssPairList
  (Maybe String, [ProductionRule])
-> m (Maybe String, [ProductionRule])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
startsymbol, [[ProductionRule]] -> [ProductionRule]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((String, [[String]]) -> [ProductionRule])
-> [(String, [[String]])] -> [[ProductionRule]]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> (String, [[String]]) -> [ProductionRule]
convert [String]
nonterminals) [(String, [[String]])]
lhsRhssPairList))

-- Checking
convert :: [String] -> (String, [[String]]) -> [ProductionRule]
convert :: [String] -> (String, [[String]]) -> [ProductionRule]
convert [String]
nonterminals (String
lhs, [[String]]
rhss) =
  ([String] -> ProductionRule) -> [[String]] -> [ProductionRule]
forall a b. (a -> b) -> [a] -> [b]
map (\[String]
rhs -> String -> [Symbol] -> ProductionRule
ProductionRule String
lhs
               ((String -> Symbol) -> [String] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> if String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nonterminals
                           then String -> Symbol
Nonterminal String
s
                           else String -> Symbol
Terminal String
s) [String]
rhs)) [[String]]
rhss

-- Parsing
data State =
    NoState
  | StartSymbol String
  | Lhs String
  | Rhs [[String]]
  deriving State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq

-- Note
--  * take the first word. After that, it may be regarded as a comment.
begin :: Monad m => [Char] -> m State
begin :: String -> m State
begin [] = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return State
NoState
begin (Char
'@':Char
's':Char
't':Char
'a':Char
'r':Char
't':Char
' ':String
cs) = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State
StartSymbol (String -> String
takeWord String
cs))
begin (Char
';':String
cs) = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return State
NoState
begin (Char
' ':Char
' ':Char
'=':[]) = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return ([[String]] -> State
Rhs [[]])
begin (Char
' ':Char
' ':Char
'=':Char
' ':String
cs) = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return ([[String]] -> State
Rhs [String -> [String]
words String
cs])
begin (Char
' ':Char
' ':Char
'|':Char
' ':String
cs) = State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return ([[String]] -> State
Rhs [String -> [String]
words String
cs])
begin String
cs =
  let w :: String
w = String -> String
takeWord String
cs in
    case String
w of
      [] -> State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return State
NoState
      String
_  -> State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> State
Lhs String
w)

takeWord :: String -> String
takeWord :: String -> String
takeWord []        = []
takeWord (Char
' ':String
cs)  = []
takeWord (Char
'\t':String
cs) = []
takeWord (Char
c:String
cs)    = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
takeWord String
cs

rep :: Monad m => State -> [String] -> m LitGrm
rep :: State -> [String] -> m LitGrm
rep (Lhs String
lhs) []     = String -> m LitGrm
forall a. HasCallStack => String -> a
error String
"rep: Can't end with Lhs"
rep (State
_)       []     = LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return (LitGrm -> m LitGrm) -> LitGrm -> m LitGrm
forall a b. (a -> b) -> a -> b
$ LitGrm :: Maybe String -> [(String, [[String]])] -> [[String]] -> LitGrm
LitGrm {start :: Maybe String
start=Maybe String
forall a. Maybe a
Nothing, rules :: [(String, [[String]])]
rules=[], rhss :: [[String]]
rhss=[]}
rep State
prestate  (String
s:[String]
ss) = do
  State
state <- String -> m State
forall (m :: * -> *). Monad m => String -> m State
begin String
s
  LitGrm
startLhsRhsPairList <- State -> [String] -> m LitGrm
forall (m :: * -> *). Monad m => State -> [String] -> m LitGrm
rep State
state [String]
ss
  case (State
prestate, State
state) of
    (State
NoState, State
NoState) -> LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList
    (State
NoState, StartSymbol String
s) -> 
      case LitGrm -> Maybe String
start LitGrm
startLhsRhsPairList of
        Just String
s' -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: StartSymbol duplicated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s'
        Maybe String
Nothing -> LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList {start :: Maybe String
start = String -> Maybe String
forall a. a -> Maybe a
Just String
s}
    (State
NoState, Lhs String
lhs) ->
      let rules_ :: [(String, [[String]])]
rules_ = LitGrm -> [(String, [[String]])]
rules LitGrm
startLhsRhsPairList
          rhss_ :: [[String]]
rhss_  = LitGrm -> [[String]]
rhss LitGrm
startLhsRhsPairList
      in LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList { rules :: [(String, [[String]])]
rules=(String
lhs,[[String]]
rhss_)(String, [[String]])
-> [(String, [[String]])] -> [(String, [[String]])]
forall a. a -> [a] -> [a]
:[(String, [[String]])]
rules_, rhss :: [[String]]
rhss=[] }
    (State
NoState, Rhs [[String]]
rhss) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error String
"rep: Nostate can't change to Rule lhs rhss."
    
    (Lhs String
lhs, State
NoState) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: Lhs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" can't change to Nostate."
    (Lhs String
lhs, StartSymbol String
s) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: Lhs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" can't change to StartSymbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    (Lhs String
lhs, Lhs String
lhs') -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: Lhs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lhs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" can't change to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lhs'
    (Lhs String
lhs, Rhs [[String]]
rhss_) ->
      let rhss__ :: [[String]]
rhss__ = LitGrm -> [[String]]
rhss LitGrm
startLhsRhsPairList
      in  LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList {rhss :: [[String]]
rhss = [[String]]
rhss_ [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [[String]]
rhss__}
    
    (Rhs [[String]]
rhss, State
NoState) -> LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList
    (Rhs [[String]]
rhss, StartSymbol String
s) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: Rhs can't change to StartSymbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    (Rhs [[String]]
_, Lhs String
_) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error String
"rep: Rhs can't change to Lhs lhs."
    (Rhs [[String]]
_, Rhs [[String]]
rhss_) ->
      let rhss__ :: [[String]]
rhss__ = LitGrm -> [[String]]
rhss LitGrm
startLhsRhsPairList
      in  LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList {rhss :: [[String]]
rhss = [[String]]
rhss_ [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [[String]]
rhss__}
    
    (StartSymbol String
s, State
NoState) -> LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList
    (StartSymbol String
s, StartSymbol String
s') -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: StartSymbol duplicated(4): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s'
    (StartSymbol String
s, Lhs String
lhs) ->
      let rules_ :: [(String, [[String]])]
rules_ = LitGrm -> [(String, [[String]])]
rules LitGrm
startLhsRhsPairList
          rhss_ :: [[String]]
rhss_  = LitGrm -> [[String]]
rhss LitGrm
startLhsRhsPairList
      in LitGrm -> m LitGrm
forall (m :: * -> *) a. Monad m => a -> m a
return LitGrm
startLhsRhsPairList { rules :: [(String, [[String]])]
rules=(String
lhs,[[String]]
rhss_)(String, [[String]])
-> [(String, [[String]])] -> [(String, [[String]])]
forall a. a -> [a] -> [a]
:[(String, [[String]])]
rules_, rhss :: [[String]]
rhss=[] }
    (StartSymbol String
s, Rhs [[String]]
rhss) -> String -> m LitGrm
forall a. HasCallStack => String -> a
error (String -> m LitGrm) -> String -> m LitGrm
forall a b. (a -> b) -> a -> b
$ String
"rep: StartSymbol " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" can't change to Rule"

----
-- For testing with grm/polyrpc.lgrm
-- 

test :: (String -> IO a) -> IO ()
test String -> IO a
fun = do
  [String]
args <- IO [String]
getArgs
  (String -> IO a) -> [String] -> IO ()
forall a. (String -> IO a) -> [String] -> IO ()
repTest String -> IO a
fun [String]
args

repTest :: (String -> IO a) -> [String] -> IO ()
repTest String -> IO a
fun [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
repTest String -> IO a
fun (String
arg:[String]
args) = do
  String
text <- String -> IO String
readFile String
arg
  String -> IO a
fun String
text
  (String -> IO a) -> [String] -> IO ()
repTest String -> IO a
fun [String]
args

parsing :: String -> IO ()
parsing String
text = do
  LitGrm
startLhsRhssPairList <- State -> [String] -> IO LitGrm
forall (m :: * -> *). Monad m => State -> [String] -> m LitGrm
rep State
NoState (String -> [String]
lines String
text)
  let startsymbol :: Maybe String
startsymbol = LitGrm -> Maybe String
start LitGrm
startLhsRhssPairList
  let lhsRhssPairList :: [(String, [[String]])]
lhsRhssPairList = LitGrm -> [(String, [[String]])]
rules LitGrm
startLhsRhssPairList
  ((String, [[String]]) -> IO ()) -> [(String, [[String]])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
lhs,[[String]]
rhss) -> String -> [[String]] -> IO ()
prLhsRhss String
lhs [[String]]
rhss) [(String, [[String]])]
lhsRhssPairList

prLhsRhss :: String -> [[String]] -> IO ()
prLhsRhss :: String -> [[String]] -> IO ()
prLhsRhss String
lhs [[String]]
rhss = do
  String -> IO ()
putStrLn String
lhs
  ([String] -> IO ()) -> [[String]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[String]
rhs ->
         do { String -> IO ()
putStr String
"\t"
            ; (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
s -> do {String -> IO ()
putStr String
s; String -> IO ()
putStr String
" "}) [String]
rhs
            ; String -> IO ()
putStrLn String
""} )  [[String]]
rhss

conversion :: String -> IO ()
conversion String
text = do
  (Maybe String
startsymbol_, [ProductionRule]
prodrules_) <- [String] -> IO (Maybe String, [ProductionRule])
forall (m :: * -> *).
Monad m =>
[String] -> m (Maybe String, [ProductionRule])
readGrammar (String -> [String]
lines String
text)
  case Maybe String
startsymbol_ of
    Maybe String
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"conversion: No start symbol"
    Just String
startsymbol ->
      do
        let startsymbol' :: String
startsymbol' = String
startsymbol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        let startprod :: ProductionRule
startprod = String -> [Symbol] -> ProductionRule
ProductionRule String
startsymbol' [ String -> Symbol
Nonterminal String
startsymbol ]
        let prodrules :: [ProductionRule]
prodrules = ProductionRule
startprod ProductionRule -> [ProductionRule] -> [ProductionRule]
forall a. a -> [a] -> [a]
: [ProductionRule]
prodrules_
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CFG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
startsymbol' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [\n "
        -- May replace prodRuleToStr with show
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
",\n " ((ProductionRule -> String) -> [ProductionRule] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ProductionRule -> String
prodRuleToStr [ProductionRule]
prodrules))  
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"]"