Added cabal and vim dir

cabal/share/x86_64-osx-ghc-7.8.4/happy-1.19.5/GLR_Lib-ghc-debug

@@ -0,0 +1,467 @@
+{-# LINE 1 "templates/GLR_Lib.hs" #-}
+{-# LINE 1 "templates/GLR_Lib.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# 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)
+				
+{-# LINE 181 "templates/GLR_Lib.hs" #-}
+ : 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))
+			    
+{-# LINE 210 "templates/GLR_Lib.hs" #-}
+ : 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
+	           
+{-# LINE 243 "templates/GLR_Lib.hs" #-}
+       $ ("Pack at " ++ show key ++ " " ++ show fids)
+		   
+{-# LINE 243 "templates/GLR_Lib.hs" #-}
+       : ("**" ++ show stk)
+		   
+{-# LINE 243 "templates/GLR_Lib.hs" #-}
+       : 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
+	           
+{-# LINE 258 "templates/GLR_Lib.hs" #-}
+       $ ("Stack Matches: " ++ show (length stack_matches))
+	           
+{-# LINE 258 "templates/GLR_Lib.hs" #-}
+       : map show stack_matches) $ return ())
+       
+
+       (happyTrace ( if not (duplicate && appears_in) then "" else
+	             
+{-# LINE 261 "templates/GLR_Lib.hs" #-}
+       unlines
+	           
+{-# LINE 261 "templates/GLR_Lib.hs" #-}
+       $ ("DROP:" ++ show ((I# (st)),key) ++ " -- " ++ show stk)
+	           
+{-# LINE 261 "templates/GLR_Lib.hs" #-}
+       : "*****"
+	           
+{-# LINE 261 "templates/GLR_Lib.hs" #-}
+       : 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)
+
+