{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- should this be named Data.Hasktags or such?
module Hasktags (
  FileData,
  generate,
  findThings,
  findThingsInBS,

  Mode(..),
  TagsFile(..),
  Tags(..),
  --  TODO think about these: Must they be exported ?
  getOutFile,

  dirToFiles
) where
import           Control.Monad              (when)
import           Control.Arrow              ((***))
import qualified Data.ByteString.Char8 as BS (ByteString, readFile, unpack)
import qualified Data.ByteString.UTF8  as BS8 (fromString)
import           Data.Char                  (isSpace)
import           Data.String                (IsString(..))
import           Data.List                  (isPrefixOf, isSuffixOf, groupBy,
                                             tails, nub)
import           Data.Maybe                 (maybeToList)
import           DebugShow                  (trace_)
import           System.Directory           (doesDirectoryExist, doesFileExist,
                                             getDirectoryContents,
                                             getModificationTime,
                                             canonicalizePath,
#if MIN_VERSION_directory(1,3,0)
                                              pathIsSymbolicLink)
#else
                                              isSymbolicLink)
#endif
import           System.FilePath            ((</>))
import           System.IO                  (Handle, IOMode, hClose, openFile, stdout, utf8, hSetEncoding)
import           Tags                       (FileData (..), FileName,
                                             FoundThing (..),
                                             FoundThingType (FTClass, FTCons, FTConsAccessor, FTConsGADT, FTData, FTDataGADT, FTFuncImpl, FTFuncTypeDef, FTInstance, FTModule, FTNewtype, FTPattern, FTPatternTypeDef, FTType),
                                             Pos (..), Scope, mywords,
                                             writectagsfile, writeetagsfile)
import           Text.JSON.Generic          (decodeJSON, encodeJSON)

-- 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


-- | getOutFile scans 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 -> IO Handle
getOutFile :: String -> IOMode -> IO Handle
getOutFile String
filepath IOMode
openMode
  | String
"-" forall a. Eq a => a -> a -> Bool
== String
filepath = forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
  | Bool
otherwise       = do
    Handle
h <- String -> IOMode -> IO Handle
openFile String
filepath IOMode
openMode
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h

data TagsFile = TagsFile
  { TagsFile -> String
_ctagsFile :: FilePath
  , TagsFile -> String
_etagsFile :: FilePath
  }

instance Show TagsFile where
  show :: TagsFile -> String
show TagsFile{String
_etagsFile :: String
_ctagsFile :: String
_etagsFile :: TagsFile -> String
_ctagsFile :: TagsFile -> String
..} = String
"ctags: " forall a. [a] -> [a] -> [a]
++ String
_ctagsFile forall a. [a] -> [a] -> [a]
++ String
", etags: " forall a. [a] -> [a] -> [a]
++ String
_etagsFile

instance IsString TagsFile where
  fromString :: String -> TagsFile
fromString String
s = String -> String -> TagsFile
TagsFile String
s String
s

data Tags =
    Ctags
  | Etags
  | Both
  deriving Int -> Tags -> ShowS
[Tags] -> ShowS
Tags -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tags] -> ShowS
$cshowList :: [Tags] -> ShowS
show :: Tags -> String
$cshow :: Tags -> String
showsPrec :: Int -> Tags -> ShowS
$cshowsPrec :: Int -> Tags -> ShowS
Show

data Mode = Mode
  { Mode -> Tags
_tags             :: Tags
  , Mode -> Bool
_extendedCtag     :: Bool
  , Mode -> IOMode
_appendTags       :: IOMode
  , Mode -> TagsFile
_outputFile       :: TagsFile
  , Mode -> Bool
_cacheData        :: Bool
  , Mode -> Bool
_followSymlinks   :: Bool
  , Mode -> [String]
_suffixes         :: [String]
  , Mode -> Bool
_absoluteTagPaths :: Bool
  } deriving Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show

data Token = Token String Pos
            | NewLine Int -- space 8*" " = "\t"
  deriving (Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq)
instance Show Token where
  -- show (Token t (Pos _ l _ _) ) = "Token " ++ t ++ " " ++ (show l)
  show :: Token -> String
show (Token String
t (Pos String
_ Int
_l Int
_ String
_) ) = String
" " forall a. [a] -> [a] -> [a]
++ String
t forall a. [a] -> [a] -> [a]
++ String
" "
  show (NewLine Int
i)               = String
"NewLine " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i

tokenString :: Token -> String
tokenString :: Token -> String
tokenString (Token String
s Pos
_) = String
s
tokenString (NewLine Int
_) = String
"\n"

isNewLine :: Maybe Int -> Token -> Bool
isNewLine :: Maybe Int -> Token -> Bool
isNewLine Maybe Int
Nothing (NewLine Int
_)   = Bool
True
isNewLine (Just Int
c) (NewLine Int
c') = Int
c forall a. Eq a => a -> a -> Bool
== Int
c'
isNewLine Maybe Int
_ Token
_                   = Bool
False

trimNewlines :: [Token] -> [Token]
trimNewlines :: [Token] -> [Token]
trimNewlines = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Token -> Bool
isNewLine forall a. Maybe a
Nothing)

