{-# LINE 1 "templates/GLR_Lib.hs" #-}
{-# LINE 1 "templates/GLR_Lib.hs" #-}
{-# LINE 1 "<command-line>" #-}
{-# LINE 1 "templates/GLR_Lib.hs" #-}
{-# LINE 1 "GLR_Lib.hs" #-}

{-
   GLR_Lib.lhs
   Id: GLR_Lib.lhs,v 1.5 2005/08/03 13:42:23 paulcc Exp 
-}

 {-
 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
 -}

{- supplied by Happy
<> module XYZ (
<>              lexer	-- conditional
-}

	-- 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 Data.Char
import qualified Data.Map as Map

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

import GHC.Prim
import GHC.Exts



import System.IO.Unsafe
import Pretty


{- these inserted by Happy -}

fakeimport DATA

{- borrowed from GenericTemplate.hs -}

{-# LINE 89 "templates/GLR_Lib.hs" #-}



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






doParse = glr_parse


----------------------------------------------------------------------------
-- Main data types

-- A forest is a map of `spans' to branches, where a span is a start position,
-- and end position, and a grammatical category for that interval. Branches
-- are lists of conjunctions of symbols which can be matched in that span.
-- Note that tokens are stored as part of the spans.

type Forest       = Map.Map ForestId [Branch]

---
-- End result of parsing:
--  - successful parse with rooted forest
--  - else syntax error or premature eof

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)

-----------------------
-- Forest to simplified output

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


---
-- main function

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



---
-- record an entry
--  - expected: "i" will contain a token

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

---
-- add a new branch
--  - due to packing, we check to see if a branch is already there
--  - return True if the branch is already there

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)

---
-- only for use with nodes that exist

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





-----------------------------------------------------------------------------
-- Auxiliary functions

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



-- Tomita stack
--  - basic idea taken from Peter Ljungloef's Licentiate thesis


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 ]



---
-- id uniquely identifies a stack

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

--instance Ord (TStack a) where
--      s1 `compare` s2 = (I# (ts_id s1)) `compare` (I# (ts_id s2))

---
-- Nothing special done for insertion
-- - NB merging done at strategic points

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



----------------------------------------------------------------------------
-- Monad
-- TODO (pcc): combine the s/i, or use the modern libraries - might be faster?
--             but some other things are much, much, much more expensive!

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)