{-# LINE 1 "templates/GLR_Lib.lhs" #-}
{-# LINE 1 "/tmp/ghc4905_0/ghc4905_0.lpp" #-}
{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command line>" #-}
{-# LINE 1 "/tmp/ghc4905_0/ghc4905_0.lpp" #-}
{-# LINE 1 "templates/GLR_Lib.lhs" #-}
 {-# LINE 1 "GLR_Lib.lhs" #-}






  {-
  Parser driver for the GLR parser.
  
  (c) University of Durham, Ben Medlock 2001
          -- initial code, for structure parsing
  (c) University of Durham, Paul Callaghan 2004-05
          -- extension to semantic rules
          -- shifting to chart data structure
          -- supporting hidden left recursion
          -- many optimisations
  -}






        -- probable, but might want to parametrise
            , doParse
            , TreeDecode(..), decode    -- only for tree decode
            , LabelDecode(..)           -- only for label decode

        -- standard exports
            , Tokens
            , GLRResult(..)
            , NodeMap
            , RootNode
            , ForestId
            , GSymbol(..)
            , Branch(..)
            , GSem(..)
            )
   where

 import Char
 import System


 import qualified Data.Map as Map







 import Monad (foldM)
 import Maybe (fromJust)
 import List (insertBy, nub, maximumBy, partition, find, groupBy, delete)


 import System.IO.Unsafe
 import Pretty


 {- these inserted by Happy -}

 fakeimport DATA



{-# LINE 94 "templates/GLR_Lib.lhs" #-}



 happyTrace string expr = unsafePerformIO $ do
     hPutStr stderr string
     return expr






 doParse = glr_parse











 type Forest       = Map.Map ForestId [Branch]









 type NodeMap = [(ForestId, [Branch])]
 type RootNode = ForestId
 type Tokens = [[(Int, GSymbol)]]       -- list of ambiguous lexemes

 data GLRResult 
  = ParseOK     RootNode Forest    -- forest with root
  | ParseError  Tokens   Forest    -- partial forest with bad input
  | ParseEOF             Forest    -- partial forest (missing input)




 forestResult :: Int -> Forest -> GLRResult
 forestResult length f
  = case roots of
        []       -> ParseEOF f
        [r]      -> ParseOK r f
        rs@(_:_) -> error $ "multiple roots in forest, = " ++ show rs
                                                ++ unlines (map show ns_map)
    where

        ns_map = Map.toList f 



        roots = [ r | (r@(0,sz,sym),_) <- ns_map
                    , sz == length
                    , sym == top_symbol ]




 glr_parse :: [[UserDefTok]] -> GLRResult
 glr_parse toks 

  = case runST Map.empty [0..] (tp toks) of



     (f,Left ts)   -> ParseError ts f 
                                                -- Error within sentence
     (f,Right ss)  -> forestResult (length toks) f
                                                -- Either good parse or EOF
    where
        tp tss = doActions [initTS 0] 
               $ zipWith (\i ts -> [(i, t) | t <- ts]) [0..] 
               $ [ [ HappyTok {-j-} t | (j,t) <- zip [0..] ts ] | ts <- tss ]
                 ++ [[HappyEOF]]



 type PM a = ST Forest [Int] a
 type FStack = TStack ForestId





 doActions :: [FStack] -> Tokens -> PM (Either Tokens [FStack])

 doActions ss []                -- no more tokens (this is ok)
  = return (Right ss)           -- return the stacks (may be empty)

 doActions stks (tok:toks)
  = do
        stkss <- sequence [ do
                              stks' <- reduceAll [] tok_form stks 
                              shiftAll tok_form stks'
                          | tok_form <- tok ]
        let new_stks = merge $ concat stkss
        (happyTrace (unlines $ ("Stacks after R*/S pass" ++ show tok)                                  : map show new_stks) $ return ())

        case new_stks of            -- did this token kill stacks?
          [] -> case toks of
                  []  -> return $ Right []         -- ok if no more tokens
                  _:_ -> return $ Left (tok:toks)  -- not ok if some input left
          _  -> doActions new_stks toks

 reduceAll 
  :: [GSymbol] -> (Int, GSymbol) -> [FStack] -> PM [(FStack, Int)]
 reduceAll _ tok [] = return []
 reduceAll cyclic_names itok@(i,tok) (stk:stks)
  = do
      case action this_state tok of
        Accept      -> reduceAll [] itok stks
        Error       -> reduceAll [] itok stks
        Shift st rs -> do { ss <- redAll rs ; return $ (stk,st) : ss } 
        Reduce rs   -> redAll rs
  where 
   this_state = top stk
   redAll rs 
    = do 
        let reds = [ (bf fids,stk',m) 
                   | (m,n,bf) <- rs
                   , not (n == 0 && m `elem` cyclic_names)  -- remove done ones
                   , (fids,stk') <- pop n stk
                   ]
                   -- WARNING: incomplete if more than one Empty in a prod(!)
                   -- WARNING: can avoid by splitting emps/non-emps
        (happyTrace (unlines $ ("Packing reds = " ++ show (length reds))                              : map show reds) $ return ()) 

        stks' <- foldM (pack i) stks reds       
        let new_cyclic = [ m | (m,0,_) <- rs
                             , (this_state ==#  goto this_state m)
                             , m `notElem` cyclic_names ]
        reduceAll (cyclic_names ++ new_cyclic) itok $ merge stks' 

 shiftAll :: (Int, GSymbol) -> [(FStack, Int)] -> PM [FStack]
 shiftAll tok [] = return []
 shiftAll (j,tok) stks
  = do  
        let end = j + 1 
        let key = end `seq` (j,end,tok)
        newNode key
        let mss = [ (stk, st)
                  | ss@((_,st):_) <- groupBy (\a b -> snd a == snd b) stks
                  , stk <- merge $ map fst ss ]
        stks' <- sequence [ do { nid <- getID ; return (push key st nid stk) }
                          | (stk,(I# (st))) <- mss ]
        return stks'


 pack 
  :: Int -> [FStack] -> (Branch, FStack, GSymbol) -> PM [FStack]

 pack e_i stks (fids,stk,m)
  | (st <#  0#) 
     = return stks
  | otherwise
     = do
        let s_i = endpoint stk
        let key = (s_i,e_i,m)
        (happyTrace ( unlines                     $ ("Pack at " ++ show key ++ " " ++ show fids)                    : ("**" ++ show stk)                     : map show stks) $ return ())



 
        duplicate <- addBranch key fids
 
        let stack_matches = [ s | s <- stks
                                , (top s ==#  st)
                                , let (k,s') = case ts_tail s of x:_ -> x
                                , stk == s'
                                , k == key
                                ]  -- look for first obvious packing site
        let appears_in = not $ null stack_matches
 
        (happyTrace ( unlines                     $ ("Stack Matches: " ++ show (length stack_matches))                    : map show stack_matches) $ return ())


        (happyTrace ( if not (duplicate && appears_in) then "" else                      unlines                     $ ("DROP:" ++ show ((I# (st)),key) ++ " -- " ++ show stk)                    : "*****"                     : map show stks) $ return ())





        if duplicate && appears_in
         then return stks       -- because already there
         else do
               nid <- getID
               case stack_matches of
                 []  -> return $ insertStack (push key st nid stk) stks
                                -- No prior stacks

                 s:_ -> return $ insertStack (push key st nid stk) (delete s stks)
                                -- pack into an existing stack
     where
        st = goto (top stk) m







 newNode :: ForestId -> PM ()
 newNode i

  = chgS $ \f -> ((), Map.insert i [] f)









 addBranch :: ForestId -> Branch -> PM Bool
 addBranch i b 
  = do
        f <- useS id

        case Map.lookup i f of 
          Nothing               -> chgS $ \f -> (False, Map.insert i [b] f)   
          Just bs | b `elem` bs -> return True
                  | otherwise   -> chgS $ \f -> (True,  Map.insert i (b:bs) f)









 getBranches ::  ForestId -> PM [Branch]
 getBranches i 

  = useS $ \s -> Map.findWithDefault no_such_node i s



    where
        no_such_node = error $ "No such node in Forest: " ++ show i








 (<>) x y = (x,y)  -- syntactic sugar








 data TStack a 
  = TS { top      :: Int#           -- state
       , ts_id    :: Int#           -- ID
       , stoup    :: !(Maybe a)         -- temp holding place, for left rec.
       , ts_tail  :: ![(a,TStack a)]    -- [(element on arc , child)] 
       }

 instance Show a => Show (TStack a) where
   show ts 
    = "St" ++ show ((I# (top ts))) 

      ++ "\n" ++ render (spp $ ts_tail ts)
      where
        spp ss = nest 2 
                $ vcat [ vcat [text (show (v,(I# (top s)))), spp (ts_tail s)] 
                       | (v,s) <- ss ]






 instance Eq (TStack a) where
       s1 == s2 = (ts_id s1 ==#  ts_id s2)








 insertStack :: TStack a -> [TStack a] -> [TStack a]
 insertStack = (:)



 initTS :: Int -> TStack a
 initTS (I# (id)) = TS 0# id Nothing []



 push :: ForestId -> Int# -> Int -> TStack ForestId -> TStack ForestId
 push x@(s_i,e_i,m) st (I# (id)) stk 
  = TS st id stoup [(x,stk)] 
    where
        -- only fill stoup for cyclic states that don't consume input
        stoup | s_i == e_i && (st ==#  goto st m) = Just x       
              | otherwise                        = Nothing



 pop :: Int -> TStack a -> [([a],TStack a)] 
 pop 0 ts = [([],ts)]
 pop 1 st@TS{stoup=Just x}
  = pop 1 st{stoup=Nothing} ++ [ ([x],st) ] 
 pop n ts = [ (xs ++ [x] , stk')
            | (x,stk) <- ts_tail ts
            , (xs,stk') <- pop (n-1) stk ] 



 popF :: TStack a -> TStack a 
 popF ts = case ts_tail ts of (_,c):_ -> c



 endpoint stk
  = case ts_tail stk of
      [] -> 0
      ((_,e_i,_),_):_ -> e_i





 merge :: (Eq a, Show a) => [TStack a] -> [TStack a]
 merge stks
  = [ TS st id ss (nub ch)
    | (I# (st)) <- nub (map (\s -> (I# (top s))) stks)
    , let ch  = concat  [ x | TS st2 _ _ x <- stks, (st ==# st2) ]
          ss  = mkss    [ s | TS st2 _ s _ <- stks, (st ==# st2) ]
          (I# (id)) = head [ (I# (i)) | TS st2 i _ _ <- stks, (st ==# st2) ]
          -- reuse of id is ok, since merge discards old stacks
    ]
    where
         mkss s = case nub [ x | Just x <- s ] of
                    []  -> Nothing
                    [x] -> Just x
                    xs  -> error $ unlines $ ("Stoup merge: " ++ show xs) 
                                           : map show stks








 data ST s i a = MkST (s -> i -> (a,s,i))

 instance Functor (ST s i) where
  fmap f (MkST sf) 
   = MkST $ \s i -> case sf s i of (a,s',i') -> (f a,s',i')

 instance Monad (ST s i) where
  return a = MkST $ \s i -> (a,s,i)
  MkST sf >>= k
   = MkST $ \s i ->
        case sf s i of
         (a,s',i') -> let (MkST sf') = k a in  sf' s' i' 

 runST :: s -> i -> ST s i a -> (s,a)
 runST s i (MkST sf) = case sf s i of
                           (a,s,_) -> (s,a)

 chgS :: (s -> (a,s)) -> ST s i a
 chgS sf = MkST $ \s i -> let (a,s') = sf s in (a,s',i)

 useS :: (s -> b) -> ST s i b
 useS fn = MkST $ \s i -> (fn s,s,i)

 getID :: ST s [Int] Int
 getID = MkST $ \s (i:is) -> (i,s,is)