generate :: Mode -> [FilePath] -> IO ()
generate :: Mode -> [String] -> IO ()
generate Mode{Bool
[String]
IOMode
Tags
TagsFile
_absoluteTagPaths :: Bool
_suffixes :: [String]
_followSymlinks :: Bool
_cacheData :: Bool
_outputFile :: TagsFile
_appendTags :: IOMode
_extendedCtag :: Bool
_tags :: Tags
_absoluteTagPaths :: Mode -> Bool
_suffixes :: Mode -> [String]
_followSymlinks :: Mode -> Bool
_cacheData :: Mode -> Bool
_outputFile :: Mode -> TagsFile
_appendTags :: Mode -> IOMode
_extendedCtag :: Mode -> Bool
_tags :: Mode -> Tags
..} [String]
files = do
  [String]
files_or_dirs <- if Bool
_absoluteTagPaths
                          then forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
canonicalizePath [String]
files
                          else forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files

  [String]
filenames <- (forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> [String] -> String -> IO [String]
dirToFiles Bool
_followSymlinks [String]
_suffixes) [String]
files_or_dirs

  [FileData]
filedata <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> String -> IO FileData
findWithCache Bool
_cacheData) [String]
filenames

  Tags -> [FileData] -> IO ()
writeTags Tags
_tags [FileData]
filedata

  where
    writeTags :: Tags -> [FileData] -> IO ()
writeTags Tags
Ctags [FileData]
filedata = String -> (Handle -> IO ()) -> IO ()
writeFile' String
_ctagsFile (Bool -> [FileData] -> Handle -> IO ()
writectagsfile Bool
_extendedCtag [FileData]
filedata)
    writeTags Tags
Etags [FileData]
filedata = String -> (Handle -> IO ()) -> IO ()
writeFile' String
_etagsFile ([FileData] -> Handle -> IO ()
writeetagsfile [FileData]
filedata)
    writeTags Tags
Both [FileData]
filedata  = Tags -> [FileData] -> IO ()
writeTags Tags
Ctags [FileData]
filedata forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tags -> [FileData] -> IO ()
writeTags Tags
Etags [FileData]
filedata
    writeFile' :: FilePath -> (Handle -> IO ()) -> IO ()
    writeFile' :: String -> (Handle -> IO ()) -> IO ()
writeFile' String
name Handle -> IO ()
f = do
      Handle
file <- String -> IOMode -> IO Handle
getOutFile String
name IOMode
_appendTags
      Handle -> IO ()
f Handle
file
      Handle -> IO ()
hClose Handle
file
    TagsFile{String
_etagsFile :: String
_ctagsFile :: String
_etagsFile :: TagsFile -> String
_ctagsFile :: TagsFile -> String
..} = TagsFile
_outputFile

-- Find the definitions in a file, or load from cache if the file
-- hasn't changed since last time.
findWithCache ::  Bool -> FileName -> IO FileData
findWithCache :: Bool -> String -> IO FileData
findWithCache Bool
cache String
filename = do
  Bool
cacheExists <- if Bool
cache then String -> IO Bool
doesFileExist String
cacheFilename else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  if Bool
cacheExists
     then do UTCTime
fileModified <- String -> IO UTCTime
getModificationTime String
filename
             UTCTime
cacheModified <- String -> IO UTCTime
getModificationTime String
cacheFilename
             if UTCTime
cacheModified forall a. Ord a => a -> a -> Bool
> UTCTime
fileModified
              then do ByteString
bytes <- String -> IO ByteString
BS.readFile String
cacheFilename
                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Data a => String -> a
decodeJSON (ByteString -> String
BS.unpack ByteString
bytes))
              else IO FileData
findAndCache
     else IO FileData
findAndCache

  where cacheFilename :: String
cacheFilename = ShowS
filenameToTagsName String
filename
        filenameToTagsName :: ShowS
filenameToTagsName = (forall a. [a] -> [a] -> [a]
++String
"tags") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
        findAndCache :: IO FileData
findAndCache = do
          FileData
filedata <- String -> IO FileData
findThings String
filename
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cache (String -> String -> IO ()
writeFile String
cacheFilename (forall a. Data a => a -> String
encodeJSON FileData
filedata))
          forall (m :: * -> *) a. Monad m => a -> m a
return FileData
filedata

-- eg Data.Text says that using ByteStrings could be fastest depending on ghc
-- platform and whatnot - so let's keep the hacky BS.readFile >>= BS.unpack
-- usage till there is a problem, still need to match utf-8 chars like this: ⇒
-- to get correct class names, eg MonadBaseControl case (testcase testcases/monad-base-control.hs)
-- so use the same conversion which is applied to files when they got read ..
utf8_to_char8_hack :: String -> String
utf8_to_char8_hack :: ShowS
utf8_to_char8_hack = ByteString -> String
BS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS8.fromString

-- Find the definitions in a file
findThings :: FileName -> IO FileData
findThings :: String -> IO FileData
findThings String
filename =
  String -> ByteString -> FileData
findThingsInBS String
filename forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
filename

