uulib-0.9.24/0000755000000000000000000000000013431353253011116 5ustar0000000000000000uulib-0.9.24/Setup.hs0000644000000000000000000000010013431353253012541 0ustar0000000000000000module Main where import Distribution.Simple main = defaultMain uulib-0.9.24/CHANGELOG0000644000000000000000000000111613431353253012327 0ustar0000000000000000uulib Changelog =============== ### 0.9.24 * Applied patch hiding (<>) from Prelude * Patch made dependent on ghc 8.0 * Removed warning in Derived w.r.t. type sig ### 0.9.23 * Applied patch for ghc 8.2 compatibility ### 0.9.22 * Applied patch for removing import hide of Prelude(join) ### 0.9.20 * Make sure Changelog is included in cabal package/hackage. ### 0.9.19 * Refactor of IsParser into Applicative, Functor, and Alternative. No need to hide the previously duplicate interface anymore. ### 0.9.18 * Add changelog, update cabal metadata ### 0.9.17 * GHC 7.10 support (by asr) uulib-0.9.24/uulib.cabal0000644000000000000000000000341113431353253013221 0ustar0000000000000000name: uulib version: 0.9.24 license: BSD3 license-file: COPYRIGHT maintainer: UU Computer Science homepage: https://github.com/UU-ComputerScience/uulib bug-reports: https://github.com/UU-ComputerScience/uulib/issues description: Fast Parser Combinators and Pretty Printing Combinators synopsis: Haskell Utrecht Tools Library category: Parsing stability: Stable copyright: Universiteit Utrecht cabal-version: >= 1.6 build-type: Simple extra-source-files: README.md, CHANGELOG, examples/bibtex/Bibtex.hs, examples/parser/Example.hs, examples/parser/Makefile, examples/parser/README, examples/parser/Scanner.x source-repository head type: git location: https://github.com/UU-ComputerScience/uulib.git library build-depends: base>=4 && <5, ghc-prim >= 0.2.0.0 exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived UU.Parsing.Interface UU.Parsing.MachineInterface UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms UU.Parsing.StateParser UU.Parsing UU.PPrint UU.Pretty.Ext UU.Pretty UU.Scanner.GenToken UU.Scanner.GenTokenOrd UU.Scanner.GenTokenParser UU.Scanner.GenTokenSymbol UU.Scanner.Position UU.Scanner.Scanner UU.Scanner.Token UU.Scanner.TokenParser UU.Scanner.TokenShow UU.Scanner UU.Util.BinaryTrees UU.Util.PermTree UU.Util.Utils UU.Pretty.Basic UU.Parsing.Machine extensions: RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification hs-source-dirs: src uulib-0.9.24/README.md0000644000000000000000000000041713431353253012377 0ustar0000000000000000[![Build Status](https://travis-ci.org/UU-ComputerScience/uulib.svg?branch=master)](https://travis-ci.org/UU-ComputerScience/uulib) uulib ===== This is a conventional cabal package and can be installed accordingly. See also http://foswiki.cs.uu.nl/foswiki/HUT/WebHome uulib-0.9.24/COPYRIGHT0000644000000000000000000000270213431353253012412 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. uulib-0.9.24/examples/0000755000000000000000000000000013431353253012734 5ustar0000000000000000uulib-0.9.24/examples/parser/0000755000000000000000000000000013431353253014230 5ustar0000000000000000uulib-0.9.24/examples/parser/Scanner.x0000644000000000000000000000374513431353253016023 0ustar0000000000000000{ -- alex scanner for use with uulib -- compile with alex -o Scanner.hs -g Scanner.x module Scanner(tokenize) where import UU.Scanner import Data.Word (Word8) } $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." -- In Alex3 alexGetByte must be defined. alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte (_, []) = Nothing alexGetByte (p, (c:cs)) = let p' = adv p c in Just ((fromIntegral $ ord c), (p', cs)) 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' } uulib-0.9.24/examples/parser/Example.hs0000644000000000000000000000415613431353253016165 0ustar0000000000000000module 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 | Add pExpr :: TokenParser Expr pExpr = (\_ x _ e _ b -> Let x e b) <$> pKey "let" <*> pVarid <*> pKey "=" <*> pExpr <*> pKey "in" <*> pExpr <|> pAdd -- Add -> Factor | Factor + Expr pAdd :: TokenParser Expr pAdd = pFactor <|> (\l _ r -> Plus l r) <$> pFactor <*> pKey "+" <*> pExpr -- Factor -> Term | Term * Factor pFactor :: TokenParser Expr pFactor = pTerm <|> (\l _ r -> Times 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*y+z") in case res of Left errs -> mapM_ putStrLn errs Right tree -> putStrLn $ show tree uulib-0.9.24/examples/parser/Makefile0000644000000000000000000000027413431353253015673 0ustar0000000000000000test: 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 uulib-0.9.24/examples/parser/README0000644000000000000000000000453713431353253015121 0ustar0000000000000000This 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 uulib-0.9.24/examples/bibtex/0000755000000000000000000000000013431353253014211 5ustar0000000000000000uulib-0.9.24/examples/bibtex/Bibtex.hs0000644000000000000000000001316313431353253015766 0ustar0000000000000000{-# 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 Data.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] uulib-0.9.24/src/0000755000000000000000000000000013431353253011705 5ustar0000000000000000uulib-0.9.24/src/UU/0000755000000000000000000000000013431353253012236 5ustar0000000000000000uulib-0.9.24/src/UU/Pretty.hs0000644000000000000000000000016413431353253014062 0ustar0000000000000000module UU.Pretty(module UU.Pretty.Basic, module UU.Pretty.Ext ) where import UU.Pretty.Basic import UU.Pretty.Ext uulib-0.9.24/src/UU/PPrint.hs0000644000000000000000000003155413431353253014016 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- {-| Module : PPrint Copyright : (c) Daan Leijen 2000, Version : $version: $ Maintainer : daan@cs.uu.nl Stability : provisional Portability : portable Pretty print library based on Philip Wadlers "prettier printer" "A prettier printer" Draft paper, April 1997, revised March 1998. Haskell98 compatible -} --------------------------------------------------------------------------------- module UU.PPrint ( Doc , Pretty, pretty , show, putDoc, hPutDoc , (<>) , (<+>) , (), () , (<$>), (<$$>) , sep, fillSep, hsep, vsep , cat, fillCat, hcat, vcat , punctuate , align, hang, indent , fill, fillBreak , list, tupled, semiBraces, encloseSep , angles, langle, rangle , parens, lparen, rparen , braces, lbrace, rbrace , brackets, lbracket, rbracket , dquotes, dquote, squotes, squote , comma, space, dot, backslash , semi, colon, equals , string, bool, int, integer, float, double, rational , softline, softbreak , empty, char, text, line, linebreak, nest, group , column, nesting, width , SimpleDoc(..) , renderPretty, renderCompact , displayS, displayIO ) where import System.IO (Handle,hPutStr,hPutChar,stdout) #if __GLASGOW_HASKELL__ >= 800 import Prelude hiding ((<$>),(<>)) #elif __GLASGOW_HASKELL__ >= 710 import Prelude hiding ((<$>)) #endif infixr 5 ,,<$>,<$$> infixr 6 <>,<+> ----------------------------------------------------------- -- list, tupled and semiBraces pretty print a list of -- documents either horizontally or vertically aligned. ----------------------------------------------------------- list = encloseSep lbracket rbracket comma tupled = encloseSep lparen rparen comma semiBraces = encloseSep lbrace rbrace semi encloseSep left right sep ds = case ds of [] -> left <> right [d] -> left <> d <> right _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) ----------------------------------------------------------- -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] ----------------------------------------------------------- punctuate p [] = [] punctuate p [d] = [d] punctuate p (d:ds) = (d <> p) : punctuate p ds ----------------------------------------------------------- -- high-level combinators ----------------------------------------------------------- sep = group . vsep fillSep = fold () hsep = fold (<+>) vsep = fold (<$>) cat = group . vcat fillCat = fold () hcat = fold (<>) vcat = fold (<$$>) fold f [] = empty fold f ds = foldr1 f ds x <> y = x `beside` y x <+> y = x <> space <> y x y = x <> softline <> y x y = x <> softbreak <> y x <$> y = x <> line <> y x <$$> y = x <> linebreak <> y softline = group line softbreak = group linebreak squotes = enclose squote squote dquotes = enclose dquote dquote braces = enclose lbrace rbrace parens = enclose lparen rparen angles = enclose langle rangle brackets = enclose lbracket rbracket enclose l r x = l <> x <> r lparen = char '(' rparen = char ')' langle = char '<' rangle = char '>' lbrace = char '{' rbrace = char '}' lbracket = char '[' rbracket = char ']' squote = char '\'' dquote = char '"' semi = char ';' colon = char ':' comma = char ',' space = char ' ' dot = char '.' backslash = char '\\' equals = char '=' ----------------------------------------------------------- -- Combinators for prelude types ----------------------------------------------------------- -- string is like "text" but replaces '\n' by "line" string "" = empty string ('\n':s) = line <> string s string s = case (span (/='\n') s) of (xs,ys) -> text xs <> string ys bool :: Bool -> Doc bool b = text (show b) int :: Int -> Doc int i = text (show i) integer :: Integer -> Doc integer i = text (show i) float :: Float -> Doc float f = text (show f) double :: Double -> Doc double d = text (show d) rational :: Rational -> Doc rational r = text (show r) ----------------------------------------------------------- -- overloading "pretty" ----------------------------------------------------------- class Pretty a where pretty :: a -> Doc prettyList :: [a] -> Doc prettyList = list . map pretty instance Pretty a => Pretty [a] where pretty = prettyList instance Pretty Doc where pretty = id instance Pretty () where pretty () = text "()" instance Pretty Bool where pretty b = bool b instance Pretty Char where pretty c = char c prettyList s = string s instance Pretty Int where pretty i = int i instance Pretty Integer where pretty i = integer i instance Pretty Float where pretty f = float f instance Pretty Double where pretty d = double d --instance Pretty Rational where -- pretty r = rational r instance (Pretty a,Pretty b) => Pretty (a,b) where pretty (x,y) = tupled [pretty x, pretty y] instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where pretty (x,y,z)= tupled [pretty x, pretty y, pretty z] instance Pretty a => Pretty (Maybe a) where pretty Nothing = empty pretty (Just x) = pretty x ----------------------------------------------------------- -- semi primitive: fill and fillBreak ----------------------------------------------------------- fillBreak f x = width x (\w -> if (w > f) then nest f linebreak else text (spaces (f - w))) fill f d = width d (\w -> if (w >= f) then empty else text (spaces (f - w))) width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) ----------------------------------------------------------- -- semi primitive: Alignment and indentation ----------------------------------------------------------- indent i d = hang i (text (spaces i) <> d) hang i d = align (nest i d) align d = column (\k -> nesting (\i -> nest (k - i) d)) --nesting might be negative :-) ----------------------------------------------------------- -- Primitives ----------------------------------------------------------- data Doc = Empty | Char Char -- invariant: char is not '\n' | Text !Int String -- invariant: text doesn't contain '\n' | Line !Bool -- True <=> when undone by group, do not insert a space | Cat Doc Doc | Nest !Int Doc | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc | Column (Int -> Doc) | Nesting (Int -> Doc) data SimpleDoc = SEmpty | SChar Char SimpleDoc | SText !Int String SimpleDoc | SLine !Int SimpleDoc empty = Empty char '\n' = line char c = Char c text "" = Empty text s = Text (length s) s line = Line False linebreak = Line True beside x y = Cat x y nest i x = Nest i x column f = Column f nesting f = Nesting f group x = Union (flatten x) x flatten :: Doc -> Doc flatten (Cat x y) = Cat (flatten x) (flatten y) flatten (Nest i x) = Nest i (flatten x) flatten (Line break) = if break then Empty else Text 1 " " flatten (Union x y) = flatten x flatten (Column f) = Column (flatten . f) flatten (Nesting f) = Nesting (flatten . f) flatten other = other --Empty,Char,Text ----------------------------------------------------------- -- Renderers ----------------------------------------------------------- ----------------------------------------------------------- -- renderPretty: the default pretty printing algorithm ----------------------------------------------------------- -- list of indentation/document pairs; saves an indirection over [(Int,Doc)] data Docs = Nil | Cons !Int Doc Docs renderPretty :: Float -> Int -> Doc -> SimpleDoc renderPretty rfrac w x = best 0 0 (Cons 0 x Nil) where -- r :: the ribbon width in characters r = max 0 (min w (round (fromIntegral w * rfrac))) -- best :: n = indentation of current line -- k = current column -- (ie. (k >= n) && (k - n == count of inserted characters) best n k Nil = SEmpty best n k (Cons i d ds) = case d of Empty -> best n k ds Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds)) Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds)) Line _ -> SLine i (best i i ds) Cat x y -> best n k (Cons i x (Cons i y ds)) Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds)) Union x y -> nicest n k (best n k (Cons i x ds)) (best n k (Cons i y ds)) Column f -> best n k (Cons i (f k) ds) Nesting f -> best n k (Cons i (f i) ds) --nicest :: r = ribbon width, w = page width, -- n = indentation of current line, k = current column -- x and y, the (simple) documents to chose from. -- precondition: first lines of x are longer than the first lines of y. nicest n k x y | fits width x = x | otherwise = y where width = min (w - k) (r - k + n) fits w x | w < 0 = False fits w SEmpty = True fits w (SChar c x) = fits (w - 1) x fits w (SText l s x) = fits (w - l) x fits w (SLine i x) = True ----------------------------------------------------------- -- renderCompact: renders documents without indentation -- fast and fewer characters output, good for machines ----------------------------------------------------------- renderCompact :: Doc -> SimpleDoc renderCompact x = scan 0 [x] where scan k [] = SEmpty scan k (d:ds) = case d of Empty -> scan k ds Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) Line _ -> SLine 0 (scan 0 ds) Cat x y -> scan k (x:y:ds) Nest j x -> scan k (x:ds) Union x y -> scan k (y:ds) Column f -> scan k (f k:ds) Nesting f -> scan k (f 0:ds) ----------------------------------------------------------- -- Displayers: displayS and displayIO ----------------------------------------------------------- displayS :: SimpleDoc -> ShowS displayS SEmpty = id displayS (SChar c x) = showChar c . displayS x displayS (SText l s x) = showString s . displayS x displayS (SLine i x) = showString ('\n':indentation i) . displayS x displayIO :: Handle -> SimpleDoc -> IO () displayIO handle simpleDoc = display simpleDoc where display SEmpty = return () display (SChar c x) = do{ hPutChar handle c; display x} display (SText l s x) = do{ hPutStr handle s; display x} display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x} ----------------------------------------------------------- -- default pretty printers: show, putDoc and hPutDoc ----------------------------------------------------------- instance Show Doc where showsPrec d doc = displayS (renderPretty 0.4 80 doc) putDoc :: Doc -> IO () putDoc doc = hPutDoc stdout doc hPutDoc :: Handle -> Doc -> IO () hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc) ----------------------------------------------------------- -- insert spaces -- "indentation" used to insert tabs but tabs seem to cause -- more trouble than they solve :-) ----------------------------------------------------------- spaces n | n <= 0 = "" | otherwise = replicate n ' ' indentation n = spaces n --indentation n | n >= 8 = '\t' : indentation (n-8) -- | otherwise = spaces n uulib-0.9.24/src/UU/Parsing.hs0000644000000000000000000000145613431353253014203 0ustar0000000000000000module UU.Parsing( module UU.Parsing.Derived , module UU.Parsing.Interface , parseIO ) where import UU.Parsing.Derived import UU.Parsing.Interface parseIO :: (Eq s, Show s, Symbol s) => Parser s a -> [s] -> IO a parseIO = parseIOMessage showMessage where 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" uulib-0.9.24/src/UU/Scanner.hs0000644000000000000000000000055713431353253014172 0ustar0000000000000000module UU.Scanner ( module UU.Scanner.Scanner , module UU.Scanner.Token , module UU.Scanner.TokenParser , module UU.Scanner.Position ) where import UU.Scanner.Scanner import UU.Scanner.Token import UU.Scanner.TokenParser import UU.Scanner.Position -- instances import UU.Scanner.TokenShow() import UU.Scanner.GenTokenOrd() import UU.Scanner.GenTokenSymbol() uulib-0.9.24/src/UU/Util/0000755000000000000000000000000013431353253013153 5ustar0000000000000000uulib-0.9.24/src/UU/Util/Utils.hs0000644000000000000000000000046113431353253014610 0ustar0000000000000000module UU.Util.Utils where newtype Id x = Id x cross :: (a->c) -> (b->d) -> (a,b) -> (c,d) cross f g (x,y) = (f x, g y) split :: (a->b) -> (a->c) -> a -> (b,c) split f g x = (f x,g x) fst3 :: (a,b,c) -> a fst3 (a,_,_) = a snd3 :: (a,b,c) -> b snd3 (_,b,_) = b thd3 :: (a,b,c) -> c thd3 (_,_,c) = c uulib-0.9.24/src/UU/Util/PermTree.hs0000644000000000000000000000371313431353253015236 0ustar0000000000000000module UU.Util.PermTree where import Control.Monad(ap,liftM2) ------------------------------------------------------------------------------------ -- data type for permutation trees ------------------------------------------------------------------------------------ data Perms p a = Choice (Maybe a) [Branch p a] data Branch p a = forall x . Br (p x) (Perms p (x->a)) ------------------------------------------------------------------------------------ -- definition of fmap on permutation trees ------------------------------------------------------------------------------------ instance Functor (Perms p) where fmap f (Choice e bs) = Choice (fmap f e) (map (fmap f) bs) instance Functor (Branch p) where fmap f (Br p ps) = Br p (fmap (f.) ps) ------------------------------------------------------------------------------------ -- add single parser to permutation tree ------------------------------------------------------------------------------------ {- ap :: Maybe (a->b)-> Maybe a -> Maybe b ap (Just f) (Just x) = Just (f x) ap _ _ = Nothing -} add :: Maybe a -> p a -> Perms p (a->b) -> Perms p b add da pa tab@(Choice dab bsab) = let empty = dab `ap` da insert (Br px txab) = Br px (add da pa (fmap flip txab)) in Choice empty (Br pa tab:map insert bsab) ------------------------------------------------------------------------------------ -- permutation construction combinators ------------------------------------------------------------------------------------ empty :: a -> Perms p a empty x = Choice (Just x) [] (<$$>) :: (a->b) -> p a -> Perms p b f <$$> p = empty f <||> p (<$?>) :: (a->b) -> (a, p a) -> Perms p b f <$?> (e,p) = empty f <|?> (e,p) (<||>) :: Perms p (a->b) -> p a -> Perms p b ps <||> p = add Nothing p ps (<|?>) :: Perms p (a->b) -> (a, p a) -> Perms p b ps <|?> (e,p) = add (Just e) p ps uulib-0.9.24/src/UU/Util/BinaryTrees.hs0000644000000000000000000000464613431353253015750 0ustar0000000000000000{- Copyright: S. Doaitse Swierstra Department of Computer Science Utrecht University P.O. Box 80.089 3508 TB UTRECHT the Netherlands swierstra@cs.uu.nl -} module UU.Util.BinaryTrees ( BinSearchTree(..) , tab2tree , btFind , btLocateIn , btLookup ) where -- ======================================================================================= -- ===== BINARY SEARCH TREES ============================================================= -- ======================================================================================= data BinSearchTree av = Node (BinSearchTree av) av (BinSearchTree av) | Nil tab2tree :: [av] -> BinSearchTree av tab2tree tab = tree where (tree,[]) = sl2bst (length tab) (tab) sl2bst 0 list = (Nil , list) sl2bst n list = let ll = (n - 1) `div` 2 ; rl = n - 1 - ll (lt,a:list1) = sl2bst ll list (rt, list2) = sl2bst rl list1 in (Node lt a rt, list2) -- remember we compare the key value with the lookup value btFind :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c btFind = btLookup fst snd btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a -> b -> Maybe a btLocateIn = btLookup id id btLookup :: (a -> b) -> (a -> c) -> (b -> d -> Ordering) -> BinSearchTree a -> d -> Maybe c btLookup key val cmp (Node Nil kv Nil) = let comp = cmp (key kv) r = val kv in \i -> case comp i of LT -> Nothing EQ -> Just r GT -> Nothing btLookup key val cmp (Node left kv Nil) = let comp = cmp (key kv) findleft = btLookup key val cmp left r = val kv in \i -> case comp i of LT -> Nothing EQ -> Just r GT -> findleft i btLookup key val cmp (Node Nil kv right ) = let comp = cmp (key kv) findright = btLookup key val cmp right r = val kv in \i -> case comp i of LT -> findright i EQ -> Just r GT -> Nothing btLookup key val cmp (Node left kv right) = let comp = cmp (key kv) findleft = btLookup key val cmp left findright = btLookup key val cmp right r = val kv in \i -> case comp i of LT -> findright i EQ -> Just r GT -> findleft i btLookup _ _ _ Nil = \i -> Nothing uulib-0.9.24/src/UU/Pretty/0000755000000000000000000000000013431353253013525 5ustar0000000000000000uulib-0.9.24/src/UU/Pretty/Basic.hs0000644000000000000000000007756413431353253015125 0ustar0000000000000000-- $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Basic.hs,v 1.2 2003/02/26 11:18:27 uust Exp $ -- $Name: $ (version name) module UU.Pretty.Basic ( PP (..), PP_Doc, PP_Exp -- Single layout combinators , empty, text, indent, (>|<), (>-<), fill , fillblock -- Multiple layout combinators , (>//<), join, par, (>>$<) , eindent, (>>|<<), (>>-<<), (>>//<<), ejoin, (>>$<<) -- Displaying the result , render, renderAll, disp -- Additional generated combinators , c2e, element_h1, eelement_h1, vcenter, invisible -- Additional derived combinators , fpar, spar ) where {- Pretty-printers and pretty-printing combinators. Version 2.0d Authors: S. Doaitse Swierstra and Pablo R. Azero Date: July, 1999 -} -- ................................................................... -- ..... Interface definition ........................................ infixr 3 >|< , >>|<< infixr 2 >-< , >>-<< infixr 1 >//<, >>//<< infixr 0 >>$<, >>$<< -- ------------------------------------------------------------------- -- PP class ---------------------------------------------------------- newtype PP_Doc = PPDoc T_PPS class Show a => PP a where pp :: a -> PP_Doc pp = text . show ppList :: [a] -> PP_Doc ppList as = if null as then empty else foldr (>|<) empty . map pp $ as instance PP PP_Doc where pp = id instance PP Char where pp c = text [c] ppList = text instance PP a => PP [a] where pp = ppList instance Show PP_Doc where show p = disp p 200 "" -- ------------------------------------------------------------------- -- Single layout combinators ----------------------------------------- empty :: PP_Doc empty = PPDoc sem_PPS_Empty text :: String -> PP_Doc text = PPDoc . sem_PPS_Text indent :: PP a => Int -> a -> PP_Doc indent i fs = PPDoc (sem_PPS_Indent i nfs) where (PPDoc nfs) = pp fs (>|<) :: (PP a, PP b) => a -> b -> PP_Doc l >|< r = PPDoc (sem_PPS_Beside ppl ppr) where (PPDoc ppl) = pp l (PPDoc ppr) = pp r (>-<) :: (PP a, PP b) => a -> b -> PP_Doc u >-< l = PPDoc (sem_PPS_Above ppu ppl) where (PPDoc ppu) = pp u (PPDoc ppl) = pp l fill :: PP a => [a] -> PP_Doc fill = PPDoc . sem_PPS_Fill . foldr fill_alg sem_FillList_Nil where fill_alg f = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp) fillblock :: PP a => Int -> [a] -> PP_Doc fillblock i = PPDoc . sem_PPS_FillBlock i . foldr fill_alg sem_FillList_Nil where fill_alg f = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp) -- ------------------------------------------------------------------- -- Multiple layout combinators --------------------------------------- (>//<) :: (PP a, PP b) => a -> b -> PP_Doc a >//< b = PPDoc (sem_PPS_Dup ppa ppb) where (PPDoc ppa) = pp a (PPDoc ppb) = pp b join :: PP_Doc -> PP_Doc join (PPDoc d) = PPDoc . sem_PPS_Join $ d newtype PP_Exp = PPExp T_PPC eindent :: Int -> PP_Exp -> PP_Exp eindent i (PPExp ppc) = PPExp (sem_PPC_Indent i ppc) (>>|<<), (>>-<<), (>>//<<) :: PP_Exp -> PP_Exp -> PP_Exp (PPExp l) >>|<< (PPExp r) = PPExp (sem_PPC_Beside l r) (PPExp u) >>-<< (PPExp l) = PPExp (sem_PPC_Above u l) (PPExp a) >>//<< (PPExp b) = PPExp (sem_PPC_Dup a b) ejoin :: PP_Exp -> PP_Exp ejoin (PPExp dc) = PPExp . sem_PPC_Join $ dc par :: PP_Exp par = PPExp sem_PPC_Par (>>$<) :: PP a => PP_Exp -> [a] -> PP_Doc (PPExp e) >>$< pl = PPDoc . sem_PPS_Apply e . foldr ppslist sem_PPSArgs_Nil $ pl where ppslist p = sem_PPSArgs_Cons (case (pp p) of (PPDoc ppp) -> ppp) (>>$<<) :: PP_Exp -> [PP_Exp] -> PP_Exp (PPExp e) >>$<< pl = PPExp . sem_PPC_Apply e . foldr ppclist sem_PPCArgs_Nil $ pl where ppclist (PPExp p) = sem_PPCArgs_Cons p -- ------------------------------------------------------------------- -- Displaying the result --------------------------------------------- render, renderAll :: PP_Doc -> Int -> IO () render (PPDoc fs) = putStr . sem_Root_Best fs renderAll (PPDoc fs) = putStr . sem_Root_All fs disp :: PP_Doc -> Int -> ShowS disp (PPDoc fs) = sem_Disp_Disp fs -- ------------------------------------------------------------------- -- Additional generated combinators ---------------------------------- c2e :: PP a => a -> PP_Exp c2e s = let (PPDoc s') = pp s in PPExp . sem_PPC_Pps $ s' element_h1 :: PP_Doc -> PP_Doc element_h1 = \(PPDoc fs) -> PPDoc (sem_PPS_Filt fs) eelement_h1 :: PP_Exp -> PP_Exp eelement_h1 (PPExp pe) = PPExp . sem_PPC_Filt $ pe vcenter :: PP a => [ a ] -> PP_Doc vcenter = PPDoc . sem_PPS_Center . foldr center_alg sem_CenterList_Nil where center_alg f = sem_CenterList_Cons (case (pp f) of (PPDoc pf) -> pf) invisible :: PP_Doc -> PP_Doc invisible (PPDoc a) = PPDoc . sem_PPS_Inv $ a -- ------------------------------------------------------------------- -- Additional derived combinators ------------------------------------ fpar, spar :: PP_Exp fpar = plift first par spar = plift second par first fs = case fs of (TFormats fa _ ea _) -> (AFormat fa, ea ) (AFormat fa) -> (AFormat fa, False) second fs = case fs of (TFormats _ fb _ eb) -> (AFormat fb, eb ) (AFormat fb) -> (AFormat fb, False) -- Utilities lift :: (T_Formats -> T_Formats) -> PP_Doc -> PP_Doc lift f (PPDoc p) = PPDoc . sem_LiftS_Lift p $ f --elift :: (T_Formats -> T_Formats) -> T_PPC -> T_PPC elift f (PPExp e) = PPExp . sem_LiftC_Lift e $ f --plift :: (a -> b) -> T_PPC -> T_PPC plift f (PPExp e) = PPExp . sem_LiftC_Pair e $ f -- ................................................................... -- ..... Basic machinery ............................................. type Formats = [Format] {- Pretty-printer combinators with global page width -} type T_PW = Int type T_PLL = Int type T_PH = Int -- Width Width last line data T_Frame = F T_PW T_PLL deriving Eq instance Ord T_Frame where (F w _) <= (F w' _) = w <= w' max x@(F w _) y@(F w' _) | w > w' = x | otherwise = y empty_fmts ::Formats empty_fmts = [] text_fmts :: String -> Formats text_fmts s = [ s2fmt s ] indent_fmts :: T_Frame -> Int -> Formats -> Formats indent_fmts (F pw _) i = map (indent_fmt i) . dropWhile (notFits (pw - i)) notFits delta e = total_w e > delta beside_fmts :: T_Frame -> Formats -> Formats -> Formats beside_fmts (F pw _) left right = mergel [ map (l `beside_fmt`) . dropWhile (tooWide pw l) $ right | l <- left ] tooWide pw x y = (total_w x `max` (last_w x + total_w y)) > pw above_fmts :: Formats -> Formats -> Formats above_fmts [] ls = [] above_fmts us [] = [] above_fmts up@(upper:ru) low@(lower:rl) | utw >= ltw = firstelem : above_fmts ru low | utw < ltw = firstelem : above_fmts up rl where utw = total_w upper ltw = total_w lower firstelem = upper `above_fmt` lower {- Pretty-printing with error correction -} error_indent :: Int -> Formats -> Formats error_indent i = map (indent_fmt i) error_beside :: Formats -> Formats -> Formats error_beside left right = mergel [ map (l `beside_fmt`) right | l <- left ] -- ------------------------------------------------------------------- -- Formatting one layout --------------------------------------------- data Format = Elem { height :: T_PH , last_w :: T_PLL , total_w :: T_PW , txtstr :: Int -> String -> String } instance Eq Format where x == y = height x == height y && total_w x == total_w y && last_w x == last_w y instance Ord Format where x <= y = height x <= height y || ( height x == height y && total_w x <= total_w y ) x < y = height x < height y || ( height x == height y && total_w x < total_w y ) s2fmt :: String -> Format s2fmt s = Elem 1 l l (\_ -> (s++)) where l = length s indent_fmt :: Int -> Format -> Format indent_fmt i (Elem dh dl dw dt) = Elem dh (i + dl) (i + dw) (\n -> ((sp i) ++) . dt (i + n)) above_fmt, beside_fmt :: Format -> Format -> Format (Elem uh ul uw ut) `above_fmt` (Elem lh ll lw lt) = Elem (uh + lh) ll (uw `max` lw) (make_ts_above ut lt) where make_ts_above ut lt = \n -> let nl_skip = (('\n':sp n)++) in ut n . nl_skip . lt n (Elem lh ll lw lt) `beside_fmt` (Elem rh rl rw rt) = Elem (lh + rh - 1) (ll + rl) (lw `max` (ll + rw)) (\n -> lt n . rt (ll + n)) -- ------------------------------------------------------------------- -- Display the layout found ------------------------------------------ best fs = if null fs then "" else (txtstr . head $ fs) 0 "" allf = concatMap (\fmt -> (txtstr fmt) 0 "\n\n") dispf fs = if null fs then id else (txtstr . head $ fs) 0 -- ------------------------------------------------------------------- -- Utility functions ------------------------------------------------- merge [] ys = ys merge xs [] = xs merge xl@(x:xs) yl@(y:ys) | x == y = x : merge xs ys | x < y = x : merge xs yl | otherwise = y : merge xl ys spaces = ' ':spaces sp n = if n >= 0 then take n spaces else "" mergel :: Ord a => [[a]] -> [a] mergel = foldr merge [] -- ................................................................... -- ..... Generated code from Pretty.ag ............................... narrow_frame i (F s l) = F (s - i) (l - i) narrow_ll i (F s l) = F s (l - i) type T_Mins = [ (T_PW, T_PLL, T_PH) ] set_var_apply cond va vb = if cond then va else vb type T_Reqs = [ T_Frame ] type T_Fmts = [ T_Formats ] type T_Errs = [ T_Error ] beside_height lh rh = lh + rh - if (lh == 0 || rh == 0) then 0 else 1 cons_height pPh acth avail | acth == 0 = if pPh > 0 then 1 else 0 | otherwise = acth + if avail then 0 else 1 type T_Error = Bool data T_Formats = AFormat Formats | TFormats Formats Formats T_Error T_Error afmt_txt = AFormat . text_fmts set_fmts_empty = AFormat empty_fmts set_fmts_text string minw error = afmt_txt string --(if error then (asts minw) else string) set_fmts_indent int fmts pw minw frame error | int < 0 = afmt_txt "" -- int > pw = afmt_txt . asts $ minw | error = set_fmts_indent' error_indent | otherwise = set_fmts_indent' (indent_fmts frame) where set_fmts_indent' fmt_fc = case fmts of AFormat fs -> AFormat (fmt_fc int fs) TFormats as bs ae be -> TFormats (fmt_fc int as) (fmt_fc int bs) ae be set_fmts_beside ls rs lh rh frame err = set_fmts_ab ls rs set_fmts_beside' "" where set_fmts_beside' as bs = set_ab (lh == 0) (rh == 0) as bs (if err then error_beside else beside_fmts frame) set_fmts_above us ls uh lh = set_fmts_ab us ls set_fmts_above' "" where set_fmts_above' as bs = set_ab (uh == 0) (lh == 0) as bs above_fmts set_ab aempty bempty as bs fmt_fc = if aempty {- left operand empty? -} then bs else if bempty {- right operand empty? -} then as else fmt_fc as bs set_fmts_ab fs gs fmt_fc etxt = case fs of AFormat ffmts -> case gs of AFormat gfmts -> ( AFormat (fmt_fc ffmts gfmts), False ) TFormats as bs ae be -> ( TFormats (fmt_fc ffmts as) (fmt_fc ffmts bs) ae be , False ) TFormats as bs ae be -> case gs of AFormat gfmts -> ( TFormats (fmt_fc as gfmts) (fmt_fc bs gfmts) ae be , False ) otherwise -> ( afmt_txt etxt, True ) sem_fmts_dup afs bfs ae be minw = {-if (ae && be) then afmt_txt . asts $ minw else-} let get_fmts fs = case fs of AFormat as -> as TFormats _ _ _ _ -> text_fmts "" afmts = get_fmts afs bfmts = get_fmts bfs in TFormats afmts bfmts ae be set_fmts_join (TFormats as bs ae be) err = ( AFormat $ if be then (if null as then bs else as) else if ae then (if null bs then as else bs) else merge as bs , False ) set_fmts_join fs@(AFormat _) err = if err then (fs, err) else (afmt_txt "", True) set_fmts_apply True a _ = a set_fmts_apply False _ b = b set_fmts_fillblock int fmts | int < 0 = afmt_txt "" | otherwise = AFormat fmts set_error_msg numpars len = "" {- asts 0 = "" asts 1 = "*" asts s = '<' : replicate (s-2) '*' ++ ">" -} sem_fmts_cdup afs bfs ae be an bn minw em = if an /= bn then afmt_txt em else sem_fmts_dup afs bfs ae be minw set_error_msg' apars bpars = "" set_fmts_filllist ifmts nfmts ih nh frame avail = case nfmts of AFormat ns -> if ih == 0 {- left operand empty? -} then (ns, False) else if nh == 0 {- right operand empty? -} then (ifmts, False) else if nh <= 1 then ( choose_ab (beside_fmts frame) ifmts ns, False ) else ( choose_ab error_beside ifmts (text_fmts "") , True ) otherwise -> ( set_fmts_filllist' . text_fmts $ "" , True ) where set_fmts_filllist' fs = set_ab (ih == 0) (nh == 0) fs ifmts (choose_ab error_beside) choose_ab bsd_fc = if avail then bsd_fc else above_fmts set_fmts_render pw fs = if pw < 0 then text_fmts "" else case fs of AFormat fmts -> fmts otherwise -> text_fmts "" type T_Function = T_Formats -> T_Formats set_fmts_filt (AFormat fs ) minw = {-if null height1 then ( afmt_txt . asts $ minw , True ) else-} ( AFormat height1 , False ) where height1 = takeWhile ((<=1).height) fs set_fmts_filt _ _ = ( afmt_txt $ "", True ) set_fmts_inv fs = case fs of AFormat fmts -> AFormat . set_inv $ fmts TFormats as bs ae be -> TFormats (set_inv as) (set_inv bs) ae be where set_inv = (:[]) . (Elem 1 0 0) . txtstr . head type T_SynPPS = ( T_Formats, T_Error, T_PH, T_PLL, T_PW ) vapp fmts spaces pPS frame = sem_PPS_Above (\frame -> fmts) (sem_PPS_Indent spaces pPS) frame ---------------------- PPS ------------------------- -- semantic domains type T_PPS = T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW) -- funcs sem_PPS_Empty :: T_PPS sem_PPS_Empty lhs_frame = ( (set_fmts_empty), False, 0, (0), (0) ) sem_PPS_Text ::String -> T_PPS sem_PPS_Text string lhs_frame = let{ minw = (length string) ; error = (minw > pw) ; f@(F pw _ ) = (lhs_frame) }in ( (set_fmts_text string minw error), error, (1), (minw), minw ) sem_PPS_Indent ::Int -> T_PPS -> T_PPS sem_PPS_Indent int pPS lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (narrow_frame int lhs_frame) ; minw = (int + pPS_minw) ; f@(F pw _ ) = (lhs_frame) }in ( (set_fmts_indent int pPS_fmts pw minw lhs_frame pPS_error) , (or [int < 0, int > pw, pPS_error]) , pPS_maxh , (int + pPS_minll) , (minw) ) sem_PPS_Beside :: T_PPS -> T_PPS -> T_PPS sem_PPS_Beside left right lhs_frame = let{ ( left_fmts, left_error, left_maxh, left_minll, left_minw ) = left (narrow_ll right_minw lhs_frame) ; ( right_fmts, right_error, right_maxh, right_minll, right_minw ) = right (narrow_frame left_minll lhs_frame) ; error = (left_error || right_error) ; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error) }in ( (bfmts) , (error || berror) , (beside_height left_maxh right_maxh) , (left_minll + right_minll) , (left_minw `max` (left_minll + right_minw)) ) sem_PPS_Above :: T_PPS -> T_PPS -> T_PPS sem_PPS_Above upper lower lhs_frame = let{ ( upper_fmts, upper_error, upper_maxh, upper_minll, upper_minw ) = upper lhs_frame ; ( lower_fmts, lower_error, lower_maxh, lower_minll, lower_minw ) = lower lhs_frame ; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh) }in ( (afmts) , (or [lower_error, upper_error, aerror]) , upper_maxh + lower_maxh , (lower_minll) , (upper_minw `max` lower_minw) ) sem_PPS_Dup :: T_PPS -> T_PPS -> T_PPS sem_PPS_Dup opta optb lhs_frame = let{ ( opta_fmts, opta_error, opta_maxh, opta_minll, opta_minw ) = opta lhs_frame ; ( optb_fmts, optb_error, optb_maxh, optb_minll, optb_minw ) = optb lhs_frame ; minw = (opta_minw `min` optb_minw) ; error = (opta_error && optb_error) }in ( (sem_fmts_dup opta_fmts optb_fmts opta_error optb_error minw) , (error) , (opta_maxh `max` optb_maxh) , (opta_minll `min` optb_minll) , (minw) ) sem_PPS_Join :: T_PPS -> T_PPS sem_PPS_Join pPS lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame ; fe@(jfmts,jerror) = (set_fmts_join pPS_fmts pPS_error) }in ( (jfmts), (pPS_error || jerror), pPS_maxh, pPS_minll, pPS_minw ) sem_PPS_Apply :: T_PPC -> T_PPSArgs -> T_PPS sem_PPS_Apply pPC pPSArgs lhs_frame = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC (pPSArgs_error) (pPSArgs_fmts) lhs_frame (pPSArgs_mins) ; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs pPC_reqs ; error = (set_var_apply error_cond True pPC_error) ; error_cond = (pPC_numpars /= pPSArgs_len) ; lem = (length error_msg) ; error_msg = (set_error_msg pPC_numpars pPSArgs_len) }in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts) , (error) , (set_var_apply error_cond 1 pPC_maxh) , (set_var_apply error_cond lem pPC_minll) , (set_var_apply error_cond lem pPC_minw) ) sem_PPS_Fill :: T_FillList -> T_PPS sem_PPS_Fill fillList lhs_frame = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) = fillList (empty_fmts) (False) (0) (0) (0) (F w w) (w) ; f@(F w _ ) = (lhs_frame) }in ( (AFormat fillList_fmts), fillList_error, fillList_maxh, fillList_minll, fillList_minw ) sem_PPS_FillBlock ::Int -> T_FillList -> T_PPS sem_PPS_FillBlock int fillList lhs_frame = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) = fillList (empty_fmts) (False) (0) (0) (0) (f_frame) (f_width) ; f@(F w _ ) = (lhs_frame) ; f_width = (if int > w then w else int) ; f_frame = (if int > w then lhs_frame else (F int int)) ; error = (or [int < 0, fillList_error]) }in ( (set_fmts_fillblock int fillList_fmts), (error), fillList_maxh, fillList_minll, fillList_minw ) sem_PPS_Filt :: T_PPS -> T_PPS sem_PPS_Filt pPS lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame ; ef@(fmts,error) = (set_fmts_filt pPS_fmts pPS_minw) }in ( (fmts), (error || pPS_error), pPS_maxh, pPS_minll, pPS_minw ) sem_PPS_Inv :: T_PPS -> T_PPS sem_PPS_Inv pPS lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F maxBound maxBound) }in ( (set_fmts_inv pPS_fmts), (False), (1), (0), (0) ) sem_PPS_Center :: T_CenterList -> T_PPS sem_PPS_Center centerList lhs_frame = let{ ( centerList_maxw, centerList_fmts ) = centerList (centerList_maxw) (sem_PPS_Empty lhs_frame) lhs_frame ; clf@(fmts,error,maxh,minll,minw) = (centerList_fmts) }in ( (fmts), (error), (maxh), (minll), (minw) ) ---------------------- PPC ------------------------- -- semantic domains type T_PPC = T_Errs -> T_Fmts -> T_Frame -> T_Mins -> (T_Formats,T_Error,T_PH,T_Reqs,T_PLL ,T_PW,Int) -- funcs sem_PPC_Indent ::Int -> T_PPC -> T_PPC sem_PPC_Indent int pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC lhs_fillerrs lhs_fillfmts (narrow_frame int lhs_frame) lhs_fillmins ; minw = (int + pPC_minw) ; f@(F pw _ ) = (lhs_frame) }in ( (set_fmts_indent int pPC_fmts pw minw lhs_frame pPC_error) , (or [int < 0, int > pw, pPC_error]) , pPC_maxh , pPC_reqs , (int + pPC_minll) , (minw) , pPC_numpars ) sem_PPC_Beside :: T_PPC -> T_PPC -> T_PPC sem_PPC_Beside left right lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( left_fmts, left_error, left_maxh, left_reqs, left_minll, left_minw, left_numpars ) = left (les) (lfs) (narrow_ll right_minw lhs_frame) (lim) ; ( right_fmts, right_error, right_maxh, right_reqs, right_minll, right_minw, right_numpars ) = right (res) (rfs) (narrow_frame left_minll lhs_frame) (rim) ; i@(lim,rim) = (splitAt left_numpars lhs_fillmins) ; e@(les,res) = (splitAt left_numpars lhs_fillerrs) ; m@(lfs,rfs) = (splitAt left_numpars lhs_fillfmts) ; error = (left_error || right_error) ; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error) }in ( (bfmts) , (error || berror) , (beside_height left_maxh right_maxh) , left_reqs ++ right_reqs , (left_minll + right_minll) , (left_minw `max` (left_minll + right_minw)) , left_numpars + right_numpars ) sem_PPC_Above :: T_PPC -> T_PPC -> T_PPC sem_PPC_Above upper lower lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( upper_fmts, upper_error, upper_maxh, upper_reqs, upper_minll, upper_minw, upper_numpars ) = upper (ues) (ufs) lhs_frame (uim) ; ( lower_fmts, lower_error, lower_maxh, lower_reqs, lower_minll, lower_minw, lower_numpars ) = lower (les) (lfs) lhs_frame (lim) ; i@(uim,lim) = (splitAt upper_numpars lhs_fillmins) ; e@(ues,les) = (splitAt upper_numpars lhs_fillerrs) ; m@(ufs,lfs) = (splitAt upper_numpars lhs_fillfmts) ; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh) }in ( (afmts) , (or [lower_error, upper_error, aerror]) , (upper_maxh + lower_maxh) , upper_reqs ++ lower_reqs , lower_minll , (upper_minw `max` lower_minw) , upper_numpars + lower_numpars ) sem_PPC_Dup :: T_PPC -> T_PPC -> T_PPC sem_PPC_Dup opta optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( opta_fmts, opta_error, opta_maxh, opta_reqs, opta_minll, opta_minw, opta_numpars ) = opta lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins ; ( optb_fmts, optb_error, optb_maxh, optb_reqs, optb_minll, optb_minw, optb_numpars ) = optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins ; minw = (opta_minw `min` optb_minw) ; error = (or [opta_numpars /= optb_numpars, opta_error && optb_error]) ; error_msg = (set_error_msg' opta_numpars optb_numpars) }in ( (sem_fmts_cdup opta_fmts optb_fmts opta_error optb_error opta_numpars optb_numpars minw error_msg) , (error) , (opta_maxh `max` optb_maxh) , (zipWith max opta_reqs optb_reqs) , (opta_minll `min` optb_minll) , (minw) , (opta_numpars) ) sem_PPC_Join :: T_PPC -> T_PPC sem_PPC_Join pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins ; fe@(jfmts,jerror) = (set_fmts_join pPC_fmts pPC_error) }in ( (jfmts), (pPC_error || jerror), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) sem_PPC_Par :: T_PPC sem_PPC_Par lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ m@(minw,minll,maxh) = (head lhs_fillmins) ; error = (head lhs_fillerrs) ; fmts = (head lhs_fillfmts) }in ( fmts, error, maxh, ([lhs_frame]), minll, minw, 1 ) sem_PPC_Apply :: T_PPC -> T_PPCArgs -> T_PPC sem_PPC_Apply pPC pPCArgs lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC (pPCArgs_error) (pPCArgs_fmts) (lhs_frame) (pPCArgs_ofillmins) ; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len ) = pPCArgs (lhs_fillerrs) (lhs_fillfmts) (pPC_reqs) (lhs_fillmins) ; error = (set_var_apply error_cond True pPC_error) ; error_cond = (pPC_numpars /= pPCArgs_len) ; lem = (length error_msg) ; error_msg = (set_error_msg pPC_numpars pPCArgs_len) }in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts) , (error) , (set_var_apply error_cond 1 pPC_maxh) , (pPCArgs_reqs) , (set_var_apply error_cond lem pPC_minll) , (set_var_apply error_cond lem pPC_minw) , (pPCArgs_numpars) ) sem_PPC_Pps :: T_PPS -> T_PPC sem_PPC_Pps pPS lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame }in ( pPS_fmts, pPS_error, pPS_maxh, ([]), pPS_minll, pPS_minw, (0) ) sem_PPC_Filt :: T_PPC -> T_PPC sem_PPC_Filt pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins ; ef@(fmts,error) = (set_fmts_filt pPC_fmts pPC_minw) }in ( (fmts), (error || pPC_error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) ---------------------- PPSArgs ------------------------- -- semantic domains type T_PPSArgs = T_Reqs ->(T_Errs,T_Fmts,T_Mins,Int) -- funcs sem_PPSArgs_Nil :: T_PPSArgs sem_PPSArgs_Nil lhs_reqs = ( ([]), ([]), ([]), (0) ) sem_PPSArgs_Cons :: T_PPS -> T_PPSArgs -> T_PPSArgs sem_PPSArgs_Cons pPS pPSArgs lhs_reqs = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (head lhs_reqs) ; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs (tail lhs_reqs) }in ( (pPS_error:pPSArgs_error), (pPS_fmts:pPSArgs_fmts), ((pPS_minw ,pPS_minll, pPS_maxh):pPSArgs_mins), (pPSArgs_len + 1) ) ---------------------- PPCArgs ------------------------- -- semantic domains type T_PPCArgs = T_Errs -> T_Fmts -> T_Reqs -> T_Mins ->(T_Errs,T_Fmts,T_Reqs,T_Mins,Int,Int) -- funcs sem_PPCArgs_Nil :: T_PPCArgs sem_PPCArgs_Nil lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins = ( ([]), ([]), [], ([]), 0, (0) ) sem_PPCArgs_Cons :: T_PPC -> T_PPCArgs -> T_PPCArgs sem_PPCArgs_Cons pPC pPCArgs lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC (pef) (pff) (head lhs_ireqs) (pim) ; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len ) = pPCArgs (lef) (lff) (tail lhs_ireqs) (lim) ; i@(pim,lim) = (splitAt pPC_numpars lhs_ifillmins) ; e@(pef,lef) = (splitAt pPC_numpars lhs_ifillerrs) ; m@(pff,lff) = (splitAt pPC_numpars lhs_ifillfmts) }in ( (pPC_error:pPCArgs_error) , (pPC_fmts:pPCArgs_fmts) , pPC_reqs ++ pPCArgs_reqs , ((pPC_minw ,pPC_minll,pPC_maxh):pPCArgs_ofillmins) , pPC_numpars + pPCArgs_numpars , (pPCArgs_len + 1) ) ---------------------- FillList ------------------------- -- semantic domains type T_FillList = Formats -> T_Error -> T_PH -> T_PW -> T_PLL -> T_Frame -> T_PW ->(Formats,T_Error,T_PH,T_PW,T_PLL) -- funcs sem_FillList_Nil :: T_FillList sem_FillList_Nil lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw = ( lhs_fmts, lhs_error, lhs_maxh, lhs_minw, lhs_minll ) sem_FillList_Cons :: T_PPS -> T_FillList -> T_FillList sem_FillList_Cons pPS fillList lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame) ; ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) = fillList (ffmts) (lhs_error || ferror) (cons_height pPS_maxh lhs_maxh avail) (if (not avail) || (lhs_minw == lhs_pw) then lhs_pw else lhs_minll) (if ferror then lhs_pw + 1 else if avail then newll else pPS_minw) lhs_frame lhs_pw ; avail = (lhs_pw - newll >= 0) ; newll = (lhs_minll + pPS_minw) ; fe@(ffmts,ferror) = (set_fmts_filllist lhs_fmts pPS_fmts lhs_maxh pPS_maxh lhs_frame avail) }in ( fillList_fmts, (fillList_error || pPS_error), fillList_maxh, fillList_minw, fillList_minll ) ---------------------- Root ------------------------- -- semantic domains type T_Root = T_PW ->String -- funcs sem_Root_Best :: T_PPS -> T_Root sem_Root_Best pPS lhs_pw = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) }in (best . set_fmts_render lhs_pw $ pPS_fmts) sem_Root_All :: T_PPS -> T_Root sem_Root_All pPS lhs_pw = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) }in (allf . set_fmts_render lhs_pw $ pPS_fmts) ---------------------- Disp ------------------------- -- semantic domains type T_Disp = T_PW ->ShowS -- funcs sem_Disp_Disp :: T_PPS -> T_Disp sem_Disp_Disp pPS lhs_pw = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) }in (dispf . set_fmts_render lhs_pw $ pPS_fmts) ---------------------- LiftS ------------------------- -- semantic domains type T_LiftS = T_Function -> T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW) -- funcs sem_LiftS_Lift :: T_PPS -> T_LiftS sem_LiftS_Lift pPS lhs_f lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame }in ( (lhs_f pPS_fmts), pPS_error, pPS_maxh, pPS_minll, pPS_minw ) ---------------------- LiftC ------------------------- -- funcs sem_LiftC_Lift pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins }in ( (lhs_f pPC_fmts), pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) sem_LiftC_Pair pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins ; fe@(fmts,error) = (lhs_f pPC_fmts) }in ( (fmts), (pPC_error || error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) ---------------------- CenterList ------------------------- -- semantic domains type T_CenterList = Int -> T_SynPPS -> T_Frame ->(Int,T_SynPPS) -- funcs sem_CenterList_Nil :: T_CenterList sem_CenterList_Nil lhs_maxw lhs_fmts lhs_frame = ( (0), lhs_fmts ) sem_CenterList_Cons :: T_PPS -> T_CenterList -> T_CenterList sem_CenterList_Cons pPS centerList lhs_maxw lhs_fmts lhs_frame = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame) ; ( centerList_maxw, centerList_fmts ) = centerList lhs_maxw (vapp lhs_fmts spaces pPS lhs_frame) lhs_frame ; spaces = ((lhs_maxw - pPS_minw) `div` 2) }in ( (pPS_minw `max` centerList_maxw), centerList_fmts ) uulib-0.9.24/src/UU/Pretty/Ext.hs0000644000000000000000000001520013431353253014617 0ustar0000000000000000-- $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Ext.hs,v 1.1 2002/11/13 16:05:20 uust Exp $ -- $Name: $ (version name) module UU.Pretty.Ext ( -- Derived from single and multiple (>^<), (>>^<<), (>#<), (>>#<<), wide_text , vlist, hlist, hlist_sp, list_h1, hlist_h1 , (>|<<), (>-<<), (>>|<), (>>-<), pp_es -- Displaying the result , vdisp -- Printing brackets , pp_wrap, pp_quotes, pp_doubleQuotes , pp_parens, pp_brackets, pp_braces -- Printing structures , hv, hv_sp, pp_block, pp_ite , pp_list, pp_slist, pp_parens_list ) where {- Derived pretty-printing combinators. Version 2.0c Authors: S. Doaitse Swierstra and Pablo R. Azero Date: July, 1999 -} import UU.Pretty.Basic infixr 3 >#<, >>#<<, >>|<, >|<< infixr 2 >>-<, >-<< infixr 1 >^<, >>^<< -- ------------------------------------------------------------------- -- PP instances for often used simple data types --------------------- instance PP Int where pp = text . show instance PP Float where pp = text . show -- ------------------------------------------------------------------- -- Derived from single and multiple ---------------------------------- (>^<), (>#<) :: (PP a, PP b) => a -> b -> PP_Doc a >^< b = join (a >//< b) l >#< r = l >|< " " >|< r pp_es string = if null string then empty else pp string wide_text t s | ls > t = text s | otherwise = text . (if t >= 0 then take t else take 0) $ (s ++ spaces) where ls = length s spaces = repeat ' ' hlist, vlist, hlist_sp :: PP a => [a] -> PP_Doc vlist = foldr (>-<) empty hlist = foldr (>|<) empty hlist_sp = foldr (>#<) empty list_h1 :: [PP_Doc] -> [PP_Doc] list_h1 = map element_h1 hlist_h1 = foldr1 (>|<) . list_h1 (>>^<<), (>>#<<) :: PP_Exp -> PP_Exp -> PP_Exp a >>^<< b = ejoin (a >>//<< b) l >>#<< r = l >>|<< (" " >|<< r) (>|<<), (>-<<) :: PP a => a -> PP_Exp -> PP_Exp l >|<< r = c2e l >>|<< r u >-<< l = c2e u >>-<< l (>>|<), (>>-<) :: PP a => PP_Exp -> a -> PP_Exp l >>|< r = l >>|<< c2e r u >>-< l = u >>-<< c2e l -- ------------------------------------------------------------------- -- Displaying the result --------------------------------------------- vdisp :: Int -> [PP_Doc] -> ShowS vdisp pw = foldr (\f fs -> disp f pw . ("\n"++) . fs) id -- ------------------------------------------------------------------- -- Printing brackets ------------------------------------------------- pp_wrap :: PP a => a -> a -> PP_Doc -> PP_Doc pp_wrap op cl p = op >|< (p >|< cl) pp_quotes = pp_wrap '`' '\'' pp_doubleQuotes = pp_wrap '"' '"' pp_parens = pp_wrap '(' ')' pp_brackets = pp_wrap '[' ']' pp_braces = pp_wrap '{' '}' -- ------------------------------------------------------------------- -- Printing structures -- hv: display a list of elements either horizontally or vertically, -- 2 possible layouts: horizonal or vertical hv :: PP a => [a] -> PP_Doc hv = join . foldr onehv (empty >//< empty) . map pp where onehv p ps = eelement_h1 par >>|<< fpar >>//<< par >>-<< spar >>$< [p, ps] -- hv_sp: same as hv but inserts spaces between the elements -- 2 possible layouts: horizonal or vertical hv_sp :: PP a => [a] -> PP_Doc hv_sp l | null l = empty | otherwise = lhv_sp . map pp $ l lhv_sp fs@(f:fss) = hs >>^<< vs >>$< fs where (hs, vs) = foldr paralg (par, par) fss paralg = \_ (nhs,nvs) -> (eelement_h1 par >>#<< nhs, par >>-<< nvs) -- pp_block: printing of block structures with open, close and separator -- keywords -- 2 possible layouts: horizonal or vertical --pp_block :: String -> String -> String -> [PP_Doc] -> PP_Doc pp_block okw ckw sep fs | null fs = hv [open, close] | otherwise = join ( eelement_h1 par >>|<< fpar >>//<< par >>-<< spar >>$< [open >|< (indent (startcolumn-lk) . head $ fs), hvopts] ) where lk = length okw lsep = length sep startcolumn = (lk `max` lsep) hvopts = foldr hvoptalg dclose (tail fs) hvoptalg p ps = ( par >>|<< eelement_h1 par >>|<< fpar >>//<< par >>|<< eindent (startcolumn - lsep) par >>-<< spar ) >>$< [pp_es sep, p, ps] dclose = eindent (startcolumn-lk) par >>//<< par >>$< [close] open = pp_es okw close = pp_es ckw -- pp_ite: printing an if-then-else-fi statement -- three possible layouts: horizonal, vertical or mixed --pp_ite :: (PP a, PP b, PP c, PP d) -- => a -> b -> c -> d -> PP_Doc -> PP_Doc -> PP_Doc -> PP_Doc pp_ite kw_if kw_then kw_else kw_fi c t e = ( eelement_h1 ( par >>|<< par >>|<< par >>|<< par ) >>^<< ( ( ( par >>|<< par >>^<< par >>-<< par ) >>$<< [par, par >>-<< par] ) >>-<< par ) ) >>$< [ kw_if >|< c , kw_then >|< t , kw_else >|< e , pp kw_fi ] -- pp_slist: printing a list of elements in a "mini page", needs open, close and -- separator keywords and a "mini page" width -- one possible layout: depends on the page width given, when it reaches the end -- of the page it continues on the next line -- restrictions: only simple elements allowed (no pp_slists or flexible layouts -- in the list [PP_Doc]) pp_slist :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc pp_slist pw ol cl sep fl | null fl = hv [open, close] | otherwise = eelement_h1 (par >>|<< par) >>^<< (par >>-<< par) >>$< [nes, close] where nes = fillblock pw (open: ne: map (pp_es sep >|<) (tail fl)) ne = (replicate (if ws == 0 then 0 else ws - 1) ' ') >|< (head fl) ws = length sep open = pp_es ol close = pp_es cl -- pp_list: printing a list of elements in a "mini page", needs open, close and -- separator keywords and a "mini page" width -- one possible layout: depends on the page width given, when it reaches the end -- of the page it continues on the next line pp_list :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc pp_list pw ol cl _ [] = pp_es (ol ++ cl) pp_list pw ol cl sep (f:fs) = fillblock pw (pp ol: (pp f): (map (pp_es sep >|<) fs) ++ [ pp cl ]) -- pp_parens_list: idem pp_list, with parenthesis and comma separator pp_parens_list :: Int -> [PP_Doc] -> PP_Doc pp_parens_list mpw = pp_list mpw "(" ")" ", " uulib-0.9.24/src/UU/Parsing/0000755000000000000000000000000013431353253013641 5ustar0000000000000000uulib-0.9.24/src/UU/Parsing/Machine.hs0000644000000000000000000007171713431353253015556 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Parsing.Machine where #if __GLASGOW_HASKELL__ >= 710 import Prelude hiding ( traverse ) #endif import GHC.Prim #if __GLASGOW_HASKELL__ >= 708 import GHC.Types (isTrue#) #endif import UU.Util.BinaryTrees import UU.Parsing.MachineInterface pDynE v = anaDynE v pDynL v = anaDynL v -- ========================================================================================== -- ===== BASIC PARSER TYPE ================================================================= -- ======================================================================================= newtype RealParser state s p a = P(forall r' r'' . (a -> r'' -> r') -> (state -> Steps r'' s p) -> state -> Steps r' s p) newtype RealRecogn state s p = R(forall r . (state -> Steps r s p) -> state -> Steps r s p) newtype RealAccept state result s p a = A(forall r . (state -> Steps r s p) -> state -> Steps (result a r) s p) newtype ParsRec state result s p a = PR ( RealParser state s p a , RealRecogn state s p , RealAccept state result s p a ) mkPR (P p, R r) = PR (P p, R r, A (p acceptR)) {-# INLINE unP #-} {-# INLINE unR #-} unP (P p) = p unR (R p) = p parseRecbasic :: (inp -> Steps (out c d) sym pos) -> ParsRec inp out sym pos a -> inp -> Steps (out a (out c d)) sym pos parseRecbasic eof (PR ( P rp, rr, A ra)) inp = (ra eof inp) parsebasic :: (inp -> Steps (out c d) sym pos) -> AnaParser inp out sym pos a -> inp -> Steps (out a (out c d)) sym pos parsebasic eof (pp) inp = parseRecbasic eof (pars pp) inp -- ======================================================================================= -- ===== CORE PARSERS ==================================================================== -- ======================================================================================= libAccept :: (OutputState a, InputState b s p) => ParsRec b a s p s libAccept = mkPR (P (\ acc k state -> case splitState state of (# s, ss #) -> OkVal (acc s) (k ss)) ,R (\ k state -> case splitState state of (# s, ss #) -> Ok (k ss)) ) libInsert c sym firsts =mkPR( P (\acc k state -> let msg = Msg firsts (getPosition state) (Insert sym) in StRepair c msg (val (acc sym) (k (insertSymbol sym (reportError msg state))))) , R (\ k state -> let msg = Msg firsts (getPosition state) (Insert sym) in StRepair c msg (k (insertSymbol sym (reportError msg state)))) ) {- {-# INLINE libSeq #-} {-# INLINE libSeqL #-} {-# INLINE libSeqR #-} {-# INLINE libDollar #-} {-# INLINE libDollarL #-} {-# INLINE libDollarR #-} {-# INLINE libSucceed #-} -} libSucceed v =mkPR( P (\ acc -> let accv = val (acc v) in {-# SCC "machine" #-} \ k state -> accv (k state)) , R id ) libSeq (PR (P pp, R pr, _)) ~(PR (P qp, R qr, A qa)) =mkPR ( P (\ acc -> let p = pp (nextR acc) in {-# SCC "machine" #-} \k state -> p (qa k) state) , R ( pr.qr) ) libDollar f (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> {-# SCC "machine" #-} qp (acc.f)) , R qr ) libDollarL f (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> let accf = val (acc f) in {-# SCC "machine" #-} \ k state -> qr (\ inp -> accf ( k inp)) state) , R qr ) libDollarR f (PR (P qp, R qr, _ )) = mkPR (P qp, R qr) libSeqL (PR (P pp, R pr, _ )) ~(PR (P qp, R qr , _ )) = mkPR ( P (\acc -> let p = pp acc in {-# SCC "machine" #-}\k state -> p (qr k) state) , R (pr.qr) ) libSeqR (PR (P pp, R pr, _ )) ~(PR (P qp, R qr, _ )) = mkPR ( P (\acc -> let q = qp acc in {-# SCC "machine" #-}\k state -> pr (q k) state) , R (pr.qr) ) libOr (PR (P pp, R pr,_ )) (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> let p = pp acc q = qp acc in {-# SCC "machine" #-} \ k state -> p k state `libBest` q k state) , R (\ k state -> pr k state `libBest` qr k state) ) libFail :: OutputState a => ParsRec b a c p d libFail = mkPR ( P (\ _ _ _ -> (usererror "calling an always failing parser" )) , R (\ _ _ -> (usererror "calling an always failing recogniser")) ) starting :: Steps a s p -> Expecting s starting (StRepair _ m _ ) = getStart m starting (Best l _ _ ) = starting l starting _ = systemerror "UU.Parsing.Machine" "starting" {- {-# INLINE hasSuccess #-} -} hasSuccess :: Steps a s p -> Bool hasSuccess (StRepair _ _ _ ) = False hasSuccess (Best _ _ _ ) = False hasSuccess _ = True getStart (Msg st _ _) = st addToMessage (Msg exp pos act) more = Msg (more `eor` exp) pos act addexpecting more (StRepair cost msg rest) = StRepair cost (addToMessage msg more) rest addexpecting more (Best l sel r) = Best (addexpecting more l) (addexpecting more sel) (addexpecting more r) addexpecting more (OkVal v rest ) = systemerror "UU_Parsing" ("addexpecting: OkVal") addexpecting more (Ok _ ) = systemerror "UU_Parsing" ("addexpecting: Ok") addexpecting more (Cost _ _ ) = systemerror "UU_Parsing" ("addexpecting: Cost") addexpecting more _ = systemerror "UU_Parsing" ("addexpecting: other") eor :: Ord a => Expecting a -> Expecting a -> Expecting a eor p q = EOr (merge (tolist p) (tolist q)) where merge x@(l:ll) y@(r:rr) = case compare l r of LT -> l:( ll `merge` y) GT -> r:( x `merge` rr) EQ -> l:( ll `merge` rr) merge l [] = l merge [] r = r tolist (EOr l) = l tolist x = [x] -- ======================================================================================= -- ===== SELECTING THE BEST RESULT ====================================================== -- ======================================================================================= -- INV: the first argument should be the shorter insertion libBest :: Ord s => Steps b s p -> Steps b s p -> Steps b s p libBest ls rs = libBest' ls rs id id libBest' :: Ord s => Steps b s p -> Steps c s p -> (b -> d) -> (c -> d) -> Steps d s p libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w)) libBest' (OkVal v ls) (Ok rs) lf rf = Ok (libBest' ls rs (lf.v) rf ) libBest' (Ok ls) (OkVal w rs) lf rf = Ok (libBest' ls rs lf (rf.w)) libBest' (Ok ls) (Ok rs) lf rf = Ok (libBest' ls rs lf rf ) libBest' (OkVal v ls) _ lf rf = OkVal (lf.v) ls libBest' _ (OkVal w rs) lf rf = OkVal (rf.w) rs 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 | isTrue (i ==# j) = Cost i (libBest' ls rs lf rf) | isTrue (i <# j) = Cost i (val lf ls) | isTrue (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) libBest' _ r@(Cost j rs) lf rf = Cost j (val rf rs) libBest' l r lf rf = libCorrect l r lf rf -- Unboxed comparison changed in 7.8: https://ghc.haskell.org/trac/ghc/wiki/NewPrimopsInGHC7.8 #if __GLASGOW_HASKELL__ >= 708 isTrue = isTrue# #else isTrue = id #endif lib_correct :: Ord s => (b -> c -> Steps d s p) -> (b -> c -> Steps d s p) -> b -> c -> Steps d s p lib_correct p q = \k inp -> libCorrect (p k inp) ( q k inp) id id 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# (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# a 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 isTrue (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 -# 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 isTrue (i +# v >=# bv) then b 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 isTrue (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 isTrue (bv <=# v) then b else ToBeat v (f t) -- ======================================================================================= -- ===== DESCRIPTORS ===================================================================== -- ======================================================================================= data AnaParser state result s p a = AnaParser { pars :: ParsRec state result s p a , leng :: Nat , zerop :: Maybe (Bool, Either a (ParsRec state result s p a)) , onep :: OneDescr state result s p a } -- deriving Show data OneDescr state result s p a = OneDescr { firsts :: Expecting s , table :: [(SymbolR s, TableEntry state result s p a)] } -- deriving Show data TableEntry state result s p a = TableEntry (ParsRec state result s p a) (Expecting s -> ParsRec state result s p a) -- ======================================================================================= -- ===== ANALYSING COMBINATORS =========================================================== -- ======================================================================================= anaFail :: OutputState a => AnaParser b a c p d anaFail = AnaParser { pars = libFail , leng = Infinite , zerop = Nothing , onep = noOneParser } noOneParser = OneDescr (EOr []) [] pEmpty p zp = AnaParser { pars = p , leng = Zero , zerop = Just zp , onep = noOneParser } anaSucceed v = pEmpty (libSucceed v) (False, Left v) anaLow v = pEmpty (libSucceed v) (True, Left v) anaDynE p = pEmpty p (False, Right p) anaDynL p = pEmpty p (True , Right p) --anaDynN fi len range p = mkParser Nothing (OneDescr len fi [(range, p)]) anaOr ld@(AnaParser _ ll zl ol) rd@(AnaParser _ lr zr or) = mkParser newlength newZeroDescr newOneDescr where (newlength, maybeswap) = ll `nat_min` lr newZeroDescr = case zl of {Nothing -> zr ;_ -> case zr of {Nothing -> zl ;_ -> usererror ("Two empty alternatives") } } newOneDescr = maybeswap orOneOneDescr ol or False {- {-# INLINE anaSeq #-} -} anaSeq libdollar libseq comb (AnaParser pl ll zl ol) ~rd@(AnaParser pr lr zr or) = case zl of Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr libdollar libseq comb newOneDescr = let newOneOne = mapOnePars ( `libseq` pr) ol newZeroOne = case zp of Left f -> mapOnePars (f `libdollar` ) or Right p -> mapOnePars (p `libseq` ) or in orOneOneDescr newZeroOne newOneOne b -- left one is shortest in mkParser lr newZeroDescr newOneDescr _ -> AnaParser (pl `libseq` pr) (ll `nat_add` lr) Nothing (mapOnePars (`libseq` pr) ol) seqZeroZero Nothing _ _ _ _ = Nothing seqZeroZero _ Nothing _ _ _ = Nothing seqZeroZero (Just (llow, left)) (Just (rlow, right)) libdollar libseq comb = Just ( llow || rlow , case left of Left lv -> case right of Left rv -> Left (comb lv rv) Right rp -> Right (lv `libdollar` rp) Right lp -> case right of Left rv -> Right (lp `libseq` libSucceed rv) Right rp -> Right (lp `libseq` rp) ) orOneOneDescr ~(OneDescr fl tl) ~(OneDescr fr tr) b = let keystr = map fst tr lefttab = if b then [r | r@(k,_) <- tl, not (k `elem` keystr)] else tl in OneDescr (fl `eor` fr) (lefttab ++ tr) anaCostRange _ _ EmptyR = anaFail anaCostRange ins_cost ins_sym range = mkParser (Succ Zero) Nothing ( OneDescr (ESym range) [(range, TableEntry libAccept (libInsert ins_cost ins_sym) )]) --anaCostSym i ins sym = pCostRange i ins (Range sym sym) anaGetFirsts (AnaParser p l z od) = firsts od anaSetFirsts newexp (AnaParser _ l zd od) = mkParser l zd (od{firsts = newexp }) -- ======================================================================================= -- ===== UTILITIES ======================================================================== -- ======================================================================================= mapOnePars fp ~(OneDescr fi t) = OneDescr fi [ (k, TableEntry (fp p) (fp.corr)) | (k, TableEntry p corr ) <- t ] -- ======================================================================================= -- ===== MKPARSER ======================================================================== -- ======================================================================================= mkParser :: (InputState state s p, Symbol s, Ord s, OutputState result) => Nat -> Maybe (Bool, Either a (ParsRec state result s p a)) -> OneDescr state result s p a -> AnaParser state result s p a mkParser length zd ~descr@(OneDescr firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers = let parstab = foldr1 mergeTables [[(k, p)]| (k, TableEntry p _) <- tab] mkactualparser getp = let ptab = [(k, (getp pr) )| (k, pr) <- parstab] find = case ptab of [(s1, p1)] -> ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else Nothing ) where r1 = symInRange s1 [(s1, p1), (s2, p2)] -> ({-# SCC "Locating" #-} \ s -> if r1 s then Just p1 else if r2 s then Just p2 else Nothing) where r1 = symInRange s1 r2 = symInRange s2 [(s1, p1), (s2, p2), (s3, p3)] -> ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else if r2 s then Just p2 else if r3 s then Just p3 else Nothing) where r1 = symInRange s1 r2 = symInRange s2 r3 = symInRange s3 _ -> lookupSym (tab2tree ptab) zerop = getp (case zd of Nothing -> libFail Just (_, Left v) -> libSucceed v Just (_, Right p) -> p ) -- SDS/AD 20050603: only the shortest alternative in possible corrections now is taken -- insertsyms = foldr1 lib_correct [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ] insertsyms = head [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ] correct k inp = case splitState inp of (# 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 Nothing ->({-# SCC "mkParser1" #-}\k inp -> case splitStateE inp of Left' s ss -> case find s of Just p -> p k inp Nothing -> correct k inp Right' ss -> insertsyms k ss) Just (True, _) ->({-# SCC "mkParser2" #-}\k inp -> case splitStateE inp of Left' s ss -> case find s of Just p -> p k inp Nothing -> let r = zerop k inp in if hasSuccess r then r else libCorrect r (correct k inp) id id Right' ss -> zerop k ss) Just (False, _) ->({-# SCC "mkParser3" #-}\k inp -> case splitStateE inp of Left' s ss -> case find s of Just p -> p k inp `libBest` zerop k inp Nothing -> let r = zerop k inp in if hasSuccess r then r else libCorrect r (correct k inp) id id Right' ss -> zerop k ss) in result res = mkPR (P ( \ acc -> mkactualparser (\ (PR (P p, _ , _)) -> p acc)) ,R ( mkactualparser (\ (PR (_ , R p, _)) -> p )) ) in AnaParser res length zd descr -- ======================================================================================= -- ===== MINIMAL LENGTHS (lazily formulated) ============================================= -- ======================================================================================= data Nat = Zero | Succ Nat | Infinite deriving (Eq, Show) nat_le Zero _ = True nat_le _ Zero = False nat_le Infinite _ = False nat_le _ Infinite = True nat_le (Succ l) (Succ r) = nat_le l r nat_min Infinite r = (r, flip) nat_min l Infinite = (l, id) nat_min Zero _ = (Zero, id) nat_min _ Zero = (Zero, flip) nat_min (Succ ll) (Succ rr) = let (v, fl) = ll `nat_min` rr in (Succ v, fl) nat_add Infinite _ = Infinite nat_add Zero r = r nat_add (Succ l) r = Succ (nat_add l r) -- ======================================================================================= -- ===== CHOICE STRUCTURES ============================================================= -- ======================================================================================= mergeTables l [] = l mergeTables [] r = r mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs) = let ct'' = ct `libOr` ct' in if cd then mergeTables rss lss else (le,ct'') : mergeTables ls rs-- equals -- ======================================================================================= -- ===== WRAPPING AND MAPPING ============================================================== -- ======================================================================================= libMap :: OutputState result => (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps r'' s p)) -> (forall r . state -> Steps ( r) s p -> ( state, Steps r s p)) -> ParsRec state result s p a -> ParsRec state result s p b libMap f f' (PR (P p, R r, _)) = mkPR ( P(\acc -> let pp = p (,) facc = f acc in \ k instate -> let inresult = pp k outstate (outstate, outresult) = facc instate inresult in outresult ) , R(\ k instate -> let inresult = r k outstate (outstate, outresult) = f' instate inresult in outresult) ) pMap :: OutputState result => (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps r'' s p)) -> (forall r . state -> Steps ( r) s p -> ( state, Steps r s p)) -> AnaParser state result s p a -> AnaParser state result s p b pMap f f' (AnaParser p l z o) = AnaParser (libMap f f' p) l (case z of Nothing -> Nothing Just (b, v) -> Just (b, case v of Left w -> Right (libMap f f' (libSucceed w)) Right pp -> Right (libMap f f' pp))) (mapOnePars (libMap f f') o) libWrap :: OutputState result => (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> (state -> Steps r s p) -> (state, Steps r'' s p, state -> Steps r s p)) -> (forall r . state -> Steps r s p -> (state -> Steps r s p) -> (state, Steps r s p, state -> Steps r s p)) -> ParsRec state result s p a -> ParsRec state result s p b libWrap f f' (PR (P p, R r, _)) = mkPR ( P(\ acc -> let pp = p (,) facc = f acc in \ k instate -> let (stl, ar, str2rr) = facc instate rl k rl = pp str2rr stl in ar ) , R(\ k instate -> let (stl, ar, str2rr) = f' instate rl k rl = r str2rr stl in ar) ) pWrap :: OutputState result => (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> (state -> Steps r s p) -> (state, Steps r'' s p, state -> Steps r s p)) -> (forall r . state -> Steps r s p -> (state -> Steps r s p) -> (state, Steps r s p, state -> Steps r s p)) -> AnaParser state result s p a -> AnaParser state result s p b pWrap f f' (AnaParser p l z o) = AnaParser (libWrap f f' p) l (case z of Nothing -> Nothing Just (b, v) -> Just (b, case v of Left w -> Right (libWrap f f' (libSucceed w)) Right pp -> Right (libWrap f f' pp))) (mapOnePars (libWrap f f') o) -- ======================================================================================= -- ===== BINARY SEARCH TREES ============================================================= -- ======================================================================================= lookupSym :: Ord a => BinSearchTree (SymbolR a, b) -> a -> Maybe b lookupSym = btFind symRS uulib-0.9.24/src/UU/Parsing/Offside.hs0000644000000000000000000003536413431353253015567 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Parsing.Offside( parseOffside , pBlock , pBlock1 , pOffside , pOpen , pClose , pSeparator , scanOffside , scanOffsideWithTriggers , scanLiftTokensToOffside , OffsideTrigger(..) , OffsideSymbol(..) , OffsideInput , Stream , OffsideParser(..) ) where import GHC.Prim import Data.Maybe import Control.Applicative import UU.Parsing.Interface import UU.Parsing.Machine import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep) import UU.Scanner.Position data OffsideTrigger = Trigger_IndentGT | Trigger_IndentGE deriving Eq data OffsideSymbol s = Symbol s | SemiColon | CloseBrace | OpenBrace deriving (Ord,Eq,Show) data Stream inp s p = Cons (OffsideSymbol s) (OffsideInput inp s p) | End inp data IndentContext = Cxt Bool -- properties: allows nesting on equal indentation (triggered by Trigger_IndentGE) Int -- indentation data OffsideInput inp s p = Off p -- position (Stream inp s p) -- input stream (Maybe (OffsideInput inp s p)) -- next in stack of nested OffsideInput's -- | plainly lift tokens to offside tokens -- scanLiftTokensToOffside :: (InputState i s p) => [i] -> OffsideInput i s p -> OffsideInput i s p scanLiftTokensToOffside ts rest = lift ts where cons p s r = Off p (Cons (Symbol s) r) Nothing lift tss = case splitStateE tss of Left' t ts -> cons (getPosition tss) t (lift ts) _ -> rest -- | convert tokens to offside tokens, dealing with Haskell's layout rule scanOffside :: (InputState i s p, Position p, Eq s) => s -> s -> s -> [s] -> i -> OffsideInput i s p scanOffside mod open close triggers ts = scanOffsideWithTriggers mod open close (zip (repeat Trigger_IndentGT) triggers) ts scanOffsideWithTriggers :: forall i s p. (InputState i s p, Position p, Eq s) => s -> s -> s -> [(OffsideTrigger,s)] -> i -> OffsideInput i s p scanOffsideWithTriggers mod open close triggers ts = start ts [] where isModule t = t == mod isOpen t = t == open isClose t = t == close isTrigger tr = \t -> t `elem` triggers' where triggers' = [ s | (tr',s) <- triggers, tr == tr' ] isTriggerGT = isTrigger Trigger_IndentGT isTriggerGE = isTrigger Trigger_IndentGE end ts = Off (getPosition ts) (End ts) cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p cons p s r = Off p (Cons s r) Nothing start = case splitStateE ts of Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (Cxt False (column (getPosition ts))) _ -> layoutL 0 -- L (:ts) (m:ms) = ; : (L ts (m:ms)) if m = n -- = } : (L (:ts) ms) if n < m -- L (:ts) ms = L ts ms startlnL l n ts (m:ms) | m == n = cons (getPosition ts) SemiColon (layoutL (line (getPosition ts)) ts (m:ms)) | n < m = cons (getPosition ts) CloseBrace (startlnL l n ts ms) startlnL l n ts ms = layoutL (line (getPosition ts)) ts ms -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n > m (Note 1) -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n >= m (as per Haskell2010, inside a do only) -- L ({n}:ts) [] = { : (L ts [n]) if n > 0 (Note 1) -- L ({n}:ts) ms = { : } : (L (:ts) ms) (Note 2) implicitL l (Cxt ge n) ts (m:ms) | n > m || (n >= m && ge) = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms)) implicitL l (Cxt _ n) ts [] | n > 0 = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n]) implicitL l (Cxt _ n) ts ms = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms)) layoutL ln ts ms | ln /= sln = startln (column pos) ts ms | otherwise = sameln ts ms where sln = line pos pos = getPosition ts layout = layoutL ln implicit = implicitL ln startln = startlnL ln -- If a let ,where ,do , or of keyword is not followed by the lexeme {, -- the token {n} is inserted after the keyword, where nis the indentation of -- the next lexeme if there is one, or 0 if the end of file has been reached. aftertrigger isTriggerGE ts ms = case splitStateE ts of Left' t _ | isOpen t -> layout ts ms | otherwise -> implicit (Cxt isTriggerGE (column(getPosition ts))) ts ms Right' _ -> implicit (Cxt False 0 ) ts ms -- L ( }:ts) (0:ms) = } : (L ts ms) (Note 3) -- L ( }:ts) ms = parse-error (Note 3), matching of implicit/explicit braces is handled by parser -- L ( {:ts) ms = {: (L ts (0:ms)) (Note 4) -- 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 :: (InputState i s p, Position p, Eq s) => i -> [Int] -> OffsideInput i s p sameln tts ms = case splitStateE tts of Left' t ts -> let tail | isTriggerGE t = aftertrigger True ts ms | isTriggerGT t = aftertrigger False 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 -- L [] [] = [] -- L [] (m:ms) = } : L [] ms if m /=0 (Note 6) -- = L [] ms, if m == 0 (this is an error, the parser should yield a parse error, if this situation occurs) endofinput pos rest [] = Off pos (End rest) Nothing endofinput pos rest (m:ms) | m /= 0 = cons pos CloseBrace (endofinput pos rest ms) | otherwise = endofinput pos rest ms instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where splitStateE inp@(Off p stream _) = case stream of Cons s rest -> Left' s rest where take 0 _ = [] take _ (Off _ (End _) _) = [] take n (Off _ (Cons h t) _) = h : take (n-1) t _ -> Right' inp splitState (Off _ stream _) = case stream of 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# symBefore s = case s of Symbol s -> Symbol (symBefore s) SemiColon -> error "Symbol.symBefore SemiColon" OpenBrace -> error "Symbol.symBefore OpenBrace" CloseBrace -> error "Symbol.symBefore CloseBrace" symAfter s = case s of Symbol s -> Symbol (symAfter s) SemiColon -> error "Symbol.symAfter SemiColon" OpenBrace -> error "Symbol.symAfter OpenBrace" CloseBrace -> error "Symbol.symAfter CloseBrace" newtype OffsideParser i o s p a = OP (AnaParser (OffsideInput i s p) o (OffsideSymbol s) p a) instance (Symbol s, Ord s, InputState i s p, OutputState o) => IsParser (OffsideParser i o s p) s where {- (<*>:) = operator (<*>:) (<*: ) = operator (<*: ) ( *>:) = operator ( *>:) (<|>:) = operator (<|>:) (<$>:) = operatorr (<$>:) (<$: ) = operatorr (<$ ) pSucceed = OP . pSucceed pFail = OP pFail -} pLow = OP . pLow pCostRange c s (Range l r) = OP (getSymbol <$> pCostRange c (Symbol s) (Range (Symbol l)(Symbol r))) pCostSym c s t = OP (getSymbol <$> pCostSym c (Symbol s) (Symbol t)) pSym s = OP (getSymbol <$> pSym (Symbol s)) pRange s (Range l r) = OP (getSymbol <$> pRange (Symbol s) (Range (Symbol l)(Symbol r))) getfirsts (OP p) = removeSymbol (getfirsts p) setfirsts exp (OP p) = OP (setfirsts (addSymbol exp) p) getzerop (OP p) = fmap OP (getzerop p) getonep (OP p) = fmap OP (getonep p) instance (Symbol s, Ord s, InputState i s p, OutputState o) => Applicative (OffsideParser i o s p) where (<*>) = operator (<*>) {-# INLINE (<*>) #-} (<* ) = operator (<* ) {-# INLINE (<*) #-} ( *>) = operator ( *>) {-# INLINE (*>) #-} pure = OP . pure {-# INLINE pure #-} instance (Symbol s, Ord s, InputState i s p, OutputState o) => Alternative (OffsideParser i o s p) where (<|>) = operator (<|>) {-# INLINE (<|>) #-} empty = OP pFail {-# INLINE empty #-} instance (Symbol s, Ord s, InputState i s p, OutputState o, Applicative (OffsideParser i o s p)) => Functor (OffsideParser i o s p) where fmap = operatorr fmap {-# INLINE fmap #-} (<$) = operatorr (<$) {-# INLINE (<$) #-} removeSymbol exp = case exp of ESym (Range (Symbol l) (Symbol r)) -> ESym (Range l r) ESym _ -> EOr [] EStr txt -> EStr txt EOr exps -> EOr (map removeSymbol exps) ESeq exps -> ESeq (map removeSymbol exps) addSymbol exp = case exp of ESym (Range l r) -> ESym (Range (Symbol l) (Symbol r)) EStr txt -> EStr txt EOr exps -> EOr (map addSymbol exps) ESeq exps -> ESeq (map addSymbol exps) getSymbol (Symbol s) = s operator f (OP p) (OP q) = OP (f p q) operatorr f g (OP p) = OP (f g p) pSeparator :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) => OffsideParser i o s p () 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 () pClose = OP (pWrap f g ( () <$ pSym CloseBrace) ) where g state steps1 k = (state,ar,k) where ar = case state of Off _ _ (Just state') -> let steps2 = k state' in if not (hasSuccess steps1) && hasSuccess steps2 then Cost 1# steps2 else steps1 _ -> steps1 f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps) k in (stl ,val (acc ()) ar , str2rr ) pOpen = OP (() <$ pSym OpenBrace) pOffside :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) => OffsideParser i o s p x -> OffsideParser i o s p y -> OffsideParser i o s p a -> OffsideParser i o s p a -> OffsideParser i o s p a pOffside open close bodyE bodyI = open *> bodyE <* close <|> pOpen *> bodyI <* pClose pBlock :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) => OffsideParser i o s p x -> OffsideParser i o s p y -> OffsideParser i o s p z -> OffsideParser i o s p a -> OffsideParser i o s p [a] pBlock open sep close p = pOffside open close explicit implicit where elem = (Just <$> p) `opt` Nothing sep' = () <$ sep elems s = (\h t -> catMaybes (h:t)) <$> elem <*> pList (s *> elem) explicit = elems sep' implicit = elems (sep' <|> pSeparator) {- where elem = (:) <$> p `opt` id sep' = () <$ sep elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem explicit = elems sep' implicit = elems (sep' <|> pSeparator) -} pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) => OffsideParser i o s p x -> OffsideParser i o s p y -> OffsideParser i o s p z -> OffsideParser i o s p a -> OffsideParser i o s p [a] pBlock1 open sep close p = pOffside open close explicit implicit where elem = (Just <$> p) `opt` Nothing sep' = () <$ sep elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList (s *> elem) explicit = elems sep' implicit = elems (sep' <|> pSeparator) {- where elem = (Just <$> p) `opt` Nothing sep' = () <$ sep elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem) explicit = elems sep' implicit = elems (sep' <|> pSeparator) -} {- pBlock1 open sep close p = pOffside open close explicit implicit where elem = (Just <$> p) <|> pSucceed Nothing sep' = () <$ sep elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem) explicit = elems sep' implicit = elems (sep' <|> pSeparator) -} {- 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 -> OffsideInput i s p -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p parseOffside (OP p) inp = val fromPair (parse p inp) where fromPair (Pair x (Pair y _)) = (x,y) uulib-0.9.24/src/UU/Parsing/StateParser.hs0000644000000000000000000000247713431353253016444 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Parsing.StateParser(StateParser(..)) where import GHC.Prim import UU.Parsing.MachineInterface import UU.Parsing.Machine(AnaParser, ParsRec(..),RealParser(..),RealRecogn(..), mkPR, anaDynE) instance (InputState inp s p) => InputState (inp, state) s p where splitStateE (inp, st) = case splitStateE inp of Left' x xs -> Left' x (xs, st) Right' xs -> Right' (xs, st) splitState (inp, st) = case splitState inp of (# x,xs #) -> (# x, (xs, st) #) getPosition (inp, _) = getPosition inp class StateParser p st | p -> st where change :: (st -> st) -> p st -- return the old state set :: st -> p st set x = change (const x) get :: p st get = change id fconst x y = y instance (InputState inp s p ,OutputState out) => StateParser (AnaParser (inp, st) out s p) st where get = anaDynE (mkPR (rp,rr)) where f addRes k state = (val (addRes (snd state)) (k state)) rp = P f rr = R (f fconst ) change ch = anaDynE (mkPR (rp,rr)) where f addRes k state = case state of (inp, st) -> val (addRes st) (k (inp, ch st)) rp = P f rr = R (f fconst) newtype Errors s p = Errors [[Message s p]] uulib-0.9.24/src/UU/Parsing/Derived.hs0000644000000000000000000002447113431353253015567 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MonoLocalBinds #-} module UU.Parsing.Derived ( -- * Checking acceptsepsilon , mnz -- * Prelude defs , (<..>) , pExcept , opt -- * Sequential compositions , asList , asList1 , asOpt , (<+>) , (<**>) , (<$$>) , () , () , pPacked -- * Iterating parsers , pFoldr_ng, pFoldr_gr, pFoldr , pFoldr1_ng, pFoldr1_gr, pFoldr1 , pFoldrSep_ng, pFoldrSep_gr, pFoldrSep , pFoldr1Sep_ng, pFoldr1Sep_gr, pFoldr1Sep , pList_ng, pList_gr, pList , pList1_ng, pList1_gr, pList1 , pListSep_ng, pListSep_gr, pListSep , pList1Sep_ng, pList1Sep_gr, pList1Sep , pChainr_ng, pChainr_gr, pChainr , pChainl_ng, pChainl_gr, pChainl -- * Misc , pAny , pAnySym , pToks , pLocate ) where import UU.Parsing.Interface import Control.Applicative infixl 2 -- infixl 4 <**> infixl 4 , <+> infixl 2 `opt` infixl 5 <..> -- ======================================================================================= -- ===== CHECKING ======================================================================== -- ======================================================================================= -- | Checks if the parser accepts epsilon. acceptsepsilon :: (IsParser p s) => p v -> Bool acceptsepsilon p = case getzerop p of {Nothing -> False; _ -> True} mnz :: (IsParser p s) => p v -> t -> String -> t mnz p v comb = if( acceptsepsilon p) then usererror ("The combinator <" ++ comb ++ "> from is called with a parser that accepts the empty string.\n" ++ "The library cannot handle the resulting left recursive formulation (which is ambiguous too).\n" -- ++ -- (case getfirsts p of -- ESeq [] -> "There are no other alternatives for this parser" -- d -> "The other alternatives of this parser may start with:\n"++ show d ) --) else v -- ======================================================================================= -- ===== START OF PRELUDE DEFINITIONS ========== ========================================= -- ======================================================================================= -- | Parses the specified range, see also 'pRange'. -- -- Example: -- -- > pDig = 'a' <..> 'z' (<..>) :: (IsParser p s) => s -> s -> p s a <..> b = pRange a (Range a b) pExcept :: (IsParser p s, Symbol s, Ord s, Eq (SymbolR s)) => (s, s, s) -> [s] -> p s pExcept (l,r,err) elems = let ranges = filter (/= EmptyR) (Range l r `except` elems) in if null ranges then pFail else foldr (<|>) pFail (map (pRange err) ranges) -- | Optionally recognize parser 'p'. -- -- If 'p' can be recognized, the return value of 'p' is used. Otherwise, -- the value 'v' is used. Note that opt is greedy, if you do not want -- this use @... <|> pSucceed v@ instead. Furthermore, 'p' should not -- recognise the empty string. opt :: (IsParser p s) => p a -> a -> p a p `opt` v = mnz p (p <|> pLow v) "opt" -- ======================================================================================= -- ===== Special sequential compositions ========================================= -- ======================================================================================= asList :: (IsParser p s) => Expecting s -> p v -> p v asList exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)*"]) asList1 :: (IsParser p s) => Expecting s -> p v -> p v asList1 exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)+"]) asOpt :: (IsParser p s) => Expecting s -> p v -> p v asOpt exp = setfirsts (ESeq [EStr "( ", exp, EStr " ...)?"]) -- | Parses the sequence of 'pa' and 'pb', and combines them as a tuple. (<+>) :: (IsParser p s) => p a -> p b -> p (a, b) pa <+> pb = (,) <$> pa <*> pb {- -- | Suppose we have a parser a with two alternatives that both start -- with recognizing a non-terminal p, then we will typically rewrite: -- -- > a = f <$> p <*> q -- > <|> g <$> p <*> r -- -- into: -- -- > a = p <**> (f <$$> q <|> g <$$> r) (<**>) :: (IsParser p s) => p a -> p (a -> b) -> p b p <**> q = (\ x f -> f x) <$> p <*> q -} (<$$>) :: (IsParser p s) => (a -> b -> c) -> p b -> p (a -> c) f <$$> p = pSucceed (flip f) <*> p () :: (IsParser p s) => p a -> p (a -> a) -> p a p q = p <**> (q `opt` id) () :: (IsParser p s) => p v -> String -> p v p str = setfirsts (EStr str) p -- | This can be used to parse 'x' surrounded by 'l' and 'r'. -- -- Example: -- -- > pParens = pPacked pOParen pCParen pPacked :: (IsParser p s) => p a -> p b1 -> p b -> p b pPacked l r x = l *> x <* r -- ======================================================================================= -- ===== Iterating ps =============================================================== -- ======================================================================================= pFoldr_ng :: (IsParser p s) => (a -> a1 -> a1, a1) -> p a -> p a1 pFoldr_ng alg@(op,e) p = mnz p (asList (getfirsts p) pfm) "pFoldr_ng" where pfm = (op <$> p <*> pfm) <|> pSucceed e pFoldr_gr :: (IsParser p s) => (a -> b -> b, b) -> p a -> p b pFoldr_gr alg@(op,e) p = mnz p (asList (getfirsts p) pfm) "pFoldr_gr" where pfm = (op <$> p <*> pfm) `opt` e pFoldr :: (IsParser p s) =>(a -> b -> b, b) -> p a -> p b pFoldr alg p = pFoldr_gr alg p pFoldr1_gr :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b pFoldr1_gr alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr alg p) pFoldr1_ng :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b pFoldr1_ng alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng alg p) pFoldr1 :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b pFoldr1 alg p = pFoldr1_gr alg p pFoldrSep_gr :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b pFoldrSep_gr alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg sepp) `opt` e )) "pFoldrSep_gr (both args)" where sepp = sep *> p pFoldrSep_ng :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b pFoldrSep_ng alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg sepp) <|> pSucceed e)) "pFoldrSep_ng (both args)" where sepp = sep *> p pFoldrSep :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b pFoldrSep alg sep p = pFoldrSep_gr alg sep p pFoldr1Sep_gr :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b pFoldr1Sep_gr alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_gr (both arguments)" else pfm where pfm = op <$> p <*> pFoldr_gr alg (sep *> p) pFoldr1Sep_ng :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b pFoldr1Sep_ng alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_ng (both arguments)" else pfm where pfm = op <$> p <*> pFoldr_ng alg (sep *> p) pFoldr1Sep :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b pFoldr1Sep alg sep p = pFoldr1Sep_gr alg sep p list_alg :: (a -> [a] -> [a], [a1]) list_alg = ((:), []) pList_gr :: (IsParser p s) => p a -> p [a] pList_gr p = pFoldr_gr list_alg p pList_ng :: (IsParser p s) => p a -> p [a] pList_ng p = pFoldr_ng list_alg p pList :: (IsParser p s) => p a -> p [a] pList p = pList_gr p pList1_gr :: (IsParser p s) => p a -> p [a] pList1_gr p = pFoldr1_gr list_alg p pList1_ng :: (IsParser p s) => p a -> p [a] pList1_ng p = pFoldr1_ng list_alg p pList1 :: (IsParser p s) => p a -> p [a] pList1 p = pList1_gr p pListSep_gr :: (IsParser p s) => p a1 -> p a -> p [a] pListSep_gr s p = pFoldrSep_gr list_alg s p pListSep_ng :: (IsParser p s) => p a1 -> p a -> p [a] pListSep_ng s p = pFoldrSep_ng list_alg s p pListSep :: (IsParser p s) => p a -> p a1 -> p [a1] pListSep s p = pListSep_gr s p pList1Sep_gr :: (IsParser p s) => p a1 -> p a -> p [a] pList1Sep_gr s p = pFoldr1Sep_gr list_alg s p pList1Sep_ng :: (IsParser p s) => p a1 -> p a -> p [a] pList1Sep_ng s p = pFoldr1Sep_ng list_alg s p pList1Sep :: (IsParser p s) =>p a -> p a1 -> p [a1] pList1Sep s p = pList1Sep_gr s p pChainr_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c pChainr_gr op x = if acceptsepsilon op then mnz x r "pChainr_gr (both arguments)" else r where r = x (flip <$> op <*> r) pChainr_ng :: (IsParser p s) => p (a -> a -> a) -> p a -> p a pChainr_ng op x = if acceptsepsilon op then mnz x r "pChainr_ng (both arguments)" else r where r = x <**> ((flip <$> op <*> r) <|> pSucceed id) pChainr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c pChainr op x = pChainr_gr op x pChainl_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c pChainl_gr op x = if acceptsepsilon op then mnz x r "pChainl_gr (both arguments)" else r where r = (f <$> x <*> pList_gr (flip <$> op <*> x) ) f x [] = x f x (func:rest) = f (func x) rest pChainl_ng :: (IsParser p s) => p (c -> c -> c) -> p c -> p c pChainl_ng op x = if acceptsepsilon op then mnz x r "pChainl_ng (both arguments)" else r where r = (f <$> x <*> pList_ng (flip <$> op <*> x) ) f x [] = x f x (func:rest) = f (func x) rest pChainl :: (IsParser p s) => p (c -> c -> c) -> p c -> p c pChainl op x = pChainl_gr op x -- | Parses using any of the parsers in the list 'l'. -- -- Warning: 'l' may not be an empty list. pAny :: (IsParser p s) =>(a -> p a1) -> [a] -> p a1 pAny f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l) -- | Parses any of the symbols in 'l'. pAnySym :: (IsParser p s) =>[s] -> p s pAnySym l = pAny pSym l -- used to be called pAnySym pToks :: (IsParser p s) => [s] -> p [s] pToks [] = pSucceed [] pToks (a:as) = (:) <$> pSym a <*> pToks as pLocate :: (IsParser p s) => [[s]] -> p [s] pLocate list = pAny pToks list uulib-0.9.24/src/UU/Parsing/CharParser.hs0000644000000000000000000000421013431353253016224 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Parsing.CharParser where import GHC.Prim import UU.Parsing.Interface import UU.Scanner.Position type CharParser = AnaParser Input Pair Char Pos instance Symbol Char where symBefore = pred symAfter = succ deleteCost _ = 5# data Input = Input String !Pos instance InputState Input Char Pos where splitStateE (Input inp pos) = case inp of ('\CR': xs) -> case xs of ('\LF' : _ ) -> Left' '\CR' (Input xs pos) _ -> Left' '\CR' (Input xs (newl pos)) ('\LF': xs) -> Left' '\LF' (Input xs (newl pos)) -- ('\n' : xs) -> Left' '\n' (Input xs (newl pos)) -- \n already captured above ('\t' : xs) -> Left' '\t' (Input xs (tab pos)) (x : xs) -> Left' x (Input xs (advc 1 pos)) [] -> Right' (Input [] pos) 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) #) -- ('\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) #) getPosition (Input inp pos) = pos parseString :: CharParser a -> [Char] -> Steps (Pair a (Pair Input ())) Char Pos parseString p txt = parse p ((Input txt (initPos ""))) parseStringIO :: (Message Char Pos -> String) -> CharParser a -> [Char] -> IO a parseStringIO showM p txt = parseIOMessage showM p (Input txt (initPos "")) parseFile :: (Message Char Pos -> String) -> CharParser a -> [Char] -> IO a parseFile showM p filename = do txt <- readFile filename parseIOMessage showM p (Input txt (initPos filename)) uulib-0.9.24/src/UU/Parsing/Merge.hs0000644000000000000000000000162713431353253015242 0ustar0000000000000000{-# LANGUAGE CPP #-} module UU.Parsing.Merge((<||>), pMerged, list_of) where import UU.Parsing -- ==== merging -- e.g. chars_digs = cat3 `pMerged` (list_of pDig <||> list_of pL <||> list_of pU) -- parsing "12abCD1aV" now returns "121abaCDV", so the sequence of -- recognised elements is stored in three lists, which are then passed to cat3 (<||>) :: IsParser p s => (c,p (d -> d),e -> f -> g) -> (h,p (i -> i),g -> j -> k) -> ((c,h),p ((d,i) -> (d,i)),e -> (f,j) -> k) (pe, pp, punp) <||> (qe, qp, qunp) =( (pe, qe) , (\f (pv, qv) -> (f pv, qv)) <$> pp <|> (\f (pv, qv) -> (pv, f qv)) <$> qp , \f (x, y) -> qunp (punp f x) y ) pMerged :: IsParser p s => c -> (d,p (d -> d),c -> d -> e) -> p e sem `pMerged` (units, alts, unp) = let pres = alts <*> pres `opt` units in unp sem <$> pres list_of :: IsParser p s => p c -> ([d],p ([c] -> [c]),e -> e) list_of p = ([], (:) <$> p, id) uulib-0.9.24/src/UU/Parsing/MachineInterface.hs0000644000000000000000000001535513431353253017373 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} 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 -- consists of 'splitStateE', 'splitState' and 'getPosition'. class InputState state s pos | state -> s, state -> pos where -- | Splits the state in a strict variant of 'Either', with 'Left'' if a symbol -- 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 -> (# s, state #) -- | Gets the current position in the input getPosition :: state -> pos -- | Reports an error reportError :: Message s pos -> state -> state reportError _ = id -- | Modify the state as the result of inserting a symbol 's' in the input. -- The symbol that has already been considered as having been inserted -- is passed. It should normally not be added to the state. insertSymbol :: s -> state -> state insertSymbol _ = id -- | Modify the state as the result of deleting a symbol 's' from the input. -- The symbol that has already been deleted from the input state is passed. -- It should normally not be deleted from the state. deleteSymbol :: s -> state -> state deleteSymbol _ = id {- {-# INLINE splitStateE #-} {-# INLINE splitState #-} {-# INLINE insertSymbol #-} {-# INLINE deleteSymbol #-} -} class OutputState r where acceptR :: v -> rest -> r v rest nextR :: (a -> rest -> rest') -> (b -> a) -> (r b rest) -> rest' {- {-# INLINE acceptR #-} {-# INLINE nextR #-} -} class Symbol s where deleteCost :: s -> Int# symBefore :: s -> s symAfter :: s -> s 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" data Either' state s = Left' !s (state ) | Right' (state ) -- ======================================================================================= -- ===== STEPS =========================================================================== -- ======================================================================================= data Steps val s p = forall a . OkVal (a -> val) (Steps a s p) | Ok { 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 | Delete s | Other String val :: (a -> b) -> Steps a s p -> Steps b s p val f (OkVal a rest) = OkVal (f.a) rest val f (Ok rest) = OkVal f rest val f (Cost i rest) = Cost i (val f rest) val f (StRepair c m r) = StRepair c m (val f r) val f (Best l s r) = Best (val f l) (val f s) (val f r) val f (NoMoreSteps v) = NoMoreSteps (f v) evalSteps :: Steps a s p -> a evalSteps (OkVal v rest ) = v (evalSteps rest) evalSteps (Ok rest ) = evalSteps rest evalSteps (Cost _ rest ) = evalSteps rest evalSteps (StRepair _ msg rest ) = evalSteps rest evalSteps (Best _ rest _) = evalSteps rest evalSteps (NoMoreSteps v ) = v getMsgs :: Steps a s p -> [Message s p] getMsgs (OkVal _ rest) = getMsgs rest getMsgs (Ok rest) = getMsgs rest getMsgs (Cost _ rest) = getMsgs rest getMsgs (StRepair _ m rest) = m:getMsgs rest getMsgs (Best _ m _) = getMsgs m getMsgs (NoMoreSteps _ ) = [] data Message sym pos = Msg (Expecting sym) !pos (Action sym) -- Msg (String, String, Expecting s) -- action, position, expecting instance (Eq s, Show s) => Show (Expecting s) where show (ESym s) = show s show (EStr str) = str show (EOr []) = "Nothing expected " show (EOr [e]) = show e show (EOr (e:ee)) = show e ++ " or " ++ show (EOr ee) show (ESeq seq) = concat (map show seq) instance (Eq s, Show s, Show p) => Show (Message s p) where show (Msg expecting position action) = "\n?? Error : " ++ show position ++ "\n?? Expecting : " ++ show expecting ++ "\n?? Repaired by: " ++ show action ++"\n" instance Show s => Show (Action s) where show (Insert s) = "inserting: " ++ show s show (Delete s) = "deleting: " ++ show s show (Other s) = s data Expecting s = ESym (SymbolR s) | EStr String | EOr [Expecting s] | ESeq [Expecting s] deriving (Ord, Eq) -- ======================================================================================= -- ===== SYMBOLS and RANGES ============================================================== -- ======================================================================================= data SymbolR s = Range !s !s | EmptyR deriving (Eq,Ord) instance (Eq s,Show s) => Show (SymbolR s) where show EmptyR = "the empty range" show (Range a b) = if a == b then show a else show a ++ ".." ++ show b mk_range l r = if l > r then EmptyR else Range l r symInRange (Range l r) = if l == r then (l==) else (\ s -> s >= l && s <= r) symRS (Range l r) = if l == r then (compare l) else (\ s -> if s < l then GT else if s > r then LT else EQ) range `except` elems = foldr removeelem [range] elems where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem] EmptyR `minus` _ = [] ran@(Range l r) `minus` elem = if symInRange ran elem then [mk_range l (symBefore elem), mk_range (symAfter elem) r] else [ran] -- ======================================================================================= -- ===== TRACING and ERRORS and MISC =================================================== -- ======================================================================================= usererror m = error ("Your grammar contains a problem:\n" ++ m) systemerror modname m = error ("I apologise: I made a mistake in my design. This should not have happened.\n" ++ " Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n") uulib-0.9.24/src/UU/Parsing/Perms.hs0000644000000000000000000000441613431353253015270 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module UU.Parsing.Perms(Perms(), pPerms, pPermsSep, succeedPerms, (~*~), (~$~)) where import UU.Parsing import Data.Maybe -- ======================================================================================= -- ===== PERMUTATIONS ================================================================ -- ======================================================================================= newtype Perms p a = Perms (Maybe (p a), [Br p a]) data Br p a = forall b. Br (Perms p (b -> a)) (p b) instance IsParser p s => Functor (Perms p) where fmap f (Perms (mb, bs)) = Perms (fmap (f<$>) mb, map (fmap f) bs) instance IsParser p s => Functor (Br p) where fmap f (Br perm p) = Br (fmap (f.) perm) p (~*~) :: IsParser p s => Perms p (a -> b) -> p a -> Perms p b perms ~*~ p = perms `add` (getzerop p, getonep p) (~$~) :: IsParser p s => (a -> b) -> p a -> Perms p b f ~$~ p = succeedPerms f ~*~ p succeedPerms :: IsParser p s => a -> Perms p a succeedPerms x = Perms (Just (pLow x), []) add :: IsParser p s => Perms p (a -> b) -> (Maybe (p a),Maybe (p a)) -> Perms p b add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb) = let changing :: IsParser p s => (a -> b) -> Perms p a -> Perms p b f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np]) in Perms ( do { f <- eb2a ; x <- eb ; return (f <*> x) } , (case nb of Nothing -> id Just pb -> (Br b2a pb:) )[ Br ((flip `changing` c) `add` bp) d | Br c d <- nb2a] ) pPerms :: IsParser p s => Perms p a -> p a pPerms (Perms (empty,nonempty)) = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp | Br pp p <- nonempty ] pPermsSep :: IsParser p s => p x -> Perms p a -> p a pPermsSep (sep :: p z) perm = p2p (pSucceed ()) perm where p2p :: p () -> Perms p a -> p a p2p fsep (Perms (mbempty, nonempties)) = let empty = fromMaybe pFail mbempty pars (Br t p) = flip ($) <$ fsep <*> p <*> p2p_sep t in foldr (<|>) empty (map pars nonempties) p2p_sep = p2p (()<$ sep) uulib-0.9.24/src/UU/Parsing/Interface.hs0000644000000000000000000002471113431353253016102 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Parsing.Interface ( AnaParser, pWrap, pMap , module UU.Parsing.MachineInterface , module UU.Parsing.Interface , (<*>), (<*), (*>), (<$>), (<$), (<|>) ) where import GHC.Prim import UU.Parsing.Machine import UU.Parsing.MachineInterface --import IOExts import System.IO.Unsafe import System.IO import Control.Applicative -- ================================================================================== -- ===== PRIORITIES ====================================================================== -- ======================================================================================= {- 20150402 AD: use of Applicative, Functor, Alternative infixl 3 <|>: infixl 4 <*>:, <$>: infixl 4 <$: infixl 4 <*:, *>: -} -- ======================================================================================= -- ===== ANAPARSER INSTANCES ============================================================= -- ======================================================================================= type Parser s = AnaParser [s] Pair s (Maybe s) -- ======================================================================================= -- ===== PARSER CLASSES ================================================================== -- ======================================================================================= -- | The 'IsParser' class contains the base combinators with which -- to write parsers. A minimal complete instance definition consists of -- definitions for '(<*>)', '(<|>)', 'pSucceed', 'pLow', 'pFail', -- 'pCostRange', 'pCostSym', 'getfirsts', 'setfirsts', and 'getzerop'. -- All operators available through 'Applicative', 'Functor", and 'Alternative' have the same names suffixed with ':'. class (Applicative p, Alternative p, Functor p) => IsParser p s | p -> s where {- 20150402 AD: use of Applicative, Functor, Alternative -- | Sequential composition. Often used in combination with <$>. -- The function returned by parsing the left-hand side is applied -- to the value returned by parsing the right-hand side. -- Note: Implementations of this combinator should lazily match on -- and evaluate the right-hand side parser. The derived combinators -- for list parsing will explode if they do not. (<*>:) :: p (a->b) -> p a -> p b -- | Value ignoring versions of sequential composition. These ignore -- either the value returned by the parser on the right-hand side or -- the left-hand side, depending on the visual direction of the -- combinator. (<*: ) :: p a -> p b -> p a ( *>:) :: p a -> p b -> p b -- | Applies the function f to the result of p after parsing p. (<$>:) :: (a->b) -> p a -> p b (<$: ) :: b -> p a -> p b -} {- 20150402 AD: use of Applicative, Functor, Alternative f <$>: p = pSucceed f <*>: p f <$: q = pSucceed f <* q p <*: q = pSucceed const <*>: p <*>: q p *>: q = pSucceed (flip const) <*>: p <*>: q -} {- 20150402 AD: use of Applicative, Functor, Alternative -- | Alternative combinator. Succeeds if either of the two arguments -- succeed, and returns the result of the best success parse. (<|>:) :: p a -> p a -> p a -} -- | Two variants of the parser for empty strings. 'pSucceed' parses the -- empty string, and fully counts as an alternative parse. It returns the -- value passed to it. pSucceed :: a -> p a -- | 'pLow' parses the empty string, but alternatives to pLow are always -- preferred over 'pLow' parsing the empty string. pLow :: a -> p a pSucceed = pure -- | This parser always fails, and never returns any value at all. pFail :: p a -- | 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# -> 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# -> s -> s -> p s -- | Parses a symbol. Returns the symbol parsed. pSym :: s -> p s pRange :: s -> SymbolR s -> p s -- | Get the firsts set from the parser, i.e. the symbols it expects. getfirsts :: p v -> Expecting s -- | Set the firsts set in the parser. setfirsts :: Expecting s -> p v -> p v pFail = empty 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. getzerop :: p v -> Maybe (p v) -- | 'getonep' returns @Nothing@ if the parser can only parse the empty -- string, and returns @Just p@ with @p@ a parser that does not parse any -- empty string. getonep :: p v -> Maybe (p v) -- ======================================================================================= -- ===== AnaParser ======================================================================= -- ======================================================================================= -- | The fast 'AnaParser' instance of the 'IsParser' class. Note that this -- requires a functioning 'Ord' for the symbol type s, as tokens are -- often compared using the 'compare' function in 'Ord' rather than always -- using '==' rom 'Eq'. The two do need to be consistent though, that is -- for any two @x1@, @x2@ such that @x1 == x2@ you must have -- @compare x1 x2 == EQ@. instance (Ord s, Symbol s, InputState state s p, OutputState result) => IsParser (AnaParser state result s p) s where {- 20150402 AD: use of Applicative, Functor, Alternative (<*>:) p q = anaSeq libDollar libSeq ($) p q (<*: ) p q = anaSeq libDollarL libSeqL const p q ( *>:) p q = anaSeq libDollarR libSeqR (flip const) p q pSucceed = anaSucceed (<|>:) = anaOr pFail = anaFail -} pLow = anaLow pCostRange = anaCostRange pCostSym i ins sym = anaCostRange i ins (mk_range sym sym) getfirsts = anaGetFirsts setfirsts = anaSetFirsts getzerop p = case zerop p of Nothing -> Nothing Just (b,e) -> Just p { pars = libSucceed `either` id $ e , leng = Zero , onep = noOneParser } getonep p = let tab = table (onep p) in if null tab then Nothing else Just (mkParser (leng p) Nothing (onep p)) instance (Ord s, Symbol s, InputState state s p, OutputState result) => Applicative (AnaParser state result s p) where (<*>) p q = anaSeq libDollar libSeq ($) p q {-# INLINE (<*>) #-} (<* ) p q = anaSeq libDollarL libSeqL const p q {-# INLINE (<*) #-} ( *>) p q = anaSeq libDollarR libSeqR (flip const) p q {-# INLINE (*>) #-} pure = anaSucceed {-# INLINE pure #-} instance (Ord s, Symbol s, InputState state s p, OutputState result) => Alternative (AnaParser state result s p) where (<|>) = anaOr {-# INLINE (<|>) #-} empty = anaFail {-# INLINE empty #-} instance (Ord s, Symbol s, InputState state s p, OutputState result, Applicative (AnaParser state result s p)) => Functor (AnaParser state result s p) where fmap f p = pure f <*> p {-# INLINE fmap #-} instance InputState [s] s (Maybe s) where splitStateE [] = Right' [] splitStateE (s:ss) = Left' s ss splitState (s:ss) = (# s, ss #) getPosition [] = Nothing getPosition (s:ss) = Just s instance OutputState Pair where acceptR = Pair 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 () 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) getInputState :: (InputState a c d, Symbol c, Ord c, OutputState b)=>AnaParser a b c d a getInputState = pMap f g (pSucceed id) where f acc inp steps = (inp, val (acc inp . snd) steps) g = (,) handleEof input = case splitStateE input of Left' s ss -> StRepair (deleteCost s) (Msg (EStr "end of file") (getPosition input) (Delete s) ) (handleEof ss) Right' ss -> NoMoreSteps (Pair ss ()) parse :: (Symbol s, InputState inp s pos) => AnaParser inp Pair s pos a -> inp -> Steps (Pair a (Pair inp ())) s pos parse = parsebasic handleEof parseIOMessage :: ( Symbol s, InputState inp s p) => (Message s p -> String) -> AnaParser inp Pair s p a -> inp -> IO a parseIOMessage showMessage p inp = do (Pair v final) <- evalStepsIO showMessage (parse p inp) final `seq` return v -- in order to force the trailing error messages to be printed parseIOMessageN :: ( Symbol s, InputState inp s p) => (Message s p -> String) -> Int -> AnaParser inp Pair s p a -> inp -> IO a parseIOMessageN showMessage n p inp = do (Pair v final) <- evalStepsIO' showMessage n (parse p inp) final `seq` return v -- in order to force the trailing error messages to be printed data Pair a r = Pair a r evalStepsIO :: (Message s p -> String) -> Steps b s p -> IO b evalStepsIO showMessage = evalStepsIO' showMessage (-1) evalStepsIO' :: (Message s p -> String) -> Int -> Steps b s p -> IO b evalStepsIO' showMessage n (steps :: Steps b s p) = eval n steps where eval :: Int -> Steps a s p -> IO a eval 0 steps = return (evalSteps steps) eval n steps = case steps of OkVal v rest -> do arg <- unsafeInterleaveIO (eval n rest) return (v arg) Ok rest -> eval n rest Cost _ rest -> eval n rest StRepair _ msg rest -> do hPutStr stderr (showMessage msg) eval (n-1) rest Best _ rest _ -> eval n rest NoMoreSteps v -> return v uulib-0.9.24/src/UU/Scanner/0000755000000000000000000000000013431353253013627 5ustar0000000000000000uulib-0.9.24/src/UU/Scanner/Position.hs0000644000000000000000000000301113431353253015762 0ustar0000000000000000module UU.Scanner.Position where type Line = Int type Column = Int type Filename = String class Position p where line :: p -> Line column :: p -> Column file :: p -> Filename instance Position Pos where line (Pos l _ _) = l column (Pos _ c _) = c file (Pos _ _ f) = f data Pos = Pos !Line !Column Filename instance Show Pos where show (Pos l c f) | l == (-1) = "" | otherwise = let file = if null f then "" else show f lc = "(line " ++ show l ++ ", column " ++ show c ++")" in file ++ lc initPos :: FilePath -> Pos initPos fn = Pos 1 1 fn noPos :: Pos noPos = Pos (-1) (-1) "" advl :: Line -> Pos ->Pos advl i (Pos l c f) = (Pos (l+i) 1 f) advc :: Column -> Pos -> Pos advc i (Pos l c f) = (Pos l (c+i) f) adv :: Pos -> Char -> Pos adv pos c = case c of '\t' -> advc (tabWidth (column pos)) pos '\n' -> advl 1 pos _ -> advc 1 pos updPos :: Char -> Pos -> Pos updPos x = case x of '\n' -> newl '\t' -> tab _ -> advc 1 tab :: Pos -> Pos tab (Pos l c f) = Pos l (c+tabWidth c) f newl :: Pos ->Pos newl = advl 1 tabWidth :: Column -> Int tabWidth c = 8 - ((c-1) `mod` 8) updPos' :: Char -> Pos -> (Pos -> a) -> a updPos' c p cont = p `seq` cont (updPos c p) advc' :: Int -> Pos -> (Pos -> a) -> a advc' i p cont = p `seq` cont (advc i p) tab' :: Pos -> (Pos -> a) -> a tab' p cont = p `seq` cont (tab p) newl' :: Pos -> (Pos -> a) -> a newl' p cont = p `seq` cont (newl p) uulib-0.9.24/src/UU/Scanner/TokenParser.hs0000644000000000000000000000720413431353253016423 0ustar0000000000000000{-# LANGUAGE CPP #-} module UU.Scanner.TokenParser where import UU.Parsing.Interface(IsParser(..), (<$), (<$>)) import UU.Parsing.Derived(pListSep, pPacked) import UU.Scanner.Position(Pos) import UU.Scanner.GenTokenParser(pReserved, pValToken) import UU.Scanner.Token(Token,EnumValToken(..)) ------------------------------------------------------------------------- -- IsParsers for Symbols ------------------------------------------------------------------------- pKeyPos :: IsParser p Token => String -> p Pos pKeyPos keyword = pReserved keyword pSpecPos :: IsParser p Token => Char -> p Pos pSpecPos s = pReserved [s] pKey :: IsParser p Token => String -> p String pKey key = key <$ pKeyPos key pSpec :: IsParser p Token => Char -> p String pSpec c = [c] <$ pSpecPos c pStringPos, pCharPos, pInteger8Pos, pInteger10Pos, pInteger16Pos, pFractionPos, pVaridPos, pConidPos, pTextnmPos, pTextlnPos, pIntegerPos, pVarsymPos, pConsymPos :: IsParser p Token => p (String,Pos) pStringPos = pValToken TkString "" pCharPos = pValToken TkChar "\NUL" pInteger8Pos = pValToken TkInteger8 "0" pInteger10Pos = pValToken TkInteger10 "0" pInteger16Pos = pValToken TkInteger16 "0" pFractionPos = pValToken TkFraction "0.0" pVaridPos = pValToken TkVarid "" pConidPos = pValToken TkConid "" pConsymPos = pValToken TkConOp "" pVarsymPos = pValToken TkOp "" pTextnmPos = pValToken TkTextnm "" pTextlnPos = pValToken TkTextln "" pIntegerPos = pInteger10Pos pString, pChar, pInteger8, pInteger10, pInteger16, pFraction, pVarid, pConid, pTextnm, pTextln, pInteger, pVarsym, pConsym :: IsParser p Token => p String pString = fst <$> pStringPos pChar = fst <$> pCharPos pInteger8 = fst <$> pInteger8Pos pInteger10 = fst <$> pInteger10Pos pInteger16 = fst <$> pInteger16Pos pFraction = fst <$> pFractionPos pVarid = fst <$> pVaridPos pConid = fst <$> pConidPos pVarsym = fst <$> pVarsymPos pConsym = fst <$> pConsymPos pTextnm = fst <$> pTextnmPos pTextln = fst <$> pTextlnPos pInteger = fst <$> pIntegerPos pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly :: IsParser p Token => p String pComma = pSpec ',' pSemi = pSpec ';' pOParen = pSpec '(' pCParen = pSpec ')' pOBrack = pSpec '[' pCBrack = pSpec ']' pOCurly = pSpec '{' pCCurly = pSpec '}' pCommaPos, pSemiPos, pOParenPos, pCParenPos, pOBrackPos, pCBrackPos, pOCurlyPos, pCCurlyPos :: IsParser p Token => p Pos pCommaPos = pSpecPos ',' pSemiPos = pSpecPos ';' pOParenPos = pSpecPos '(' pCParenPos = pSpecPos ')' pOBrackPos = pSpecPos '[' pCBrackPos = pSpecPos ']' pOCurlyPos = pSpecPos '{' pCCurlyPos = pSpecPos '}' pCommas :: IsParser p Token => p a -> p [a] pSemics :: IsParser p Token => p a -> p [a] pParens :: IsParser p Token => p a -> p a pBracks :: IsParser p Token => p a -> p a pCurly :: IsParser p Token => p a -> p a pCommas = pListSep pComma pSemics = pListSep pSemi pParens = pPacked pOParen pCParen pBracks = pPacked pOBrack pCBrack pCurly = pPacked pOCurly pCCurly pParens_pCommas :: IsParser p Token => p a -> p [a] pBracks_pCommas :: IsParser p Token => p a -> p [a] pCurly_pSemics :: IsParser p Token => p a -> p [a] pParens_pCommas = pParens.pCommas pBracks_pCommas = pBracks.pCommas pCurly_pSemics = pCurly .pSemics uulib-0.9.24/src/UU/Scanner/GenToken.hs0000644000000000000000000000050613431353253015676 0ustar0000000000000000module UU.Scanner.GenToken where import UU.Scanner.Position(Pos) data GenToken key tp val = Reserved !key !Pos | ValToken !tp val !Pos position :: GenToken k t v -> Pos position tok = case tok of Reserved _ p -> p ValToken _ _ p -> p uulib-0.9.24/src/UU/Scanner/GenTokenSymbol.hs0000644000000000000000000000043513431353253017065 0ustar0000000000000000{-# LANGUAGE MagicHash #-} 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# uulib-0.9.24/src/UU/Scanner/GenTokenParser.hs0000644000000000000000000000471113431353253017055 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-} module UU.Scanner.GenTokenParser where import GHC.Base 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) pCostReserved' (I# c) key = let tok = Reserved key noPos in pCostSym c tok tok pReserved' :: IsParser p (GenToken key tp val) => key -> p (GenToken key tp val) pReserved' key = let tok = Reserved key noPos in pSym tok pCostValToken' :: IsParser p (GenToken key tp val) => Int -> tp -> val -> p (GenToken key tp val) pCostValToken' (I# c) tp val = let tok = ValToken tp val noPos in pCostSym c tok tok pValToken' :: IsParser p (GenToken key tp val) => tp -> val -> p (GenToken key tp val) pValToken' tp val = let tok = ValToken tp val noPos in pSym tok pCostReserved :: IsParser p (GenToken key tp val) => 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) pCostValToken c tp val = let getVal x = case x of ValToken _ v p -> (v,p) _ -> error "pValToken: cannot get value of Reserved" in getVal <$> pCostValToken' c tp val pReserved :: IsParser p (GenToken key tp val) => key -> p Pos pReserved = pCostReserved 5 pValToken :: IsParser p (GenToken key tp val) => tp -> val -> p (val,Pos) pValToken = pCostValToken 5 pValTokenNoPos :: IsParser p (GenToken key tp val) => tp -> val -> p val pValTokenNoPos tp val = fst <$> pValToken tp val uulib-0.9.24/src/UU/Scanner/Token.hs0000644000000000000000000000122113431353253015237 0ustar0000000000000000module UU.Scanner.Token where import UU.Scanner.GenToken(GenToken(..)) import UU.Scanner.Position(Pos) type Token = GenToken String EnumValToken String data EnumValToken = TkVarid | TkConid | TkString | TkChar | TkInteger8 | TkInteger10 | TkInteger16 | TkFraction | TkTextnm | TkTextln | TkOp | TkConOp | TkError deriving (Eq, Ord) reserved :: String -> Pos -> Token reserved = Reserved valueToken :: EnumValToken -> String -> Pos -> Token valueToken = ValToken errToken :: String -> Pos -> Token errToken = valueToken TkError uulib-0.9.24/src/UU/Scanner/Scanner.hs0000644000000000000000000002514113431353253015557 0ustar0000000000000000module UU.Scanner.Scanner where import Data.Char(isLower, isUpper, isSpace, isAlphaNum, isDigit, chr, ord) import Data.List(sort) import Data.Maybe(isJust) import UU.Util.BinaryTrees(tab2tree,btLocateIn) import UU.Scanner.Token(Token, EnumValToken(..), valueToken, reserved, errToken) import UU.Scanner.Position(Pos, initPos, advc, adv) {- A parametrisable scanner - - Author: Doaitse Swierstra: doaitse@cs.uu.nl and: Pablo Azero : pablo@cs.uu.nl - Version 1.0 , May 25, 1998, SDS first appearance on the software web site. - Version 1.01, June 7, 1998, SDS changed String recognition to recognise escaped characters - Version 1.02, Aug 30, 1998, SDS includes with unsafePerformIO - Version 2.1, Jul 7, 1999, slightly different definition of valueToken ordering between tokens introduced - Version 2.2, Jul 8, 1999, AG_Scanner and UU_Scanner merged - Version 2.3, Jul 15, 1999, modifications: recognize decimal, octal and - hexadecimal numbers; handles ' as part of a - lower case identifier - fixes: bug in msort (loops when passing an - empty list) - Version 2.4, Jul 23, 1999, additions: recognize characters and infix - operators - - Lang. compat: Hugs 98 (because it is required by UU_Parsing) - Version 2.5, Aug 15, 1999, changed names, pSym -> pSpec , all parsers start with p.... - Version 2.6, Sept 15, 1999, changed error message for unterminated string - Version 2.7, Sept 23, 1999, changed definition of pOper_Any - Version 2.8 Aug 14, 2000, adapted to changes in search trees - ?? Oct 25, 2000, adapted to use column numbers - ?? Feb 2, 2001, incorporated changes of AD - ?? Feb 28, 2001, tabs are handled correctly for column numbers - ?? Mar 1, 2001, now generates space tokens that have to be filtered again - ?? Apr 4, 2001, tabs are now handled relative to current column number -} scanFile :: [String] -> [String] -> String -> String -> FilePath -> IO [Token] scanFile keywordstxt keywordsops specchars opchars fn = do txt <- readFile fn return (scan keywordstxt keywordsops specchars opchars (initPos fn) txt) scan :: [String] -> [String] -> String -> String -> Pos -> String -> [Token] scan keywordstxt keywordsops specchars opchars pos input = doScan pos input where locatein :: Ord a => [a] -> a -> Bool locatein es = isJust . btLocateIn compare (tab2tree (sort es)) iskw = locatein keywordstxt isop = locatein keywordsops isSymbol = locatein specchars isOpsym = locatein opchars isIdStart c = isLower c || c == '_' isIdChar c = isAlphaNum c || c == '\'' || c == '_' scanIdent p s = let (name,rest) = span isIdChar s in (name,advc (length name) p,rest) doScan p [] = [] doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s in doScan (foldl adv p (c:sp)) next doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) doScan p ('{':'-':s) = lexNest doScan (advc 2 p) s doScan p ('"':ss) = let (s,swidth,rest) = scanString ss in if null rest || head rest /= '"' then errToken "Unterminated string literal" p : doScan (advc swidth p) rest else valueToken TkString s p : doScan (advc (swidth+2) p) (tail rest) doScan p ('\'':ss) = let (mc,cwidth,rest) = scanChar ss in case mc of Nothing -> errToken "Error in character literal" p : doScan (advc cwidth p) rest Just c -> if null rest || head rest /= '\'' then errToken "Unterminated character literal" p : doScan (advc (cwidth+1) p) rest else valueToken TkChar [c] p : doScan (advc (cwidth+2) p) (tail rest) {- In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier) doScan p ('`':ss) = case ss of [] -> [errToken "Unterminated infix identifier" p] (c:s) -> let res | isIdStart c || isUpper c = let (name,p1,rest) = scanIdent (advc 2 p) s ident = c:name tokens | null rest || head rest /= '`' = errToken "Unterminated infix identifier" p : doScan p1 rest | iskw ident = errToken ("Keyword used as infix identifier: " ++ ident) p : doScan (advc 1 p1) (tail rest) | otherwise = valueToken TkOp ident p : doScan (advc 1 p1) (tail rest) in tokens | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p : doScan (adv p c) s in res -} doScan p cs@(c:s) | isSymbol c = reserved [c] p : doScan(advc 1 p) s | isIdStart c || isUpper c = let (name', p', s') = scanIdent (advc 1 p) s name = c:name' tok = if iskw name then reserved name p else if null name' && isSymbol c then reserved [c] p else valueToken (if isIdStart c then TkVarid else TkConid) name p in tok : doScan p' s' | isOpsym c = let (name, s') = span isOpsym cs tok | isop name = reserved name p | c==':' = valueToken TkConOp name p | otherwise = valueToken TkOp name p in tok : doScan (foldl adv p name) s' | isDigit c = let (tktype,number,width,s') = getNumber cs in valueToken tktype number p : doScan (advc width p) s' | otherwise = errToken ("Unexpected character " ++ show c) p : doScan (adv p c) s {- -- ks: no clean implementation of columns readname s lc = (name,orest,nlc) where (line,irest) = span (/='\n') s orest = if null irest then "" else irest nlc = if null irest then lc else (lc `advl` 1) name = takename . dropWhile (\x -> not $ x `elem` "{[") $ line takename ln | null ln = "" | otherwise = if not (null tln) && (isAlpha . head $ tln) then if not (null rln) && (head rln `elem` "}]") then cname else err lc 1 else err lc 1 where (cname, rln) = span validChar tln tln = tail ln validChar c = isAlpha c || c `elem` ".-_" || isDigit c -- ks: changed definition from (lc+1) to (lc) err lc 1 = error ("in scanner bad name definition" ++ maybeshow (lc)) err lc fn 2 = error ("in scanner not a valid name in file inclusion" ++ maybeshow (lc)) -} lexNest :: (Pos -> String -> [Token]) -> Pos -> String -> [Token] lexNest cont pos inp = lexNest' cont pos inp where lexNest' c p ('-':'}':s) = c (advc 2 p) s lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s lexNest' c p (x:s) = lexNest' c (adv p x) s lexNest' _ _ [] = [ errToken "Unterminated nested comment" pos] scanString :: String -> (String,Int,String) scanString [] = ("",0,[]) scanString ('\\':'&':xs) = let (str,w,r) = scanString xs in (str,w+2,r) scanString ('\'':xs) = let (str,w,r) = scanString xs in ('\'': str,w+1,r) scanString xs = let (ch,cw,cr) = getchar xs (str,w,r) = scanString cr str' = maybe "" (:str) ch in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch scanChar :: [Char] -> (Maybe Char,Int,[Char]) scanChar ('"' :xs) = (Just '"',1,xs) scanChar xs = getchar xs getchar :: [Char] -> (Maybe Char,Int,[Char]) getchar [] = (Nothing,0,[]) getchar s@('\n':_ ) = (Nothing,0,s ) getchar s@('\t':_ ) = (Nothing,0,s) getchar s@('\'':_ ) = (Nothing,0,s) getchar s@('\"' :_ ) = (Nothing,0,s) getchar ('\\':xs) = let (c,l,r) = getEscChar xs in (c,l+1,r) getchar (x:xs) = (Just x,1,xs) getEscChar :: [Char] -> (Maybe Char,Int,[Char]) getEscChar [] = (Nothing,0,[]) getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s val = case tp of TkInteger8 -> readn 8 n TkInteger16 -> readn 16 n TkInteger10 -> readn 10 n in if val >= 0 && val <= 255 then (Just (chr val),len, rest) else (Nothing,1,rest) | otherwise = case x `lookup` cntrChars of Nothing -> (Nothing,0,s) Just c -> (Just c,1,xs) where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') ,('v','\v'),('\\','\\'),('\"','\"'),('\'','\'')] readn :: Int -> [Char] -> Int readn base n = foldl (\r x -> value x + base * r) 0 n getNumber :: [Char] -> (EnumValToken,[Char],Int,[Char]) getNumber cs@(c:s) | c /= '0' = num10 | null s = const0 | hs == 'x' || hs == 'X' = num16 | hs == 'o' || hs == 'O' = num8 | otherwise = num10 where (hs:ts) = s const0 = (TkInteger10, "0",1,s) num10 = let (n,r) = span isDigit cs in (TkInteger10,n,length n,r) num16 = readNum isHexaDigit ts TkInteger16 num8 = readNum isOctalDigit ts TkInteger8 readNum p ts tk = let nrs@(n,rs) = span p ts in if null n then const0 else (tk , n, 2+length n,rs) isHexaDigit :: Char -> Bool isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') isOctalDigit :: Char -> Bool isOctalDigit d = d >= '0' && d <= '7' value :: Char -> Int value c | isDigit c = ord c - ord '0' | isUpper c = ord c - ord 'A' + 10 | isLower c = ord c - ord 'a' + 10 uulib-0.9.24/src/UU/Scanner/GenTokenOrd.hs0000644000000000000000000000107513431353253016345 0ustar0000000000000000module UU.Scanner.GenTokenOrd() where import UU.Scanner.GenToken(GenToken(..)) instance (Eq key, Eq tp) => Eq (GenToken key tp val) where Reserved x _ == Reserved y _ = x == y ValToken tx _ _ == ValToken ty _ _ = tx == ty _ == _ = False instance (Ord key, Ord tp) => Ord (GenToken key tp val) where compare (Reserved x _) (Reserved y _) = compare x y compare (Reserved _ _) _ = LT compare (ValToken tx _ _) (ValToken ty _ _) = compare tx ty compare _ _ = GT uulib-0.9.24/src/UU/Scanner/TokenShow.hs0000644000000000000000000000241413431353253016105 0ustar0000000000000000module UU.Scanner.TokenShow() where import UU.Scanner.Token(Token,EnumValToken(..)) import UU.Scanner.Position(Pos(..)) import UU.Scanner.GenToken(GenToken(..)) instance Show Token where showsPrec _ token = showString (case token of Reserved key pos -> "symbol " ++ key ++ maybeshow pos ValToken tp val pos -> show tp ++ " " ++ val ++ maybeshow pos ) instance Show EnumValToken where show tp = case tp of TkOp -> "operator" TkConOp -> "con operator" TkString -> "string" TkChar -> "character" TkInteger8 -> "octal integer" TkInteger10 -> "decimal Integer" TkInteger16 -> "hexadecimal integer" TkFraction -> "fraction (float,...)" TkVarid -> "lower case identifier" TkConid -> "upper case identifier" TkTextnm -> "text name" TkTextln -> "text lines" TkError -> "error in scanner:" maybeshow :: Pos -> String maybeshow (Pos l c fn) | l <= 0 || c <= 0 = "" | otherwise = " at line " ++ show l ++ ", column " ++ show c ++ " of file " ++ show fn