hasktags 0.68.2 → 0.68.3
raw patch · 30 files changed
+4938/−613 lines, 30 filesdep +HUnitdep +interludedep +jsondep ~basedep ~bytestringdep ~directory
Dependencies added: HUnit, interlude, json, unix
Dependency ranges changed: base, bytestring, directory
Files
- README +21/−1
- TODO +13/−0
- hasktags.cabal +74/−11
- hasktags.hs +0/−601
- src/Hasktags.hs +435/−0
- src/Main.hs +136/−0
- src/Tags.hs +161/−0
- testcases/HUnitBase.lhs +253/−0
- testcases/Repair.lhs +147/−0
- testcases/blockcomment.hs +4/−0
- testcases/constructor.hs +10/−0
- testcases/expected_failures_testing_suite.hs +12/−0
- testcases/firstconstructor.hs +2/−0
- testcases/module.hs +4/−0
- testcases/space.hs +4/−0
- testcases/substring.hs +3/−0
- testcases/tabs.hs +3/−0
- testcases/testcase1.hs +86/−0
- testcases/testcase10.hs +443/−0
- testcases/testcase11.hs +84/−0
- testcases/testcase2.hs +256/−0
- testcases/testcase3.lhs +1313/−0
- testcases/testcase4.hs +509/−0
- testcases/testcase8.hs +22/−0
- testcases/testcase9.hs +825/−0
- testcases/twoblockcommentshs.hs +5/−0
- testcases/twoblockcommentslhs.lhs +6/−0
- testcases/twoblockcommentstogether.hs +4/−0
- testcases/typesig.hs +2/−0
- tests/Test.hs +101/−0
README view
@@ -9,7 +9,7 @@ so that you can find / jump to them fast. HOWTO (GENERATING TAG FILES):- ghc --make hasktags.hs+ Build hasktags (standard cabal build) I've been using this bash function or something similar for a long time. It may be cumbersome but works:@@ -45,6 +45,26 @@ features. hasktags itself was moved out of the ghc repository. Then I only verified that my fork finds at least as much tags as the one forked by Igloo. +Things which could be done in the future:+- make json support optional+- Marco Túlio Pimenta Gontijo proposed replacing json by aeson because it might+ be faster+- write a nice README.md file instead++maintainers: See cabal file+++comments about literate haskell (lhs):+=======================================+http://www.haskell.org/haskellwiki/Literate_programming+alex no longer supports bird style ">", so should we drop support, too?++contributors:+ Tsuru Capital (github/liyang)+ Marco Túlio Pimenta Gontijo (github/marcotmarcot)+ TODO: add all people having contributed before Oct 2012+ This includes people contributing to the darcs repository as well as people+ having contributed when this repository has been part of ghc related work (list taken from announce of lushtags: https://github.com/bitc/lushtags
+ TODO view
@@ -0,0 +1,13 @@++ - From: Evan Laforge <qdunkan@gmail.com>+ To: Marc Weber <marco-oweber@gmx.de>+ Date: August 18 2009 10:50pm (11 hours ago)+ Subject: Re: hasktags - If nobody minds I'll maintain it..+ Labels: inbox, libraries_haskell, sent+ In reply to: Marc Weber's message of August 18 2009 1:40pm+ Thanks for taking this up, tags are very useful. I have two+ suggestions: why not write the file sorted by default? Also, if you+ put '!_TAG_FILE_SORTED\t1\t ~' on the first line, vim will assume it's+ sorted and not fall back on the slow linear search when it doesn't+ find a tag.+
hasktags.cabal view
@@ -1,24 +1,87 @@ Name: hasktags-Version: 0.68.2+Version: 0.68.3 Copyright: The University Court of the University of Glasgow License: BSD3 License-File: LICENSE Author: The GHC Team-Maintainer: Marc Weber <marco-oweber@gmx.de>+Maintainer:+ Marc Weber <marco-oweber@gmx.de>,+ Marco Túlio Pimenta Gontijo <marcotmarcot@gmail.com>+homepage: http://github.com/MarcWeber/hasktags+bug-reports: http://github.com/MarcWeber/hasktags/issues Synopsis: Produces ctags "tags" and etags "TAGS" files for Haskell programs Description: Produces ctags "tags" and etags "TAGS" files for Haskell programs. Category: Development build-type: Simple-cabal-version: >=1.2-extra-source-files: README+cabal-version: >=1.10+extra-source-files:+ README,+ TODO,+ testcases/HUnitBase.lhs+ testcases/Repair.lhs+ testcases/blockcomment.hs+ testcases/constructor.hs+ testcases/firstconstructor.hs+ testcases/module.hs+ testcases/space.hs+ testcases/substring.hs+ testcases/tabs.hs+ testcases/testcase1.hs+ testcases/testcase2.hs+ testcases/testcase3.lhs+ testcases/testcase4.hs+ testcases/testcase8.hs+ testcases/twoblockcommentshs.hs+ testcases/twoblockcommentslhs.lhs+ testcases/twoblockcommentstogether.hs+ testcases/typesig.hs+ testcases/expected_failures_testing_suite.hs+ testcases/testcase9.hs+ testcases/testcase10.hs+ testcases/testcase11.hs --- Later, this isn't compatible with Cabal 1.2:--- source-repository head--- type: darcs--- location: http://code.haskell.org/hasktags/ +-- TODO finish implementation+Flag enable_caching+ Default: True++Flag debug+ Default: False++source-repository head+ type: git+ location: http://github.com/MarcWeber/hasktags+ Executable hasktags- Main-Is: hasktags.hs- -- < 6 because hasktags does not use special functions thus its unlikely to break- Build-Depends: base < 6, bytestring, directory, filepath+ Main-Is: Main.hs+ Build-Depends:+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ directory >= 1.1 && < 1.3,+ filepath,+ json >= 0.5 && < 0.8,+ interlude,+ HUnit >= 1.2 && < 1.3+ other-modules: Tags, Hasktags+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010++ if !os(windows)+ build-depends: unix++ if flag(debug)+ cpp-options: -Ddebug++Test-Suite test+ Type: exitcode-stdio-1.0+ Main-Is: Test.hs+ hs-source-dirs: src, tests+ Build-Depends: base, bytestring, directory, filepath, json,+ HUnit >= 1.2 && < 1.3+ ghc-options: -Wall+ default-language: Haskell2010++ if flag(debug)+ cpp-options: -Ddebug
− hasktags.hs
@@ -1,601 +0,0 @@-module Main (main) where-import qualified Data.ByteString.Char8 as BS-import Data.Char-import Data.List-import Data.Maybe-import Control.Monad( when )--import System.IO-import System.Environment-import System.Directory (doesDirectoryExist, getDirectoryContents)-import System.FilePath ((</>))-import System.Console.GetOpt-import System.Exit-import Control.Monad---import Debug.Trace----- search for definitions of things--- we do this by looking for the following patterns:--- data XXX = ... giving a datatype location--- newtype XXX = ... giving a newtype location--- bla :: ... giving a function location------ by doing it this way, we avoid picking up local definitions--- (whether this is good or not is a matter for debate)------- We generate both CTAGS and ETAGS format tags files--- The former is for use in most sensible editors, while EMACS uses ETAGS---- alternatives: http://haskell.org/haskellwiki/Tags--{- .hs or literate .lhs haskell file?-Really not a easy question - maybe there is an answer - I don't know--.hs -> non literate haskel file-.lhs -> literate haskell file-.chs -> is this always plain?-.whatsoever -> try to get to know the answer (*)- contains any '> ... ' line -> interpreted as literate- else non literate--(*) This is difficult because- System.Log.Logger is using - {-- [...]- > module Example where- > [...]- -}- module System.Log.Logger(- so it might looks like beeing a .lhs file- My first fix was checking for \\begin occurence (doesn't work because HUnit is using > but no \\begin)- Further ideas: - * use unlit executable distributed with ghc or the like and check for errors?- (Will this work if cpp is used as well ?)- * Remove comments before checking for '> ..'- does'nt work because {- -} may be unbalanced in literate comments- So my solution is : take file extension and keep guessing code for all unkown files--}- ---- Reference: http://ctags.sourceforge.net/FORMAT-main :: IO ()-main = do- progName <- getProgName- args <- getArgs- let usageString = - "Usage: " ++ progName ++ " [OPTION...] [files or directories...]\n"- ++ "directories will be replaced by DIR/**/*.hs DIR/**/*.lhs\n"- ++ "Thus hasktags . tags all important files in the current directory"- let a@(modes, files_or_dirs, errs) = getOpt Permute options args-- filenames <- liftM (nub . concat) $ mapM (dirToFiles False) files_or_dirs-- when (errs /= [] || elem Help modes || files_or_dirs == [])- (do putStr $ unlines errs- putStr $ usageInfo usageString options- exitWith (ExitFailure 1))-- when (filenames == []) $ do- putStrLn "warning: no files found!"-- let mode = getMode (filter ( `elem` [BothTags, CTags, ETags] ) modes)- openFileMode = if elem Append modes- then AppendMode- else WriteMode- filedata <- mapM (findthings (IgnoreCloseImpl `elem` modes)) filenames-- when (mode == CTags)- (do ctagsfile <- getOutFile "tags" openFileMode modes- writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata- hClose ctagsfile)-- when (mode == ETags)- (do etagsfile <- getOutFile "TAGS" openFileMode modes- writeetagsfile etagsfile filedata- hClose etagsfile)-- -- avoid problem when both is used in combination- -- with redirection on stdout- when (mode == BothTags)- (do etagsfile <- getOutFile "TAGS" openFileMode modes- writeetagsfile etagsfile filedata- ctagsfile <- getOutFile "tags" openFileMode modes- writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata- hClose etagsfile- hClose ctagsfile)--dirToFiles :: Bool -> FilePath -> IO [ FilePath ]-dirToFiles hsExtOnly p = do- isD <- doesDirectoryExist p- if isD then recurse p- else return $ if not hsExtOnly || ".hs" `isSuffixOf` p || ".lhs" `isSuffixOf` p then [p] else []- where recurse p = do- names <- liftM (filter ( (/= '.') . head ) ) $ getDirectoryContents p- -- skip . .. and hidden files (linux) - liftM concat $ mapM (processFile . (p </>) ) names- processFile f = dirToFiles True f----- | getMode takes a list of modes and extract the mode with the--- highest precedence. These are as follows: Both, CTags, ETags--- The default case is Both.-getMode :: [Mode] -> Mode-getMode [] = BothTags-getMode xs = maximum xs---- | getOutFile scan the modes searching for output redirection--- if not found, open the file with name passed as parameter.--- Handle special file -, which is stdout-getOutFile :: String -> IOMode -> [Mode] -> IO Handle-getOutFile _ _ ((OutRedir "-"):_) = return stdout-getOutFile _ openMode ((OutRedir f):_) = openFile f openMode-getOutFile name openMode (_:xs) = getOutFile name openMode xs-getOutFile defaultName openMode [] = openFile defaultName openMode--data Mode = ExtendedCtag- | IgnoreCloseImpl- | ETags - | CTags - | BothTags - | Append - | OutRedir String- | Help- deriving (Ord, Eq, Show)--options :: [OptDescr Mode]-options = [ Option "c" ["ctags"]- (NoArg CTags) "generate CTAGS file (ctags)"- , Option "e" ["etags"]- (NoArg ETags) "generate ETAGS file (etags)"- , Option "b" ["both"]- (NoArg BothTags) "generate both CTAGS and ETAGS"- , Option "a" ["append"]- (NoArg Append) "append to existing CTAGS and/or ETAGS file(s). After this file will no longer be sorted!"- , Option "" ["ignore-close-implementation"]- (NoArg IgnoreCloseImpl) "ignores found implementation if its closer than 7 lines - so you can jump to definition in one shot"- , Option "o" ["output"]- (ReqArg OutRedir "") "output to given file, instead of 'tags', '-' file is stdout"- , Option "f" ["file"]- (ReqArg OutRedir "") "same as -o, but used as compatibility with ctags"- , Option "x" ["extendedctag"]- (NoArg ExtendedCtag) "Generate additional information in ctag file."- , Option "h" ["help"] (NoArg Help) "This help"- ]--type FileName = String--type ThingName = String---- The position of a token or definition-data Pos = Pos- FileName -- file name- Int -- line number- Int -- token number- String -- string that makes up that line- deriving (Show, Eq)---- A definition we have found--- I'm not sure wether I've used the right names.. but I hope you fix it / get what I mean-data FoundThingType = FTFuncTypeDef | FTFuncImpl | FTType | FTData | FTDataGADT | FTNewtype | FTClass | FTModule | FTCons | FTOther | FTConsAccessor | FTConsGADT- deriving Eq--instance Show FoundThingType where- show FTFuncTypeDef = "ft"- show FTFuncImpl = "fi"- show FTType = "t"- show FTData = "d"- show FTDataGADT = "d_gadt"- show FTNewtype = "nt"- show FTClass = "c"- show FTModule = "m"- show FTCons = "cons"- show FTConsGADT = "c_gadt"- show FTConsAccessor = "c_a"- show FTOther = "o"--data FoundThing = FoundThing FoundThingType ThingName Pos- deriving (Show, Eq)---- Data we have obtained from a file-data FileData = FileData FileName [FoundThing]--data Token = Token String Pos- | NewLine Int -- space 8*" " = "\t"- deriving (Eq)-instance Show Token where- -- show (Token t (Pos _ l _ _) ) = "Token " ++ t ++ " " ++ (show l)- show (Token t (Pos _ _l _ _) ) = " " ++ t ++ " "- show (NewLine i) = "NewLine " ++ show i--tokenString :: Token -> String-tokenString (Token s _) = s-tokenString (NewLine _) = "\n"--isNewLine :: Maybe Int -> Token -> Bool-isNewLine Nothing (NewLine _) = True-isNewLine (Just c) (NewLine c') = c == c'-isNewLine _ _ = False--trimNewlines :: [Token] -> [Token]-trimNewlines = filter (not . isNewLine Nothing)----- stuff for dealing with ctags output format--writectagsfile :: Handle -> Bool -> [FileData] -> IO ()-writectagsfile ctagsfile extended filedata = do- let things = concatMap getfoundthings filedata- when extended- (do hPutStrLn ctagsfile "!_TAG_FILE_FORMAT\t2\t/extended format; --format=1 will not append ;\" to lines/"- hPutStrLn ctagsfile "!_TAG_FILE_SORTED\t1\t/0=unsorted, 1=sorted, 2=foldcase/"- hPutStrLn ctagsfile "!_TAG_PROGRAM_NAME\thasktags")- mapM_ (hPutStrLn ctagsfile . dumpthing extended) (sortThings things)--sortThings :: [FoundThing] -> [FoundThing]-sortThings = sortBy comp- where - comp (FoundThing _ a (Pos f1 l1 _ _)) (FoundThing _ b (Pos f2 l2 _ _)) =- c (c (compare a b) $ (compare f1 f2)) (compare l1 l2)- c a b = if a == EQ then b else a---getfoundthings :: FileData -> [FoundThing]-getfoundthings (FileData _ things) = things---- | Dump found tag in normal or extended (read : vim like) ctag--- line-dumpthing :: Bool -> FoundThing -> String-dumpthing False (FoundThing _ name (Pos filename line _ _)) =- name ++ "\t" ++ filename ++ "\t" ++ show (line + 1)-dumpthing True (FoundThing kind name (Pos filename line _ lineText)) =- name ++ "\t" ++ filename- ++ "\t/^" ++ concatMap ctagEncode lineText- ++ "$/;\"\t" ++ show kind- ++ "\tline:" ++ show (line + 1)--ctagEncode :: Char -> String-ctagEncode '/' = "\\/"-ctagEncode '\\' = "\\\\"-ctagEncode a = [a]---- stuff for dealing with etags output format--writeetagsfile :: Handle -> [FileData] -> IO ()-writeetagsfile etagsfile = mapM_ (hPutStr etagsfile . etagsDumpFileData)--etagsDumpFileData :: FileData -> String-etagsDumpFileData (FileData filename things) =- "\x0c\n" ++ filename ++ "," ++ show thingslength ++ "\n" ++ thingsdump- where thingsdump = concatMap etagsDumpThing things- thingslength = length thingsdump--etagsDumpThing :: FoundThing -> String-etagsDumpThing (FoundThing _ _name (Pos _filename line token fullline)) =- concat (take (token + 1) $ spacedwords fullline)- ++ "\x7f" ++ show line ++ "," ++ show (line + 1) ++ "\n"----- like "words", but keeping the whitespace, and so letting us build--- accurate prefixes--spacedwords :: String -> [String]-spacedwords [] = []-spacedwords xs = (blanks ++ wordchars) : spacedwords rest2- where (blanks,rest) = span isSpace xs- (wordchars,rest2) = break isSpace rest---- Find the definitions in a file-findthings :: Bool -> FileName -> IO FileData-findthings ignoreCloseImpl filename = do- aslines <- fmap ( lines . evaluate . BS.unpack) $ BS.readFile filename-- let stripNonHaskellLines = let- emptyLine = all (all isSpace . tokenString)- . filter (not . isNewLine Nothing)- cppLine (_nl:t:_) = ("#" `isPrefixOf`) $ tokenString t- cppLine _ = False- in filter (not . emptyLine) . filter (not . cppLine)-- -- remove -- comments, then break each line into tokens (adding line numbers)- -- then remove {- -} comments- -- split by lines again ( to get indent- let (fileLines, numbers) = unzip . fromLiterate filename $ zip aslines [0..]- let tokenLines =- stripNonHaskellLines- $ stripslcomments- $ splitByNL Nothing- $ stripblockcomments- $ concat- $ zipWith3 (withline filename)- (map ( filter (not . all isSpace) . mywords) fileLines)- fileLines- numbers--- -- TODO ($defines / empty lines etc)- -- separate by top level declarations (everything starting with the- -- same topmost indentation is what I call section here)- -- so that z in- -- let x = 7- -- z = 20- -- won't be found as function - let sections = map tail -- strip leading NL (no longer needed - $ filter (not . null)- $ splitByNL (Just (getTopLevelIndent tokenLines) )- $ concat tokenLines- -- only take one of- -- a 'x' = 7- -- a _ = 0- let filterAdjacentFuncImpl = nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _)) - (FoundThing t2 n2 (Pos f2 _ _ _))- -> f1 == f2 && n1 == n2 && t1 == FTFuncImpl && t2 == FTFuncImpl )-- let iCI = if ignoreCloseImpl - then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _)) - (FoundThing _ n2 (Pos f2 l2 _ _))- -> f1 == f2 && n1 == n2 && ( ( <= 7 ) $ abs $ l2 - l1))- else id- return $ FileData filename $ iCI $ filterAdjacentFuncImpl $ concatMap findstuff sections-- where - evaluate :: String -> String - evaluate [] = []- evaluate (c:cs) = c `seq` c:evaluate cs- -- my words is mainly copied from Data.List.- -- difference abc::def is recognized as three words- -- `abc` is recognized as "`" "abc" "`"- mywords :: String -> [String]- mywords ('{':xs) = "{" : mywords xs- mywords ('(':xs) = "(" : mywords xs- mywords ('`':xs) = "`" : mywords xs- mywords ('=':'>':xs) = "=>" : mywords xs- mywords ('=':xs) = "=" : mywords xs- mywords (',':xs) = "," : mywords xs- mywords (':':':':xs) = "::" : mywords xs- mywords s = case dropWhile {-partain:Char.-}isSpace s of- ')':xs -> ")" : mywords xs- "" -> []- s' -> w : mywords s''- where (w, s'') = myBreak s'- myBreak [] = ([],[])- myBreak (':':':':xs) = ([], "::"++xs)- myBreak (')':xs) = ([],')':xs)- myBreak ('(':xs) = ([],'(':xs)- myBreak ('`':xs) = ([],'`':xs)- myBreak ('=':xs) = ([],'=':xs)- myBreak (',':xs) = ([],',':xs)- myBreak (' ':xs) = ([],xs);- myBreak (x:xs) = let (a,b) = myBreak xs - in (x:a,b)- --- Create tokens from words, by recording their line number--- and which token they are through that line--withline :: FileName -> [String] -> String -> Int -> [Token]-withline filename sourceWords fullline i =- let countSpaces (' ':xs) = 1 + countSpaces xs- countSpaces ('\t':xs) = 8 + countSpaces xs- countSpaces _ = 0- in NewLine (countSpaces fullline)- : zipWith (\w t -> Token w (Pos filename i t fullline)) sourceWords [1 ..]---- comments stripping--stripslcomments :: [[Token]] -> [[Token]]-stripslcomments = let f ((NewLine _):(Token "--" _):_) = False- f _ = True- in filter f--stripblockcomments :: [Token] -> [Token]-stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs-stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs-stripblockcomments (x:xs) = x:stripblockcomments xs-stripblockcomments [] = []--afterlitend :: [Token] -> [Token]-afterlitend (Token "\\begin{code}" _ : xs) = xs-afterlitend (_ : xs) = afterlitend xs-afterlitend [] = []--afterblockcomend :: [Token] -> [Token]-afterblockcomend (t:xs)- | contains "-}" (tokenString t) = xs- | otherwise = afterblockcomend xs-afterblockcomend [] = []----- does one string contain another string--contains :: Eq a => [a] -> [a] -> Bool-contains sub = any (isPrefixOf sub) . tails---- actually pick up definitions--findstuff :: [Token] -> [FoundThing]-findstuff ((Token "module" _):(Token name pos):_) =- [FoundThing FTModule name pos] -- nothing will follow this section-findstuff ((Token "data" _):(Token name pos):xs)- | any ( (== "where"). tokenString ) xs -- GADT - -- TODO will be found as FTCons (not FTConsGADT), the same for functions - but they are found :) - = FoundThing FTDataGADT name pos : getcons2 xs ++ fromWhereOn xs -- ++ (findstuff xs)- | otherwise = FoundThing FTData name pos : getcons FTData (trimNewlines xs)-- ++ (findstuff xs)-findstuff ((Token "newtype" _):ts@(((Token name pos)):_)) =- FoundThing FTNewtype name pos : getcons FTCons (trimNewlines ts)-- ++ (findstuff xs)- -- FoundThing FTNewtype name pos : findstuff xs-findstuff ((Token "type" _):(Token name pos):xs) =- FoundThing FTType name pos : findstuff xs-findstuff ((Token "class" _):xs) = case break ((== "where").tokenString) xs of- (ys,[]) -> maybeToList $ className ys- (_,r) -> maybe [] (:fromWhereOn r) $ className xs- where isParenOpen (Token "(" _) = True- isParenOpen _ = False- className lst = case (head . dropWhile isParenOpen . reverse . takeWhile ((/= "=>").tokenString) . reverse) lst of- (Token name p) -> Just $ FoundThing FTClass name p- _ -> Nothing-findstuff xs = findFunc xs ++ findFuncTypeDefs [] xs--findFuncTypeDefs :: [Token] -> [Token] -> [FoundThing]-findFuncTypeDefs found (t@(Token _ _): Token "," _ :xs) =- findFuncTypeDefs (t : found) xs-findFuncTypeDefs found (t@(Token _ _): Token "::" _ :_) =- map (\(Token name p) -> FoundThing FTFuncTypeDef name p) (t:found)-findFuncTypeDefs found (Token "(" _ :xs) =- case break myBreakF xs of- (inner@((Token _ p):_), _:xs') ->- let merged = Token ( concatMap (\(Token x _) -> x) inner ) p- in findFuncTypeDefs found $ merged : xs'- _ -> []- where myBreakF (Token ")" _) = True- myBreakF _ = False -findFuncTypeDefs _ _ = []--fromWhereOn :: [Token] -> [FoundThing]-fromWhereOn [] = []-fromWhereOn [_] = []-fromWhereOn (_: xs@((NewLine _):_)) =- concatMap (findstuff . tail')- $ splitByNL (Just ( minimum- . (10000:)- . map (\(NewLine i) -> i)- . filter (isNewLine Nothing) $ xs)) xs-fromWhereOn (_:xw) = findstuff xw--findFunc :: [Token] -> [FoundThing]-findFunc x = case findInfix x of- a@(_:_) -> a- _ -> findF x--findInfix :: [Token] -> [FoundThing]-findInfix x = case dropWhile ((/= "`"). tokenString) (takeWhile ( (/= "=") . tokenString) x) of- _:(Token name p):_ -> [FoundThing FTFuncImpl name p]- _ -> []---findF :: [Token] -> [FoundThing]-findF ((Token name p):xs) =- [FoundThing FTFuncImpl name p | any (("=" ==) . tokenString) xs]-findF _ = []--tail' :: [a] -> [a]-tail' (_:xs) = xs-tail' [] = []---- get the constructor definitions, knowing that a datatype has just started--getcons :: FoundThingType -> [Token] -> [FoundThing]-getcons ftt ((Token "=" _):(Token name pos):xs) =- FoundThing ftt name pos : getcons2 xs-getcons ftt (_:xs) = getcons ftt xs-getcons _ [] = []---getcons2 :: [Token] -> [FoundThing]-getcons2 ((Token name pos):(Token "::" _):xs) =- FoundThing FTConsAccessor name pos : getcons2 xs-getcons2 ((Token "=" _):_) = []-getcons2 ((Token "|" _):(Token name pos):xs) =- FoundThing FTCons name pos : getcons2 xs-getcons2 (_:xs) = getcons2 xs-getcons2 [] = []---splitByNL :: (Maybe Int) -> [Token] -> [[Token]]-splitByNL maybeIndent (nl@(NewLine _):ts) =- let (a,b) = break (isNewLine maybeIndent) ts- in (nl : a) : splitByNL maybeIndent b-splitByNL _ _ = []--getTopLevelIndent :: [[Token]] -> Int-getTopLevelIndent [] = 0 -- (no import found , assuming indent 0 : this can be- -- done better but should suffice for most needs-getTopLevelIndent (x:xs) = if any ((=="import") . tokenString) x- then let ((NewLine i):_) = x in i- else getTopLevelIndent xs---- removes literate stuff if any line '> ... ' is found and any word is \begin (hglogger has ^> in it's commetns)-fromLiterate :: FilePath -> [(String, Int)] -> [(String, Int)]-fromLiterate file lines = - let literate = [ (ls, n) | ('>':ls, n) <- lines ]- in if ".lhs" `isSuffixOf` file && (not . null $ literate) then literate -- not . null literate because of Repair.lhs of darcs - else if (".hs" `isSuffixOf` file)- || (null literate || not ( any ( any ("\\begin" `isPrefixOf`). words . fst) lines))- then lines- else literate--{- testcase:--checkToBeFound(){- toBeFound=$(sed -n 's/-- to be found\s*//p' testcase.hs)- for i in $toBeFound; do- grep -l $i tags 2>&1 > /dev/null || echo "tag $i was not found"- done- echo -n "to be found ocunt: "- echo "$toBeFound" | wc -l-}---- to be found A.B.testcase-module A.B.testcase(module System.FilePath.Windows) where- import asdf---- to be found Request--- to be found Request2--- to be found rqBody--- to be found rqMethod--- to be found rqPeer--- to be found Request3- data Request = Request2 { rqMethod::Method,- rqBody :: RqBody,- rqPeer :: Host- }- | Request3-deriving(Show,Read,Typeable)- -- http://hackage.haskell.org/trac/ghc/ticket/1184- -- ! Convert Bool into another monad--- to be found boolM- boolM False = mzero---- to be found sadlkfj- sadlkfj- = 7---- to be found onlyTheFirstOne- onlyTheFirstOne (x:xs) = 8- onlyTheFirstOne [] = 8--- to be found AC- AC a b c d e f g = 7--- to be found abc- abc = let a = 7- b = 8- in a + b- where x = 34- o = 423--- to be found BB--- to be found AA- AA, BB :: Int----- to be found foo- ad `foo` oh = 90---- to be found X--- to be found xyz- class (A a) => X a where- xyz :: dummy--- to be found Z--- to be found o- class (A a) => Z a where o :: Int---- to be found ABC- newtype ABC = Int--- to be found DBM- newtype IE.ISession sess => DBM mark sess a = DBM (ReaderT sess IO a)--- to be found SAA-newtype Symbol = SAA String---- TODO ---- to be found =~-(=~) :: (Regex rho) => String -> rho -> Bool--}
+ src/Hasktags.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- should this be named Data.Hasktags or such?+module Hasktags (+ FileData,+ findWithCache,+ findThings,+ findThingsInBS,++ Mode(..),+ -- TODO think about these: Must they be exported ?+ getMode,+ getOutFile+) where++import Tags++-- the lib+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.List+import Data.Maybe++import System.IO+import System.Directory+import Text.JSON.Generic+import Control.Monad++import DebugShow++-- search for definitions of things+-- we do this by looking for the following patterns:+-- data XXX = ... giving a datatype location+-- newtype XXX = ... giving a newtype location+-- bla :: ... giving a function location+--+-- by doing it this way, we avoid picking up local definitions+-- (whether this is good or not is a matter for debate)+--++-- We generate both CTAGS and ETAGS format tags files+-- The former is for use in most sensible editors, while EMACS uses ETAGS++-- alternatives: http://haskell.org/haskellwiki/Tags++{- .hs or literate .lhs haskell file?+Really not a easy question - maybe there is an answer - I don't know++.hs -> non literate haskel file+.lhs -> literate haskell file+.chs -> is this always plain?+.whatsoever -> try to get to know the answer (*)+ contains any '> ... ' line -> interpreted as literate+ else non literate++(*) This is difficult because+ System.Log.Logger is using+ {-+ [...]+ > module Example where+ > [...]+ -}+ module System.Log.Logger(+ so it might looks like beeing a .lhs file+ My first fix was checking for \\begin occurence (doesn't work because HUnit is+ using > but no \\begin)+ Further ideas:+ * use unlit executable distributed with ghc or the like and check for+ errors?+ (Will this work if cpp is used as well ?)+ * Remove comments before checking for '> ..'+ does'nt work because {- -} may be unbalanced in literate comments+ So my solution is : take file extension and keep guessing code for all unkown+ files+-}+++-- Reference: http://ctags.sourceforge.net/FORMAT+++-- | getMode takes a list of modes and extract the mode with the+-- highest precedence. These are as follows: Both, CTags, ETags+-- The default case is Both.+getMode :: [Mode] -> Mode+getMode [] = BothTags+getMode xs = maximum xs++-- | getOutFile scan the modes searching for output redirection+-- if not found, open the file with name passed as parameter.+-- Handle special file -, which is stdout+getOutFile :: String -> IOMode -> [Mode] -> IO Handle+getOutFile _ _ (OutRedir "-" : _) = return stdout+getOutFile _ openMode (OutRedir f : _) = openFile f openMode+getOutFile name openMode (_:xs) = getOutFile name openMode xs+getOutFile defaultName openMode [] = openFile+ defaultName+ openMode++data Mode = ExtendedCtag+ | IgnoreCloseImpl+ | ETags+ | CTags+ | BothTags+ | Append+ | OutRedir String+ | CacheFiles+ | FollowDirectorySymLinks+ | Help+ | HsSuffixes [String]+ deriving (Ord, Eq, Show)++data Token = Token String Pos+ | NewLine Int -- space 8*" " = "\t"+ deriving (Eq)+instance Show Token where+ -- show (Token t (Pos _ l _ _) ) = "Token " ++ t ++ " " ++ (show l)+ show (Token t (Pos _ _l _ _) ) = " " ++ t ++ " "+ show (NewLine i) = "NewLine " ++ show i++tokenString :: Token -> String+tokenString (Token s _) = s+tokenString (NewLine _) = "\n"++isNewLine :: Maybe Int -> Token -> Bool+isNewLine Nothing (NewLine _) = True+isNewLine (Just c) (NewLine c') = c == c'+isNewLine _ _ = False++trimNewlines :: [Token] -> [Token]+trimNewlines = filter (not . isNewLine Nothing)++-- Find the definitions in a file, or load from cache if the file+-- hasn't changed since last time.+findWithCache :: Bool -> Bool -> FileName -> IO FileData+findWithCache cache ignoreCloseImpl filename = do+ cacheExists <- if cache then doesFileExist cacheFilename else return False+ if cacheExists+ then do fileModified <- getModificationTime filename+ cacheModified <- getModificationTime cacheFilename+ if cacheModified > fileModified+ then do bytes <- BS.readFile cacheFilename+ return (decodeJSON (BS.unpack bytes))+ else findAndCache+ else findAndCache++ where cacheFilename = filenameToTagsName filename+ filenameToTagsName = (++"tags") . reverse . dropWhile (/='.') . reverse+ findAndCache = do+ filedata <- findThings ignoreCloseImpl filename+ when cache (writeFile cacheFilename (encodeJSON filedata))+ return filedata++-- Find the definitions in a file+findThings :: Bool -> FileName -> IO FileData+findThings ignoreCloseImpl filename =+ fmap (findThingsInBS ignoreCloseImpl filename) $ BS.readFile filename++findThingsInBS :: Bool -> String -> BS.ByteString -> FileData+findThingsInBS ignoreCloseImpl filename bs = do+ let aslines = lines $ BS.unpack bs++ let stripNonHaskellLines = let+ emptyLine = all (all isSpace . tokenString)+ . filter (not . isNewLine Nothing)+ cppLine (_nl:t:_) = ("#" `isPrefixOf`) $ tokenString t+ cppLine _ = False+ in filter (not . emptyLine) . filter (not . cppLine)++ let debugStep m = (\s -> trace_ (m ++ " result") s s)++ let (isLiterate, slines) =+ debugStep "fromLiterate"+ $ fromLiterate filename+ $ zip aslines [0..]++ -- remove -- comments, then break each line into tokens (adding line+ -- numbers)+ -- then remove {- -} comments+ -- split by lines again ( to get indent+ let+ (fileLines, numbers)+ = unzip slines++ let tokenLines {- :: [[Token]] -} =+ debugStep "stripNonHaskellLines" $ stripNonHaskellLines+ $ debugStep "stripslcomments" $ stripslcomments+ $ debugStep "splitByNL" $ splitByNL Nothing+ $ debugStep "stripblockcomments pipe" $ stripblockcomments+ $ concat+ $ zipWith3 (withline filename)+ (map+ (filter (not . all isSpace) . mywords False)+ fileLines)+ fileLines+ numbers+++ -- TODO ($defines / empty lines etc)+ -- separate by top level declarations (everything starting with the+ -- same topmost indentation is what I call section here)+ -- so that z in+ -- let x = 7+ -- z = 20+ -- won't be found as function+ let topLevelIndent = debugStep "top level indent" $ getTopLevelIndent isLiterate tokenLines+ let sections = map tail -- strip leading NL (no longer needed+ $ filter (not . null)+ $ splitByNL (Just (topLevelIndent) )+ $ concat (trace_ "tokenLines" tokenLines tokenLines)+ -- only take one of+ -- a 'x' = 7+ -- a _ = 0+ let filterAdjacentFuncImpl = nubBy (\(FoundThing t1 n1 (Pos f1 _ _ _))+ (FoundThing t2 n2 (Pos f2 _ _ _))+ -> f1 == f2+ && n1 == n2+ && t1 == FTFuncImpl+ && t2 == FTFuncImpl )++ let iCI = if ignoreCloseImpl+ then nubBy (\(FoundThing _ n1 (Pos f1 l1 _ _))+ (FoundThing _ n2 (Pos f2 l2 _ _))+ -> f1 == f2+ && n1 == n2+ && ((<= 7) $ abs $ l2 - l1))+ else id+ let things = iCI $ filterAdjacentFuncImpl $ concatMap findstuff $ map (\s -> trace_ "section in findThingsInBS" s s) sections+ let+ -- If there's a module with the same name of another definition, we+ -- are not interested in the module, but only in the definition.+ uniqueModuleName (FoundThing FTModule moduleName _)+ = not+ $ any (\(FoundThing thingType thingName _)+ -> thingType /= FTModule && thingName == moduleName) things+ uniqueModuleName _ = True+ FileData filename $ filter uniqueModuleName things++-- Create tokens from words, by recording their line number+-- and which token they are through that line++withline :: FileName -> [String] -> String -> Int -> [Token]+withline filename sourceWords fullline i =+ let countSpaces (' ':xs) = 1 + countSpaces xs+ countSpaces ('\t':xs) = 8 + countSpaces xs+ countSpaces _ = 0+ in NewLine (countSpaces fullline)+ : zipWith (\w t -> Token w (Pos filename i t fullline)) sourceWords [1 ..]++-- comments stripping++stripslcomments :: [[Token]] -> [[Token]]+stripslcomments = let f (NewLine _ : Token "--" _ : _) = False+ f _ = True+ in filter f++stripblockcomments :: [Token] -> [Token]+stripblockcomments (Token "\\end{code}" pos : xs) =+ trace_ "stripblockcomments end{code} found at " (show pos) $+ afterlitend xs+stripblockcomments (Token "{-" pos : xs) =+ trace_ "{- found at " (show pos) $+ afterblockcomend xs+stripblockcomments (x:xs) = x:stripblockcomments xs+stripblockcomments [] = []++afterlitend :: [Token] -> [Token]+afterlitend (Token "\\begin{code}" pos : xs) = + trace_ "stripblockcomments begin{code} found at " (show pos) $+ stripblockcomments xs+afterlitend (_ : xs) = afterlitend xs+afterlitend [] = []++afterblockcomend :: [Token] -> [Token]+afterblockcomend (t@(Token _ pos):xs)+ | contains "-}" (tokenString t) =+ trace_ "-} found at " (show pos) $+ stripblockcomments xs+ | otherwise = afterblockcomend xs+afterblockcomend [] = []+afterblockcomend (_:xs) = afterblockcomend xs+++-- does one string contain another string++contains :: Eq a => [a] -> [a] -> Bool+contains sub = any (isPrefixOf sub) . tails++-- actually pick up definitions++findstuff :: [Token] -> [FoundThing]+findstuff (Token "module" _ : Token name pos : _) =+ trace_ "module" pos $+ [FoundThing FTModule name pos] -- nothing will follow this section+findstuff tokens@(Token "data" _ : Token name pos : xs)+ | any ( (== "where"). tokenString ) xs -- GADT+ -- TODO will be found as FTCons (not FTConsGADT), the same for+ -- functions - but they are found :)+ =+ trace_ "findstuff data b1" tokens $+ FoundThing FTDataGADT name pos+ : getcons2 xs ++ fromWhereOn xs -- ++ (findstuff xs)+ | otherwise+ =+ trace_ "findstuff data otherwise" tokens $+ FoundThing FTData name pos+ : getcons FTData (trimNewlines xs)-- ++ (findstuff xs)+findstuff tokens@(Token "newtype" _ : ts@(Token name pos : _)) =+ trace_ "findstuff newtype" tokens $+ FoundThing FTNewtype name pos+ : getcons FTCons (trimNewlines ts)-- ++ (findstuff xs)+ -- FoundThing FTNewtype name pos : findstuff xs+findstuff tokens@(Token "type" _ : Token name pos : xs) =+ trace_ "findstuff type" tokens $+ FoundThing FTType name pos : findstuff xs+findstuff tokens@(Token "class" _ : xs) =+ trace_ "findstuff class" tokens $+ case (break ((== "where").tokenString) xs) of+ (ys, []) ->+ trace_ "findstuff class b1 " ys $+ maybeToList $ className ys+ (ys, r) ->+ trace_ "findstuff class b2 " (ys, r) $+ (maybeToList $ className ys)+ ++ (maybe [] (:fromWhereOn r) $ className xs)+ where isParenOpen (Token "(" _) = True+ isParenOpen _ = False+ className lst+ = case (head+ . dropWhile isParenOpen+ . reverse+ . takeWhile ((/= "=>") . tokenString)+ . reverse) lst of+ (Token name p) -> Just $ FoundThing FTClass name p+ _ -> Nothing+findstuff xs =+ trace_ "findstuff rest " xs $+ findFunc xs ++ findFuncTypeDefs [] xs++findFuncTypeDefs :: [Token] -> [Token] -> [FoundThing]+findFuncTypeDefs found (t@(Token _ _): Token "," _ :xs) =+ findFuncTypeDefs (t : found) xs+findFuncTypeDefs found (t@(Token _ _): Token "::" _ :_) =+ map (\(Token name p) -> FoundThing FTFuncTypeDef name p) (t:found)+findFuncTypeDefs found (Token "(" _ :xs) =+ case break myBreakF xs of+ (inner@(Token _ p : _), _:xs') ->+ let merged = Token ( concatMap (\(Token x _) -> x) inner ) p+ in findFuncTypeDefs found $ merged : xs'+ _ -> []+ where myBreakF (Token ")" _) = True+ myBreakF _ = False+findFuncTypeDefs _ _ = []++fromWhereOn :: [Token] -> [FoundThing]+fromWhereOn [] = []+fromWhereOn [_] = []+fromWhereOn (_: xs@(NewLine _ : _)) =+ concatMap (findstuff . tail')+ $ splitByNL (Just ( minimum+ . (10000:)+ . map (\(NewLine i) -> i)+ . filter (isNewLine Nothing) $ xs)) xs+fromWhereOn (_:xw) = findstuff xw++findFunc :: [Token] -> [FoundThing]+findFunc x = case findInfix x of+ a@(_:_) -> a+ _ -> findF x++findInfix :: [Token] -> [FoundThing]+findInfix x+ = case dropWhile+ ((/= "`"). tokenString)+ (takeWhile ( (/= "=") . tokenString) x) of+ _ : Token name p : _ -> [FoundThing FTFuncImpl name p]+ _ -> []+++findF :: [Token] -> [FoundThing]+findF (Token name p : xs) =+ [FoundThing FTFuncImpl name p | any (("=" ==) . tokenString) xs]+findF _ = []++tail' :: [a] -> [a]+tail' (_:xs) = xs+tail' [] = []++-- get the constructor definitions, knowing that a datatype has just started++getcons :: FoundThingType -> [Token] -> [FoundThing]+getcons ftt (Token "=" _: Token name pos : xs) =+ FoundThing ftt name pos : getcons2 xs+getcons ftt (_:xs) = getcons ftt xs+getcons _ [] = []+++getcons2 :: [Token] -> [FoundThing]+getcons2 (Token name pos : Token "::" _ : xs) =+ FoundThing FTConsAccessor name pos : getcons2 xs+getcons2 (Token "=" _ : _) = []+getcons2 (Token "|" _ : Token name pos : xs) =+ FoundThing FTCons name pos : getcons2 xs+getcons2 (_:xs) = getcons2 xs+getcons2 [] = []+++splitByNL :: Maybe Int -> [Token] -> [[Token]]+splitByNL maybeIndent (nl@(NewLine _):ts) =+ let (a,b) = break (isNewLine maybeIndent) ts+ in (nl : a) : splitByNL maybeIndent b+splitByNL _ _ = []++-- this only exists for test case testcases/HUnitBase.lhs (bird literate haskell style)+getTopLevelIndent :: Bool -> [[Token]] -> Int+getTopLevelIndent isLiterate [] = 0 -- (no import found , assuming indent 0 : this can be+ -- done better but should suffice for most needs+getTopLevelIndent isLiterate ((nl:next:rest):xs) = if "import" == (tokenString next)+ then let (NewLine i) = nl in i+ else getTopLevelIndent isLiterate xs+getTopLevelIndent isLiterate (_:xs) = getTopLevelIndent isLiterate xs++-- removes literate stuff if any line '> ... ' is found and any word is \begin+-- (hglogger has ^> in it's comments)+fromLiterate :: FilePath -> [(String, Int)] + -> (Bool -- is literate+ , [(String, Int)])+fromLiterate file lns =+ let literate = [ (ls, n) | ('>':ls, n) <- lns ]+ -- not . null literate because of Repair.lhs of darcs+ in if ".lhs" `isSuffixOf` file && (not . null $ literate) then (True, literate)+ else if (".hs" `isSuffixOf` file)+ || (null literate+ || not ( any ( any ("\\begin" `isPrefixOf`). words . fst) lns))+ then (False, lns)+ else (True, literate)
+ src/Main.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+module Main (main) where+import Hasktags+import Tags++import System.Environment+import Interlude+import Data.List++import System.IO+import System.Directory+#ifdef VERSION_unix+import System.Posix.Files+#endif+import System.FilePath ((</>))+import System.Console.GetOpt+import System.Exit+import Control.Monad++options :: [OptDescr Mode]+options = [ Option "c" ["ctags"]+ (NoArg CTags) "generate CTAGS file (ctags)"+ , Option "e" ["etags"]+ (NoArg ETags) "generate ETAGS file (etags)"+ , Option "b" ["both"]+ (NoArg BothTags) "generate both CTAGS and ETAGS"+ , Option "a" ["append"]+ (NoArg Append)+ $ "append to existing CTAGS and/or ETAGS file(s). After this file "+ ++ "will no longer be sorted!"+ , Option "" ["ignore-close-implementation"]+ (NoArg IgnoreCloseImpl)+ $ "ignores found implementation if its closer than 7 lines - so "+ ++ "you can jump to definition in one shot"+ , Option "o" ["output"]+ (ReqArg OutRedir "")+ "output to given file, instead of 'tags', '-' file is stdout"+ , Option "f" ["file"]+ (ReqArg OutRedir "")+ "same as -o, but used as compatibility with ctags"+ , Option "x" ["extendedctag"]+ (NoArg ExtendedCtag) "Generate additional information in ctag file."+ , Option "" ["cache"] (NoArg CacheFiles) "Cache file data."+ , Option "L" ["follow-symlinks"] (NoArg FollowDirectorySymLinks) "follow symlinks when recursing directories"+ , Option "S" ["suffixes"] (OptArg suffStr ".hs,.lhs") "list of hs suffixes including \".\""+ , Option "h" ["help"] (NoArg Help) "This help"+ ]+ where suffStr Nothing = HsSuffixes [ ".hs", ".lhs" ]+ suffStr (Just s) = HsSuffixes $ strToSuffixes s+ strToSuffixes = lines . map commaToEOL+ commaToEOL ',' = '\n'+ commaToEOL x = x+++main :: IO ()+main = do+ progName <- getProgName+ args <- getArgs+ let usageString =+ "Usage: " ++ progName+ ++ " [OPTION...] [files or directories...]\n"+ ++ "directories will be replaced by DIR/**/*.hs DIR/**/*.lhs\n"+ ++ "Thus hasktags . tags all important files in the current\n"+ ++ "directory.\n"+ ++ "\n"+ ++ "If directories are symlinks they will not be followed\n"+ ++ "unless you pass -L.\n"+ ++ "\n"+ ++ "A special file \"STDIN\" will make hasktags read the line separated file\n"+ ++ "list to be tagged from STDIN.\n"+ let (modes, files_or_dirs, errs) = getOpt Permute options args++ let hsSuffixes = head [ s | (HsSuffixes s) <- modes ]++ let followSymLinks = FollowDirectorySymLinks `elem` modes++ filenames+ <- liftM (nub . concat) $ mapM (dirToFiles followSymLinks hsSuffixes) files_or_dirs++ when (errs /= [] || elem Help modes || files_or_dirs == [])+ (do putStr $ unlines errs+ putStr $ usageInfo usageString options+ exitWith (ExitFailure 1))++ when (filenames == []) $ putStrLn "warning: no files found!"++ let mode = getMode (filter ( `elem` [BothTags, CTags, ETags] ) modes)+ openFileMode = if Append `elem` modes+ then AppendMode+ else WriteMode+ filedata <- mapM (findWithCache (CacheFiles `elem` modes)+ (IgnoreCloseImpl `elem` modes))+ filenames++ when (mode == CTags)+ (do ctagsfile <- getOutFile "tags" openFileMode modes+ writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata+ hClose ctagsfile)++ when (mode == ETags)+ (do etagsfile <- getOutFile "TAGS" openFileMode modes+ writeetagsfile etagsfile filedata+ hClose etagsfile)++ -- avoid problem when both is used in combination+ -- with redirection on stdout+ when (mode == BothTags)+ (do etagsfile <- getOutFile "TAGS" openFileMode modes+ writeetagsfile etagsfile filedata+ ctagsfile <- getOutFile "tags" openFileMode modes+ writectagsfile ctagsfile (ExtendedCtag `elem` modes) filedata+ hClose etagsfile+ hClose ctagsfile)++-- suffixes: [".hs",".lhs"], use "" to match all files+dirToFiles :: Bool -> [String] -> FilePath -> IO [ FilePath ]+dirToFiles _ _ "STDIN" = fmap lines $ hGetContents stdin+dirToFiles followSyms suffixes p = do+ isD <- doesDirectoryExist p+ isSymLink <-+#ifdef VERSION_unix+ isSymbolicLink `fmap` getSymbolicLinkStatus p+#else+ return False+#endif+ case isD of+ False -> return $ if matchingSuffix then [p] else []+ True ->+ if isSymLink && not followSyms+ then return []+ else do+ -- filter . .. and hidden files .*+ contents <- filter ((/=) '.' . head) `fmap` getDirectoryContents p+ concat `fmap` (mapM (dirToFiles followSyms suffixes . (</>) p) contents)+ where matchingSuffix = any (`isSuffixOf` p) suffixes
+ src/Tags.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- everyting tagfile related ..+-- this should be moved into its own library (after cleaning up most of it ..)+-- yes, this is still specific to hasktags :(+module Tags where+import Data.Char+import Data.List+import Data.Data++import System.IO+import Control.Monad++-- my words is mainly copied from Data.List.+-- difference abc::def is recognized as three words+-- `abc` is recognized as "`" "abc" "`"+mywords :: Bool -> String -> [String]+mywords spaced s = case rest of+ ')':xs -> (blanks' ++ ")") : mywords spaced xs+ "" -> []+ '{':'-':xs -> (blanks' ++ "{-") : mywords spaced xs+ '-':'}':xs -> (blanks' ++ "-}") : mywords spaced xs+ '{':xs -> (blanks' ++ "{") : mywords spaced xs+ '(':xs -> (blanks' ++ "(") : mywords spaced xs+ '`':xs -> (blanks' ++ "`") : mywords spaced xs+ '=':'>':xs -> (blanks' ++ "=>") : mywords spaced xs+ '=':xs -> (blanks' ++ "=") : mywords spaced xs+ ',':xs -> (blanks' ++ ",") : mywords spaced xs+ ':':':':xs -> (blanks' ++ "::") : mywords spaced xs+ s' -> (blanks' ++ w) : mywords spaced s''+ where (w, s'') = myBreak s'+ myBreak [] = ([],[])+ myBreak (':':':':xs) = ([], "::"++xs)+ myBreak (')':xs) = ([],')':xs)+ myBreak ('(':xs) = ([],'(':xs)+ myBreak ('`':xs) = ([],'`':xs)+ myBreak ('=':xs) = ([],'=':xs)+ myBreak (',':xs) = ([],',':xs)+ myBreak xss@(x:xs)+ | isSpace x+ = if spaced+ then ([], xss)+ else ([], dropWhile isSpace xss)+ | otherwise = let (a,b) = myBreak xs+ in (x:a,b)+ where blanks' = if spaced then blanks else ""+ (blanks, rest) = span {-partain:Char.-}isSpace s+++type FileName = String++type ThingName = String++-- The position of a token or definition+data Pos = Pos+ FileName -- file name+ Int -- line number+ Int -- token number+ String -- string that makes up that line+ deriving (Show,Eq,Typeable,Data)++-- A definition we have found+-- I'm not sure wether I've used the right names.. but I hope you fix it / get+-- what I mean+data FoundThingType+ = FTFuncTypeDef+ | FTFuncImpl+ | FTType+ | FTData+ | FTDataGADT+ | FTNewtype+ | FTClass+ | FTModule+ | FTCons+ | FTOther+ | FTConsAccessor+ | FTConsGADT+ deriving (Eq,Typeable,Data)++instance Show FoundThingType where+ show FTFuncTypeDef = "ft"+ show FTFuncImpl = "fi"+ show FTType = "t"+ show FTData = "d"+ show FTDataGADT = "d_gadt"+ show FTNewtype = "nt"+ show FTClass = "c"+ show FTModule = "m"+ show FTCons = "cons"+ show FTConsGADT = "c_gadt"+ show FTConsAccessor = "c_a"+ show FTOther = "o"++data FoundThing = FoundThing FoundThingType ThingName Pos+ deriving (Show,Eq,Typeable,Data)++-- Data we have obtained from a file+data FileData = FileData FileName [FoundThing]+ deriving (Typeable,Data,Show)++getfoundthings :: FileData -> [FoundThing]+getfoundthings (FileData _ things) = things++ctagEncode :: Char -> String+ctagEncode '/' = "\\/"+ctagEncode '\\' = "\\\\"+ctagEncode a = [a]++-- | Dump found tag in normal or extended (read : vim like) ctag+-- line+dumpthing :: Bool -> FoundThing -> String+dumpthing False (FoundThing _ name (Pos filename line _ _)) =+ name ++ "\t" ++ filename ++ "\t" ++ show (line + 1)+dumpthing True (FoundThing kind name (Pos filename line _ lineText)) =+ name ++ "\t" ++ filename+ ++ "\t/^" ++ concatMap ctagEncode lineText+ ++ "$/;\"\t" ++ show kind+ ++ "\tline:" ++ show (line + 1)+++-- stuff for dealing with ctags output format+writectagsfile :: Handle -> Bool -> [FileData] -> IO ()+writectagsfile ctagsfile extended filedata = do+ let things = concatMap getfoundthings filedata+ when extended+ (do hPutStrLn+ ctagsfile+ $ "!_TAG_FILE_FORMAT\t2\t/extended format; --format=1 will not "+ ++ "append ;\" to lines/"+ hPutStrLn+ ctagsfile+ "!_TAG_FILE_SORTED\t1\t/0=unsorted, 1=sorted, 2=foldcase/"+ hPutStrLn ctagsfile "!_TAG_PROGRAM_NAME\thasktags")+ mapM_ (hPutStrLn ctagsfile . dumpthing extended) (sortThings things)++sortThings :: [FoundThing] -> [FoundThing]+sortThings = sortBy comp+ where+ comp (FoundThing _ a (Pos f1 l1 _ _)) (FoundThing _ b (Pos f2 l2 _ _)) =+ c (c (compare a b) (compare f1 f2)) (compare l1 l2)+ c a b = if a == EQ then b else a+++-- stuff for dealing with etags output format++writeetagsfile :: Handle -> [FileData] -> IO ()+writeetagsfile etagsfile = mapM_ (hPutStr etagsfile . etagsDumpFileData)++etagsDumpFileData :: FileData -> String+etagsDumpFileData (FileData filename things) =+ "\x0c\n" ++ filename ++ "," ++ show thingslength ++ "\n" ++ thingsdump+ where thingsdump = concatMap etagsDumpThing things+ thingslength = length thingsdump++etagsDumpThing :: FoundThing -> String+etagsDumpThing (FoundThing _ name (Pos _filename line token fullline)) =+ let wrds = mywords True fullline+ in concat (take token wrds ++ map (take 1) (take 1 $ drop token wrds))+ ++ "\x7f"+ ++ name ++ "\x01"+ ++ show line ++ "," ++ show (line + 1) ++ "\n"+
+ testcases/HUnitBase.lhs view
@@ -0,0 +1,253 @@+HUnitBase.lhs -- basic definitions++-- to be found assertEqual+-- to be found ListAssertable+-- to be found AssertionPredicable+-- to be found @?+-- to be found @=?+-- to be found @?=+-- to be found Path+-- to be found testCaseCount+-- to be found Testable+-- to be found ~?+-- to be found ~=?+-- to be found ~?=+-- to be found ~:+-- to be found State+-- to be found ReportProblem+-- to be found testCasePaths+-- to be found performTest+-- to be found Test+-- to be found Assertable+-- to be found ListAssertable+-- to be found AssertionPredicate+-- to be found testCasePaths+-- to be found performTest+++> module Test.HUnit.Base+> (+> {- from Test.HUnit.Lang: -} Assertion, assertFailure,+> assertString, assertBool, assertEqual,+> Assertable(ftp://ftp.videolan.org/pub/videolan/x264/snapshots/x264-snapshot-20080519-2245.tar.bz2..), ListAssertable(..),+> AssertionPredicate, AssertionPredicable(..),+> (@?), (@=?), (@?=),+> Test(..), Node(..), Path,+> testCaseCount,+> Testable(..),+> (~?), (~=?), (~?=), (~:),+> Counts(..), State(..),+> ReportStart, ReportProblem,+> testCasePaths,+> performTest+> )+> where++> import Control.Monad (unless, foldM)+++Assertion Definition+====================++> import Test.HUnit.Lang+++Conditional Assertion Functions+-------------------------------++> assertBool :: String -> Bool -> Assertion+> assertBool msg b = unless b (assertFailure msg)++> assertString :: String -> Assertion+> assertString s = unless (null s) (assertFailure s)++> assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion+> assertEqual preface expected actual =+> unless (actual == expected) (assertFailure msg)+> where msg = (if null preface then "" else preface ++ "\n") +++> "expected: " ++ show expected ++ "\n but got: " ++ show actual+++Overloaded `assert` Function+----------------------------++> class Assertable t+> where assert :: t -> Assertion++> instance Assertable ()+> where assert = return++> instance Assertable Bool+> where assert = assertBool ""++> instance (ListAssertable t) => Assertable [t]+> where assert = listAssert++> instance (Assertable t) => Assertable (IO t)+> where assert = (>>= assert)++We define the assertability of `[Char]` (that is, `String`) and leave+other types of list to possible user extension.++> class ListAssertable t+> where listAssert :: [t] -> Assertion++> instance ListAssertable Char+> where listAssert = assertString+++Overloaded `assertionPredicate` Function+----------------------------------------++> type AssertionPredicate = IO Bool++> class AssertionPredicable t+> where assertionPredicate :: t -> AssertionPredicate++> instance AssertionPredicable Bool+> where assertionPredicate = return++> instance (AssertionPredicable t) => AssertionPredicable (IO t)+> where assertionPredicate = (>>= assertionPredicate)+++Assertion Construction Operators+--------------------------------++> infix 1 @?, @=?, @?=++> (@?) :: (AssertionPredicable t) => t -> String -> Assertion+> pred @? msg = assertionPredicate pred >>= assertBool msg++> (@=?) :: (Eq a, Show a) => a -> a -> Assertion+> expected @=? actual = assertEqual "" expected actual++> (@?=) :: (Eq a, Show a) => a -> a -> Assertion+> actual @?= expected = assertEqual "" expected actual++++Test Definition+===============++> data Test = TestCase Assertion+> | TestList [Test]+> | TestLabel String Test++> instance Show Test where+> showsPrec p (TestCase _) = showString "TestCase _"+> showsPrec p (TestList ts) = showString "TestList " . showList ts+> showsPrec p (TestLabel l t) = showString "TestLabel " . showString l+> . showChar ' ' . showsPrec p t++> testCaseCount :: Test -> Int+> testCaseCount (TestCase _) = 1+> testCaseCount (TestList ts) = sum (map testCaseCount ts)+> testCaseCount (TestLabel _ t) = testCaseCount t+++> data Node = ListItem Int | Label String+> deriving (Eq, Show, Read)++> type Path = [Node] -- Node order is from test case to root.+++> testCasePaths :: Test -> [Path]+> testCasePaths t = tcp t []+> where tcp (TestCase _) p = [p]+> tcp (TestList ts) p =+> concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]+> tcp (TestLabel l t) p = tcp t (Label l : p)+++Overloaded `test` Function+--------------------------++> class Testable t+> where test :: t -> Test++> instance Testable Test+> where test = id++> instance (Assertable t) => Testable (IO t)+> where test = TestCase . assert++> instance (Testable t) => Testable [t]+> where test = TestList . map test+++Test Construction Operators+---------------------------++> infix 1 ~?, ~=?, ~?=+> infixr 0 ~:++> (~?) :: (AssertionPredicable t) => t -> String -> Test+> pred ~? msg = TestCase (pred @? msg)++> (~=?) :: (Eq a, Show a) => a -> a -> Test+> expected ~=? actual = TestCase (expected @=? actual)++> (~?=) :: (Eq a, Show a) => a -> a -> Test+> actual ~?= expected = TestCase (actual @?= expected)++> (~:) :: (Testable t) => String -> t -> Test+> label ~: t = TestLabel label (test t)++++Test Execution+==============++> data Counts = Counts { cases, tried, errors, failures :: Int }+> deriving (Eq, Show, Read)++> data State = State { path :: Path, counts :: Counts }+> deriving (Eq, Show, Read)++> type ReportStart us = State -> us -> IO us++> type ReportProblem us = String -> State -> us -> IO us+++Note that the counts in a start report do not include the test case+being started, whereas the counts in a problem report do include the+test case just finished. The principle is that the counts are sampled+only between test case executions. As a result, the number of test+case successes always equals the difference of test cases tried and+the sum of test case errors and failures.+++> performTest :: ReportStart us -> ReportProblem us -> ReportProblem us+> -> us -> Test -> IO (Counts, us)+> performTest reportStart reportError reportFailure us t = do+> (ss', us') <- pt initState us t+> unless (null (path ss')) $ error "performTest: Final path is nonnull"+> return (counts ss', us')+> where+> initState = State{ path = [], counts = initCounts }+> initCounts = Counts{ cases = testCaseCount t, tried = 0,+> errors = 0, failures = 0}++> pt ss us (TestCase a) = do+> us' <- reportStart ss us+> r <- performTestCase a+> case r of Nothing -> do return (ss', us')+> Just (True, m) -> do usF <- reportFailure m ssF us'+> return (ssF, usF)+> Just (False, m) -> do usE <- reportError m ssE us'+> return (ssE, usE)+> where c@Counts{ tried = t } = counts ss+> ss' = ss{ counts = c{ tried = t + 1 } }+> ssF = ss{ counts = c{ tried = t + 1, failures = failures c + 1 } }+> ssE = ss{ counts = c{ tried = t + 1, errors = errors c + 1 } }++> pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])+> where f (ss, us) (t, n) = withNode (ListItem n) ss us t++> pt ss us (TestLabel label t) = withNode (Label label) ss us t++> withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t+> return (ss2{ path = path0 }, us1)+> where path0 = path ss0+> ss1 = ss0{ path = node : path0 }
+ testcases/Repair.lhs view
@@ -0,0 +1,147 @@+\begin{code}+-- to be found replayRepository+{- and much more, but that's the one wich got my attraction -}+module Darcs.Repository.Repair ( replayRepository, cleanupRepositoryReplay,+ RepositoryConsistency(..), CanRepair(..) )+ where+ +import Control.Monad ( when, unless )+import Data.Maybe ( catMaybes )+import Data.List ( sort )+import System.Directory ( createDirectoryIfMissing )++import Darcs.SlurpDirectory ( empty_slurpy, withSlurpy, Slurpy, SlurpMonad )+import Darcs.Lock( rm_recursive )+import Darcs.Hopefully ( PatchInfoAnd, info )++import Darcs.Ordered ( FL(..), RL(..), lengthFL, reverseFL, reverseRL, concatRL,+ mapRL )+import Darcs.Patch.Depends ( get_patches_beyond_tag )+import Darcs.Patch.Patchy ( applyAndTryToFix )+import Darcs.Patch.Info ( human_friendly )+import Darcs.Patch ( RepoPatch, patch2patchinfo )++import Darcs.Repository.Format ( identifyRepoFormat, + RepoProperty ( HashedInventory ), format_has )+import Darcs.Repository.Cache ( Cache, HashedDir( HashedPristineDir ) )+import Darcs.Repository.HashedIO ( slurpHashedPristine, writeHashedPristine,+ clean_hashdir )+import Darcs.Repository.HashedRepo ( readHashedPristineRoot )+import Darcs.Repository.Checkpoint ( get_checkpoint_by_default )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository ( Repository, read_repo,+ checkPristineAgainstSlurpy,+ writePatchSet, makePatchLazy )++import Darcs.Sealed ( Sealed(..), unsafeUnflippedseal )+import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )+import Darcs.Utils ( catchall )+import Darcs.Global ( darcsdir )+import Darcs.Flags ( compression )+import Printer ( Doc, putDocLn, text )+import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )++run_slurpy :: Slurpy -> SlurpMonad a -> IO (Slurpy, a)+run_slurpy s f =+ case withSlurpy s f of+ Left err -> fail err+ Right x -> return x++update_slurpy :: Repository p -> Cache -> [DarcsFlag] -> Slurpy -> IO Slurpy+update_slurpy r c opts s = do+ current <- readHashedPristineRoot r+ h <- writeHashedPristine c (compression opts) s+ s' <- slurpHashedPristine c (compression opts) h+ clean_hashdir c HashedPristineDir $ catMaybes [Just h, current]+ return s'++applyAndFix :: RepoPatch p => Cache -> [DarcsFlag] -> Slurpy -> Repository p -> FL (PatchInfoAnd p) -> IO (FL (PatchInfoAnd p), Slurpy)+applyAndFix _ _ s _ NilFL = return (NilFL, s)+applyAndFix c opts s_ r psin =+ do beginTedious k+ tediousSize k $ lengthFL psin+ ps <- aaf 0 s_ psin+ endTedious k+ return ps+ where k = "Repairing patch" -- FIXME+ aaf _ s NilFL = return (NilFL, s)+ aaf i s (p:>:ps) = do+ (s', mp') <- run_slurpy s $ applyAndTryToFix p+ finishedOneIO k $ show $ human_friendly $ info p+ p' <- case mp' of+ Nothing -> return p+ Just (e,pp) -> do putStrLn e+ return pp+ p'' <- makePatchLazy r p'+ let j = if ((i::Int) + 1 < 100) then i + 1 else 0+ (ps', s'') <- aaf j s' ps+ s''' <- if j == 0 then update_slurpy r c opts s''+ else return s''+ return ((p'':>:ps'), s''')++data RepositoryConsistency = RepositoryConsistent | RepositoryInconsistent Slurpy+data CanRepair = CanRepair | CannotRepair deriving Eq++check_uniqueness :: RepoPatch p => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p -> IO ()+check_uniqueness putVerbose putInfo repository =+ do putVerbose $ text "Checking that patch names are unique..."+ r <- read_repo repository+ case has_duplicate $ mapRL info $ concatRL r of+ Nothing -> return ()+ Just pinf -> do putInfo $ text "Error! Duplicate patch name:"+ putInfo $ human_friendly pinf+ fail "Duplicate patches found."++has_duplicate :: Ord a => [a] -> Maybe a+has_duplicate li = hd $ sort li+ where hd [_] = Nothing+ hd [] = Nothing+ hd (x1:x2:xs) | x1 == x2 = Just x1+ | otherwise = hd (x2:xs)+replayRepository :: (RepoPatch p) => CanRepair -> Repository p -> [DarcsFlag] -> IO RepositoryConsistency+replayRepository canrepair repo opts = do+ let putVerbose s = when (Verbose `elem` opts) $ putDocLn s+ putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s+ check_uniqueness putVerbose putInfo repo+ maybe_chk <- get_checkpoint_by_default repo+ let c = extractCache repo+ createDirectoryIfMissing False $ darcsdir ++ "/pristine.hashed"+ rooth <- writeHashedPristine c (compression opts) empty_slurpy+ s <- slurpHashedPristine c (compression opts) rooth+ putVerbose $ text "Applying patches..."+ s' <- case maybe_chk of+ Just (Sealed chk) ->+ do let chtg = patch2patchinfo chk+ putVerbose $ text "I am repairing from a checkpoint."+ patches <- read_repo repo+ (s'', _) <- run_slurpy s $ applyAndTryToFix chk+ (_, s_) <- applyAndFix c opts s'' repo+ (reverseRL $ concatRL $ unsafeUnflippedseal $ get_patches_beyond_tag chtg patches)+ return s_+ Nothing -> do debugMessage "Fixing any broken patches..."+ rawpatches <- read_repo repo+ let psin = reverseRL $ concatRL rawpatches+ (ps, s_) <- applyAndFix c opts s repo psin+ when (canrepair == CanRepair) $ do+ writePatchSet (reverseFL ps :<: NilRL) opts+ return ()+ debugMessage "Done fixing broken patches..."+ return s_+ debugMessage "Checking pristine agains slurpy"+ is_same <- checkPristineAgainstSlurpy repo s' `catchall` return False+ if is_same+ then return RepositoryConsistent+ else return $ RepositoryInconsistent s'++cleanupRepositoryReplay :: Repository p -> IO ()+cleanupRepositoryReplay r = do+ let c = extractCache r+ rf_or_e <- identifyRepoFormat "."+ rf <- case rf_or_e of Left e -> fail e+ Right x -> return x+ unless (format_has HashedInventory rf) $+ rm_recursive $ darcsdir ++ "/pristine.hashed" + when (format_has HashedInventory rf) $ do+ current <- readHashedPristineRoot r+ clean_hashdir c HashedPristineDir $ catMaybes [current]+\end{code}
+ testcases/blockcomment.hs view
@@ -0,0 +1,4 @@+-- not to be found A+{-+data A+-}
+ testcases/constructor.hs view
@@ -0,0 +1,10 @@+-- to be found A+data A = A++-- to be found B+data B+ -- to be found B1+ = B1 B+ -- to be found B2+ -- TAGS not to be found | B2 A+ | B2 A
+ testcases/expected_failures_testing_suite.hs view
@@ -0,0 +1,12 @@+-- this file only exists to test all cases once .. all should fail+module C++-- to be found A+--+-- not to be found C++-- once to be found B+--+-- C should be found twice ... (?)+-- once to be found C+data C = C
+ testcases/firstconstructor.hs view
@@ -0,0 +1,2 @@+-- TAGS to be found data A = C+data A = C
+ testcases/module.hs view
@@ -0,0 +1,4 @@+-- not to be found A ./14/module.hs 2+module A where++data A = A
+ testcases/space.hs view
@@ -0,0 +1,4 @@+-- TAGS not to be found A{+data A+ = A { a :: A+ }
+ testcases/substring.hs view
@@ -0,0 +1,3 @@+-- TAGS not to be found data A1,2+data A=A+data AB=AB
+ testcases/tabs.hs view
@@ -0,0 +1,3 @@+-- once to be found C2+data B = C1+ | C2 B
+ testcases/testcase1.hs view
@@ -0,0 +1,86 @@+-- to be found A.B.testcase+module A.B.testcase(module System.FilePath.Windows) where+ import asdf++-- to be found Request+-- to be found Request2+-- to be found rqBody+-- to be found rqMethod+-- to be found rqPeer+-- to be found Request3+ data Request = Request2 { rqMethod::Method,+ rqBody :: RqBody,+ rqPeer :: Host+ }+ | Request3+ deriving(Show,Read,Typeable)+ -- http://hackage.haskell.org/trac/ghc/ticket/1184+ -- ! Convert Bool into another monad+-- to be found boolM+ boolM False = mzero++-- to be found sadlkfj+ sadlkfj+ = 7++-- to be found onlyTheFirstOne+ onlyTheFirstOne (x:xs) = 8+ onlyTheFirstOne [] = 8+-- to be found AC+ AC a b c d e f g = 7+-- to be found abc+ abc = let a = 7+ b = 8+ in a + b+ where x = 34+ o = 423+-- to be found BB+-- to be found AA+ AA, BB :: Int+++-- to be found foo+ ad `foo` oh = 90++-- to be found X+-- to be found xyz+ class (A a) => X a where+ xyz :: dummy+-- to be found Z+-- to be found o+ class (A a) => Z a where o :: Int++-- to be found ABC+ newtype ABC = Int+-- to be found DBM+ newtype IE.ISession sess => DBM mark sess a = DBM (ReaderT sess IO a)++-- TODO ++ -- to be found =~+ (=~) :: (Regex rho) => String -> rho -> Bool+++ -- not to be found join+ -- to be found runGetState+ runGetState m str off =+ case unGet m (mkState str off) of+ (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff)++ -- to be found SAA+ newtype Symbol = SAA String+ -- to be found value+ -- not to be found valuex+ value = reference <|> (Value `valuex` number)++-- to be found assertEqual+ assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion+ assertEqual preface expected actual =++-- to be found CheckedException +-- to be found checkedException+ newtype CheckedException l = CheckedException {checkedException::SomeException} deriving (Typeable)+++-- to be found Throws+ class Exception e => Throws e l
+ testcases/testcase10.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- to be found MonadThrow++module Control.Monad.Trans.Resource.Internal(+ ExceptionT(..)+ , InvalidAccess(..)+ , MonadResource(..)+ , MonadThrow(..)+ , MonadUnsafeIO(..)+ , ReleaseKey(..)+ , ReleaseMap(..)\+ , ResIO+ , ResourceT(..)+ , stateAlloc+ , stateCleanup+ , transResourceT+) where++import Control.Exception (throw,Exception,SomeException)+import Control.Applicative (Applicative (..))+import Control.Monad.Trans.Control+ ( MonadTransControl (..), MonadBaseControl (..)+ , ComposeSt, defaultLiftBaseWith, defaultRestoreM)+import Control.Monad.Base (MonadBase, liftBase)+import Control.Monad.Trans.Cont ( ContT )+import Control.Monad.Cont.Class ( MonadCont (..) )+import Control.Monad.Error.Class ( MonadError (..) )+import Control.Monad.RWS.Class ( MonadRWS )+import Control.Monad.Reader.Class ( MonadReader (..) )+import Control.Monad.State.Class ( MonadState (..) )+import Control.Monad.Writer.Class ( MonadWriter (..) )++import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Error ( ErrorT, Error)+import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )++import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad (liftM)+import qualified Control.Exception as E+import Control.Monad.ST (ST)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.IORef as I+import Data.Monoid+import Data.Typeable+import Data.Word(Word)++#if __GLASGOW_HASKELL__ >= 704+import Control.Monad.ST.Unsafe (unsafeIOToST)+#else+import Control.Monad.ST (unsafeIOToST)+#endif++#if __GLASGOW_HASKELL__ >= 704+import qualified Control.Monad.ST.Lazy.Unsafe as LazyUnsafe+#else+import qualified Control.Monad.ST.Lazy as LazyUnsafe+#endif++import qualified Control.Monad.ST.Lazy as Lazy++import Control.Monad.Morph++-- | A @Monad@ which allows for safe resource allocation. In theory, any monad+-- transformer stack included a @ResourceT@ can be an instance of+-- @MonadResource@.+--+-- Note: @runResourceT@ has a requirement for a @MonadBaseControl IO m@ monad,+-- which allows control operations to be lifted. A @MonadResource@ does not+-- have this requirement. This means that transformers such as @ContT@ can be+-- an instance of @MonadResource@. However, the @ContT@ wrapper will need to be+-- unwrapped before calling @runResourceT@.+--+-- Since 0.3.0+class (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResource m where+ -- | Lift a @ResourceT IO@ action into the current @Monad@.+ --+ -- Since 0.4.0+ liftResourceT :: ResourceT IO a -> m a+++-- | A lookup key for a specific release action. This value is returned by+-- 'register' and 'allocate', and is passed to 'release'.+--+-- Since 0.3.0+data ReleaseKey = ReleaseKey !(I.IORef ReleaseMap) !Int+ deriving Typeable++type RefCount = Word+type NextKey = Int++data ReleaseMap =+ ReleaseMap !NextKey !RefCount !(IntMap (IO ()))+ | ReleaseMapClosed++-- | Convenient alias for @ResourceT IO@.+type ResIO a = ResourceT IO a+++instance MonadCont m => MonadCont (ResourceT m) where+ callCC f = ResourceT $ \i -> callCC $ \c -> unResourceT (f (ResourceT . const . c)) i++instance MonadError e m => MonadError e (ResourceT m) where+ throwError = lift . throwError+ catchError r h = ResourceT $ \i -> unResourceT r i `catchError` \e -> unResourceT (h e) i++instance MonadRWS r w s m => MonadRWS r w s (ResourceT m)++instance MonadReader r m => MonadReader r (ResourceT m) where+ ask = lift ask+ local = mapResourceT . local++mapResourceT :: (m a -> n b) -> ResourceT m a -> ResourceT n b+mapResourceT f = ResourceT . (f .) . unResourceT++instance MonadState s m => MonadState s (ResourceT m) where+ get = lift get+ put = lift . put++instance MonadWriter w m => MonadWriter w (ResourceT m) where+ tell = lift . tell+ listen = mapResourceT listen+ pass = mapResourceT pass++-- | A @Monad@ which can throw exceptions. Note that this does not work in a+-- vanilla @ST@ or @Identity@ monad. Instead, you should use the 'ExceptionT'+-- transformer in your stack if you are dealing with a non-@IO@ base monad.+--+-- Since 0.3.0+class Monad m => MonadThrow m where+ monadThrow :: E.Exception e => e -> m a++instance MonadThrow IO where+ monadThrow = E.throwIO++instance MonadThrow Maybe where+ monadThrow _ = Nothing+instance MonadThrow (Either SomeException) where+ monadThrow = Left . E.toException+instance MonadThrow [] where+ monadThrow _ = []++#define GO(T) instance (MonadThrow m) => MonadThrow (T m) where monadThrow = lift . monadThrow+#define GOX(X, T) instance (X, MonadThrow m) => MonadThrow (T m) where monadThrow = lift . monadThrow+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(ResourceT)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+#undef GO+#undef GOX++instance (MonadThrow m, MonadUnsafeIO m, MonadIO m, Applicative m) => MonadResource (ResourceT m) where+ liftResourceT = transResourceT liftIO++-- | Transform the monad a @ResourceT@ lives in. This is most often used to+-- strip or add new transformers to a stack, e.g. to run a @ReaderT@.+--+-- Note that this function is a slight generalization of 'hoist'.+--+-- Since 0.3.0+transResourceT :: (m a -> n b)+ -> ResourceT m a+ -> ResourceT n b+transResourceT f (ResourceT mx) = ResourceT (\r -> f (mx r))++-- | Since 0.4.7+instance MFunctor ResourceT where+ hoist f (ResourceT mx) = ResourceT (\r -> f (mx r))+-- | Since 0.4.7+instance MMonad ResourceT where+ embed f m = ResourceT (\i -> unResourceT (f (unResourceT m i)) i)++-- | The Resource transformer. This transformer keeps track of all registered+-- actions, and calls them upon exit (via 'runResourceT'). Actions may be+-- registered via 'register', or resources may be allocated atomically via+-- 'allocate'. @allocate@ corresponds closely to @bracket@.+--+-- Releasing may be performed before exit via the 'release' function. This is a+-- highly recommended optimization, as it will ensure that scarce resources are+-- freed early. Note that calling @release@ will deregister the action, so that+-- a release action will only ever be called once.+--+-- Since 0.3.0+newtype ResourceT m a = ResourceT { unResourceT :: I.IORef ReleaseMap -> m a }+#if __GLASGOW_HASKELL__ >= 707+ deriving Typeable+#else+instance Typeable1 m => Typeable1 (ResourceT m) where+ typeOf1 = goType undefined+ where+ goType :: Typeable1 m => m a -> ResourceT m a -> TypeRep+ goType m _ =+ mkTyConApp+#if __GLASGOW_HASKELL__ >= 704+ (mkTyCon3 "resourcet" "Control.Monad.Trans.Resource" "ResourceT")+#else+ (mkTyCon "Control.Monad.Trans.Resource.ResourceT")+#endif+ [ typeOf1 m+ ]+#endif++-- | Indicates either an error in the library, or misuse of it (e.g., a+-- @ResourceT@'s state is accessed after being released).+--+-- Since 0.3.0+data InvalidAccess = InvalidAccess { functionName :: String }+ deriving Typeable++instance Show InvalidAccess where+ show (InvalidAccess f) = concat+ [ "Control.Monad.Trans.Resource."+ , f+ , ": The mutable state is being accessed after cleanup. Please contact the maintainers."+ ]++instance Exception InvalidAccess++-------- All of our monad et al instances+instance Functor m => Functor (ResourceT m) where+ fmap f (ResourceT m) = ResourceT $ \r -> fmap f (m r)++instance Applicative m => Applicative (ResourceT m) where+ pure = ResourceT . const . pure+ ResourceT mf <*> ResourceT ma = ResourceT $ \r ->+ mf r <*> ma r++instance Monad m => Monad (ResourceT m) where+ return = ResourceT . const . return+ ResourceT ma >>= f = ResourceT $ \r -> do+ a <- ma r+ let ResourceT f' = f a+ f' r++instance MonadTrans ResourceT where+ lift = ResourceT . const++instance MonadIO m => MonadIO (ResourceT m) where+ liftIO = lift . liftIO++instance MonadBase b m => MonadBase b (ResourceT m) where+ liftBase = lift . liftBase++instance MonadTransControl ResourceT where+ newtype StT ResourceT a = StReader {unStReader :: a}+ liftWith f = ResourceT $ \r -> f $ \(ResourceT t) -> liftM StReader $ t r+ restoreT = ResourceT . const . liftM unStReader+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}++instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where+ newtype StM (ResourceT m) a = StMT (StM m a)+ liftBaseWith f = ResourceT $ \reader' ->+ liftBaseWith $ \runInBase ->+ f $ liftM StMT . runInBase . (\(ResourceT r) -> r reader' )+ restoreM (StMT base) = ResourceT $ const $ restoreM base+instance Monad m => MonadThrow (ExceptionT m) where+ monadThrow = ExceptionT . return . Left . E.toException+instance MonadResource m => MonadResource (ExceptionT m) where+ liftResourceT = lift . liftResourceT+instance MonadIO m => MonadIO (ExceptionT m) where+ liftIO = lift . liftIO++#define GO(T) instance (MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT+#define GOX(X, T) instance (X, MonadResource m) => MonadResource (T m) where liftResourceT = lift . liftResourceT+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(ContT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+#undef GO+#undef GOX+++-- | The express purpose of this transformer is to allow non-@IO@-based monad+-- stacks to catch exceptions via the 'MonadThrow' typeclass.+--+-- Since 0.3.0+newtype ExceptionT m a = ExceptionT { runExceptionT :: m (Either SomeException a) }++stateAlloc :: I.IORef ReleaseMap -> IO ()+stateAlloc istate = do+ I.atomicModifyIORef istate $ \rm ->+ case rm of+ ReleaseMap nk rf m ->+ (ReleaseMap nk (rf + 1) m, ())+ ReleaseMapClosed -> throw $ InvalidAccess "stateAlloc"++stateCleanup :: I.IORef ReleaseMap -> IO ()+stateCleanup istate = E.mask_ $ do+ mm <- I.atomicModifyIORef istate $ \rm ->+ case rm of+ ReleaseMap nk rf m ->+ let rf' = rf - 1+ in if rf' == minBound+ then (ReleaseMapClosed, Just m)+ else (ReleaseMap nk rf' m, Nothing)+ ReleaseMapClosed -> throw $ InvalidAccess "stateCleanup"+ case mm of+ Just m ->+ mapM_ (\x -> try x >> return ()) $ IntMap.elems m+ Nothing -> return ()+ where+ try :: IO a -> IO (Either SomeException a)+ try = E.try+++-- | A @Monad@ based on some monad which allows running of some 'IO' actions,+-- via unsafe calls. This applies to 'IO' and 'ST', for instance.+--+-- Since 0.3.0+class Monad m => MonadUnsafeIO m where+ unsafeLiftIO :: IO a -> m a++instance MonadUnsafeIO IO where+ unsafeLiftIO = id++instance MonadUnsafeIO (ST s) where+ unsafeLiftIO = unsafeIOToST++instance MonadUnsafeIO (Lazy.ST s) where+ unsafeLiftIO = LazyUnsafe.unsafeIOToST++instance (MonadTrans t, MonadUnsafeIO m, Monad (t m)) => MonadUnsafeIO (t m) where+ unsafeLiftIO = lift . unsafeLiftIO++instance Monad m => Functor (ExceptionT m) where+ fmap f = ExceptionT . (liftM . fmap) f . runExceptionT+instance Monad m => Applicative (ExceptionT m) where+ pure = ExceptionT . return . Right+ ExceptionT mf <*> ExceptionT ma = ExceptionT $ do+ ef <- mf+ case ef of+ Left e -> return (Left e)+ Right f -> do+ ea <- ma+ case ea of+ Left e -> return (Left e)+ Right x -> return (Right (f x))+instance Monad m => Monad (ExceptionT m) where+ return = pure+ ExceptionT ma >>= f = ExceptionT $ do+ ea <- ma+ case ea of+ Left e -> return (Left e)+ Right a -> runExceptionT (f a)+instance MonadBase b m => MonadBase b (ExceptionT m) where+ liftBase = lift . liftBase+instance MonadTrans ExceptionT where+ lift = ExceptionT . liftM Right+instance MonadTransControl ExceptionT where+ newtype StT ExceptionT a = StExc { unStExc :: Either SomeException a }+ liftWith f = ExceptionT $ liftM return $ f $ liftM StExc . runExceptionT+ restoreT = ExceptionT . liftM unStExc+instance MonadBaseControl b m => MonadBaseControl b (ExceptionT m) where+ newtype StM (ExceptionT m) a = StE { unStE :: ComposeSt ExceptionT m a }+ liftBaseWith = defaultLiftBaseWith StE+ restoreM = defaultRestoreM unStE++instance MonadCont m => MonadCont (ExceptionT m) where+ callCC f = ExceptionT $+ callCC $ \c ->+ runExceptionT (f (\a -> ExceptionT $ c (Right a)))++instance MonadError e m => MonadError e (ExceptionT m) where+ throwError = lift . throwError+ catchError r h = ExceptionT $ runExceptionT r `catchError` (runExceptionT . h)++instance MonadRWS r w s m => MonadRWS r w s (ExceptionT m)++instance MonadReader r m => MonadReader r (ExceptionT m) where+ ask = lift ask+ local = mapExceptionT . local++mapExceptionT :: (m (Either SomeException a) -> n (Either SomeException b)) -> ExceptionT m a -> ExceptionT n b+mapExceptionT f = ExceptionT . f . runExceptionT++instance MonadState s m => MonadState s (ExceptionT m) where+ get = lift get+ put = lift . put++instance MonadWriter w m => MonadWriter w (ExceptionT m) where+ tell = lift . tell+ listen = mapExceptionT $ \ m -> do+ (a, w) <- listen m+ return $! fmap (\ r -> (r, w)) a+ pass = mapExceptionT $ \ m -> pass $ do+ a <- m+ return $! case a of+ Left l -> (Left l, id)+ Right (r, f) -> (Right r, f)++class Monad m where+ -- | Sequentially compose two actions, passing any value produced+ -- by the first as an argument to the second.+ (>>=) :: forall a b. m a -> (a -> m b) -> m b+ -- | Sequentially compose two actions, discarding any value produced+ -- by the first, like sequencing operators (such as the semicolon)+ -- in imperative languages.+ (>>) :: forall a b. m a -> m b -> m b+ -- Explicit for-alls so that we know what order to+ -- give type arguments when desugaring++ -- | Inject a value into the monadic type.+ return :: a -> m a+ -- | Fail with a message. This operation is not part of the+ -- mathematical definition of a monad, but is invoked on pattern-match+ -- failure in a @do@ expression.+ fail :: String -> m a++ {-# INLINE (>>) #-}+ m >> k = m >>= \_ -> k+ fail s = error s
+ testcases/testcase11.hs view
@@ -0,0 +1,84 @@+\section[GHC.Base]{Module @GHC.Base@}++simple lhs test++-- to be found Monad++Other Prelude modules are much easier with fewer complex dependencies.++\begin{code}+{- | The 'Functor' class is used for types that can be mapped over.+Instances of 'Functor' should satisfy the following laws:++> fmap id == id+> fmap (f . g) == fmap f . fmap g++The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+satisfy these laws.+-}++class Functor f where+ fmap :: (a -> b) -> f a -> f b++ -- | Replace all locations in the input with the same value.+ -- The default definition is @'fmap' . 'const'@, but this may be+ -- overridden with a more efficient version.+ (<$) :: a -> f b -> f a+ (<$) = fmap . const++{- | The 'Monad' class defines the basic operations over a /monad/,+a concept from a branch of mathematics known as /category theory/.+From the perspective of a Haskell programmer, however, it is best to+think of a monad as an /abstract datatype/ of actions.+Haskell's @do@ expressions provide a convenient syntax for writing+monadic expressions.++Minimal complete definition: '>>=' and 'return'.++Instances of 'Monad' should satisfy the following laws:++> return a >>= k == k a+> m >>= return == m+> m >>= (\x -> k x >>= h) == (m >>= k) >>= h++Instances of both 'Monad' and 'Functor' should additionally satisfy the law:++> fmap f xs == xs >>= return . f++The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class Monad m where+ -- | Sequentially compose two actions, passing any value produced+ -- by the first as an argument to the second.+ (>>=) :: forall a b. m a -> (a -> m b) -> m b+ -- | Sequentially compose two actions, discarding any value produced+ -- by the first, like sequencing operators (such as the semicolon)+ -- in imperative languages.+ (>>) :: forall a b. m a -> m b -> m b+ -- Explicit for-alls so that we know what order to+ -- give type arguments when desugaring++ -- | Inject a value into the monadic type.+ return :: a -> m a+ -- | Fail with a message. This operation is not part of the+ -- mathematical definition of a monad, but is invoked on pattern-match+ -- failure in a @do@ expression.+ fail :: String -> m a++ {-# INLINE (>>) #-}+ m >> k = m >>= \_ -> k+ fail s = error s++instance Functor ((->) r) where+ fmap = (.)++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)+\end{code}+
+ testcases/testcase2.hs view
@@ -0,0 +1,256 @@+-- to be found isLetter+-- to be found isMark+-- to be found isNumber+-- to be found isPunctuation+-- to be found isSymbol+-- to be found isSeparator+-- to be found isAsciiUpper+-- to be found isAsciiLower+-- to be found GeneralCategory+-- to be found generalCategory+-- to be found toTitle +-- to be found digitToInt ++-- to be found UppercaseLetter +-- to be found LowercaseLetter +-- to be found TitlecaseLetter +-- to be found ModifierLetter +-- to be found OtherLetter +-- to be found NonSpacingMark +-- to be found SpacingCombiningMark +-- to be found EnclosingMark +-- to be found DecimalNumber +-- to be found LetterNumber +-- to be found OtherNumber +-- to be found ConnectorPunctuation +-- to be found DashPunctuation +-- to be found OpenPunctuation +-- to be found ClosePunctuation +-- to be found InitialQuote +-- to be found FinalQuote +-- to be found OtherPunctuation +-- to be found MathSymbol +-- to be found CurrencySymbol +-- to be found ModifierSymbol +-- to be found OtherSymbol +-- to be found Space +-- to be found LineSeparator +-- to be found ParagraphSeparator +-- to be found Control +-- to be found Format +-- to be found Surrogate +-- to be found PrivateUse +-- to be found NotAssigned ++{-# OPTIONS_GHC -fno-implicit-prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Char+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : stable+-- Portability : portable+--+-- The Char type and associated operations.+--+-----------------------------------------------------------------------------++module Data.Char + (+ Char++ , String++ -- * Character classification+ -- | Unicode characters are divided into letters, numbers, marks,+ -- punctuation, symbols, separators (including spaces) and others+ -- (including control characters).+ , isControl, isSpace+ , isLower, isUpper, isAlpha, isAlphaNum, isPrint+ , isDigit, isOctDigit, isHexDigit+ , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator++ -- ** Subranges+ , isAscii, isLatin1+ , isAsciiUpper, isAsciiLower++ -- ** Unicode general categories+ , GeneralCategory(..), generalCategory++ -- * Case conversion+ , toUpper, toLower, toTitle -- :: Char -> Char++ -- * Single digit characters+ , digitToInt -- :: Char -> Int+ , intToDigit -- :: Int -> Char++ -- * Numeric representations+ , ord -- :: Char -> Int+ , chr -- :: Int -> Char++ -- * String representations+ , showLitChar -- :: Char -> ShowS+ , lexLitChar -- :: ReadS String+ , readLitChar -- :: ReadS Char ++ -- Implementation checked wrt. Haskell 98 lib report, 1/99.+ ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Arr (Ix)+import GHC.Real (fromIntegral)+import GHC.Show+import GHC.Read (Read, readLitChar, lexLitChar)+import GHC.Unicode+import GHC.Num+import GHC.Enum+#endif++#ifdef __HUGS__+import Hugs.Prelude (Ix)+import Hugs.Char+#endif++#ifdef __NHC__+import Prelude+import Prelude(Char,String)+import Char+import Ix+import NHC.FFI (CInt)+foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt+#endif++-- | Convert a single digit 'Char' to the corresponding 'Int'. +-- This function fails unless its argument satisfies 'isHexDigit',+-- but recognises both upper and lower-case hexadecimal digits+-- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).+digitToInt :: Char -> Int+digitToInt c+ | isDigit c = ord c - ord '0'+ | c >= 'a' && c <= 'f' = ord c - ord 'a' + 10+ | c >= 'A' && c <= 'F' = ord c - ord 'A' + 10+ | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh++#ifndef __GLASGOW_HASKELL__+isAsciiUpper, isAsciiLower :: Char -> Bool+isAsciiLower c = c >= 'a' && c <= 'z'+isAsciiUpper c = c >= 'A' && c <= 'Z'+#endif++-- | Unicode General Categories (column 2 of the UnicodeData table)+-- in the order they are listed in the Unicode standard.++data GeneralCategory+ = UppercaseLetter -- ^ Lu: Letter, Uppercase+ | LowercaseLetter -- ^ Ll: Letter, Lowercase+ | TitlecaseLetter -- ^ Lt: Letter, Titlecase+ | ModifierLetter -- ^ Lm: Letter, Modifier+ | OtherLetter -- ^ Lo: Letter, Other+ | NonSpacingMark -- ^ Mn: Mark, Non-Spacing+ | SpacingCombiningMark -- ^ Mc: Mark, Spacing Combining+ | EnclosingMark -- ^ Me: Mark, Enclosing+ | DecimalNumber -- ^ Nd: Number, Decimal+ | LetterNumber -- ^ Nl: Number, Letter+ | OtherNumber -- ^ No: Number, Other+ | ConnectorPunctuation -- ^ Pc: Punctuation, Connector+ | DashPunctuation -- ^ Pd: Punctuation, Dash+ | OpenPunctuation -- ^ Ps: Punctuation, Open+ | ClosePunctuation -- ^ Pe: Punctuation, Close+ | InitialQuote -- ^ Pi: Punctuation, Initial quote+ | FinalQuote -- ^ Pf: Punctuation, Final quote+ | OtherPunctuation -- ^ Po: Punctuation, Other+ | MathSymbol -- ^ Sm: Symbol, Math+ | CurrencySymbol -- ^ Sc: Symbol, Currency+ | ModifierSymbol -- ^ Sk: Symbol, Modifier+ | OtherSymbol -- ^ So: Symbol, Other+ | Space -- ^ Zs: Separator, Space+ | LineSeparator -- ^ Zl: Separator, Line+ | ParagraphSeparator -- ^ Zp: Separator, Paragraph+ | Control -- ^ Cc: Other, Control+ | Format -- ^ Cf: Other, Format+ | Surrogate -- ^ Cs: Other, Surrogate+ | PrivateUse -- ^ Co: Other, Private Use+ | NotAssigned -- ^ Cn: Other, Not Assigned+ deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)++-- | The Unicode general category of the character.+generalCategory :: Char -> GeneralCategory+#if defined(__GLASGOW_HASKELL__) || defined(__NHC__)+generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c+#endif+#ifdef __HUGS__+generalCategory c = toEnum (primUniGenCat c)+#endif++-- derived character classifiers++-- | Selects alphabetic Unicode characters (lower-case, upper-case and+-- title-case letters, plus letters of caseless scripts and modifiers letters).+-- This function is equivalent to 'Data.Char.isAlpha'.+isLetter :: Char -> Bool+isLetter c = case generalCategory c of+ UppercaseLetter -> True+ LowercaseLetter -> True+ TitlecaseLetter -> True+ ModifierLetter -> True+ OtherLetter -> True+ _ -> False++-- | Selects Unicode mark characters, e.g. accents and the like, which+-- combine with preceding letters.+isMark :: Char -> Bool+isMark c = case generalCategory c of+ NonSpacingMark -> True+ SpacingCombiningMark -> True+ EnclosingMark -> True+ _ -> False++-- | Selects Unicode numeric characters, including digits from various+-- scripts, Roman numerals, etc.+isNumber :: Char -> Bool+isNumber c = case generalCategory c of+ DecimalNumber -> True+ LetterNumber -> True+ OtherNumber -> True+ _ -> False++-- | Selects Unicode punctuation characters, including various kinds+-- of connectors, brackets and quotes.+isPunctuation :: Char -> Bool+isPunctuation c = case generalCategory c of+ ConnectorPunctuation -> True+ DashPunctuation -> True+ OpenPunctuation -> True+ ClosePunctuation -> True+ InitialQuote -> True+ FinalQuote -> True+ OtherPunctuation -> True+ _ -> False++-- | Selects Unicode symbol characters, including mathematical and+-- currency symbols.+isSymbol :: Char -> Bool+isSymbol c = case generalCategory c of+ MathSymbol -> True+ CurrencySymbol -> True+ ModifierSymbol -> True+ OtherSymbol -> True+ _ -> False++-- | Selects Unicode space and separator characters.+isSeparator :: Char -> Bool+isSeparator c = case generalCategory c of+ Space -> True+ LineSeparator -> True+ ParagraphSeparator -> True+ _ -> False++#ifdef __NHC__+-- dummy implementation+toTitle :: Char -> Char+toTitle = toUpper+#endif+
+ testcases/testcase3.lhs view
@@ -0,0 +1,1313 @@+-- list not complete+-- to be found DBM +-- to be found ifNull+-- to be found result+-- to be found result'+-- to be fonud selectNestedMultiResultSet++|+Module : Database.Enumerator+Copyright : (c) 2004 Oleg Kiselyov, Alistair Bayley+License : BSD-style+Maintainer : oleg@pobox.com, alistair@abayley.org+Stability : experimental+Portability : non-portable++Abstract database interface, providing a left-fold enumerator+and cursor operations.++There is a stub: "Database.Stub.Enumerator".+This lets you run the test cases without having a working DBMS installation.+This isn't so valuable now, because it's dead easy to install Sqlite,+but it's still there if you want to try it.++Additional reading:++ * <http://pobox.com/~oleg/ftp/Haskell/misc.html#fold-stream>++ * <http://pobox.com/~oleg/ftp/papers/LL3-collections-enumerators.txt>++ * <http://www.eros-os.org/pipermail/e-lang/2004-March/009643.html>++Note that there are a few functions that are exported from each DBMS-specific+implementation which are exposed to the API user, and which are part of+the Takusen API, but are not (necessarily) in this module.+They include:++ * @connect@ (obviously DBMS specific)++ * @prepareQuery, prepareLargeQuery, prepareCommand, sql, sqlbind, prefetch, cmdbind@++These functions will typically have the same names and intentions,+but their specific types and usage may differ between DBMS.+++Had better keep the old style, for older versions of GHC.++> {-# OPTIONS -cpp #-}+> {-# OPTIONS -fglasgow-exts #-}+> {-# OPTIONS -fallow-overlapping-instances #-}+> {-# OPTIONS -fallow-undecidable-instances #-}++New style extension declarations.++> {-# LANGUAGE CPP #-}+> {-# LANGUAGE GeneralizedNewtypeDeriving #-}+> {-# LANGUAGE OverlappingInstances #-}+> {-# LANGUAGE UndecidableInstances #-}+++> module Database.Enumerator+> (+> -- * Usage+>+> -- $usage_example+>+> -- ** Iteratee Functions+>+> -- $usage_iteratee+>+> -- ** result and result'+>+> -- $usage_result+>+> -- ** Rank-2 types, ($), and the monomorphism restriction+>+> -- $usage_rank2_types+>+> -- ** Bind Parameters+>+> -- $usage_bindparms+>+> -- ** Multiple (and nested) Result Sets+>+> -- $usage_multiresultset+>+> -- * Sessions and Transactions+> DBM -- The data constructor is not exported+> , withSession, withContinuedSession+> , commit, rollback, beginTransaction+> , withTransaction+> , IE.IsolationLevel(..)+> , execDDL, execDML, inquire+>+> -- * Exceptions and handlers+> , DBException(..)+> , formatDBException, basicDBExceptionReporter+> , reportRethrow, reportRethrowMsg+> , catchDB, catchDBError, ignoreDBError, IE.throwDB+>+> -- * Preparing and Binding+> , PreparedStmt(..) -- data constructor not exported+> , withPreparedStatement+> , withBoundStatement, IE.bindP+>+> -- * Iteratees and Cursors+> , doQuery+> , IterResult, IterAct+> , IE.currentRowNum, NextResultSet(..), RefCursor(..)+> , cursorIsEOF, cursorCurrent, cursorNext+> , withCursor+>+> -- * Utilities+> , ifNull, result, result'+> ) where++> import Prelude hiding (catch)+> import Data.Dynamic+> import Data.IORef+> import Data.Time+> import Control.Monad.Trans (liftIO)+> import Control.Exception (throw, +> dynExceptions, throwDyn, bracket, Exception, finally)+> import qualified Control.Exception (catch)+> import Control.Monad.Fix+> import Control.Monad.Reader+> import Control.Exception.MonadIO+> import qualified Database.InternalEnumerator as IE+> import Database.InternalEnumerator (DBException(..))+++-----------------------------------------------------------+++-----------------------------------------------------------+++| 'IterResult' and 'IterAct' give us some type sugar.+Without them, the types of iteratee functions become+quite unwieldy.++> type IterResult seedType = Either seedType seedType+> type IterAct m seedType = seedType -> m (IterResult seedType)++| Catch 'Database.InteralEnumerator.DBException's thrown in the 'DBM'+monad.++> catchDB :: CaughtMonadIO m => m a -> (DBException -> m a) -> m a+> catchDB action handler = gcatch action $ \e ->+> maybe (throw e) handler (dynExceptions e >>= fromDynamic)+++|This simple handler reports the error to @stdout@ and swallows it+i.e. it doesn't propagate.++> basicDBExceptionReporter :: CaughtMonadIO m => DBException -> m ()+> basicDBExceptionReporter e = liftIO (putStrLn (formatDBException e))++| This handler reports the error and propagates it+(usually to force the program to halt).++> reportRethrow :: CaughtMonadIO m => DBException -> m a+> --reportRethrow e = basicDBExceptionReporter e >> IE.throwDB e+> reportRethrow e = reportRethrowMsg "" e++| Same as reportRethrow, but you can prefix some text to the error+(perhaps to indicate which part of your program raised it).++> reportRethrowMsg :: CaughtMonadIO m => String -> DBException -> m a+> reportRethrowMsg m e = liftIO (putStr m) >> basicDBExceptionReporter e >> IE.throwDB e++| A show for 'Database.InteralEnumerator.DBException's.++> formatDBException :: DBException -> String+> formatDBException (DBError (ssc, sssc) e m) =+> ssc ++ sssc ++ " " ++ (show e) ++ ": " ++ m+> formatDBException (DBFatal (ssc, sssc) e m) =+> ssc ++ sssc ++ " " ++ (show e) ++ ": " ++ m+> formatDBException (DBUnexpectedNull r c) =+> "Unexpected null in row " ++ (show r) ++ ", column " ++ (show c) ++ "."+> formatDBException (DBNoData) = "Fetch: no more data."+++|If you want to trap a specific error number, use this.+It passes anything else up.++> catchDBError :: (CaughtMonadIO m) =>+> Int -> m a -> (DBException -> m a) -> m a+> catchDBError n action handler = catchDB action+> (\dberror ->+> case dberror of+> DBError ss e m | e == n -> handler dberror+> _ | otherwise -> IE.throwDB dberror+> )++| Analogous to 'catchDBError', but ignores specific errors instead+(propagates anything else).++> ignoreDBError :: (CaughtMonadIO m) => Int -> m a -> m a+> ignoreDBError n action = catchDBError n action (\e -> return undefined)++--------------------------------------------------------------------+-- ** Session monad+--------------------------------------------------------------------++The DBM data constructor is NOT exported. ++One may think to quantify over sess in |withSession|. We won't need+any mark then, I gather.+The quantification over Session is quite bothersome: need to enumerate+all class constraints for the Session (like IQuery, DBType, etc).++> newtype IE.ISession sess => DBM mark sess a = DBM (ReaderT sess IO a)+#ifndef __HADDOCK__+> deriving (Functor, Monad, MonadIO, MonadFix, MonadReader sess)+#else+> -- Haddock can't cope with the "MonadReader sess" instance+> deriving (Functor, Monad, MonadIO, MonadFix)+#endif+> unDBM (DBM x) = x+++> instance IE.ISession si => CaughtMonadIO (DBM mark si) where+> gcatch a h = DBM ( gcatch (unDBM a) (unDBM . h) )+> gcatchJust p a h = DBM ( gcatchJust p (unDBM a) (unDBM . h) )++| Typeable constraint is to prevent the leakage of Session and other+marked objects.++> withSession :: (Typeable a, IE.ISession sess) => +> IE.ConnectA sess -> (forall mark. DBM mark sess a) -> IO a+> withSession (IE.ConnectA connecta) m = +> bracket (connecta) (IE.disconnect) (runReaderT (unDBM m))+++| Persistent database connections. +This issue has been brought up by Shanky Surana. The following design+is inspired by that exchange.++On one hand, implementing persistent connections is easy. One may say we should+have added them long time ago, to match HSQL, HDBC, and similar+database interfaces. Alas, implementing persistent connection+safely is another matter. The simplest design is like the following++ > withContinuedSession :: (Typeable a, IE.ISession sess) => + > IE.ConnectA sess -> (forall mark. DBM mark sess a) -> + > IO (a, IE.ConnectA sess)+ > withContinuedSession (IE.ConnectA connecta) m = do+ > conn <- connecta+ > r <- runReaderT (unDBM m) conn+ > return (r,(return conn))++so that the connection object is returned as the result and can be+used again with withContinuedSession or withSession. The problem is+that nothing prevents us from writing:++ > (r1,conn) <- withContinuedSession (connect "...") query1+ > r2 <- withSession conn query2+ > r3 <- withSession conn query3++That is, we store the suspended connection and then use it twice.+But the first withSession closes the connection. So, the second+withSession gets an invalid session object. Invalid in a sense that+even memory may be deallocated, so there is no telling what happens+next. Also, as we can see, it is difficult to handle errors and+automatically dispose of the connections if the fatal error is+encountered.++All these problems are present in other interfaces... In the+case of a suspended connection, the problem is how to enforce the+/linear/ access to a variable. It can be enforced, via a+state-changing monad. The implementation below makes+the non-linear use of a suspended connection a run-time checkable+condition. It will be generic and safe - fatal errors close the+connection, an attempt to use a closed connection raises an error, and+we cannot reuse a connection. We have to write:++ > (r1, conn1) <- withContinuedSession conn ...+ > (r2, conn2) <- withContinuedSession conn1 ...+ > (r3, conn3) <- withContinuedSession conn2 ...++etc. If we reuse a suspended connection or use a closed connection,+we get a run-time (exception). That is of course not very+satisfactory - and yet better than a segmentation fault. ++> withContinuedSession :: (Typeable a, IE.ISession sess) => +> IE.ConnectA sess -> (forall mark. DBM mark sess a) +> -> IO (a, IE.ConnectA sess)+> withContinuedSession (IE.ConnectA connecta) m = +> do conn <- connecta -- this invalidates connecta+> r <- runReaderT (unDBM m) conn+> `Control.Exception.catch` (\e -> IE.disconnect conn >> throw e)+> -- make a new, one-shot connecta+> hasbeenused <- newIORef False+> let connecta = do+> fl <- readIORef hasbeenused+> when fl $ error "connecta has been re-used"+> writeIORef hasbeenused True+> return conn+> return (r,IE.ConnectA connecta)++++> beginTransaction ::+> (MonadReader s (ReaderT s IO), IE.ISession s) =>+> IE.IsolationLevel -> DBM mark s ()+> beginTransaction il = DBM (ask >>= \s -> lift $ IE.beginTransaction s il)+> commit :: IE.ISession s => DBM mark s ()+> commit = DBM( ask >>= lift . IE.commit )+> rollback :: IE.ISession s => DBM mark s ()+> rollback = DBM( ask >>= lift . IE.rollback )+++> executeCommand :: IE.Command stmt s => stmt -> DBM mark s Int+> executeCommand stmt = DBM( ask >>= \s -> lift $ IE.executeCommand s stmt )++| DDL operations don't manipulate data, so we return no information.+If there is a problem, an exception will be raised.++> execDDL :: IE.Command stmt s => stmt -> DBM mark s ()+> execDDL stmt = executeCommand stmt >> return ()++| Returns the number of rows affected.++> execDML :: IE.Command stmt s => stmt -> DBM mark s Int+> execDML = executeCommand++| Allows arbitrary actions to be run the DBM monad.+the back-end developer must supply instances of EnvInquiry,+which is hidden away in "Database.InternalEnumerator".+An example of this is 'Database.Sqlite.Enumerator.LastInsertRowid'.++> inquire :: IE.EnvInquiry key s result => key -> DBM mark s result+> inquire key = DBM( ask >>= \s -> lift $ IE.inquire key s )++--------------------------------------------------------------------+-- ** Statements; Prepared statements+--------------------------------------------------------------------++> newtype PreparedStmt mark stmt = PreparedStmt stmt++> executePreparation :: IE.IPrepared stmt sess bstmt bo =>+> IE.PreparationA sess stmt -> DBM mark sess (PreparedStmt mark stmt)+> executePreparation (IE.PreparationA action) =+> DBM( ask >>= \sess -> lift $ action sess >>= return . PreparedStmt)++> data NextResultSet mark stmt = NextResultSet (PreparedStmt mark stmt)+> data RefCursor a = RefCursor a+++The exception handling in withPreparedStatement looks awkward,+but there's a good reason...++Suppose there's some sort of error when we call destroyStmt.+The exception handler also must call destroyStmt (because the exception+might have also come from the invocation of action), but calling destroyStmt+might also raise a new exception (for example, a different error is raised+if you re-try a failed CLOSE-cursor, because the transaction is aborted).+So we wrap this call with a catch, and ensure that the original exception+is preserved and re-raised.++| Prepare a statement and run a DBM action over it.+This gives us the ability to re-use a statement,+for example by passing different bind values for each execution.++The Typeable constraint is to prevent the leakage of marked things.+The type of bound statements should not be exported (and should not be+in Typeable) so the bound statement can't leak either.++> withPreparedStatement ::+> (Typeable a, IE.IPrepared stmt sess bstmt bo)+> => IE.PreparationA sess stmt+> -- ^ preparation action to create prepared statement;+> -- this action is usually created by @prepareQuery\/Command@+> -> (PreparedStmt mark stmt -> DBM mark sess a)+> -- ^ DBM action that takes a prepared statement+> -> DBM mark sess a+> withPreparedStatement pa action = do+> ps <- executePreparation pa+> gcatch ( do+> v <- action ps+> destroyStmt ps+> return v+> ) (\e -> gcatch (destroyStmt ps >> throw e) (\_ -> throw e))+++Not exported.++> destroyStmt :: (IE.ISession sess, IE.IPrepared stmt sess bstmt bo)+> => PreparedStmt mark stmt -> DBM mark sess ()+> destroyStmt (PreparedStmt stmt) = DBM( ask >>= \s -> lift $ IE.destroyStmt s stmt )++++| Applies a prepared statement to bind variables to get a bound statement,+which is passed to the provided action.+Note that by the time it is passed to the action, the query or command+has usually been executed.+A bound statement would normally be an instance of+'Database.InternalEnumerator.Statement', so it can be passed to+'Database.Enumerator.doQuery'+in order to process the result-set, and also an instance of+'Database.InternalEnumerator.Command', so that we can write+re-usable DML statements (inserts, updates, deletes).++The Typeable constraint is to prevent the leakage of marked things.+The type of bound statements should not be exported (and should not be+in Typeable) so the bound statement can't leak either.++> withBoundStatement ::+> (Typeable a, IE.IPrepared stmt s bstmt bo)+> => PreparedStmt mark stmt+> -- ^ prepared statement created by withPreparedStatement+> -> [IE.BindA s stmt bo]+> -- ^ bind values+> -> (bstmt -> DBM mark s a)+> -- ^ action to run over bound statement+> -> DBM mark s a+> withBoundStatement (PreparedStmt stmt) ba f =+> DBM ( ask >>= \s -> +> lift $ IE.bindRun s stmt ba (\b -> runReaderT (unDBM (f b)) s))+++--------------------------------------------------------------------+-- ** Buffers and QueryIteratee+--------------------------------------------------------------------+++|The class QueryIteratee is not for the end user. It provides the+interface between the low- and the middle-layers of Takusen. The+middle-layer - enumerator - is database-independent then.++> class MonadIO m => QueryIteratee m q i seed b |+> i -> m, i -> seed, q -> b where+> iterApply :: q -> [b] -> seed -> i -> m (IterResult seed)+> allocBuffers :: q -> i -> IE.Position -> m [b]++|This instance of the class is the terminating case+i.e. where the iteratee function has one argument left.+The argument is applied, and the result returned.++> instance (IE.DBType a q b, MonadIO m) =>+> QueryIteratee m q (a -> seed -> m (IterResult seed)) seed b where+> iterApply q [buf] seed fn = do+> v <- liftIO $ IE.fetchCol q buf+> fn v seed+> allocBuffers q _ n = liftIO $ +> sequence [IE.allocBufferFor (undefined::a) q n]+++|This instance of the class implements the starting and continuation cases.++> instance (QueryIteratee m q i' seed b, IE.DBType a q b)+> => QueryIteratee m q (a -> i') seed b where+> iterApply q (buffer:moreBuffers) seed fn = do+> v <- liftIO $ IE.fetchCol q buffer+> iterApply q moreBuffers seed (fn v)+> allocBuffers q fn n = do+> buffer <- liftIO $ IE.allocBufferFor (undefined::a) q n+> moreBuffers <- allocBuffers q (undefined::i') (n+1)+> return (buffer:moreBuffers)++++--------------------------------------------------------------------+-- ** A Query monad and cursors+--------------------------------------------------------------------+++> type CollEnumerator i m s = i -> s -> m s+> type Self i m s = i -> s -> m s+> type CFoldLeft i m s = Self i m s -> CollEnumerator i m s++|A DBCursor is an IORef-mutable-pair @(a, Maybe f)@, where @a@ is the result-set so far,+and @f@ is an IO action that fetches and returns the next row (when applied to True),+or closes the cursor (when applied to False).+If @Maybe@ f is @Nothing@, then the result-set has been exhausted+(or the iteratee function terminated early),+and the cursor has already been closed.++> newtype DBCursor mark ms a =+> DBCursor (IORef (a, Maybe (Bool-> ms (DBCursor mark ms a))))+++| The left-fold interface.++> doQuery :: (IE.Statement stmt sess q,+> QueryIteratee (DBM mark sess) q i seed b,+> IE.IQuery q sess b) =>+> stmt -- ^ query+> -> i -- ^ iteratee function+> -> seed -- ^ seed value+> -> DBM mark sess seed+> doQuery stmt iteratee seed = do+> (lFoldLeft, finalizer) <- doQueryMaker stmt iteratee+> gcatch (fix lFoldLeft iteratee seed)+> (\e -> do+> finalizer+> liftIO (throw e)+> )+++An auxiliary function, not seen by the user.++> doQueryMaker stmt iteratee = do+> sess <- ask+> query <- liftIO $ IE.makeQuery sess stmt+> buffers <- allocBuffers query iteratee 1+> let+> finaliser =+> liftIO (mapM_ (IE.freeBuffer query) buffers)+> >> liftIO (IE.destroyQuery query)+> hFoldLeft self iteratee initialSeed = do+> let+> handle seed True = iterApply query buffers seed iteratee+> >>= handleIter+> handle seed False = (finaliser) >> return seed+> handleIter (Right seed) = self iteratee seed+> handleIter (Left seed) = (finaliser) >> return seed+> liftIO (IE.fetchOneRow query) >>= handle initialSeed+> return (hFoldLeft, finaliser)+++Another auxiliary function, also not seen by the user.++> openCursor stmt iteratee seed = do+> ref <- liftIO (newIORef (seed,Nothing))+> (lFoldLeft, finalizer) <- doQueryMaker stmt iteratee+> let update v = liftIO $ modifyIORef ref (\ (_, f) -> (v, f))+> let+> close finalseed = do+> liftIO$ modifyIORef ref (\_ -> (finalseed, Nothing))+> finalizer+> return (DBCursor ref)+> let+> k' fni seed' = +> let+> k fni' seed'' = do+> let k'' flag = if flag then k' fni' seed'' else close seed''+> liftIO$ modifyIORef ref (\_->(seed'', Just k''))+> return seed''+> in do+> liftIO$ modifyIORef ref (\_ -> (seed', Nothing))+> do {lFoldLeft k fni seed' >>= update}+> return $ DBCursor ref+> k' iteratee seed++++|cursorIsEOF's return value tells you if there are any more rows or not.+If you call 'cursorNext' when there are no more rows,+a 'DBNoData' exception is thrown.+Cursors are automatically closed and freed when:++ * the iteratee returns @Left a@++ * the query result-set is exhausted.++To make life easier, we've created a 'withCursor' function,+which will clean up if an error (exception) occurs,+or the code exits early.+You can nest them to get interleaving, if you desire:++ > withCursor query1 iter1 [] $ \c1 -> do+ > withCursor query2 iter2 [] $ \c2 -> do+ > r1 <- cursorCurrent c1+ > r2 <- cursorCurrent c2+ > ...+ > return something+++Note that the type of the functions below is set up so to perpetuate+the mark.++> cursorIsEOF :: DBCursor mark (DBM mark s) a -> DBM mark s Bool+> cursorIsEOF (DBCursor ref) = do+> (_, maybeF) <- liftIO $ readIORef ref+> return $ maybe True (const False) maybeF++|Returns the results fetched so far, processed by iteratee function.++> cursorCurrent :: DBCursor mark (DBM mark s) a -> DBM mark s a+> cursorCurrent (DBCursor ref) = do+> (v, _) <- liftIO $ readIORef ref+> return v++|Advance the cursor. Returns the cursor. The return value is usually ignored.++> cursorNext :: DBCursor mark (DBM mark s) a+> -> DBM mark s (DBCursor mark (DBM mark s) a)+> cursorNext (DBCursor ref) = do+> (_, maybeF) <- liftIO $ readIORef ref+> maybe (IE.throwDB DBNoData) ($ True) maybeF+++Returns the cursor. The return value is usually ignored.+This function is not available to the end user (i.e. not exported).+The cursor is closed automatically when its region exits. ++> cursorClose c@(DBCursor ref) = do+> (_, maybeF) <- liftIO $ readIORef ref+> maybe (return c) ($ False) maybeF+++|Ensures cursor resource is properly tidied up in exceptional cases.+Propagates exceptions after closing cursor.+The Typeable constraint is to prevent cursors and other marked values+(like cursor computations) from escaping.++> withCursor ::+> ( Typeable a, IE.Statement stmt sess q+> , QueryIteratee (DBM mark sess) q i seed b+> , IE.IQuery q sess b+> ) =>+> stmt -- ^ query+> -> i -- ^ iteratee function+> -> seed -- ^ seed value+> -> (DBCursor mark (DBM mark sess) seed -> DBM mark sess a) -- ^ action taking cursor parameter+> -> DBM mark sess a+> withCursor stmt iteratee seed action =+> gbracket (openCursor stmt iteratee seed) cursorClose action+++Although withTransaction has the same structure as a bracket,+we can't use bracket because the resource-release action+(commit or rollback) differs between the success and failure cases.++|Perform an action as a transaction: commit afterwards,+unless there was an exception, in which case rollback.++> withTransaction :: (IE.ISession s) =>+> IE.IsolationLevel -> DBM mark s a -> DBM mark s a+> +> withTransaction isolation action = do+> beginTransaction isolation+> gcatch ( do+> v <- action+> commit+> return v+> ) (\e -> rollback >> throw e )+++--------------------------------------------------------------------+-- ** Misc.+--------------------------------------------------------------------+++|Useful utility function, for SQL weenies.++> ifNull :: Maybe a -- ^ nullable value+> -> a -- ^ value to substitute if first parameter is null i.e. 'Data.Maybe.Nothing'+> -> a+> ifNull value subst = maybe subst id value++++| Another useful utility function.+Use this to return a value from an iteratee function (the one passed to+'Database.Enumerator.doQuery').+Note that you should probably nearly always use the strict version.++> result :: (Monad m) => IterAct m a+> result x = return (Right x)+++|A strict version. This is recommended unless you have a specific need for laziness,+as the lazy version will gobble stack and heap.+If you have a large result-set (in the order of 10-100K rows or more),+it is likely to exhaust the standard 1M GHC stack.+Whether or not 'result' eats memory depends on what @x@ does:+if it's a delayed computation then it almost certainly will.+This includes consing elements onto a list,+and arithmetic operations (counting, summing, etc).++> result' :: (Monad m) => IterAct m a+> result' x = return (Right $! x)+++That's the code... now for the documentation.+++====================================================================+== Usage notes+====================================================================+++$usage_example++Let's look at some example code:++ > -- sample code, doesn't necessarily compile+ > module MyDbExample is+ >+ > import Database.Oracle.Enumerator+ > import Database.Enumerator+ > ...+ >+ > query1Iteratee :: (Monad m) => Int -> String -> Double -> IterAct m [(Int, String, Double)]+ > query1Iteratee a b c accum = result' ((a, b, c):accum)+ >+ > -- non-query actions.+ > otherActions session = do+ > execDDL (sql "create table blah")+ > execDML (sql "insert into blah ...")+ > commit+ > -- Use withTransaction to delimit a transaction.+ > -- It will commit at the end, or rollback if an error occurs.+ > withTransaction Serialisable ( do+ > execDML (sql "update blah ...")+ > execDML (sql "insert into blah ...")+ > )+ >+ > main :: IO ()+ > main = do+ > withSession (connect "user" "password" "server") ( do+ > -- simple query, returning reversed list of rows.+ > r <- doQuery (sql "select a, b, c from x") query1Iteratee []+ > liftIO $ putStrLn $ show r+ > otherActions session+ > )++ Notes:++ * connection is made by 'Database.Enumerator.withSession',+ which also disconnects when done i.e. 'Database.Enumerator.withSession'+ delimits the connection.+ You must pass it a connection action, which is back-end specific,+ and created by calling the 'Database.Sqlite.Enumerator.connect'+ function from the relevant back-end.++ * inside the session, the usual transaction delimiter commands are usable+ e.g. 'Database.Enumerator.beginTransaction' 'Database.InternalEnumerator.IsolationLevel',+ 'Database.Enumerator.commit', 'Database.Enumerator.rollback', and+ 'Database.Enumerator.withTransaction'.+ We also provide 'Database.Enumerator.execDML' and 'Database.Enumerator.execDDL'.++ * non-DML and -DDL commands - i.e. queries - are processed by+ 'Database.Enumerator.doQuery' (this is the API for our left-fold).+ See more explanation and examples below in /Iteratee Functions/ and+ /Bind Parameters/ sections.++The first argument to 'Database.Enumerator.doQuery' must be an instance of +'Database.InternalEnumerator.Statement'.+Each back-end will provide a useful set of @Statement@ instances+and associated constructor functions for them.+For example, currently all back-ends have:++ * for basic, all-text statements (no bind variables, default row-caching)+ which can be used as queries or commands: ++ > sql "select ..."++ * for a select with bind variables:++ > sqlbind "select ..." [bindP ..., bindP ...]++ * for a select with bind variables and row caching:++ > prefetch 100 "select ..." [bindP ..., bindP ...]++ * for a DML command with bind variables:++ > cmdbind "insert into ..." [bindP ..., bindP ...]++ * for a reusable prepared statement: we have to first create the+ prepared statement, and then bind in a separate step.+ This separation lets us re-use prepared statements:++ > let stmt = prepareQuery (sql "select ...")+ > withPreparedStatement stmt $ \pstmt ->+ > withBoundStatement pstmt [bindP ..., bindP ...] $ \bstmt -> do+ > result <- doQuery bstmt iter seed+ > ...++The PostgreSQL backend additionally requires that when preparing statements,+you (1) give a name to the prepared statement,+and (2) specify types for the bind parameters.+The list of bind-types is created by applying the+'Database.PostgreSQL.Enumerator.bindType' function+to dummy values of the appropriate types. e.g.++ > let stmt = prepareQuery "stmtname" (sql "select ...") [bindType "", bindType (0::Int)]+ > withPreparedStatement stmt $ \pstmt -> ...++A longer explanation of prepared statements and+bind variables is in the Bind Parameters section below.+++$usage_iteratee++'Database.Enumerator.doQuery' takes an iteratee function, of n arguments.+Argument n is the accumulator (or seed).+For each row that is returned by the query,+the iteratee function is called with the data from that row in+arguments 1 to n-1, and the current accumulated value in the argument n.++The iteratee function returns the next value of the accumulator,+wrapped in an 'Data.Either.Either'.+If the 'Data.Either.Either' value is @Left@, then the query will terminate,+returning the wrapped accumulator\/seed value.+If the value is @Right@, then the query will continue, with the next row+begin fed to the iteratee function, along with the new accumulator\/seed value.++In the example above, @query1Iteratee@ simply conses the new row (as a tuple)+to the front of the accumulator.+The initial seed passed to 'Database.Enumerator.doQuery' was an empty list.+Consing the rows to the front of the list results in a list+with the rows in reverse order.++The types of values that can be used as arguments to the iteratee function+are back-end specific; they must be instances of the class+'Database.InternalEnumerator.DBType'.+Most backends directly support the usual lowest-common-denominator set+supported by most DBMS's: 'Data.Int.Int', 'Data.Char.String',+'Prelude.Double', 'Data.Time.UTCTime'.+('Data.Int.Int64' is often, but not always, supported.)++By directly support we mean there is type-specific marshalling code+implemented.+Indirect support for 'Text.Read.Read'- and 'Text.Show.Show'-able types+is supported by marshalling to and from 'Data.Char.String's.+This is done automatically by the back-end;+there is no need for user-code to perform the marshalling,+as long as instances of 'Text.Read.Read' and 'Text.Show.Show' are defined.++The iteratee function operates in the 'DBM' monad,+so if you want to do IO in it you must use 'Control.Monad.Trans.liftIO'+(e.g. @liftIO $ putStrLn \"boo\"@ ) to lift the IO action into 'DBM'.++The iteratee function is not restricted to just constructing lists.+For example, a simple counter function would ignore its arguments,+and the accumulator would simply be the count e.g.++ > counterIteratee :: (Monad m) => Int -> IterAct m Int+ > counterIteratee _ i = result' $ (1 + i)++The iteratee function that you pass to 'Database.Enumerator.doQuery'+needs type information,+at least for the arguments if not the return type (which is typically+determined by the type of the seed).+The type synonyms 'IterAct' and 'IterResult' give some convenience+in writing type signatures for iteratee functions:++ > type IterResult seedType = Either seedType seedType+ > type IterAct m seedType = seedType -> m (IterResult seedType)++Without them, the type for @counterIteratee@ would be:++ > counterIteratee :: (Monad m) => Int -> Int -> m (Either Int Int)++which doesn't seem so onerous, but for more elaborate seed types+(think large tuples) it certainly helps e.g.++ > iter :: Monad m =>+ > String -> Double -> CalendarTime -> [(String, Double, CalendarTime)]+ > -> m (Either [(String, Double, CalendarTime)] [(String, Double, CalendarTime)] )++reduces to (by using 'IterAct' and 'IterResult'):++ > iter :: Monad m =>+ > String -> Double -> CalendarTime -> IterAct m [(String, Double, CalendarTime)]++++$usage_result++The 'result' (lazy) and @result\'@ (strict) functions are another convenient shorthand+for returning values from iteratee functions. The return type from an iteratee is actually+@Either seed seed@, where you return @Right@ if you want processing to continue,+or @Left@ if you want processing to stop before the result-set is exhausted.+The common case is:++ > query1Iteratee a b c accum = return (Right ((a, b, c):accum))++which we can write as++ > query1Iteratee a b c accum = result $ (a, b, c):accum)++We have lazy and strict versions of @result@. The strict version is almost certainly+the one you want to use. If you come across a case where the lazy function is useful,+please tell us about it. The lazy function tends to exhaust the stack for large result-sets,+whereas the strict function does not.+This is due to the accumulation of a large number of unevaluated thunks,+and will happen even for simple arithmetic operations such as counting or summing.++If you use the lazy function and you have stack\/memory problems, do some profiling.+With GHC:++ * ensure the iteratee has its own cost-centre (make it a top-level function)++ * compile with @-prof -auto-all@++ * run with @+RTS -p -hr -RTS@++ * run @hp2ps@ over the resulting @.hp@ file to get a @.ps@ document, and take a look at it.+ Retainer sets are listed on the RHS, and are prefixed with numbers e.g. (13)CAF, (2)SYSTEM.+ At the bottom of the @.prof@ file you'll find the full descriptions of the retainer sets.+ Match the number in parentheses on the @.ps@ graph with a SET in the @.prof@ file;+ the one at the top of the @.ps@ graph is the one using the most memory.++You'll probably find that the lazy iteratee is consuming all of the stack with lazy thunks,+which is why we recommend the strict function.++++$usage_rank2_types++In some examples we use the application operator ($) instead of parentheses+(some might argue that this is a sign of developer laziness).+At first glance, ($) and conventional function application via juxtaposition+seem to be interchangeable e.g.++ > liftIO (putStrLn (show x))++ looks equivalent to++ > liftIO $ putStrLn $ show x++But they're not, because Haskell's type system gives us a nice compromise.++In a Hindley-Milner type system (like ML) there is no difference between+($) and function application, because polymorphic functions are not+first-class and cannot be passed to other functions.+At the other end of the scale, ($) and function application in System F+are equivalent, because polymorphic functions can be passed to other+functions. However, type inference in System F is undecidable.++Haskell hits the sweet spot: maintaining full inference,+and permitting rank-2 polymorphism, in exchange for very few+type annotations. Only functions that take polymorphic functions (and+thus are higher-rank) need type signatures. Rank-2 types can't be+inferred. The function ($) is a regular, rank-1 function, and so+it can't take polymorphic functions as arguments and return+polymorphic functions.++Here's an example where ($) fails: +we supply a simple test program in the README file.+If you change the @withSession@ line to use ($), like so+(and remove the matching end-parenthese):++ > withSession (connect "sqlite_db") $ do++then you get the error:++ > Main.hs:7:38:+ > Couldn't match expected type `forall mark. DBM mark Session a'+ > against inferred type `a1 b'+ > In the second argument of `($)', namely+ > ...++Another way of rewriting it is like this, where we separate the+'Database.Enumerator.DBM' action into another function:++ > {-# OPTIONS -fglasgow-exts #-}+ > module Main where+ > import Database.Sqlite.Enumerator+ > import Control.Monad.Trans (liftIO)+ > main = flip catchDB reportRethrow $+ > withSession (connect "sqlite_db") hello+ >+ > hello = withTransaction RepeatableRead $ do+ > let iter (s::String) (_::String) = result s+ > result <- doQuery (sql "select 'Hello world.'") iter ""+ > liftIO (putStrLn result)++which gives this error:++ > Main.hs:9:2:+ > Inferred type is less polymorphic than expected+ > Quantified type variable `mark' is mentioned in the environment:+ > hello :: DBM mark Session () (bound at Main.hs:15:0)+ > ...++This is just the monomorphism restriction in action.+Sans a type signature, the function `hello' is monomorphised+(that is, `mark' is replaced with (), per GHC rules).+This is easily fixed by adding this type declaration:++ > hello :: DBM mark Session ()+++++$usage_bindparms++Support for bind variables varies between DBMS's.++We call 'Database.Enumerator.withPreparedStatement' function to prepare+the statement, and then call 'Database.Enumerator.withBoundStatement'+to provide the bind values and execute the query.+The value returned by 'Database.Enumerator.withBoundStatement'+is an instance of the 'Database.InternalEnumerator.Statement' class,+so it can be passed to 'Database.Enumerator.doQuery' for result-set processing.++When we call 'Database.Enumerator.withPreparedStatement', we must pass+it a \"preparation action\", which is simply an action that returns+the prepared query. The function to create this action varies between backends,+and by convention is called 'Database.PostgreSQL.Enumerator.prepareQuery'.+For DML statements, you must use 'Database.PostgreSQL.Enumerator.prepareCommand',+as the library needs to do something different depending on whether or not the+statement returns a result-set.++For queries with large result-sets, we provide +'Database.PostgreSQL.Enumerator.prepareLargeQuery',+which takes an extra parameter: the number of rows to prefetch+in a network call to the server.+This aids performance in two ways:+1. you can limit the number of rows that come back to the+client, in order to use less memory, and+2. the client library will cache rows, so that a network call to+the server is not required for every row processed.++With PostgreSQL, we must specify the types of the bind parameters+when the query is prepared, so the 'Database.PostgreSQL.Enumerator.prepareQuery'+function takes a list of 'Database.PostgreSQL.Enumerator.bindType' values.+Also, PostgreSQL requires that prepared statements are named,+although you can use \"\" as the name.++With Sqlite and Oracle, we simply pass the query text to+'Database.PostgreSQL.Sqlite.prepareQuery',+so things are slightly simpler for these backends.++Perhaps an example will explain it better:++ > postgresBindExample = do+ > let+ > query = sql "select blah from blahblah where id = ? and code = ?"+ > iter :: (Monad m) => String -> IterAct m [String]+ > iter s acc = result $ s:acc+ > bindVals = [bindP (12345::Int), bindP "CODE123"]+ > bindTypes = [bindType (0::Int), bindType ""]+ > withPreparedStatement (prepareQuery "stmt1" query bindTypes) $ \pstmt -> do+ > withBoundStatement pstmt bindVals $ \bstmt -> do+ > actual <- doQuery bstmt iter []+ > liftIO (print actual)++Note that we pass @bstmt@ to 'Database.Enumerator.doQuery';+this is the bound statement object created by+'Database.Enumerator.withBoundStatement'.++The Oracle\/Sqlite example code is almost the same, except for the+call to 'Database.Sqlite.Enumerator.prepareQuery':++ > sqliteBindExample = do+ > let+ > query = sql "select blah from blahblah where id = ? and code = ?"+ > iter :: (Monad m) => String -> IterAct m [String]+ > iter s acc = result $ s:acc+ > bindVals = [bindP (12345::Int), bindP "CODE123"]+ > withPreparedStatement (prepareQuery query) $ \pstmt -> do+ > withBoundStatement pstmt bindVals $ \bstmt -> do+ > actual <- doQuery bstmt iter []+ > liftIO (print actual)++It can be a bit tedious to always use the @withPreparedStatement+withBoundStatement@+combination, so for the case where you don't plan to re-use the query,+we support a short-cut for bundling the query text and parameters.+The next example is valid for PostgreSQL, Sqlite, and Oracle+(the Sqlite implementation provides a dummy 'Database.Sqlite.Enumerator.prefetch'+function to ensure we have a consistent API).+Sqlite has no facility for prefetching - it's an embedded database, so no+network round-trip - so the Sqlite implementation ignores the prefetch count:++ > bindShortcutExample = do+ > let+ > iter :: (Monad m) => String -> IterAct m [String]+ > iter s acc = result $ s:acc+ > bindVals = [bindP (12345::Int), bindP "CODE123"]+ > query = prefetch 1000 "select blah from blahblah where id = ? and code = ?" bindVals+ > actual <- doQuery query iter []+ > liftIO (print actual)++A caveat of using prefetch with PostgreSQL is that you must be inside a transaction.+This is because the PostgreSQL implementation uses a cursor and \"FETCH FORWARD\"+to implement fetching a block of rows in a single network call,+and PostgreSQL requires that cursors are only used inside transactions.+It can be as simple as wrapping calls to 'Database.Enumerator.doQuery' by+'Database.Enumerator.withTransaction',+or you may prefer to delimit your transactions elsewhere (the API supports+'Database.InternalEnumerator.beginTransaction' and+'Database.InternalEnumerator.commit', if you prefer to use them):++ > withTransaction RepeatableRead $ do+ > actual <- doQuery query iter []+ > liftIO (print actual)++You may have noticed that for 'Data.Int.Int' and 'Prelude.Double' literal+bind values, we have to tell the compiler the type of the literal.+I assume this is due to interaction (which I don't fully understand and therefore+cannot explain in any detail) with the numeric literal defaulting mechanism.+For non-numeric literals the compiler can determine the correct types to use.++If you omit type information for numeric literals, from GHC the error+message looks something like this:++ > Database/PostgreSQL/Test/Enumerator.lhs:194:4:+ > Overlapping instances for Database.InternalEnumerator.DBBind a+ > Session+ > Database.PostgreSQL.PGEnumerator.PreparedStmt+ > Database.PostgreSQL.PGEnumerator.BindObj+ > arising from use of `bindP' at Database/PostgreSQL/Test/Enumerator.lhs:194:4-8+ > Matching instances:+ > Imported from Database.PostgreSQL.PGEnumerator:+ > instance (Database.InternalEnumerator.DBBind (Maybe a)+ > Session+ > Database.PostgreSQL.PGEnumerator.PreparedStmt+ > Database.PostgreSQL.PGEnumerator.BindObj) =>+ > Database.InternalEnumerator.DBBind a+ > Session+ > Database.PostgreSQL.PGEnumerator.PreparedStmt+ > Database.PostgreSQL.PGEnumerator.BindObj+ > Imported from Database.PostgreSQL.PGEnumerator:+ > instance Database.InternalEnumerator.DBBind (Maybe Double)+ > ....+++$usage_multiresultset++Support for returning multiple result sets from a single+statement exists for PostgreSQL and Oracle.+Such functionality does not exist in Sqlite.++The general idea is to invoke a database procedure or function which+returns cursor variables. The variables can be processed by+'Database.Enumerator.doQuery' in one of two styles: linear or nested.++/Linear style:/++If we assume the existence of the following PostgreSQL function,+which is used in the test suite in "Database.PostgreSQL.Test.Enumerator":++ > CREATE OR REPLACE FUNCTION takusenTestFunc() RETURNS SETOF refcursor AS $$+ > DECLARE refc1 refcursor; refc2 refcursor;+ > BEGIN+ > OPEN refc1 FOR SELECT n*n from t_natural where n < 10 order by 1;+ > RETURN NEXT refc1;+ > OPEN refc2 FOR SELECT n, n*n, n*n*n from t_natural where n < 10 order by 1;+ > RETURN NEXT refc2;+ > END;$$ LANGUAGE plpgsql;++... then this code shows how linear processing of cursors would be done:++ > withTransaction RepeatableRead $ do+ > withPreparedStatement (prepareQuery "stmt1" (sql "select * from takusenTestFunc()") []) $ \pstmt -> do+ > withBoundStatement pstmt [] $ \bstmt -> do+ > dummy <- doQuery bstmt iterMain []+ > result1 <- doQuery (NextResultSet pstmt) iterRS1 []+ > result2 <- doQuery (NextResultSet pstmt) iterRS2 []+ > where+ > iterMain :: (Monad m) => (RefCursor String) -> IterAct m [RefCursor String]+ > iterMain c acc = result (acc ++ [c])+ > iterRS1 :: (Monad m) => Int -> IterAct m [Int]+ > iterRS1 i acc = result (acc ++ [i])+ > iterRS2 :: (Monad m) => Int -> Int -> Int -> IterAct m [(Int, Int, Int)]+ > iterRS2 i i2 i3 acc = result (acc ++ [(i, i2, i3)])++Notes:++ * the use of a 'Database.Enumerator.RefCursor' 'Data.Char.String'+ type in the iteratee function indicates+ to the backend that it should save each cursor value returned,+ which it does by stuffing them into a list attached to the+ prepared statement object.+ This means that we /must/ use 'Database.Enumerator.withPreparedStatement'+ to create a prepared statement object; the prepared statament oject+ is the container for the cursors returned.++ * in this example we choose to discard the results of the first iteratee.+ This is not necessary, but in this case the only column is a+ 'Database.Enumerator.RefCursor', and the values are already saved+ in the prepared statement object.++ * saved cursors are consumed one-at-a-time by calling 'Database.Enumerator.doQuery',+ passing 'Database.Enumerator.NextResultSet' @pstmt@+ (i.e. passing the prepared statement oject wrapped by+ 'Database.Enumerator.NextResultSet').+ This simply pulls the next cursor off the list+ - they're processed in the order they were pushed on (FIFO) -+ and processes it with the given iteratee.++ * if you try to process too many cursors i.e. make too many calls+ to 'Database.Enumerator.doQuery' passing 'Database.Enumerator.NextResultSet' @pstmt@,+ then an exception will be thrown.+ OTOH, failing to process returned cursors will not raise errors,+ but the cursors will remain open on the server according to whatever scoping+ rules the server applies.+ For PostgreSQL, this will be until the transaction (or session) ends.++/Nested style:/++The linear style of cursor processing is the only style supported by+MS SQL Server and ODBC (which we do not yet support).+However, PostgreSQL and Oracle also support using nested cursors in queries.++Again for PostgreSQL, assuming we have these functions in the database:++ > CREATE OR REPLACE FUNCTION takusenTestFunc(lim int4) RETURNS refcursor AS $$+ > DECLARE refc refcursor;+ > BEGIN+ > OPEN refc FOR SELECT n, takusenTestFunc2(n) from t_natural where n < lim order by n;+ > RETURN refc;+ > END; $$ LANGUAGE plpgsql;++ > CREATE OR REPLACE FUNCTION takusenTestFunc2(lim int4) RETURNS refcursor AS $$+ > DECLARE refc refcursor;+ > BEGIN+ > OPEN refc FOR SELECT n from t_natural where n < lim order by n;+ > RETURN refc;+ > END; $$ LANGUAGE plpgsql;++... then this code shows how nested queries might work:++ > selectNestedMultiResultSet = do+ > let+ > q = "SELECT n, takusenTestFunc(n) from t_natural where n < 10 order by n"+ > iterMain (i::Int) (c::RefCursor String) acc = result' ((i,c):acc)+ > iterInner (i::Int) (c::RefCursor String) acc = result' ((i,c):acc)+ > iterInner2 (i::Int) acc = result' (i:acc)+ > withTransaction RepeatableRead $ do+ > rs <- doQuery (sql q) iterMain []+ > flip mapM_ rs $ \(outer, c) -> do+ > rs <- doQuery c iterInner []+ > flip mapM_ rs $ \(inner, c) -> do+ > rs <- doQuery c iterInner2 []+ > flip mapM_ rs $ \i -> do+ > liftIO (putStrLn (show outer ++ " " ++ show inner ++ " " ++ show i))++Just to make it clear: the outer query returns a result-set that includes+a 'Database.Enumerator.RefCursor' column. Each cursor from that column is passed to+'Database.Enumerator.doQuery' to process it's result-set;+here we use 'Control.Monad.mapM_' to apply an IO action to the list returned by+'Database.Enumerator.doQuery'.++For Oracle the example is slightly different.+The reason it's different is that:++ * Oracle requires that the parent cursor must remain open+ while processing the children+ (in the PostgreSQL example, 'Database.Enumerator.doQuery'+ closes the parent cursor after constructing the list,+ before the list is processed. This is OK because PostgreSQL+ keeps the child cursors open on the server until they are explicitly+ closed, or the transaction or session ends).++ * our current Oracle implementation prevents marshalling+ of the cursor in the result-set buffer to a Haskell value,+ so each fetch overwrites the buffer value with a new cursor.+ This means you have to fully process a given cursor before+ fetching the next one.++Contrast this with the PostgreSQL example above,+where the entire result-set is processed to give a+list of RefCursor values, and then we run a list of actions+over this list with 'Control.Monad.mapM_'.+This is possible because PostgreSQL refcursors are just the+database cursor names, which are Strings, which we can marshal+to Haskell values easily.++ > selectNestedMultiResultSet = do+ > let+ > q = "select n, cursor(SELECT nat2.n, cursor"+ > ++ " (SELECT nat3.n from t_natural nat3 where nat3.n < nat2.n order by n)"+ > ++ " from t_natural nat2 where nat2.n < nat.n order by n)"+ > ++ " from t_natural nat where n < 10 order by n"+ > iterMain (outer::Int) (c::RefCursor StmtHandle) acc = do+ > rs <- doQuery c (iterInner outer) []+ > result' ((outer,c):acc)+ > iterInner outer (inner::Int) (c::RefCursor StmtHandle) acc = do+ > rs <- doQuery c (iterInner2 outer inner) []+ > result' ((inner,c):acc)+ > iterInner2 outer inner (i::Int) acc = do+ > liftIO (putStrLn (show outer ++ " " ++ show inner ++ " " ++ show i))+ > result' (i:acc)+ > withTransaction RepeatableRead $ do+ > rs <- doQuery (sql q) iterMain []+ > return ()++Note that the PostgreSQL example can also be written like this+(except, of course, that the actual query text is that+from the PostgreSQL example).++++--------------------------------------------------------------------+-- Haddock notes:+--------------------------------------------------------------------++The best way (that I've found) to get a decent introductory/explanatory+section for the module is to break the explanation into named chunks+(these begin with -- $<chunk-name>),+put the named chunks at the end, and reference them in the export list.++You *can* write the introduction inline, as part of the module description,+but Haddock has no way to make headings.+Instead, if you make an explicit export-list then you can use+the "-- *", "-- **", etc, syntax to give section headings.++(Note: if you don't use an explicit export list, then Haddock will use "-- *" etc+comments to make headings. The headings will appear in the docs in the the locations+as they do in the source, as do functions, data types, etc.)++ - One blank line continues a comment block. Two or more end it.+ - The module comment must contain a empty line between "Portability: ..." and the description.+ - bullet-lists:+ - items must be preceded by an empty line.+ - each list item must start with "*".+ - code-sections:+ - must be preceded by an empty line.+ - use " >" rather than @...@, because "@" allows markup translation, where " >" doesn't.+ - @inline code (monospaced font)@+ - /emphasised text/+ - links: "Another.Module", 'someIdentifier' (same module),+ 'Another.Module.someIdentifier', <http:/www.haskell.org/haddock>+
+ testcases/testcase4.hs view
@@ -0,0 +1,509 @@+-- to be found logM+-- to be found debugM+-- to be found infoM+-- to be found noticeM+-- to be found warningM+-- to be found errorM+-- to be found criticalM+-- to be found alertM+-- to be found emergencyM+-- to be found traplogging+-- to be found logL+-- to be found getLogger+-- to be found getRootLogger+-- to be found rootLoggerName+-- to be found addHandler+-- to be found setHandlers+-- to be found getLevel+-- to be found setLevel+-- to be found saveGlobalLogger+-- to be found updateGlobalLogger+++{-# OPTIONS -fglasgow-exts #-}+{- arch-tag: Logger main definition+Copyright (C) 2004-2006 John Goerzen <jgoerzen@complete.org>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU Lesser General Public License as published by+the Free Software Foundation; either version 2.1 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU Lesser General Public License for more details.++You should have received a copy of the GNU Lesser General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+-}++{- |+ Module : System.Log.Logger+ Copyright : Copyright (C) 2004-2006 John Goerzen+ License : GNU LGPL, version 2.1 or above++ Maintainer : John Goerzen <jgoerzen@complete.org> + Stability : provisional+ Portability: portable++Haskell Logging Framework, Primary Interface++Written by John Goerzen, jgoerzen\@complete.org++Welcome to the error and information logging system for Haskell.++This system is patterned after Python\'s @logging@ module,+<http://www.python.org/doc/current/lib/module-logging.html> and some of+the documentation here was based on documentation there.++To log a message, you perform operations on 'Logger's. Each 'Logger' has a+name, and they are arranged hierarchically. Periods serve as separators.+Therefore, a 'Logger' named \"foo\" is the parent of loggers \"foo.printing\",+\"foo.html\", and \"foo.io\". These names can be anything you want. They're+used to indicate the area of an application or library in which a logged+message originates. Later you will see how you can use this concept to +fine-tune logging behaviors based on specific application areas.++You can also tune logging behaviors based upon how important a message is.+Each message you log will have an importance associated with it. The different+importance levels are given by the 'Priority' type. I've also provided+some convenient functions that correspond to these importance levels:+'debugM' through 'emergencyM' log messages with the specified importance.++Now, an importance level (or 'Priority') +is associated not just with a particular message but also+with a 'Logger'. If the 'Priority' of a given log message is lower than+the 'Priority' configured in the 'Logger', that message is ignored. This+way, you can globally control how verbose your logging output is.++Now, let's follow what happens under the hood when you log a message. We'll+assume for the moment that you are logging something with a high enough+'Priority' that it passes the test in your 'Logger'. In your code, you'll+call 'logM' or something like 'debugM' to log the message. Your 'Logger'+decides to accept the message. What next?++Well, we also have a notion of /handlers/ ('LogHandler's, to be precise).+A 'LogHandler' is a thing that takes a message and sends it somewhere.+That \"somewhere\" may be your screen (via standard error), your system's+logging infrastructure (via syslog), a file, or other things. Each+'Logger' can have zero or more 'LogHandler's associated with it. When your+'Logger' has a message to log, it passes it to every 'LogHandler' it knows+of to process. What's more, it is also passed to /all handlers of all+ancestors of the Logger/, regardless of whether those 'Logger's would+normally have passed on the message.++To give you one extra little knob to turn, 'LogHandler's can also have+importance levels ('Priority') associated with them in the same way+that 'Logger's do. They act just like the 'Priority' value in the+'Logger's -- as a filter. It's useful, for instance, to make sure that+under no circumstances will a mere 'DEBUG' message show up in your syslog.++There are three built-in handlers given in two built-in modules:+"System.Log.Handler.Simple" and "System.Log.Handler.Syslog".++There is a special logger known as the /root logger/ that sits at the top+of the logger hierarchy. It is always present, and handlers attached+there will be called for every message. You can use 'getRootLogger' to get+it or 'rootLoggerName' to work with it by name.++Here's an example to illustrate some of these concepts:++> import System.Log.Logger+> import System.Log.Handler.Syslog+> +> -- By default, all messages of level WARNING and above are sent to stderr.+> -- Everything else is ignored.+> +> -- "MyApp.Component" is an arbitrary string; you can tune+> -- logging behavior based on it later.+> main = do+> debugM "MyApp.Component" "This is a debug message -- never to be seen"+> warningM "MyApp.Component2" "Something Bad is about to happen."+> +> -- Copy everything to syslog from here on out.+> s <- openlog "SyslogStuff" [PID] USER DEBUG+> updateGlobalLogger rootLoggerName (addHandler s)+> +> errorM "MyApp.Component" "This is going to stderr and syslog."+>+> -- Now we'd like to see everything from BuggyComponent+> -- at DEBUG or higher go to syslog and stderr.+> -- Also, we'd like to still ignore things less than+> -- WARNING in other areas.+> -- +> -- So, we adjust the Logger for MyApp.Component.+>+> updateGlobalLogger "MyApp.BuggyComponent"+> (setLevel DEBUG)+>+> -- This message will go to syslog and stderr+> debugM "MyApp.BuggyComponent" "This buggy component is buggy"+> +> -- This message will go to syslog and stderr too.+> warningM "MyApp.BuggyComponent" "Still Buggy"+> +> -- This message goes nowhere.+> debugM "MyApp.WorkingComponent" "Hello"++-}++module System.Log.Logger(+ -- * Basic Types+ Logger,+ -- ** Re-Exported from System.Log+ Priority(..),+ -- * Logging Messages+ -- ** Basic+ logM,+ -- ** Utility Functions+ -- These functions are wrappers for 'logM' to+ -- make your job easier.+ debugM, infoM, noticeM, warningM, errorM,+ criticalM, alertM, emergencyM,+ traplogging,+ -- ** Logging to a particular Logger by object+ logL,+ -- * Logger Manipulation+{- | These functions help you work with loggers. There are some+special things to be aware of.++First of all, whenever you first access a given logger by name, it+magically springs to life. It has a default 'Priority' of 'DEBUG'+and an empty handler list -- which means that it will inherit whatever its+parents do.+-}+ -- ** Finding \/ Creating Loggers+ getLogger, getRootLogger, rootLoggerName,+ -- ** Modifying Loggers+{- | Keep in mind that \"modification\" here is modification in the Haskell+sense. We do not actually cause mutation in a specific 'Logger'. Rather,+we return you a new 'Logger' object with the change applied.++Also, please note that these functions will not have an effect on the+global 'Logger' hierarchy. You may use your new 'Logger's locally,+but other functions won't see the changes. To make a change global,+you'll need to use 'updateGlobalLogger' or 'saveGlobalLogger'.+-}+ addHandler, setHandlers,+ getLevel, setLevel,+ -- ** Saving Your Changes+{- | These functions commit changes you've made to loggers to the global+logger hierarchy. -}+ saveGlobalLogger,+ updateGlobalLogger+ ) where+import System.Log+import System.Log.Handler(LogHandler)+import qualified System.Log.Handler(handle)+import System.Log.Handler.Simple+import System.IO+import System.IO.Unsafe+import Control.Concurrent.MVar+import Data.List(map, isPrefixOf)+import qualified Data.Map as Map+import qualified Control.Exception+import Control.Monad.Error+---------------------------------------------------------------------------+-- Basic logger types+---------------------------------------------------------------------------+data HandlerT = forall a. LogHandler a => HandlerT a++data Logger = Logger { level :: Priority,+ handlers :: [HandlerT],+ name :: String}+++type LogTree = Map.Map String Logger++{- | This is the base class for the various log handlers. They should+all adhere to this class. -}+++---------------------------------------------------------------------------+-- Utilities+---------------------------------------------------------------------------++-- | The name of the root logger, which is always defined and present+-- on the system.+rootLoggerName = ""++{- | Placeholders created when a new logger must be created. This is used+only for the root logger default for now, as all others crawl up the tree+to find a sensible default. -}+placeholder :: Logger+placeholder = Logger {level = WARNING, handlers = [], name = ""}++---------------------------------------------------------------------------+-- Logger Tree Storage+---------------------------------------------------------------------------++-- | The log tree. Initialize it with a default root logger +-- and (FIXME) a logger for MissingH itself.++{-# NOINLINE logTree #-}++logTree :: MVar LogTree+-- note: only kick up tree if handled locally+logTree = + unsafePerformIO $ do+ h <- streamHandler stderr DEBUG+ newMVar (Map.singleton rootLoggerName (Logger + {level = WARNING,+ name = "",+ handlers = [HandlerT h]}))++{- | Given a name, return all components of it, starting from the root.+Example return value: ++>["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"]++-}+componentsOfName :: String -> [String]+componentsOfName name =+ let joinComp [] _ = []+ joinComp (x:xs) [] = x : joinComp xs x+ joinComp (x:xs) accum =+ let newlevel = accum ++ "." ++ x in+ newlevel : joinComp xs newlevel+ in+ rootLoggerName : joinComp (split "." name) []++---------------------------------------------------------------------------+-- Logging With Location+---------------------------------------------------------------------------++{- | Log a message using the given logger at a given priority. -}++logM :: String -- ^ Name of the logger to use+ -> Priority -- ^ Priority of this message+ -> String -- ^ The log text itself+ -> IO ()++logM logname pri msg = do+ l <- getLogger logname+ logL l pri msg++---------------------------------------------------------------------------+-- Utility functions+---------------------------------------------------------------------------++{- | Log a message at 'DEBUG' priority -}+debugM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+debugM s = logM s DEBUG++{- | Log a message at 'INFO' priority -}+infoM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+infoM s = logM s INFO++{- | Log a message at 'NOTICE' priority -}+noticeM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+noticeM s = logM s NOTICE++{- | Log a message at 'WARNING' priority -}+warningM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+warningM s = logM s WARNING++{- | Log a message at 'ERROR' priority -}+errorM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+errorM s = logM s ERROR++{- | Log a message at 'CRITICAL' priority -}+criticalM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+criticalM s = logM s CRITICAL++{- | Log a message at 'ALERT' priority -}+alertM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+alertM s = logM s ALERT++{- | Log a message at 'EMERGENCY' priority -}+emergencyM :: String -- ^ Logger name+ -> String -- ^ Log message+ -> IO ()+emergencyM s = logM s EMERGENCY++---------------------------------------------------------------------------+-- Public Logger Interaction Support+---------------------------------------------------------------------------++-- | Returns the logger for the given name. If no logger with that name+-- exists, creates new loggers and any necessary parent loggers, with+-- no connected handlers.++getLogger :: String -> IO Logger+getLogger lname = modifyMVar logTree $ \lt ->+ case Map.lookup lname lt of+ Just x -> return (lt, x) -- A logger exists; return it and leave tree+ Nothing -> do+ -- Add logger(s). Then call myself to retrieve it.+ let newlt = createLoggers (componentsOfName lname) lt+ result <- Map.lookup lname newlt+ return (newlt, result)+ where createLoggers :: [String] -> LogTree -> LogTree+ createLoggers [] lt = lt -- No names to add; return tree unmodified+ createLoggers (x:xs) lt = -- Add logger to tree+ if Map.member x lt+ then createLoggers xs lt+ else createLoggers xs + (Map.insert x ((modellogger lt) {name=x}) lt)+ modellogger :: LogTree -> Logger+ -- the modellogger is what we use for adding new loggers+ modellogger lt =+ findmodellogger lt (reverse $ componentsOfName lname)+ findmodellogger _ [] = error "findmodellogger: root logger does not exist?!"+ findmodellogger lt (x:xs) =+ case Map.lookup x lt of+ Left (_::String) -> findmodellogger lt xs+ Right logger -> logger {handlers = []}++-- | Returns the root logger.++getRootLogger :: IO Logger+getRootLogger = getLogger rootLoggerName++-- | Log a message, assuming the current logger's level permits it.+logL :: Logger -> Priority -> String -> IO ()+logL l pri msg = handle l (pri, msg)++-- | Handle a log request.+handle :: Logger -> LogRecord -> IO ()+handle l (pri, msg) = + let parentHandlers [] = return []+ parentHandlers name =+ let pname = (head . drop 1 . reverse . componentsOfName) name+ in+ do + --putStrLn (join "," foo)+ --putStrLn pname+ --putStrLn "1"+ parent <- getLogger pname+ --putStrLn "2"+ next <- parentHandlers pname+ --putStrLn "3"+ return ((handlers parent) ++ next)+ in+ if pri >= (level l)+ then do + ph <- parentHandlers (name l)+ sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg)+ (name l))+ else return ()+++-- | Call a handler given a HandlerT.+callHandler :: LogRecord -> String -> HandlerT -> IO ()+callHandler lr loggername ht =+ case ht of+ HandlerT x -> System.Log.Handler.handle x lr loggername++-- | Generate IO actions for the handlers.+handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()]+handlerActions h lr loggername = map (callHandler lr loggername ) h+ +-- | Add handler to 'Logger'. Returns a new 'Logger'.+addHandler :: LogHandler a => a -> Logger -> Logger+addHandler h l= l{handlers = (HandlerT h) : (handlers l)}++-- | Set the 'Logger'\'s list of handlers to the list supplied.+-- All existing handlers are removed first.+setHandlers :: LogHandler a => [a] -> Logger -> Logger+setHandlers hl l = + l{handlers = map (\h -> HandlerT h) hl}++-- | Returns the "level" of the logger. Items beneath this+-- level will be ignored.++getLevel :: Logger -> Priority+getLevel l = level l++-- | Sets the "level" of the 'Logger'. Returns a new+-- 'Logger' object with the new level.++setLevel :: Priority -> Logger -> Logger+setLevel p l = l{level = p}++-- | Updates the global record for the given logger to take into+-- account any changes you may have made.++saveGlobalLogger :: Logger -> IO ()+saveGlobalLogger l = modifyMVar_ logTree + (\lt -> return $ Map.insert (name l) l lt)++{- | Helps you make changes on the given logger. Takes a function+that makes changes and writes those changes back to the global+database. Here's an example from above (\"s\" is a 'LogHandler'):++> updateGlobalLogger "MyApp.BuggyComponent"+> (setLevel DEBUG . setHandlers [s])+-}++updateGlobalLogger :: String -- ^ Logger name+ -> (Logger -> Logger) -- ^ Function to call+ -> IO ()+updateGlobalLogger ln func =+ do l <- getLogger ln+ saveGlobalLogger (func l)++{- | Traps exceptions that may occur, logging them, then passing them on.++Takes a logger name, priority, leading description text (you can set it to+@\"\"@ if you don't want any), and action to run.+-}++traplogging :: String -- Logger name+ -> Priority -- Logging priority+ -> String -- Descriptive text to prepend to logged messages+ -> IO a -- Action to run+ -> IO a -- Return value+traplogging logger priority desc action =+ let realdesc = case desc of+ "" -> ""+ x -> x ++ ": "+ handler e = do+ logM logger priority (realdesc ++ (show e))+ Control.Exception.throw e -- Re-raise it+ in+ Control.Exception.catch action handler+ +{- This function pulled in from MissingH to avoid a dep on it -}+split :: Eq a => [a] -> [a] -> [[a]]+split _ [] = []+split delim str =+ let (firstline, remainder) = breakList (isPrefixOf delim) str+ in+ firstline : case remainder of+ [] -> []+ x -> if x == delim+ then [] : []+ else split delim+ (drop (length delim) x)++-- This function also pulled from MissingH+breakList :: ([a] -> Bool) -> [a] -> ([a], [a])+breakList func = spanList (not . func)++-- This function also pulled from MissingH+spanList :: ([a] -> Bool) -> [a] -> ([a], [a])++spanList _ [] = ([],[])+spanList func list@(x:xs) =+ if func list+ then (x:ys,zs)+ else ([],list)+ where (ys,zs) = spanList func xs+
+ testcases/testcase8.hs view
@@ -0,0 +1,22 @@+-- to be found Main+-- to be found ABC+-- to be found ABCD+-- to be found @=?+-- to be found @=:+-- to be found dummy+-- to be found main+module Main where++data ABC a = ABC a+class (Show a) => (ABCD a) where+ abcshow :: (ABC a)++(@=?), (@=:) :: (Eq a, Show a) => a -> a -> Int++expected @=? actual = undefined+expected @=: actual = undefined++dummy = "a"++main = print "abc"+
+ testcases/testcase9.hs view
@@ -0,0 +1,825 @@+\section[GHC.Base]{Module @GHC.Base@}++!!! This test case also tests the getTopLevelIndent implementation, because it+has the word "import" as comment !!!++-- to be found Monad+++The overall structure of the GHC Prelude is a bit tricky.++ a) We want to avoid "orphan modules", i.e. ones with instance+ decls that don't belong either to a tycon or a class+ defined in the same module++ b) We want to avoid giant modules++So the rough structure is as follows, in (linearised) dependency order+++GHC.Prim Has no implementation. It defines built-in things, and+ by importing it you bring them into scope.+ The source file is GHC.Prim.hi-boot, which is just+ copied to make GHC.Prim.hi++GHC.Base Classes: Eq, Ord, Functor, Monad+ Types: list, (), Int, Bool, Ordering, Char, String++Data.Tuple Types: tuples, plus instances for GHC.Base classes++GHC.Show Class: Show, plus instances for GHC.Base/GHC.Tup types++GHC.Enum Class: Enum, plus instances for GHC.Base/GHC.Tup types++Data.Maybe Type: Maybe, plus instances for GHC.Base classes++GHC.List List functions++GHC.Num Class: Num, plus instances for Int+ Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)++ Integer is needed here because it is mentioned in the signature+ of 'fromInteger' in class Num++GHC.Real Classes: Real, Integral, Fractional, RealFrac+ plus instances for Int, Integer+ Types: Ratio, Rational+ plus intances for classes so far++ Rational is needed here because it is mentioned in the signature+ of 'toRational' in class Real++GHC.ST The ST monad, instances and a few helper functions++Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples++GHC.Arr Types: Array, MutableArray, MutableVar++ Arrays are used by a function in GHC.Float++GHC.Float Classes: Floating, RealFloat+ Types: Float, Double, plus instances of all classes so far++ This module contains everything to do with floating point.+ It is a big module (900 lines)+ With a bit of luck, many modules can be compiled without ever reading GHC.Float.hi+++Other Prelude modules are much easier with fewer complex dependencies.++\begin{code}+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE CPP+ , NoImplicitPrelude+ , BangPatterns+ , ExplicitForAll+ , MagicHash+ , UnboxedTuples+ , ExistentialQuantification+ , Rank2Types+ #-}+-- -fno-warn-orphans is needed for things like:+-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++-----------------------------------------------------------------------------+-- |+-- Module : GHC.Base+-- Copyright : (c) The University of Glasgow, 1992-2002+-- License : see libraries/base/LICENSE+-- +-- Maintainer : cvs-ghc@haskell.org+-- Stability : internal+-- Portability : non-portable (GHC extensions)+--+-- Basic data types and classes.+-- +-----------------------------------------------------------------------------++#include "MachDeps.h"++-- #hide+module GHC.Base+ (+ module GHC.Base,+ module GHC.Classes,+ module GHC.CString,+ module GHC.Types,+ module GHC.Prim, -- Re-export GHC.Prim and GHC.Err, to avoid lots+ module GHC.Err -- of people having to import it explicitly+ ) + where++import GHC.Types+import GHC.Classes+import GHC.CString+import GHC.Prim+import {-# SOURCE #-} GHC.Err+import {-# SOURCE #-} GHC.IO (failIO)++-- This is not strictly speaking required by this module, but is an+-- implicit dependency whenever () or tuples are mentioned, so adding it+-- as an import here helps to get the dependencies right in the new+-- build system.+import GHC.Tuple ()+-- Likewise we need Integer when deriving things like Eq instances, and+-- this is a convenient place to force it to be built+import GHC.Integer ()++infixr 9 .+infixr 5 +++infixl 4 <$+infixl 1 >>, >>=+infixr 0 $++default () -- Double isn't available yet+\end{code}+++%*********************************************************+%* *+\subsection{DEBUGGING STUFF}+%* (for use when compiling GHC.Base itself doesn't work)+%* *+%*********************************************************++\begin{code}+{-+data Bool = False | True+data Ordering = LT | EQ | GT +data Char = C# Char#+type String = [Char]+data Int = I# Int#+data () = ()+data [] a = MkNil++not True = False+(&&) True True = True+otherwise = True++build = error "urk"+foldr = error "urk"+-}+\end{code}+++%*********************************************************+%* *+\subsection{Monadic classes @Functor@, @Monad@ }+%* *+%*********************************************************++\begin{code}+{- | The 'Functor' class is used for types that can be mapped over.+Instances of 'Functor' should satisfy the following laws:++> fmap id == id+> fmap (f . g) == fmap f . fmap g++The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+satisfy these laws.+-}++class Functor f where+ fmap :: (a -> b) -> f a -> f b++ -- | Replace all locations in the input with the same value.+ -- The default definition is @'fmap' . 'const'@, but this may be+ -- overridden with a more efficient version.+ (<$) :: a -> f b -> f a+ (<$) = fmap . const++{- | The 'Monad' class defines the basic operations over a /monad/,+a concept from a branch of mathematics known as /category theory/.+From the perspective of a Haskell programmer, however, it is best to+think of a monad as an /abstract datatype/ of actions.+Haskell's @do@ expressions provide a convenient syntax for writing+monadic expressions.++Minimal complete definition: '>>=' and 'return'.++Instances of 'Monad' should satisfy the following laws:++> return a >>= k == k a+> m >>= return == m+> m >>= (\x -> k x >>= h) == (m >>= k) >>= h++Instances of both 'Monad' and 'Functor' should additionally satisfy the law:++> fmap f xs == xs >>= return . f++The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class Monad m where+ -- | Sequentially compose two actions, passing any value produced+ -- by the first as an argument to the second.+ (>>=) :: forall a b. m a -> (a -> m b) -> m b+ -- | Sequentially compose two actions, discarding any value produced+ -- by the first, like sequencing operators (such as the semicolon)+ -- in imperative languages.+ (>>) :: forall a b. m a -> m b -> m b+ -- Explicit for-alls so that we know what order to+ -- give type arguments when desugaring++ -- | Inject a value into the monadic type.+ return :: a -> m a+ -- | Fail with a message. This operation is not part of the+ -- mathematical definition of a monad, but is invoked on pattern-match+ -- failure in a @do@ expression.+ fail :: String -> m a++ {-# INLINE (>>) #-}+ m >> k = m >>= \_ -> k+ fail s = error s++instance Functor ((->) r) where+ fmap = (.)++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)+\end{code}+++%*********************************************************+%* *+\subsection{The list type}+%* *+%*********************************************************++\begin{code}+instance Functor [] where+ fmap = map++instance Monad [] where+ m >>= k = foldr ((++) . k) [] m+ m >> k = foldr ((++) . (\ _ -> k)) [] m+ return x = [x]+ fail _ = []+\end{code}++A few list functions that appear here because they are used here.+The rest of the prelude list functions are in GHC.List.++----------------------------------------------+-- foldr/build/augment+----------------------------------------------+ +\begin{code}+-- | 'foldr', applied to a binary operator, a starting value (typically+-- the right-identity of the operator), and a list, reduces the list+-- using the binary operator, from right to left:+--+-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)++foldr :: (a -> b -> b) -> b -> [a] -> b+-- foldr _ z [] = z+-- foldr f z (x:xs) = f x (foldr f z xs)+{-# INLINE [0] foldr #-}+-- Inline only in the final stage, after the foldr/cons rule has had a chance+-- Also note that we inline it when it has *two* parameters, which are the +-- ones we are keen about specialising!+foldr k z = go+ where+ go [] = z+ go (y:ys) = y `k` go ys++-- | A list producer that can be fused with 'foldr'.+-- This function is merely+--+-- > build g = g (:) []+--+-- but GHC's simplifier will transform an expression of the form+-- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,+-- which avoids producing an intermediate list.++build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]+{-# INLINE [1] build #-}+ -- The INLINE is important, even though build is tiny,+ -- because it prevents [] getting inlined in the version that+ -- appears in the interface file. If [] *is* inlined, it+ -- won't match with [] appearing in rules in an importing module.+ --+ -- The "1" says to inline in phase 1++build g = g (:) []++-- | A list producer that can be fused with 'foldr'.+-- This function is merely+--+-- > augment g xs = g (:) xs+--+-- but GHC's simplifier will transform an expression of the form+-- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to+-- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.++augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]+{-# INLINE [1] augment #-}+augment g xs = g (:) xs++{-# RULES+"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . + foldr k z (build g) = g k z++"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . + foldr k z (augment g xs) = g k (foldr k z xs)++"foldr/id" foldr (:) [] = \x -> x+"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys+ -- Only activate this from phase 1, because that's+ -- when we disable the rule that expands (++) into foldr++-- The foldr/cons rule looks nice, but it can give disastrously+-- bloated code when commpiling+-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]+-- i.e. when there are very very long literal lists+-- So I've disabled it for now. We could have special cases+-- for short lists, I suppose.+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)++"foldr/single" forall k z x. foldr k z [x] = k x z+"foldr/nil" forall k z. foldr k z [] = z ++"augment/build" forall (g::forall b. (a->b->b) -> b -> b)+ (h::forall b. (a->b->b) -> b -> b) .+ augment g (build h) = build (\c n -> g c (h c n))+"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .+ augment g [] = build g+ #-}++-- This rule is true, but not (I think) useful:+-- augment g (augment h t) = augment (\cn -> g c (h c n)) t+\end{code}+++----------------------------------------------+-- map +----------------------------------------------++\begin{code}+-- | 'map' @f xs@ is the list obtained by applying @f@ to each element+-- of @xs@, i.e.,+--+-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]+-- > map f [x1, x2, ...] == [f x1, f x2, ...]++map :: (a -> b) -> [a] -> [b]+map _ [] = []+map f (x:xs) = f x : map f xs++-- Note eta expanded+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst+{-# INLINE [0] mapFB #-}+mapFB c f = \x ys -> c (f x) ys++-- The rules for map work like this.+-- +-- Up to (but not including) phase 1, we use the "map" rule to+-- rewrite all saturated applications of map with its build/fold +-- form, hoping for fusion to happen.+-- In phase 1 and 0, we switch off that rule, inline build, and+-- switch on the "mapList" rule, which rewrites the foldr/mapFB+-- thing back into plain map. +--+-- It's important that these two rules aren't both active at once +-- (along with build's unfolding) else we'd get an infinite loop +-- in the rules. Hence the activation control below.+--+-- The "mapFB" rule optimises compositions of map.+--+-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc.++{-# RULES+"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)+"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f+"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) + #-}+\end{code}+++----------------------------------------------+-- append +----------------------------------------------+\begin{code}+-- | Append two lists, i.e.,+--+-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]+-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]+--+-- If the first list is not finite, the result is the first list.++(++) :: [a] -> [a] -> [a]+(++) [] ys = ys+(++) (x:xs) ys = x : xs ++ ys++{-# RULES+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+ #-}++\end{code}+++%*********************************************************+%* *+\subsection{Type @Bool@}+%* *+%*********************************************************++\begin{code}+-- |'otherwise' is defined as the value 'True'. It helps to make+-- guards more readable. eg.+--+-- > f x | x < 0 = ...+-- > | otherwise = ...+otherwise :: Bool+otherwise = True+\end{code}++%*********************************************************+%* *+\subsection{Type @Char@ and @String@}+%* *+%*********************************************************++\begin{code}+-- | A 'String' is a list of characters. String constants in Haskell are values+-- of type 'String'.+--+type String = [Char]++{-# RULES+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False+ #-}++unsafeChr :: Int -> Char+unsafeChr (I# i#) = C# (chr# i#)++-- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.+ord :: Char -> Int+ord (C# c#) = I# (ord# c#)+\end{code}++String equality is used when desugaring pattern-matches against strings.++\begin{code}+eqString :: String -> String -> Bool+eqString [] [] = True+eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2+eqString _ _ = False++{-# RULES "eqString" (==) = eqString #-}+-- eqString also has a BuiltInRule in PrelRules.lhs:+-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2+\end{code}+++%*********************************************************+%* *+\subsection{Type @Int@}+%* *+%*********************************************************++\begin{code}+maxInt, minInt :: Int++{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}+#if WORD_SIZE_IN_BITS == 31+minInt = I# (-0x40000000#)+maxInt = I# 0x3FFFFFFF#+#elif WORD_SIZE_IN_BITS == 32+minInt = I# (-0x80000000#)+maxInt = I# 0x7FFFFFFF#+#else +minInt = I# (-0x8000000000000000#)+maxInt = I# 0x7FFFFFFFFFFFFFFF#+#endif+\end{code}+++%*********************************************************+%* *+\subsection{The function type}+%* *+%*********************************************************++\begin{code}+-- | Identity function.+id :: a -> a+id x = x++-- | The call '(lazy e)' means the same as 'e', but 'lazy' has a +-- magical strictness property: it is lazy in its first argument, +-- even though its semantics is strict.+lazy :: a -> a+lazy x = x+-- Implementation note: its strictness and unfolding are over-ridden+-- by the definition in MkId.lhs; in both cases to nothing at all.+-- That way, 'lazy' does not get inlined, and the strictness analyser+-- sees it as lazy. Then the worker/wrapper phase inlines it.+-- Result: happiness++-- Assertion function. This simply ignores its boolean argument.+-- The compiler may rewrite it to @('assertError' line)@.++-- | If the first argument evaluates to 'True', then the result is the+-- second argument. Otherwise an 'AssertionFailed' exception is raised,+-- containing a 'String' with the source file and line number of the+-- call to 'assert'.+--+-- Assertions can normally be turned on or off with a compiler flag+-- (for GHC, assertions are normally on unless optimisation is turned on +-- with @-O@ or the @-fignore-asserts@+-- option is given). When assertions are turned off, the first+-- argument to 'assert' is ignored, and the second argument is+-- returned as the result.++-- SLPJ: in 5.04 etc 'assert' is in GHC.Prim,+-- but from Template Haskell onwards it's simply+-- defined here in Base.lhs+assert :: Bool -> a -> a+assert _pred r = r++breakpoint :: a -> a+breakpoint r = r++breakpointCond :: Bool -> a -> a+breakpointCond _ r = r++data Opaque = forall a. O a++-- | Constant function.+const :: a -> b -> a+const x _ = x++-- | Function composition.+{-# INLINE (.) #-}+-- Make sure it has TWO args only on the left, so that it inlines+-- when applied to two functions, even if there is no final argument+(.) :: (b -> c) -> (a -> b) -> a -> c+(.) f g = \x -> f (g x)++-- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.+flip :: (a -> b -> c) -> b -> a -> c+flip f x y = f y x++-- | Application operator. This operator is redundant, since ordinary+-- application @(f x)@ means the same as @(f '$' x)@. However, '$' has+-- low, right-associative binding precedence, so it sometimes allows+-- parentheses to be omitted; for example:+--+-- > f $ g $ h x = f (g (h x))+--+-- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,+-- or @'Data.List.zipWith' ('$') fs xs@.+{-# INLINE ($) #-}+($) :: (a -> b) -> a -> b+f $ x = f x++-- | @'until' p f@ yields the result of applying @f@ until @p@ holds.+until :: (a -> Bool) -> (a -> a) -> a -> a+until p f x | p x = x+ | otherwise = until p f (f x)++-- | 'asTypeOf' is a type-restricted version of 'const'. It is usually+-- used as an infix operator, and its typing forces its first argument+-- (which is usually overloaded) to have the same type as the second.+asTypeOf :: a -> a -> a+asTypeOf = const+\end{code}++%*********************************************************+%* *+\subsection{@Functor@ and @Monad@ instances for @IO@}+%* *+%*********************************************************++\begin{code}+instance Functor IO where+ fmap f x = x >>= (return . f)++instance Monad IO where+ {-# INLINE return #-}+ {-# INLINE (>>) #-}+ {-# INLINE (>>=) #-}+ m >> k = m >>= \ _ -> k+ return = returnIO+ (>>=) = bindIO+ fail s = failIO s++returnIO :: a -> IO a+returnIO x = IO $ \ s -> (# s, x #)++bindIO :: IO a -> (a -> IO b) -> IO b+bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s++thenIO :: IO a -> IO b -> IO b+thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s++unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))+unIO (IO a) = a+\end{code}++%*********************************************************+%* *+\subsection{@getTag@}+%* *+%*********************************************************++Returns the 'tag' of a constructor application; this function is used+by the deriving code for Eq, Ord and Enum.++The primitive dataToTag# requires an evaluated constructor application+as its argument, so we provide getTag as a wrapper that performs the+evaluation before calling dataToTag#. We could have dataToTag#+evaluate its argument, but we prefer to do it this way because (a)+dataToTag# can be an inline primop if it doesn't need to do any+evaluation, and (b) we want to expose the evaluation to the+simplifier, because it might be possible to eliminate the evaluation+in the case when the argument is already known to be evaluated.++\begin{code}+{-# INLINE getTag #-}+getTag :: a -> Int#+getTag x = x `seq` dataToTag# x+\end{code}++%*********************************************************+%* *+\subsection{Numeric primops}+%* *+%*********************************************************++Definitions of the boxed PrimOps; these will be+used in the case of partial applications, etc.++\begin{code}+{-# INLINE quotInt #-}+{-# INLINE remInt #-}++quotInt, remInt, divInt, modInt :: Int -> Int -> Int+(I# x) `quotInt` (I# y) = I# (x `quotInt#` y)+(I# x) `remInt` (I# y) = I# (x `remInt#` y)+(I# x) `divInt` (I# y) = I# (x `divInt#` y)+(I# x) `modInt` (I# y) = I# (x `modInt#` y)++quotRemInt :: Int -> Int -> (Int, Int)+(I# x) `quotRemInt` (I# y) = case x `quotRemInt#` y of+ (# q, r #) ->+ (I# q, I# r)++divModInt :: Int -> Int -> (Int, Int)+(I# x) `divModInt` (I# y) = case x `divModInt#` y of+ (# q, r #) -> (I# q, I# r)++divModInt# :: Int# -> Int# -> (# Int#, Int# #)+x# `divModInt#` y#+ | (x# ># 0#) && (y# <# 0#) = case (x# -# 1#) `quotRemInt#` y# of+ (# q, r #) -> (# q -# 1#, r +# y# +# 1# #)+ | (x# <# 0#) && (y# ># 0#) = case (x# +# 1#) `quotRemInt#` y# of+ (# q, r #) -> (# q -# 1#, r +# y# -# 1# #)+ | otherwise = x# `quotRemInt#` y#++{-# RULES+"x# +# 0#" forall x#. x# +# 0# = x#+"0# +# x#" forall x#. 0# +# x# = x#+"x# -# 0#" forall x#. x# -# 0# = x#+"x# -# x#" forall x#. x# -# x# = 0#+"x# *# 0#" forall x#. x# *# 0# = 0#+"0# *# x#" forall x#. 0# *# x# = 0#+"x# *# 1#" forall x#. x# *# 1# = x#+"1# *# x#" forall x#. 1# *# x# = x#+ #-}++{-# RULES+"x# ># x#" forall x#. x# ># x# = False+"x# >=# x#" forall x#. x# >=# x# = True+"x# ==# x#" forall x#. x# ==# x# = True+"x# /=# x#" forall x#. x# /=# x# = False+"x# <# x#" forall x#. x# <# x# = False+"x# <=# x#" forall x#. x# <=# x# = True+ #-}++{-# RULES+"plusFloat x 0.0" forall x#. plusFloat# x# 0.0# = x#+"plusFloat 0.0 x" forall x#. plusFloat# 0.0# x# = x#+"minusFloat x 0.0" forall x#. minusFloat# x# 0.0# = x#+"timesFloat x 1.0" forall x#. timesFloat# x# 1.0# = x#+"timesFloat 1.0 x" forall x#. timesFloat# 1.0# x# = x#+"divideFloat x 1.0" forall x#. divideFloat# x# 1.0# = x#+ #-}++{-# RULES+"plusDouble x 0.0" forall x#. (+##) x# 0.0## = x#+"plusDouble 0.0 x" forall x#. (+##) 0.0## x# = x#+"minusDouble x 0.0" forall x#. (-##) x# 0.0## = x#+"timesDouble x 1.0" forall x#. (*##) x# 1.0## = x#+"timesDouble 1.0 x" forall x#. (*##) 1.0## x# = x#+"divideDouble x 1.0" forall x#. (/##) x# 1.0## = x#+ #-}++{-+We'd like to have more rules, but for example:++This gives wrong answer (0) for NaN - NaN (should be NaN):+ "minusDouble x x" forall x#. (-##) x# x# = 0.0##++This gives wrong answer (0) for 0 * NaN (should be NaN):+ "timesDouble 0.0 x" forall x#. (*##) 0.0## x# = 0.0##++This gives wrong answer (0) for NaN * 0 (should be NaN):+ "timesDouble x 0.0" forall x#. (*##) x# 0.0## = 0.0##++These are tested by num014.++Similarly for Float (#5178):++"minusFloat x x" forall x#. minusFloat# x# x# = 0.0#+"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0#+"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0#+-}++-- Wrappers for the shift operations. The uncheckedShift# family are+-- undefined when the amount being shifted by is greater than the size+-- in bits of Int#, so these wrappers perform a check and return+-- either zero or -1 appropriately.+--+-- Note that these wrappers still produce undefined results when the+-- second argument (the shift amount) is negative.++-- | Shift the argument left by the specified number of bits+-- (which must be non-negative).+shiftL# :: Word# -> Int# -> Word#+a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0##+ | otherwise = a `uncheckedShiftL#` b++-- | Shift the argument right by the specified number of bits+-- (which must be non-negative).+shiftRL# :: Word# -> Int# -> Word#+a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0##+ | otherwise = a `uncheckedShiftRL#` b++-- | Shift the argument left by the specified number of bits+-- (which must be non-negative).+iShiftL# :: Int# -> Int# -> Int#+a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0#+ | otherwise = a `uncheckedIShiftL#` b++-- | Shift the argument right (signed) by the specified number of bits+-- (which must be non-negative).+iShiftRA# :: Int# -> Int# -> Int#+a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0#+ | otherwise = a `uncheckedIShiftRA#` b++-- | Shift the argument right (unsigned) by the specified number of bits+-- (which must be non-negative).+iShiftRL# :: Int# -> Int# -> Int#+a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#+ | otherwise = a `uncheckedIShiftRL#` b++#if WORD_SIZE_IN_BITS == 32+{-# RULES+"narrow32Int#" forall x#. narrow32Int# x# = x#+"narrow32Word#" forall x#. narrow32Word# x# = x#+ #-}+#endif++{-# RULES+"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x#+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#+ #-}+++-- Rules for C strings (the functions themselves are now in GHC.CString)+{-# RULES+"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)+"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n++-- There's a built-in rule (in PrelRules.lhs) for+-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n++ #-}+\end{code}+++#ifdef __HADDOCK__+\begin{code}+-- | A special argument for the 'Control.Monad.ST.ST' type constructor,+-- indexing a state embedded in the 'Prelude.IO' monad by+-- 'Control.Monad.ST.stToIO'.+data RealWorld+\end{code}+#endif+
+ testcases/twoblockcommentshs.hs view
@@ -0,0 +1,5 @@+{--}+-- not to be found E+{-+data E+-}
+ testcases/twoblockcommentslhs.lhs view
@@ -0,0 +1,6 @@+\begin{code}+\end{code}+\begin{code}+-- not to be found A+\end{code}+data A
+ testcases/twoblockcommentstogether.hs view
@@ -0,0 +1,4 @@+-- not to be found E+{--}{-+data E+-}
+ testcases/typesig.hs view
@@ -0,0 +1,2 @@+-- TAGS not to be found a, b, c :: String+a, b, c :: String
+ tests/Test.hs view
@@ -0,0 +1,101 @@+module Main where++import Hasktags+import Tags++import Control.Monad+import Data.List+import System.Directory+import System.Exit++import qualified Data.ByteString.Char8 as BS++import Test.HUnit++{- TODO+Test the library (recursive, caching, ..)+But that's less likely to break+-}++-- all comments should differ at the beginning+comments :: [BS.ByteString] -> String -> [String]+comments lns comment = filter (not . null) $ map hitOrEmpty lns+ where+ c = BS.pack $ comment ++ " "+ hitOrEmpty :: BS.ByteString -> String+ hitOrEmpty bs =+ let ds = BS.dropWhile (== ' ') bs+ in if c `BS.isPrefixOf` ds+ then BS.unpack $ BS.drop (BS.length c) ds+ else ""++tagComments :: [BS.ByteString] -> String -> [String]+tagComments lns comment+ = map (takeWhile (not . (`elem` "\n\r "))) $ comments lns comment++testToBeFound :: [String] -> [String] -> Test+testToBeFound foundTagNames toBeFound =+ "these were not found"+ ~: [] ~?= filter (not . (`elem` foundTagNames)) toBeFound++testNotToBeFound :: [String] -> [String] -> Test+testNotToBeFound foundTagNames notToBeFound =+ "these should not have been found"+ ~: [] ~=? filter (`elem` foundTagNames) notToBeFound++testToBeFoundOnce :: [String] -> [String] -> Test+testToBeFoundOnce foundTagNames list =+ "these should have been found exactly one time"+ ~: []+ ~=? [name+ | name <- list, 1 /= length (filter (== name ) foundTagNames)]++etagsToBeFound :: String -> [String] -> Test+etagsToBeFound etags toBeFound =+ "these were not found on TAGS"+ ~: [] ~=? filter (not . (`isInfixOf` etags)) toBeFound++etagsNotToBeFound :: String -> [String] -> Test+etagsNotToBeFound etags notToBeFound =+ "these should not have been found on TAGS"+ ~: [] ~=? filter (`isInfixOf` etags) notToBeFound++etagsToBeFoundOnce :: String -> [String] -> Test+etagsToBeFoundOnce etags list =+ "these should not have been found on TAGS"+ ~: [] ~=? [ name | name <- list, 1 /= length (infixes name etags)]++infixes :: Eq a => [a] -> [a] -> [[a]]+infixes needle haystack = filter (isPrefixOf needle) (tails haystack)++createTestCase :: FilePath -> IO Test+createTestCase filename = do+ bs <- BS.readFile filename+ let lns = BS.lines bs+ let fd = findThingsInBS True filename bs+ let FileData _ things = fd++ let foundTagNames = [name | FoundThing _ name _ <- things]+ let etags = etagsDumpFileData fd++ let testList = TestList [+ testToBeFound foundTagNames (tagComments lns "-- to be found"),+ testNotToBeFound foundTagNames (tagComments lns "-- not to be found"),+ testToBeFoundOnce+ foundTagNames+ (tagComments lns "-- once to be found"),+ etagsToBeFound etags (comments lns "-- TAGS to be found"),+ etagsNotToBeFound etags (comments lns "-- TAGS not to be found"),+ etagsToBeFoundOnce etags (comments lns "-- TAGS once to be found")+ ]++ return $ filename ~: testList++main :: IO ()+main+ = do+ setCurrentDirectory "testcases"+ files <- getDirectoryContents "."+ tests <- mapM createTestCase $ filter (not . (`elem` [".", "..", "expected_failures_testing_suite.hs"])) files+ counts_ <- runTestTT $ TestList tests+ when (errors counts_ + failures counts_ > 0) exitFailure