findThingsInBS :: String -> BS.ByteString -> FileData
findThingsInBS :: String -> ByteString -> FileData
findThingsInBS String
filename ByteString
bs = do
        let aslines :: [String]
aslines = String -> [String]
lines forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
bs

        let stripNonHaskellLines :: [[Token]] -> [[Token]]
stripNonHaskellLines = let
                  emptyLine :: [Token] -> Bool
emptyLine = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString)
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Token -> Bool
isNewLine forall a. Maybe a
Nothing)
                  cppLine :: [Token] -> Bool
cppLine (Token
_nl:Token
t:[Token]
_) = (String
"#" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall a b. (a -> b) -> a -> b
$ Token -> String
tokenString Token
t
                  cppLine [Token]
_         = Bool
False
                in forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Bool
emptyLine) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Bool
cppLine)

        let debugStep :: String -> b -> b
debugStep String
m b
s = forall a b. String -> a -> b -> b
trace_ (String
m forall a. [a] -> [a] -> [a]
++ String
" result") b
s b
s

        let (Bool
isLiterate, [(String, Int)]
slines) =
              forall {b}. String -> b -> b
debugStep String
"fromLiterate"
              forall a b. (a -> b) -> a -> b
$ String -> [(String, Int)] -> (Bool, [(String, Int)])
fromLiterate String
filename
              forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [String]
aslines [Int
0..]

        --  remove -- comments, then break each line into tokens (adding line
        --  numbers)
        --  then remove {- -} comments
        --  split by lines again ( to get indent
        let
          ([String]
fileLines, [Int]
numbers)
            = forall a b. [(a, b)] -> ([a], [b])
unzip [(String, Int)]
slines

        let tokenLines :: [[Token]]
tokenLines {- :: [[Token]] -} =
                        forall {b}. String -> b -> b
debugStep String
"stripNonHaskellLines" forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
stripNonHaskellLines
                      forall a b. (a -> b) -> a -> b
$ forall {b}. String -> b -> b
debugStep String
"stripslcomments" forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
stripslcomments
                      forall a b. (a -> b) -> a -> b
$ forall {b}. String -> b -> b
debugStep String
"splitByNL" forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL forall a. Maybe a
Nothing
                      forall a b. (a -> b) -> a -> b
$ forall {b}. String -> b -> b
debugStep String
"stripblockcomments pipe" forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripblockcomments
                      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                      forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (String -> [String] -> String -> Int -> [Token]
withline String
filename)
                                 (forall a b. (a -> b) -> [a] -> [b]
map
                                   (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> [String]
mywords Bool
False)
                                   [String]
fileLines)
                                 [String]
fileLines
                                 [Int]
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 :: Int
topLevelIndent = forall {b}. String -> b -> b
debugStep String
"top level indent" forall a b. (a -> b) -> a -> b
$ Bool -> [[Token]] -> Int
getTopLevelIndent Bool
isLiterate [[Token]]
tokenLines
        let sections :: [[Token]]
sections = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
tail -- strip leading NL (no longer needed)
                       forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
                       forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL (forall a. a -> Maybe a
Just Int
topLevelIndent )
                       forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. String -> a -> b -> b
trace_ String
"tokenLines" [[Token]]
tokenLines [[Token]]
tokenLines)
        -- only take one of
        -- a 'x' = 7
        -- a _ = 0
        let filterAdjacentFuncImpl :: [FoundThing] -> [FoundThing]
filterAdjacentFuncImpl = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(FoundThing FoundThingType
t1 String
n1 (Pos String
f1 Int
_ Int
_ String
_))
                                                          (FoundThing FoundThingType
t2 String
n2 (Pos String
f2 Int
_ Int
_ String
_))
                                                          -> String
f1 forall a. Eq a => a -> a -> Bool
== String
f2
                                                            Bool -> Bool -> Bool
&& String
n1 forall a. Eq a => a -> a -> Bool
== String
n2
                                                            Bool -> Bool -> Bool
&& FoundThingType -> FoundThingType -> Bool
areFuncImpls FoundThingType
t1 FoundThingType
t2)
            areFuncImpls :: FoundThingType -> FoundThingType -> Bool
areFuncImpls (FTFuncImpl Scope
_) (FTFuncImpl Scope
_) = Bool
True
            areFuncImpls FoundThingType
_ FoundThingType
_                           = Bool
False

        let iCI :: [FoundThing] -> [FoundThing]
iCI = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(FoundThing FoundThingType
t1 String
n1 (Pos String
f1 Int
l1 Int
_ String
_))
                                       (FoundThing FoundThingType
t2 String
n2 (Pos String
f2 Int
l2 Int
_ String
_))
                                       -> String
f1 forall a. Eq a => a -> a -> Bool
== String
f2
                                         Bool -> Bool -> Bool
&& String
n1 forall a. Eq a => a -> a -> Bool
== String
n2
                                         Bool -> Bool -> Bool
&& FoundThingType -> FoundThingType -> Bool
skipCons FoundThingType
t1 FoundThingType
t2
                                         Bool -> Bool -> Bool
&& ((forall a. Ord a => a -> a -> Bool
<= Int
7) forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Int
l2 forall a. Num a => a -> a -> a
- Int
l1))
            skipCons :: FoundThingType -> FoundThingType -> Bool
