diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,13 @@ + + - From: Evan Laforge + To: Marc Weber + 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. + diff --git a/hasktags.cabal b/hasktags.cabal --- a/hasktags.cabal +++ b/hasktags.cabal @@ -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 +Maintainer: + Marc Weber , + Marco Túlio Pimenta Gontijo +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 diff --git a/hasktags.hs b/hasktags.hs deleted file mode 100644 --- a/hasktags.hs +++ /dev/null @@ -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 --} diff --git a/src/Hasktags.hs b/src/Hasktags.hs new file mode 100644 --- /dev/null +++ b/src/Hasktags.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Tags.hs b/src/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Tags.hs @@ -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" + diff --git a/testcases/HUnitBase.lhs b/testcases/HUnitBase.lhs new file mode 100644 --- /dev/null +++ b/testcases/HUnitBase.lhs @@ -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 } diff --git a/testcases/Repair.lhs b/testcases/Repair.lhs new file mode 100644 --- /dev/null +++ b/testcases/Repair.lhs @@ -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} diff --git a/testcases/blockcomment.hs b/testcases/blockcomment.hs new file mode 100644 --- /dev/null +++ b/testcases/blockcomment.hs @@ -0,0 +1,4 @@ +-- not to be found A +{- +data A +-} diff --git a/testcases/constructor.hs b/testcases/constructor.hs new file mode 100644 --- /dev/null +++ b/testcases/constructor.hs @@ -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 diff --git a/testcases/expected_failures_testing_suite.hs b/testcases/expected_failures_testing_suite.hs new file mode 100644 --- /dev/null +++ b/testcases/expected_failures_testing_suite.hs @@ -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 diff --git a/testcases/firstconstructor.hs b/testcases/firstconstructor.hs new file mode 100644 --- /dev/null +++ b/testcases/firstconstructor.hs @@ -0,0 +1,2 @@ +-- TAGS to be found data A = C +data A = C diff --git a/testcases/module.hs b/testcases/module.hs new file mode 100644 --- /dev/null +++ b/testcases/module.hs @@ -0,0 +1,4 @@ +-- not to be found A ./14/module.hs 2 +module A where + +data A = A diff --git a/testcases/space.hs b/testcases/space.hs new file mode 100644 --- /dev/null +++ b/testcases/space.hs @@ -0,0 +1,4 @@ +-- TAGS not to be found A{ +data A + = A { a :: A + } diff --git a/testcases/substring.hs b/testcases/substring.hs new file mode 100644 --- /dev/null +++ b/testcases/substring.hs @@ -0,0 +1,3 @@ +-- TAGS not to be found data A1,2 +data A=A +data AB=AB diff --git a/testcases/tabs.hs b/testcases/tabs.hs new file mode 100644 --- /dev/null +++ b/testcases/tabs.hs @@ -0,0 +1,3 @@ +-- once to be found C2 +data B = C1 + | C2 B diff --git a/testcases/testcase1.hs b/testcases/testcase1.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase1.hs @@ -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 diff --git a/testcases/testcase10.hs b/testcases/testcase10.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase10.hs @@ -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 diff --git a/testcases/testcase11.hs b/testcases/testcase11.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase11.hs @@ -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} + diff --git a/testcases/testcase2.hs b/testcases/testcase2.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase2.hs @@ -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 + diff --git a/testcases/testcase3.lhs b/testcases/testcase3.lhs new file mode 100644 --- /dev/null +++ b/testcases/testcase3.lhs @@ -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: + + * + + * + + * + +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 -- $), +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', + diff --git a/testcases/testcase4.hs b/testcases/testcase4.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase4.hs @@ -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 + +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 + 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, + 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 + diff --git a/testcases/testcase8.hs b/testcases/testcase8.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase8.hs @@ -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" + diff --git a/testcases/testcase9.hs b/testcases/testcase9.hs new file mode 100644 --- /dev/null +++ b/testcases/testcase9.hs @@ -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 + diff --git a/testcases/twoblockcommentshs.hs b/testcases/twoblockcommentshs.hs new file mode 100644 --- /dev/null +++ b/testcases/twoblockcommentshs.hs @@ -0,0 +1,5 @@ +{--} +-- not to be found E +{- +data E +-} diff --git a/testcases/twoblockcommentslhs.lhs b/testcases/twoblockcommentslhs.lhs new file mode 100644 --- /dev/null +++ b/testcases/twoblockcommentslhs.lhs @@ -0,0 +1,6 @@ +\begin{code} +\end{code} +\begin{code} +-- not to be found A +\end{code} +data A diff --git a/testcases/twoblockcommentstogether.hs b/testcases/twoblockcommentstogether.hs new file mode 100644 --- /dev/null +++ b/testcases/twoblockcommentstogether.hs @@ -0,0 +1,4 @@ +-- not to be found E +{--}{- +data E +-} diff --git a/testcases/typesig.hs b/testcases/typesig.hs new file mode 100644 --- /dev/null +++ b/testcases/typesig.hs @@ -0,0 +1,2 @@ +-- TAGS not to be found a, b, c :: String +a, b, c :: String diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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