uulib 0.9.5 → 0.9.7
raw patch · 15 files changed
+450/−61 lines, 15 filesdep +ghc-primdep ~base
Dependencies added: ghc-prim
Dependency ranges changed: base
Files
- README +10/−0
- examples/bibtex/Bibtex.hs +130/−0
- examples/parser/Example.hs +84/−0
- examples/parser/Makefile +8/−0
- examples/parser/README +65/−0
- examples/parser/Scanner.x +54/−0
- src/UU/Parsing/CharParser.hs +7/−7
- src/UU/Parsing/Interface.hs +7/−6
- src/UU/Parsing/Machine.hs +25/−24
- src/UU/Parsing/MachineInterface.hs +8/−5
- src/UU/Parsing/Offside.hs +32/−5
- src/UU/Parsing/StateParser.hs +2/−1
- src/UU/Scanner/GenTokenParser.hs +7/−7
- src/UU/Scanner/GenTokenSymbol.hs +3/−3
- uulib.cabal +8/−3
README view
@@ -60,6 +60,16 @@ you don't need to pass a path to configure, just follow the steps outlined above. +Source tarball (uploadable to hackage)+--------------------------------------++ Use the "sdist" cabal command:++ ghc --make Setup.hs -o setup -package Cabal+ ./setup configure+ ./setup sdist++ You will find the tarball in the dist directory. Optionally generating Haddock Documentation -------------------------------------------
+ examples/bibtex/Bibtex.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{- Fast, Error Correcting Parser Combinators; Version: see Version History in same directory.+ - Copyright: S. Doaitse Swierstra+ Department of Computer Science+ Utrecht University+ P.O. Box 80.089+ 3508 TB UTRECHT + the Netherlands+ swierstra@cs.uu.nl+-}++{- file: bibtex6.hs+ A parser for BibTeX+ using the UU parsing combinators+ Piet van Oostrum, Atze Dijkstra, Doaitse Swierstra (April 22, 2001)+-}+module Bibtex where+import UU.Parsing+import Char++newtype IS s = IS (Int,Int,[s])++instance InputState (IS Char) Char (Maybe String) where+ splitStateE (IS (l, p, [] )) = Right' (IS(l,p,[]))+ splitStateE (IS (l, p, (s:ss))) = Left' s (if s == '\n' then IS(l+1, 1, ss) else IS(l, p+1, ss))+ splitState (IS (l, p, (s:ss))) = ({-L-} s, (if s == '\n' then IS(l+1, 1, ss) else IS(l, p+1, ss)) {-R-})+ getPosition (IS (l, p, [] )) = Nothing+ getPosition (IS (l, p, (s:ss))) = Just (" before " ++ show s ++ " at line: " ++show l ++ " column: " ++ show p)++instance Symbol Char where+ symBefore = pred+ symAfter = succ+ ++parsebib filename -- e.g. parsebib "btxdoc.bib"+ = let showMessage (Msg expecting position action) + = let pos = case position of+ Nothing -> "at end of file"+ Just s -> case action of + Insert _ -> "before " ++ show s+ Delete t -> "at " ++ show t + in "\n?? Error : " ++ pos +++ "\n?? Expecting : " ++ show expecting +++ "\n?? Repaired by: " ++ show action ++ "\n" + in do input <- readFile filename+ res <- parseIOMessage showMessage pBibData (IS (1,1,input))+ putStr ("\nResult:" ++ show (length res) ++ " bib items were parsed\n")+-- =======================================================================================+-- ===== DATA TYPES ======================================================================+-- =======================================================================================+type BibData = [ BibEntry]++data BibEntry = Entry String (String, [Field]) -- kind keyword fieldlist+ | Comment String+ | Preamble [ValItem]+ | StringDef Field+ deriving Show++type Field = (String, [ValItem])++data ValItem = StringVal String + | IntVal Int+ | NameUse String+ deriving Show+-- =======================================================================================+-- ===== PARSERS =========================================================================+-- =======================================================================================+-- pBibData parses a list of BiBTex entries separated by garbage+-- a @ signifies the start of a new entry+pBibData = pChainr ((\ entry _ right -> entry:right) <$> pBibEntry)+ ( [] <$ pList (allChars `pExcept` "@"))++pBibEntry + = ( Entry <$ pAt <*> pName <*> pOpenClose ( pKeyName <* pSpec ','+ <+> pListSep_ng pComma pField + <* (pComma `opt` ' '))+ <|> Comment <$ pAt <* pKey "comment" <*> ( pCurly (pList (allChars `pExcept` "}"))+ <|> pParen (pList (allChars `pExcept` ")"))+ )+ <|> Preamble <$ pAt <* pKey "preamble" <*> pOpenClose pValItems + <|> StringDef <$ pAt <* pKey "string" <*> pOpenClose pField+ ) ++pField = pName <* pSpec '=' <+> pValItems++pValItems = pList1Sep (pSpec '#') ( StringVal <$> pString + <|> int_or_name <$> pName+ )+ where int_or_name s = if all isDigit s+ then IntVal.(read::String->Int) $ s+ else NameUse s+-- =======================================================================================+-- ===== LEXICAL STUFF ===================================================================+-- =======================================================================================+pLAYOUT :: AnaParser (IS Char) Pair Char (Maybe String) String++pLAYOUT = pList (pAnySym " \t\r\n")+pSpec c = pSym c <* pLAYOUT++pParen p = pPacked (pSpec '(') (pSpec ')') p+pCurly p = pPacked (pSpec '{') (pSpec '}') p+pOpenClose p = pParen p <|> pCurly p +pComma = pCostSym 4 ',' ',' <* pLAYOUT+pAt = pSpec '@'++allChars = (chr 1, chr 127, ' ')++pName = pList1 ('a'<..>'z' <|> 'A'<..>'Z' <|> '0'<..>'9' <|> pAnySym "-_/") <* pLAYOUT+pKeyName = pList1 ((chr 33, chr 127, ' ') `pExcept` ",=@" ) <* pLAYOUT++pKey [s] = lift <$> (pSym s <|> pSym (toUpper s)) <* pLAYOUT+pKey (s:ss) = (:) <$> (pSym s <|> pSym (toUpper s)) <*> pKey ss+pKey [] = usererror "Scanner: You cannot have empty reserved words!"++pString + = let curlyStrings = stringcons <$> pSym '{' <*> pConc pStringWord <*> pSym '}'+ pStringWordDQ = lift <$> pStringCharDQ <|> curlyStrings+ pStringWord = lift <$> pStringChar <|> curlyStrings+ pStringCharDQ = allChars `pExcept` "\"{}"+ pStringChar = pStringCharDQ <|> pSym '\"'+ pConc = pFoldr ((++),[]) + stringcons c1 ss c2 = [c1] ++ ss ++ [c2]+ in ( pSym '"' *> pConc pStringWordDQ <* pSym '"'+ <|> pSym '{' *> pConc pStringWord <* pSym '}'+ ) <* pLAYOUT++lift c = [c]+
+ examples/parser/Example.hs view
@@ -0,0 +1,84 @@+module Main where++-- import the the library functions from uulib+import UU.Parsing+import UU.Scanner++-- import our custom made Alex-scanner+import Scanner+++-- Some boilerplate code to use the parser+-- Give `parsetokens' your parser and a list of tokens, returned by the `scanTokens'+-- function exported by the Scanner module, then you get either a list of error+-- messages in case of a parse error, or the parse tree.+type TokenParser a = Parser Token a++parseTokens :: TokenParser a -> [Token] -> Either [String] a+parseTokens p tks+ = if null msgs+ then final `seq` Right v+ else Left (map show msgs)+ where+ steps = parse p tks+ msgs = getMsgs steps+ (Pair v final) = evalSteps steps+++-- define a parse tree+data Expr+ = Identifier String+ | Integer Int+ | String String+ | Plus Expr Expr+ | Times Expr Expr+ | Let String -- variable+ Expr -- = expr+ Expr -- body+ deriving Show+++-- write a parser for it+-- Note: * make sure that the parser is not left recursive+-- (to the left is never a pExpr, or always a terminal first)+-- * make sure that the parser is not ambiguous+-- (by introducing priority levels for the operators)+++-- Term -> let var = Expr in Expr+pExpr :: TokenParser Expr+pExpr+ = (\_ x _ e _ b -> Let x e b) <$> pKey "let" <*> pVarid <*> pKey "=" <*> pExpr <*> pKey "in" <*> pExpr+ <|> pMult++-- Expr -> Factor | Factor * Expr+pMult :: TokenParser Expr+pMult+ = pFactor + <|> (\l _ r -> Times l r) <$> pFactor <*> pKey "*" <*> pExpr++-- Factor -> Term | Term * Factor+pFactor :: TokenParser Expr+pFactor+ = pTerm+ <|> (\l _ r -> Plus l r) <$> pTerm <*> pKey "+" <*> pFactor++-- Term -> var+-- Term -> String+-- Term -> Int+-- Term -> (Expr)+pTerm :: TokenParser Expr+pTerm+ = Identifier <$> pVarid+ <|> (Integer . read) <$> pInteger16+ <|> (String . read) <$> pString+ <|> (\_ e _ -> e) <$> pKey "(" <*> pExpr <*> pKey ")"+++-- test it+main :: IO ()+main+ = let res = parseTokens pExpr (tokenize "nofile" "let x = 3 in x+x")+ in case res of+ Left errs -> mapM_ putStrLn errs+ Right tree -> putStrLn $ show tree
+ examples/parser/Makefile view
@@ -0,0 +1,8 @@+test: Example.hs Scanner.hs+ ghc --make Example.hs -o test++Scanner.hs: Scanner.x+ alex -o Scanner.hs -g Scanner.x++clean:+ rm -f test Example.hi Example.o Scanner.hi Scanner.o Scanner.hs
+ examples/parser/README view
@@ -0,0 +1,65 @@+This example consists of two parts:+- Scanner.hs: generated with Alex from Scanner.x. Put your own regular+expressions for your scanner there, and see the "haskell blocks" to the+right of each regular expression for which functions to call to+construct the right tokens. The rest is reusable junk code.++- Example.hs: contains a parser for some basic expression language. I+only used BNF-parsers (sequential <*> and alternative <$>) here. There+are abstractions for EBNF-parsers, and actually, there is a huge amount+of even more abstractions, but for those I always have to look inside+the source files what their names are (bad bad bad documentation).++The idea is that if you have a production:++N -> S1 S2 S3 S4++That you write it down as:++pN :: TokenParser type+pN = function <$> pS1 <*> pS2 <*> pS3 <*> pS4++where the function gets values from parsing S1..S4 as parameters and+returns a value of the type you gave as parameter to TokenParser:++pN = (\v1 v2 v3 v4 -> ...) <$> pS1 <*> pS2 <*> pS3 <*> pS4++if you have more than one production for a nonterminal, then you can write:++pN = parser-alternative-1+ <|> parser-alternative-2+ <|> ...++Your parsers may be recursive, but they are not allowed to be left+recursive. A parser is left recursive when you call itself again without+having parsed a terminal first. For example, this one is recursive, but+only left-recursive if p can parse the empty string (but then it would+also be ambiguous because then you can't differentiate between p and pSucceed+[]):++pMany :: Parser a -> Parser [a]+pMany p+ = (\x xs -> x : xs) <$> p <*> pMany p+ <|> pSucceed []++In this case, pSucceed is a special parser which always succeeds and+yields it's parameter as semantic result. Similarly, you have pFail+which always fails (p <|> pFail === p).++Finally, you'll need parsers that can actually do some parsing, i.e.+parsers for terminals. Since your terminals in this case are tokens, you+basically need one for each token type:++For those tokens constructed with function "reserved":+pKey :: String -> TokenParser String++For those tokens constructed with function "valueToken TkVarid":+pVarid :: TokenParser String++and there are some others. If you want also the position of where these+tokens were parsed, then you can use:++pKeyPos :: String -> TokenParser Pos+pVaridPos :: TokenParser (String, Pos)++where data Pos = Pos Int Int String
+ examples/parser/Scanner.x view
@@ -0,0 +1,54 @@+{+-- alex scanner for use with uulib+-- compile with alex -o Scanner.hs -g Scanner.x+module Scanner(tokenize) where++import UU.Scanner+}++$litChar = [^[\" \\]]+$identChar = [a-zA-Z0-9\'_]+++tokens :-+ $white+ ; -- whitespace+ "--".* ; -- comment++ \" ($litChar | \\ \\ | \\ \" )* \" { valueToken TkString } -- string+ [0-9]+ { valueToken TkInteger16 } -- int+ + ( let | in ) { reserved } -- reserved keywords+ [\(\)\=] { reserved } -- reserved symbols+ [\+\*] { reserved } -- operators++ [a-zA-Z] $identChar* { valueToken TkVarid } -- identifier+++{+-- boilerplate code needed for Alex+type AlexInput = (Pos, String)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar = error "alexInputPrevChar: there is no need to go back in the input."++alexGetChar :: AlexInput -> Maybe (Char, AlexInput)+alexGetChar (_, []) = Nothing+alexGetChar (p, (c:cs))+ = let p' = adv p c+ in Just (c, (p', cs))++-- use the Alex scanner to generate a list of tokens for the uulib token parsers+tokenize :: String -> String -> [Token]+tokenize filename str+ = go (initpos, str)+ where+ initpos = Pos 1 1 filename+ + go inp@(pos, cs)+ = case alexScan inp 0 of+ AlexEOF -> []+ AlexError inp' -> valueToken TkError [head cs] pos : go inp'+ AlexSkip inp' _ -> go inp'+ AlexToken inp' len act -> act (take len cs) pos : go inp'+}+
src/UU/Parsing/CharParser.hs view
@@ -1,5 +1,5 @@ module UU.Parsing.CharParser where-+import GHC.Prim import UU.Parsing.Interface import UU.Scanner.Position @@ -9,7 +9,7 @@ instance Symbol Char where symBefore = pred symAfter = succ- deleteCost _ = 5+ deleteCost _ = 5# data Input = Input String !Pos @@ -28,12 +28,12 @@ splitState (Input inp pos) = case inp of ('\CR': xs) -> case xs of- ('\LF' : _ ) -> ('\CR', Input xs pos)- _ -> ('\CR', Input xs (newl pos))- ('\LF': xs) -> ( '\LF', Input xs (newl pos))+ ('\LF' : _ ) -> (# '\CR', Input xs pos #)+ _ -> (# '\CR', Input xs (newl pos) #)+ ('\LF': xs) -> (# '\LF', Input xs (newl pos) #) -- ('\n' : xs) -> ( '\n' , Input xs (newl pos)) -- \n already captured above- ('\t' : xs) -> ( '\t' , Input xs (tab pos))- (x : xs) -> ( x , Input xs (advc 1 pos))+ ('\t' : xs) -> (# '\t' , Input xs (tab pos) #)+ (x : xs) -> (# x , Input xs (advc 1 pos) #) getPosition (Input inp pos) = pos
src/UU/Parsing/Interface.hs view
@@ -5,6 +5,7 @@ , module UU.Parsing.Interface ) where +import GHC.Prim import UU.Parsing.Machine import UU.Parsing.MachineInterface --import IOExts@@ -66,11 +67,11 @@ -- | Parses a range of symbols with an associated cost and the symbol to -- insert if no symbol in the range is present. Returns the actual symbol -- parsed.- pCostRange :: Int{-#L-} -> s -> SymbolR s -> p s+ pCostRange :: Int# -> s -> SymbolR s -> p s -- | Parses a symbol with an associated cost and the symbol to insert if -- the symbol to parse isn't present. Returns either the symbol parsed or -- the symbol inserted.- pCostSym :: Int{-#L-} -> s -> s -> p s+ pCostSym :: Int# -> s -> s -> p s -- | Parses a symbol. Returns the symbol parsed. pSym :: s -> p s pRange :: s -> SymbolR s -> p s@@ -78,8 +79,8 @@ getfirsts :: p v -> Expecting s -- | Set the firsts set in the parser. setfirsts :: Expecting s -> p v -> p v- pSym a = pCostSym 5{-#L-} a a- pRange = pCostRange 5{-#L-}+ pSym a = pCostSym 5# a a+ pRange = pCostRange 5# -- | 'getzerop' returns @Nothing@ if the parser can not parse the empty -- string, and returns @Just p@ with @p@ a parser that parses the empty -- string and returns the appropriate value.@@ -120,7 +121,7 @@ instance InputState [s] s (Maybe s) where splitStateE [] = Right' [] splitStateE (s:ss) = Left' s ss- splitState (s:ss) = ({-#L-} s, ss{-L#-})+ splitState (s:ss) = (# s, ss #) getPosition [] = Nothing getPosition (s:ss) = Just s @@ -130,7 +131,7 @@ nextR acc = \ f ~(Pair a r) -> acc (f a) r pCost :: (OutputState out, InputState inp sym pos, Symbol sym, Ord sym) - => Int -> AnaParser inp out sym pos ()+ => Int# -> AnaParser inp out sym pos () pCost x = pMap f f' (pSucceed ()) where f acc inp steps = (inp, Cost x (val (uncurry acc) steps)) f' inp steps = (inp, Cost x steps)
src/UU/Parsing/Machine.hs view
@@ -1,4 +1,5 @@ module UU.Parsing.Machine where+import GHC.Prim import UU.Util.BinaryTrees import UU.Parsing.MachineInterface @@ -47,10 +48,10 @@ libAccept :: (OutputState a, InputState b s p) => ParsRec b a s p s libAccept = mkPR (P (\ acc k state -> case splitState state of- ({-#L-} s, ss {-L#-}) -> OkVal (acc s) (k ss))+ (# s, ss #) -> OkVal (acc s) (k ss)) ,R (\ k state -> case splitState state of- ({-#L-} s, ss {-L#-}) -> Ok (k ss))+ (# s, ss #) -> Ok (k ss)) ) libInsert c sym firsts =mkPR( P (\acc k state -> let msg = Msg firsts (getPosition state)@@ -155,9 +156,9 @@ libBest' (Ok ls) _ lf rf = OkVal lf ls libBest' _ (Ok rs) lf rf = OkVal rf rs libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf- | i =={-#L-} j = Cost i (libBest' ls rs lf rf)- | i <{-#L-} j = Cost i (val lf ls)- | i >{-#L-} j = Cost j (val rf rs)+ | i ==# j = Cost i (libBest' ls rs lf rf)+ | i <# j = Cost i (val lf ls)+ | i ># j = Cost j (val rf rs) libBest' l@(NoMoreSteps v) _ lf rf = NoMoreSteps (lf v) libBest' _ r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w) libBest' l@(Cost i ls) _ lf rf = Cost i (val lf ls)@@ -170,31 +171,31 @@ libCorrect :: Ord s => Steps a s p -> Steps c s p -> (a -> d) -> (c -> d) -> Steps d s p libCorrect ls rs lf rf = let (ToBeat _ choice) = traverse - (traverse (ToBeat 999{-#L-} (val lf newleft)) - (val lf, newleft, 0{-#L-}) 4{-#L-})- (val rf, newright, 0{-#L-}) 4{-#L-} + (traverse (ToBeat 999# (val lf newleft)) + (val lf, newleft) 0# 4#)+ (val rf, newright) 0# 4# newleft = addexpecting (starting rs) ls newright = addexpecting (starting ls) rs in Best (val lf newleft) choice (val rf newright) -data ToBeat a = ToBeat Int{-#L-} a+data ToBeat a = ToBeat Int# a -traverse :: ToBeat (Steps a s p) -> (Steps v s p -> Steps a s p, Steps v s p, Int{-L#-}) -> Int{-L#-} -> ToBeat (Steps a s p)-traverse b@(ToBeat bv br) (f, s, v) 0{-#L-} = {- trace ("comparing " ++ show bv ++ " with " ++ show v ++ "\n") $ -}- if bv <={-#L-} v +traverse :: ToBeat (Steps a s p) -> (Steps v s p -> Steps a s p, Steps v s p) -> Int# -> Int# -> ToBeat (Steps a s p)+traverse b@(ToBeat bv br) (f, s) v 0# = {- trace ("comparing " ++ show bv ++ " with " ++ show v ++ "\n") $ -}+ if bv <=# v then b else ToBeat v (f s)-traverse b@(ToBeat bv br) (f, Ok l, v) n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.Ok , l, v - n + 4) (n -{-#L-} 1{-#L-})-traverse b@(ToBeat bv br) (f, OkVal w l, v) n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.OkVal w, l, v - n + 4) (n -{-#L-} 1{-#L-})-traverse b@(ToBeat bv br) (f, Cost i l, v) n = if i +{-#L-} v >={-#L-} bv +traverse b@(ToBeat bv br) (f, Ok l) v n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.Ok , l) (v -# n +# 4#) (n -# 1#)+traverse b@(ToBeat bv br) (f, OkVal w l) v n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.OkVal w, l) (v -# n +# 4#) (n -# 1#)+traverse b@(ToBeat bv br) (f, Cost i l) v n = if i +# v >=# bv then b - else traverse b (f.Cost i, l, i +{-#L-} v) n-traverse b@(ToBeat bv br) (f, Best l _ r, v) n = traverse (traverse b (f, l, v) n) (f, r, v) n-traverse b@(ToBeat bv br) (f, StRepair i msgs r, v) n = if i +{-#L-} v >={-#L-} bv then b - else traverse b (f.StRepair i msgs, r, i +{-#L-} v) (n -{-#L-} 1{-#L-})-traverse b@(ToBeat bv br) (f, t@(NoMoreSteps _), v) n = if bv <={-#L-} v then b else ToBeat v (f t)+ else traverse b (f.Cost i, l) (i +# v) n+traverse b@(ToBeat bv br) (f, Best l _ r) v n = traverse (traverse b (f, l) v n) (f, r) v n+traverse b@(ToBeat bv br) (f, StRepair i msgs r) v n = if i +# v >=# bv then b + else traverse b (f.StRepair i msgs, r) (i +# v) (n -# 1#)+traverse b@(ToBeat bv br) (f, t@(NoMoreSteps _)) v n = if bv <=# v then b else ToBeat v (f t) -- ======================================================================================= -- ===== DESCRIPTORS ===================================================================== -- =======================================================================================@@ -324,10 +325,10 @@ insertsyms = head [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ] correct k inp = case splitState inp of- ({-#L-} s, ss {-L#-}) -> let { msg = Msg firsts (getPosition inp) (Delete s)- ; newinp = deleteSymbol s (reportError msg ss)- }- in libCorrect (StRepair (deleteCost s) msg (result k newinp))+ (# s, ss #) -> let { msg = Msg firsts (getPosition inp) (Delete s)+ ; newinp = deleteSymbol s (reportError msg ss)+ }+ in libCorrect (StRepair (deleteCost s) msg (result k newinp)) (insertsyms k inp) id id result = if null tab then zerop else case zd of
src/UU/Parsing/MachineInterface.hs view
@@ -1,4 +1,7 @@++ module UU.Parsing.MachineInterface where+import GHC.Prim -- | The 'InputState' class contains the interface that the AnaParser -- parsers expect for the input. A minimal complete instance definition@@ -8,7 +11,7 @@ -- can be split off and 'Right'' if none can splitStateE :: state -> Either' state s -- | Splits the state in the first symbol and the remaining state- splitState :: state -> ({-#L-} s, state {-L#-})+ splitState :: state -> (# s, state #) -- | Gets the current position in the input getPosition :: state -> pos -- | Reports an error@@ -36,10 +39,10 @@ {-# INLINE nextR #-} class Symbol s where- deleteCost :: s -> Int{-#L-}+ deleteCost :: s -> Int# symBefore :: s -> s symAfter :: s -> s- deleteCost b = 5{-#L-}+ deleteCost b = 5# symBefore = error "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred" symAfter = error "You should have made your token type an instance of the Class Symbol. eg by defining symAfter = succ" @@ -52,8 +55,8 @@ data Steps val s p = forall a . OkVal (a -> val) (Steps a s p) | Ok { rest :: Steps val s p}- | Cost {costing::Int{-#L-} , rest :: Steps val s p}- | StRepair {costing::Int{-#L-}, m :: !(Message s p) , rest :: Steps val s p}+ | Cost {costing::Int# , rest :: Steps val s p}+ | StRepair {costing::Int# , m :: !(Message s p) , rest :: Steps val s p} | Best (Steps val s p) (Steps val s p) ( Steps val s p) | NoMoreSteps val data Action s = Insert s
src/UU/Parsing/Offside.hs view
@@ -12,6 +12,7 @@ , OffsideParser(..) ) where +import GHC.Prim import UU.Parsing.Interface import UU.Parsing.Machine import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep)@@ -75,6 +76,23 @@ -- L (t:ts) (m:ms) = }: (L (t:ts) ms) if m /= 0 and parse-error(t) (Note 5) -- L (t:ts) ms = t : (L ts ms) sameln tts ms = case splitStateE tts of+ Left' t ts ->+ let tail+ | isTrigger t = aftertrigger ts ms+ | isClose t = case ms of+ 0:rs -> layout ts rs+ _ -> layout ts ms++ | isOpen t = layout ts (0:ms)+ | otherwise = layout ts ms+ parseError = case ms of+ m:ms | m /= 0 -> Just (layout tts ms)+ _ -> Nothing+ in Off pos (Cons (Symbol t) tail) parseError+ Right' rest -> endofinput pos rest ms+ where pos = getPosition tts+{-+ sameln tts ms = case splitStateE tts of Left' t ts | isTrigger t -> cons pos (Symbol t) (aftertrigger ts ms) | isClose t -> cons pos (Symbol t) (case ms of@@ -88,6 +106,7 @@ in Off pos (Cons (Symbol t) (layout ts ms)) parseError Right' rest -> endofinput pos rest ms where pos = getPosition tts +-} -- L [] [] = [] -- L [] (m:ms) = } : L [] ms if m /=0 (Note 6) @@ -108,16 +127,16 @@ _ -> Right' inp splitState (Off _ stream _) = case stream of- Cons s rest -> (s ,rest) + Cons s rest -> (# s ,rest #) getPosition (Off pos _ _ ) = pos instance Symbol s => Symbol (OffsideSymbol s) where deleteCost s = case s of Symbol s -> deleteCost s- SemiColon -> 5- OpenBrace -> 5- CloseBrace -> 5+ SemiColon -> 5#+ OpenBrace -> 5#+ CloseBrace -> 5# symBefore s = case s of Symbol s -> Symbol (symBefore s) SemiColon -> error "Symbol.symBefore SemiColon"@@ -170,7 +189,7 @@ pSeparator :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) => OffsideParser i o s p ()-pSeparator = OP (() <$ pCostSym 5 SemiColon SemiColon)+pSeparator = OP (() <$ pCostSym 5# SemiColon SemiColon) pClose, pOpen :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) => OffsideParser i o s p ()@@ -218,10 +237,18 @@ -> OffsideParser i o s p a -> OffsideParser i o s p [a] pBlock1 open sep close p = pOffside open close explicit implicit+ where elem = (:) <$> p `opt` id+ sep' = () <$ sep+ elems s = (:) <$ pList s <*> p <*> (($[]) <$> pFoldr1Sep ((.),id) s elem)+ explicit = elems sep'+ implicit = elems (sep' <|> pSeparator)+{-+pBlock1 open sep close p = pOffside open close explicit implicit where sep' = () <$ sep elems s = pList s *> pList1Sep (pList1 s) p <* pList s explicit = elems sep' implicit = elems (sep' <|> pSeparator)+-} parseOffside :: (Symbol s, InputState i s p, Position p) => OffsideParser i Pair s p a
src/UU/Parsing/StateParser.hs view
@@ -1,4 +1,5 @@ module UU.Parsing.StateParser(StateParser(..)) where+import GHC.Prim import UU.Parsing.MachineInterface import UU.Parsing.Machine(AnaParser, ParsRec(..),RealParser(..),RealRecogn(..), mkPR, anaDynE) @@ -7,7 +8,7 @@ Left' x xs -> Left' x (xs, st) Right' xs -> Right' (xs, st) splitState (inp, st) = case splitState inp of- (x,xs) -> (x, (xs, st))+ (# x,xs #) -> (# x, (xs, st) #) getPosition (inp, _) = getPosition inp class StateParser p st | p -> st where
src/UU/Scanner/GenTokenParser.hs view
@@ -1,12 +1,12 @@ module UU.Scanner.GenTokenParser where-+import GHC.Prim import UU.Parsing.Interface(IsParser(pCostSym, pSym, (<$>))) import UU.Scanner.GenToken(GenToken(..)) import UU.Scanner.Position(Pos, noPos) pCostReserved' :: IsParser p (GenToken key tp val) - => Int -> key -> p (GenToken key tp val)+ => Int# -> key -> p (GenToken key tp val) pCostReserved' c key = let tok = Reserved key noPos in pCostSym c tok tok @@ -16,7 +16,7 @@ in pSym tok pCostValToken' :: IsParser p (GenToken key tp val) - => Int -> tp -> val -> p (GenToken key tp val)+ => Int# -> tp -> val -> p (GenToken key tp val) pCostValToken' c tp val = let tok = ValToken tp val noPos in pCostSym c tok tok @@ -27,14 +27,14 @@ pCostReserved :: IsParser p (GenToken key tp val) - => Int -> key -> p Pos+ => Int# -> key -> p Pos pCostReserved c key = let getPos x = case x of Reserved _ p -> p ValToken _ _ p -> p in getPos <$> pCostReserved' c key pCostValToken :: IsParser p (GenToken key tp val) - => Int -> tp -> val -> p (val,Pos)+ => Int# -> tp -> val -> p (val,Pos) pCostValToken c tp val = let getVal x = case x of ValToken _ v p -> (v,p) _ -> error "pValToken: cannot get value of Reserved"@@ -42,11 +42,11 @@ pReserved :: IsParser p (GenToken key tp val) => key -> p Pos-pReserved = pCostReserved 5 +pReserved = pCostReserved 5# pValToken :: IsParser p (GenToken key tp val) => tp -> val -> p (val,Pos)-pValToken = pCostValToken 5+pValToken = pCostValToken 5# pValTokenNoPos :: IsParser p (GenToken key tp val) => tp -> val -> p val
src/UU/Scanner/GenTokenSymbol.hs view
@@ -1,8 +1,8 @@ module UU.Scanner.GenTokenSymbol() where-+import GHC.Prim import UU.Scanner.GenToken(GenToken(..)) import UU.Parsing.MachineInterface(Symbol(..)) instance Symbol (GenToken key tp val) where- deleteCost (Reserved _ _) = 5- deleteCost _ = 5+ deleteCost (Reserved _ _) = 5#+ deleteCost _ = 5#
uulib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.1 build-type: Simple name: uulib-version: 0.9.5+version: 0.9.7 license: LGPL license-file: COPYRIGHT maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -11,7 +11,7 @@ category: Parsing stability: Stable copyright: Universiteit Utrecht-build-depends: base, haskell98+build-depends: base, haskell98, ghc-prim exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived UU.Parsing.Interface UU.Parsing.MachineInterface UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms@@ -28,4 +28,9 @@ UU.DData.IntSet extensions: RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification hs-source-dirs: src-extra-source-files: README, LICENSE-LGPL+extra-source-files: README, LICENSE-LGPL,+ examples/bibtex/Bibtex.hs,+ examples/parser/Example.hs,+ examples/parser/Makefile,+ examples/parser/README,+ examples/parser/Scanner.x