skipCons FoundThingType
FTData (FTCons FoundThingType
_ String
_)       = Bool
False
            skipCons FoundThingType
FTDataGADT (FTConsGADT String
_) = Bool
False
            skipCons FoundThingType
_ FoundThingType
_                       = Bool
True
        let things :: [FoundThing]
things = [FoundThing] -> [FoundThing]
iCI forall a b. (a -> b) -> a -> b
$ [FoundThing] -> [FoundThing]
filterAdjacentFuncImpl forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip [Token] -> Scope -> [FoundThing]
findstuff forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (\[Token]
s -> forall a b. String -> a -> b -> b
trace_ String
"section in findThingsInBS" [Token]
s [Token]
s)) [[Token]]
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 -> Bool
uniqueModuleName (FoundThing FoundThingType
FTModule String
moduleName Pos
_)
            = Bool -> Bool
not
              forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(FoundThing FoundThingType
thingType String
thingName Pos
_)
                -> FoundThingType
thingType forall a. Eq a => a -> a -> Bool
/= FoundThingType
FTModule Bool -> Bool -> Bool
&& String
thingName forall a. Eq a => a -> a -> Bool
== String
moduleName) [FoundThing]
things
          uniqueModuleName FoundThing
_ = Bool
True
        String -> [FoundThing] -> FileData
FileData String
filename forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter FoundThing -> Bool
uniqueModuleName [FoundThing]
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 :: String -> [String] -> String -> Int -> [Token]
withline String
filename [String]
sourceWords String
fullline Int
i =
  let countSpaces :: String -> a
countSpaces (Char
' ':String
xs)  = a
1 forall a. Num a => a -> a -> a
+ String -> a
countSpaces String
xs
      countSpaces (Char
'\t':String
xs) = a
8 forall a. Num a => a -> a -> a
+ String -> a
countSpaces String
xs
      countSpaces String
_         = a
0
  in Int -> Token
NewLine (forall {a}. Num a => String -> a
countSpaces String
fullline)
      forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
w Int
t -> String -> Pos -> Token
Token String
w (String -> Int -> Int -> String -> Pos
Pos String
filename Int
i Int
t String
fullline)) [String]
sourceWords [Int
1 ..]

-- comments stripping

stripslcomments :: [[Token]] -> [[Token]]
stripslcomments :: [[Token]] -> [[Token]]
stripslcomments = let f :: [Token] -> Bool
f (NewLine Int
_ : Token (Char
'-':Char
'-':String
_) Pos
_ : [Token]
_) = Bool
False
                      f [Token]
_                                     = Bool
True
                      isCmt :: Token -> Bool
isCmt (Token (Char
'-':Char
'-':String
_) Pos
_)             = Bool
True
                      isCmt Token
_                                 = Bool
False
                  in forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Bool
isCmt)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [Token] -> Bool
f

stripblockcomments :: [Token] -> [Token]
stripblockcomments :: [Token] -> [Token]
stripblockcomments (Token String
"{-" Pos
pos : [Token]
xs) =
  forall a b. String -> a -> b -> b
trace_ String
"{- found at " (forall a. Show a => a -> String
show Pos
pos) forall a b. (a -> b) -> a -> b
$
  [Token] -> [Token]
afterblockcomend [Token]
xs
stripblockcomments (Token
x:[Token]
xs) = Token
xforall a. a -> [a] -> [a]
:[Token] -> [Token]
stripblockcomments [Token]
xs
stripblockcomments [] = []

afterblockcomend :: [Token] -> [Token]
afterblockcomend :: [Token] -> [Token]
afterblockcomend (t :: Token
t@(Token String
_ Pos
pos):[Token]
xs)
 | forall a. Eq a => [a] -> [a] -> Bool
contains String
"-}" (Token -> String
tokenString Token
t) =
   forall a b. String -> a -> b -> b
trace_ String
"-} found at " (forall a. Show a => a -> String
show Pos
pos) forall a b. (a -> b) -> a -> b
$
   [Token] -> [Token]
stripblockcomments [Token]
xs
 | Bool
otherwise           = [Token] -> [Token]
afterblockcomend [Token]
xs
afterblockcomend [] = []
afterblockcomend (Token
_:[Token]
xs) = [Token] -> [Token]
afterblockcomend [Token]
xs


-- does one string contain another string

contains :: Eq a => [a] -> [a] -> Bool
contains :: forall a. Eq a => [a] -> [a] -> Bool
contains [a]
sub = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
sub) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
tails

-- actually pick up definitions

findstuff :: [Token] -> Scope -> [FoundThing]
findstuff :: [Token] -> Scope -> [FoundThing]
findstuff (Token String
"module" Pos
_ : Token String
name Pos
pos : [Token]
_) Scope
_ =
        forall a b. String -> a -> b -> b
trace_ String
"module" Pos
pos [FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTModule String
name Pos
pos] -- nothing will follow this section
findstuff tokens :: [Token]
tokens@(Token String
"data" Pos
_ : Token String
name Pos
pos : [Token]
xs) Scope
_
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( (forall a. Eq a => a -> a -> Bool
== String
"where")forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString ) [Token]
xs -- GADT
            -- TODO will be found as FTCons (not FTConsGADT), the same for
            -- functions - but they are found :)
            =
              forall a b. String -> a -> b -> b
trace_  String
"findstuff data b1" [Token]
tokens forall a b. (a -> b) -> a -> b
$
              FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTDataGADT String
name Pos
pos
              forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 (String -> FoundThingType
FTConsGADT String
name) String
"" [Token]
xs forall a. [a] -> [a] -> [a]
++ [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
xs forall a. Maybe a
Nothing -- ++ (findstuff xs)
        | Bool
otherwise
            =
              forall a b. String -> a -> b -> b
trace_  String
"findstuff data otherwise" [Token]
tokens forall a b. (a -> b) -> a -> b
$
              FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTData String
name Pos
pos
              forall a. a -> [a] -> [a]
: FoundThingType -> [Token] -> [FoundThing]
getcons (FoundThingType -> String -> FoundThingType
FTCons FoundThingType
FTData String
name) ([Token] -> [Token]
trimNewlines [Token]
xs)-- ++ (findstuff xs)
findstuff tokens :: [Token]
tokens@(Token String
"newtype" Pos
_ : ts :: [Token]
ts@(Token String
name Pos
pos : [Token]
_))Scope
_  =
        forall a b. String -> a -> b -> b
trace_ String
"findstuff newtype" [Token]
tokens forall a b. (a -> b) -> a -> b
$
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTNewtype String
name Pos
pos
          forall a. a -> [a] -> [a]
: FoundThingType -> [Token] -> [FoundThing]
getcons (FoundThingType -> String -> FoundThingType
FTCons FoundThingType
FTNewtype String
name) ([Token] -> [Token]
trimNewlines [Token]
ts)-- ++ (findstuff xs)
        -- FoundThing FTNewtype name pos : findstuff xs
findstuff tokens :: [Token]
tokens@(Token String
"type" Pos
_ : Token String
name Pos
pos : [Token]
xs) Scope
_ =
        forall a b. String -> a -> b -> b
trace_  String
"findstuff type" [Token]
tokens forall a b. (a -> b) -> a -> b
$
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
== String
"where")forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff type b1 " [Token]
ys [FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTType String
name Pos
pos]
        ([Token]
ys, [Token]
r) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff type b2 " ([Token]
ys, [Token]
r) forall a b. (a -> b) -> a -> b
$
          FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTType String
name Pos
pos forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"class" Pos
_ : [Token]
xs) Scope
_ =
        forall a b. String -> a -> b -> b
trace_  String
"findstuff class" [Token]
tokens forall a b. (a -> b) -> a -> b
$
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
== String
"where")forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff class b1 " [Token]
ys forall a b. (a -> b) -> a -> b
$
          forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ [Token] -> Maybe FoundThing
className [Token]
ys
        ([Token]
ys, [Token]
r) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff class b2 " ([Token]
ys, [Token]
r) forall a b. (a -> b) -> a -> b
$
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\n :: FoundThing
n@(FoundThing FoundThingType
_ String
name Pos
_) -> FoundThing
n forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r (forall a. a -> Maybe a
Just (FoundThingType
FTClass, String
name))) forall a b. (a -> b) -> a -> b
$
              [Token] -> Maybe FoundThing
className [Token]
ys
    where isParenOpen :: Token -> Bool
isParenOpen (Token String
"(" Pos
_) = Bool
True
          isParenOpen Token
_             = Bool
False
          className :: [Token] -> Maybe FoundThing
className [Token]
lst
            = case (forall a. [a] -> Maybe a
head'
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token -> Bool
isParenOpen
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"=>", ShowS
utf8_to_char8_hack String
"⇒"])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) [Token]
lst of
              (Just (Token String
name Pos
p)) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTClass String
name Pos
p
              Maybe Token
_                     -> forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"instance" Pos
_ : [Token]
xs) Scope
_ =
        forall a b. String -> a -> b -> b
trace_  String
"findstuff instance" [Token]
tokens forall a b. (a -> b) -> a -> b
$
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
== String
"where")forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff instance b1 " [Token]
ys forall a b. (a -> b) -> a -> b
$
          forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ [Token] -> Maybe FoundThing
instanceName [Token]
ys
        ([Token]
ys, [Token]
r) ->
          forall a b. String -> a -> b -> b
trace_ String
"findstuff instance b2 " ([Token]
ys, [Token]
r) forall a b. (a -> b) -> a -> b
$
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\n :: FoundThing
n@(FoundThing FoundThingType
_ String
name Pos
_) -> FoundThing
n forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r (forall a. a -> Maybe a
Just (FoundThingType
FTInstance, String
name))) forall a b. (a -> b) -> a -> b
$
              [Token] -> Maybe FoundThing
instanceName [Token]
ys
    where instanceName :: [Token] -> Maybe FoundThing
instanceName lst :: [Token]
lst@(Token String
_ Pos
p :[Token]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTInstance
            (forall a b. (a -> b) -> [a] -> [b]
map (\Char
a -> if Char
a forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'-' else Char
a) forall a b. (a -> b) -> a -> b
$ [Token] -> String
concatTokens [Token]
lst) Pos
p
          instanceName [Token]
_ = forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"pattern" Pos
_ : Token String
name Pos
pos : Token String
"::" Pos
_ : [Token]
sig) Scope
_ =
        forall a b. String -> a -> b -> b
trace_ String
"findstuff pattern type annotation" [Token]
tokens [FoundThingType -> String -> Pos -> FoundThing
FoundThing (String -> FoundThingType
FTPatternTypeDef ([Token] -> String
concatTokens [Token]
sig)) String
name Pos
pos]
findstuff tokens :: [Token]
tokens@(Token String
"pattern" Pos
_ : Token String
name Pos
pos : [Token]
xs) Scope
scope =
        forall a b. String -> a -> b -> b
trace_ String
"findstuff pattern" [Token]
tokens forall a b. (a -> b) -> a -> b
$
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTPattern String
name Pos
pos forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
findstuff [Token]
xs Scope
scope
findstuff [Token]
xs Scope
scope =
  forall a b. String -> a -> b -> b
trace_ String
"findstuff rest " [Token]
xs forall a b. (a -> b) -> a -> b
$
  [Token] -> Scope -> [FoundThing]
findFunc [Token]
xs Scope
scope forall a. [a] -> [a] -> [a]
++ [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs [] [Token]
xs Scope
scope

findFuncTypeDefs :: [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs :: [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs [Token]
found (t :: Token
t@(Token String
_ Pos
_): Token String
"," Pos
_ :[Token]
xs) Scope
scope =
          [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs (Token
t forall a. a -> [a] -> [a]
: [Token]
found) [Token]
xs Scope
scope
findFuncTypeDefs [Token]
found (t :: Token
t@(Token String
_ Pos
_): Token String
"::" Pos
_ : [Token]
sig) Scope
scope =
          forall a b. (a -> b) -> [a] -> [b]
map (\(Token String
name Pos
p) -> FoundThingType -> String -> Pos -> FoundThing
FoundThing (String -> Scope -> FoundThingType
FTFuncTypeDef ([Token] -> String
concatTokens [Token]
sig) Scope
scope) String
name Pos
p) (Token
tforall a. a -> [a] -> [a]
:[Token]
found)
findFuncTypeDefs [Token]
found xs :: [Token]
xs@(Token String
"(" Pos
_ :[Token]
_) Scope
scope =
          case forall a. (a -> Bool) -> [a] -> ([a], [a])
break Token -> Bool
myBreakF [Token]
xs of
            (inner :: [Token]
inner@(Token String
_ Pos
p : [Token]
_), Token
rp : [Token]
xs') ->
              let merged :: Token
merged = String -> Pos -> Token
Token ( forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Token String
x Pos
_) -> String
x) forall a b. (a -> b) -> a -> b
$ [Token]
inner forall a. [a] -> [a] -> [a]
++ [Token
rp] ) Pos
p
              in if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Int -> Token -> Bool
isNewLine forall a. Maybe a
Nothing) [Token]
inner
                   then []
                   else [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs [Token]
found (Token
merged forall a. a -> [a] -> [a]
: [Token]
xs') Scope
scope
            ([Token], [Token])
_ -> []
    where myBreakF :: Token -> Bool
myBreakF (Token String
")" Pos
_) = Bool
True
          myBreakF Token
_             = Bool
False
findFuncTypeDefs [Token]
_ [Token]
_ Scope
_ = []

fromWhereOn :: [Token] -> Scope -> [FoundThing]
fromWhereOn :: [Token] -> Scope -> [FoundThing]
fromWhereOn [] Scope
_ = []
fromWhereOn [Token
_] Scope
_ = []
fromWhereOn (Token
_: xs :: [Token]
xs@(NewLine Int
_ : [Token]
_)) Scope
scope =
             forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip [Token] -> Scope -> [FoundThing]
findstuff Scope
scope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail')
             forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL (forall a. a -> Maybe a
Just ( forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
10000forall a. a -> [a] -> [a]
:)
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(NewLine Int
i) -> Int
i)
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Int -> Token -> Bool
isNewLine forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ [Token]
xs)) [Token]
xs
fromWhereOn (Token
_:[Token]
xw) Scope
scope = [Token] -> Scope -> [FoundThing]
findstuff [Token]
xw Scope
scope

findFunc :: [Token] -> Scope -> [FoundThing]
findFunc :: [Token] -> Scope -> [FoundThing]
findFunc [Token]
x Scope
scope = case [Token] -> Scope -> [FoundThing]
findInfix [Token]
x Scope
scope of
    a :: [FoundThing]
a@(FoundThing
_:[FoundThing]
_) -> [FoundThing]
a
    [FoundThing]
_       -> [Token] -> Scope -> [FoundThing]
findF [Token]
x Scope
scope

findInfix :: [Token] -> Scope -> [FoundThing]
findInfix :: [Token] -> Scope -> [FoundThing]
findInfix [Token]
x Scope
scope
   = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile
       ((forall a. Eq a => a -> a -> Bool
/= String
"`")forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString)
       (forall a. (a -> Bool) -> [a] -> [a]
takeWhile ( (forall a. Eq a => a -> a -> Bool
/= String
"=") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) [Token]
x) of
     Token
_ : Token String
name Pos
p : [Token]
_ -> [FoundThingType -> String -> Pos -> FoundThing
FoundThing (Scope -> FoundThingType
FTFuncImpl Scope
scope) String
name Pos
p]
     [Token]
_                    -> []


findF :: [Token] -> Scope -> [FoundThing]
findF :: [Token] -> Scope -> [FoundThing]
findF ts :: [Token]
ts@(Token String
"(" Pos
p : [Token]
_) Scope
scope =
    let (String
name, [Token]
xs) = [Token] -> (String, [Token])
extractOperator [Token]
ts in
    [FoundThingType -> String -> Pos -> FoundThing
FoundThing (Scope -> FoundThingType
FTFuncImpl Scope
scope) String
name Pos
p | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
"=" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) [Token]
xs]
findF (Token String
name Pos
p : [Token]
xs) Scope
scope =
    [FoundThingType -> String -> Pos -> FoundThing
FoundThing (Scope -> FoundThingType
FTFuncImpl Scope
scope) String
name Pos
p | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
"=" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) [Token]
xs]
findF [Token]
_ Scope
_ = []

head' :: [a] -> Maybe a
head' :: forall a. [a] -> Maybe a
head' (a
x:[a]
_) = forall a. a -> Maybe a
Just a
x
head' []    = forall a. Maybe a
Nothing

tail' :: [a] -> [a]
tail' :: forall a. [a] -> [a]
tail' (a
_:[a]
xs) = [a]
xs
tail' []     = []

-- get the constructor definitions, knowing that a datatype has just started

getcons :: FoundThingType -> [Token] -> [FoundThing]
getcons :: FoundThingType -> [Token] -> [FoundThing]
getcons FoundThingType
ftt (Token String
"=" Pos
_: Token String
name Pos
pos : [Token]
xs) =
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
ftt String
name Pos
pos forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 FoundThingType
ftt String
name [Token]
xs
getcons FoundThingType
ftt (Token
_:[Token]
xs) = FoundThingType -> [Token] -> [FoundThing]
getcons FoundThingType
ftt [Token]
xs
getcons FoundThingType
_ [] = []


getcons2 :: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 :: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 ftt :: FoundThingType
ftt@(FTCons FoundThingType
pt String
p) String
c (Token String
name Pos
pos : Token String
"::" Pos
_ : [Token]
xs) =
        FoundThingType -> String -> Pos -> FoundThing
FoundThing (FoundThingType -> String -> String -> FoundThingType
FTConsAccessor FoundThingType
pt String
p String
c) String
name Pos
pos forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 FoundThingType
ftt String
c [Token]
xs
getcons2 ftt :: FoundThingType
ftt@(FTConsGADT String
p) String
_ (Token String
name Pos
pos : Token String
"::" Pos
_ : [Token]
xs) =
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
ftt String
name Pos
pos forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 FoundThingType
ftt String
p [Token]
xs
getcons2 FoundThingType
ftt String
_ (Token String
"|" Pos
_ : Token String
name Pos
pos : [Token]
xs) =
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
ftt String
name Pos
pos forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 FoundThingType
ftt String
name [Token]
xs
getcons2 FoundThingType
ftt String
c (Token
_:[Token]
xs) = FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 FoundThingType
ftt String
c [Token]
xs
getcons2 FoundThingType
_ String
_ [] = []


splitByNL :: Maybe Int -> [Token] -> [[Token]]
splitByNL :: Maybe Int -> [Token] -> [[Token]]
splitByNL Maybe Int
maybeIndent (nl :: Token
nl@(NewLine Int
_):[Token]
ts) =
  let ([Token]
a,[Token]
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Maybe Int -> Token -> Bool
isNewLine Maybe Int
maybeIndent) [Token]
ts
  in (Token
nl forall a. a -> [a] -> [a]
: [Token]
a) forall a. a -> [a] -> [a]
: Maybe Int -> [Token] -> [[Token]]
splitByNL Maybe Int
maybeIndent [Token]
b
splitByNL Maybe Int
_ [Token]
_ = []

-- this only exists for test case testcases/HUnitBase.lhs (bird literate haskell style)
getTopLevelIndent :: Bool -> [[Token]] -> Int
getTopLevelIndent :: Bool -> [[Token]] -> Int
getTopLevelIndent Bool
_ [] = Int
0 -- (no import found, assuming indent 0: this can be
                           -- done better but should suffice for most needs
getTopLevelIndent Bool
isLiterate ((Token
nl:Token
next:[Token]
_):[[Token]]
xs) = if String
"import" forall a. Eq a => a -> a -> Bool
== Token -> String
tokenString Token
next
                          then let (NewLine Int
i) = Token
nl in Int
i
                          else Bool -> [[Token]] -> Int
getTopLevelIndent Bool
isLiterate [[Token]]
xs
getTopLevelIndent Bool
isLiterate ([Token]
_:[[Token]]
xs) = Bool -> [[Token]] -> Int
getTopLevelIndent Bool
isLiterate [[Token]]
xs

-- According to http://www.haskell.org/onlinereport/literate.html either
-- birdstyle or LaTeX style should be used. However simple experiments show
-- that unlit distributed by GHC has the following behavior
-- * The space after ">" can be omitted
-- * ">" must be first char in line to be read as birdstyle (then its replaced by a space)
-- * \begin{code} gets recognized if its indented, but \end{code} does not (?)
--
-- Attention: Base.lhs (shipping with GHC) have birdstyle in block comments
fromLiterate :: FilePath -> [(String, Int)]
    -> (Bool -- is literate
    , [(String, Int)])
fromLiterate :: String -> [(String, Int)] -> (Bool, [(String, Int)])
fromLiterate String
file [(String, Int)]
lns =
  if String
".lhs" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
    then (Bool
True, [(String, Int)] -> [(String, Int)]
unlit [(String, Int)]
lns)
    else (Bool
False, [(String, Int)]
lns)

  where unlit, returnCode :: [(String, Int)] -> [(String, Int)]
        unlit :: [(String, Int)] -> [(String, Int)]
unlit ((Char
'>':Char
' ':String
xs,Int
n):[(String, Int)]
ns) = (Char
' 'forall a. a -> [a] -> [a]
:String
xs,Int
n)forall a. a -> [a] -> [a]
:[(String, Int)] -> [(String, Int)]
unlit [(String, Int)]
ns -- unlit keeps space, so do we
        unlit ((String
line,Int
_):[(String, Int)]
ns) = if String
"\\begin{code}" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line then [(String, Int)] -> [(String, Int)]
returnCode [(String, Int)]
ns else [(String, Int)] -> [(String, Int)]
unlit [(String, Int)]
ns
        unlit [] = []

        -- in \begin{code} block
        returnCode :: [(String, Int)] -> [(String, Int)]
returnCode (t :: (String, Int)
t@(String
line,Int
_):[(String, Int)]
ns) = if String
"\\end{code}" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line then [(String, Int)] -> [(String, Int)]
unlit [(String, Int)]
ns else (String, Int)
tforall a. a -> [a] -> [a]
:[(String, Int)] -> [(String, Int)]
returnCode [(String, Int)]
ns
        returnCode [] = [] -- unexpected - hasktags does tagging, not compiling, thus don't treat missing \end{code} to be an error

-- suffixes: [".hs",".lhs"], use "" to match all files
dirToFiles :: Bool -> [String] -> FilePath -> IO [ FilePath ]
dirToFiles :: Bool -> [String] -> String -> IO [String]
dirToFiles Bool
_ [String]
_ String
"STDIN" = String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getContents
dirToFiles Bool
followSyms [String]
suffixes String
p = do
  Bool
isD <- String -> IO Bool
doesDirectoryExist String
p
#if MIN_VERSION_directory(1,3,0)
  Bool
isSymLink <- String -> IO Bool
pathIsSymbolicLink String
p
#else
  isSymLink <- isSymbolicLink p
#endif
  if Bool
isD
    then if Bool
isSymLink Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
followSyms
        then forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
          -- filter . .. and hidden files .*
          [String]
contents <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(/=) Char
'.' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
p
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> [String] -> String -> IO [String]
dirToFiles Bool
followSyms [String]
suffixes forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
(</>) String
p) [String]
contents
    else forall (m :: * -> *) a. Monad m => a -> m a
return [String
p | Bool
matchingSuffix ]
  where matchingSuffix :: Bool
matchingSuffix = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
p) [String]
suffixes

concatTokens :: [Token] -> String
concatTokens :: [Token] -> String
concatTokens = [String] -> String
smartUnwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Token String
name Pos
_) -> String
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Token -> Bool
isNewLine forall a. Maybe a
Nothing)
  where smartUnwords :: [String] -> String
smartUnwords [] = []
        smartUnwords [String]
a = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(String, String)
v -> ((String, String) -> String
glueNext (String, String)
v forall a. [a] -> [a] -> [a]
++)) String
"" forall a b. (a -> b) -> a -> b
$ [String]
a forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a. [a] -> [a]
tail ([String]
a forall a. [a] -> [a] -> [a]
++ [String
""])
        glueNext :: (String, String) -> String
glueNext (a :: String
a@(String
"("), String
_) = String
a
        glueNext (String
a, String
")")     = String
a
        glueNext (a :: String
a@(String
"["), String
_) = String
a
        glueNext (String
a, String
"]")     = String
a
        glueNext (String
a, String
",")     = String
a
        glueNext (String
a, String
"")      = String
a
        glueNext (String
a, String
_)       = String
a forall a. [a] -> [a] -> [a]
++ String
" "

extractOperator :: [Token] -> (String, [Token])
extractOperator :: [Token] -> (String, [Token])
extractOperator ts :: [Token]
ts@(Token String
"(" Pos
_ : [Token]
_) =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) String
")" forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. [a] -> [a]
tail' forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
== String
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) [Token]
ts
extractOperator [Token]
_ = (String
"", [])