{-# 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)
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
"-" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
filepath = Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
  | Bool
otherwise       = String -> IOMode -> IO Handle
openFile String
filepath IOMode
openMode

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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
_ctagsFile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", etags: " String -> ShowS
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
(Int -> Tags -> ShowS)
-> (Tags -> String) -> ([Tags] -> ShowS) -> Show Tags
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
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
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
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
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
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
  show (NewLine Int
i)               = String
"NewLine " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c'
isNewLine Maybe Int
_ Token
_                   = Bool
False

trimNewlines :: [Token] -> [Token]
trimNewlines :: [Token] -> [Token]
trimNewlines = (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Token -> Bool
isNewLine Maybe Int
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 (String -> IO String) -> [String] -> IO [String]
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 [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files

  [String]
filenames <- ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
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 <- (String -> IO FileData) -> [String] -> IO [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 IO () -> IO () -> IO ()
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 Bool -> IO Bool
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
fileModified
              then do ByteString
bytes <- String -> IO ByteString
BS.readFile String
cacheFilename
                      FileData -> IO FileData
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> FileData
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 = (String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"tags") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
        findAndCache :: IO FileData
findAndCache = do
          FileData
filedata <- String -> IO FileData
findThings String
filename
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cache (String -> String -> IO ()
writeFile String
cacheFilename (FileData -> String
forall a. Data a => a -> String
encodeJSON FileData
filedata))
          FileData -> IO 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 (ByteString -> String) -> (String -> ByteString) -> ShowS
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 (ByteString -> FileData) -> IO ByteString -> IO FileData
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 (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
bs

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

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

        let (Bool
isLiterate, [(String, Int)]
slines) =
              String -> (Bool, [(String, Int)]) -> (Bool, [(String, Int)])
forall b. String -> b -> b
debugStep String
"fromLiterate"
              ((Bool, [(String, Int)]) -> (Bool, [(String, Int)]))
-> (Bool, [(String, Int)]) -> (Bool, [(String, Int)])
forall a b. (a -> b) -> a -> b
$ String -> [(String, Int)] -> (Bool, [(String, Int)])
fromLiterate String
filename
              ([(String, Int)] -> (Bool, [(String, Int)]))
-> [(String, Int)] -> (Bool, [(String, Int)])
forall a b. (a -> b) -> a -> b
$ [String] -> [Int] -> [(String, Int)]
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)
            = [(String, Int)] -> ([String], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, Int)]
slines

        let tokenLines :: [[Token]]
tokenLines {- :: [[Token]] -} =
                        String -> [[Token]] -> [[Token]]
forall b. String -> b -> b
debugStep String
"stripNonHaskellLines" ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
stripNonHaskellLines
                      ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ String -> [[Token]] -> [[Token]]
forall b. String -> b -> b
debugStep String
"stripslcomments" ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [[Token]]
stripslcomments
                      ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ String -> [[Token]] -> [[Token]]
forall b. String -> b -> b
debugStep String
"splitByNL" ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL Maybe Int
forall a. Maybe a
Nothing
                      ([Token] -> [[Token]]) -> [Token] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ String -> [Token] -> [Token]
forall b. String -> b -> b
debugStep String
"stripblockcomments pipe" ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripblockcomments
                      ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                      ([[Token]] -> [Token]) -> [[Token]] -> [Token]
forall a b. (a -> b) -> a -> b
$ ([String] -> String -> Int -> [Token])
-> [[String]] -> [String] -> [Int] -> [[Token]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (String -> [String] -> String -> Int -> [Token]
withline String
filename)
                                 ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map
                                   ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
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 = String -> Int -> Int
forall b. String -> b -> b
debugStep String
"top level indent" (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Bool -> [[Token]] -> Int
getTopLevelIndent Bool
isLiterate [[Token]]
tokenLines
        let sections :: [[Token]]
sections = ([Token] -> [Token]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> [a] -> [b]
map [Token] -> [Token]
forall a. [a] -> [a]
tail -- strip leading NL (no longer needed)
                       ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ ([Token] -> Bool) -> [[Token]] -> [[Token]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Token] -> Bool) -> [Token] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
                       ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
topLevelIndent )
                       ([Token] -> [[Token]]) -> [Token] -> [[Token]]
forall a b. (a -> b) -> a -> b
$ [[Token]] -> [Token]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [[Token]] -> [[Token]] -> [[Token]]
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 = ([FoundThing] -> FoundThing) -> [[FoundThing]] -> [FoundThing]
forall a b. (a -> b) -> [a] -> [b]
map [FoundThing] -> FoundThing
forall a. [a] -> a
head ([[FoundThing]] -> [FoundThing])
-> ([FoundThing] -> [[FoundThing]]) -> [FoundThing] -> [FoundThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FoundThing -> FoundThing -> Bool)
-> [FoundThing] -> [[FoundThing]]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f2
                                                            Bool -> Bool -> Bool
&& String
n1 String -> String -> Bool
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 = ([FoundThing] -> FoundThing) -> [[FoundThing]] -> [FoundThing]
forall a b. (a -> b) -> [a] -> [b]
map [FoundThing] -> FoundThing
forall a. [a] -> a
head ([[FoundThing]] -> [FoundThing])
-> ([FoundThing] -> [[FoundThing]]) -> [FoundThing] -> [FoundThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FoundThing -> FoundThing -> Bool)
-> [FoundThing] -> [[FoundThing]]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f2
                                         Bool -> Bool -> Bool
&& String
n1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2
                                         Bool -> Bool -> Bool
&& FoundThingType -> FoundThingType -> Bool
skipCons FoundThingType
t1 FoundThingType
t2
                                         Bool -> Bool -> Bool
&& ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
7) (Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
l2 Int -> Int -> Int
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 ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$ [FoundThing] -> [FoundThing]
filterAdjacentFuncImpl ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$ ([Token] -> [FoundThing]) -> [[Token]] -> [FoundThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Token] -> Scope -> [FoundThing])
-> Scope -> [Token] -> [FoundThing]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Token] -> Scope -> [FoundThing]
findstuff Scope
forall a. Maybe a
Nothing ([Token] -> [FoundThing])
-> ([Token] -> [Token]) -> [Token] -> [FoundThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (\[Token]
s -> String -> [Token] -> [Token] -> [Token]
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
              (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (FoundThing -> Bool) -> [FoundThing] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(FoundThing FoundThingType
thingType String
thingName Pos
_)
                -> FoundThingType
thingType FoundThingType -> FoundThingType -> Bool
forall a. Eq a => a -> a -> Bool
/= FoundThingType
FTModule Bool -> Bool -> Bool
&& String
thingName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
moduleName) [FoundThing]
things
          uniqueModuleName FoundThing
_ = Bool
True
        String -> [FoundThing] -> FileData
FileData String
filename ([FoundThing] -> FileData) -> [FoundThing] -> FileData
forall a b. (a -> b) -> a -> b
$ (FoundThing -> Bool) -> [FoundThing] -> [FoundThing]
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 a -> a -> a
forall a. Num a => a -> a -> a
+ String -> a
countSpaces String
xs
      countSpaces (Char
'\t':String
xs) = a
8 a -> a -> a
forall a. Num a => a -> a -> a
+ String -> a
countSpaces String
xs
      countSpaces String
_         = a
0
  in Int -> Token
NewLine (String -> Int
forall a. Num a => String -> a
countSpaces String
fullline)
      Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Int -> Token) -> [String] -> [Int] -> [Token]
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 ([Token] -> [Token]) -> [[Token]] -> [[Token]]
forall a b. (a -> b) -> [a] -> [b]
map ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Bool
isCmt)) ([[Token]] -> [[Token]])
-> ([[Token]] -> [[Token]]) -> [[Token]] -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token] -> Bool) -> [[Token]] -> [[Token]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Token] -> Bool
f

stripblockcomments :: [Token] -> [Token]
stripblockcomments :: [Token] -> [Token]
stripblockcomments (Token String
"{-" Pos
pos : [Token]
xs) =
  String -> String -> [Token] -> [Token]
forall a b. String -> a -> b -> b
trace_ String
"{- found at " (Pos -> String
forall a. Show a => a -> String
show Pos
pos) ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$
  [Token] -> [Token]
afterblockcomend [Token]
xs
stripblockcomments (Token
x:[Token]
xs) = Token
xToken -> [Token] -> [Token]
forall 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)
 | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
contains String
"-}" (Token -> String
tokenString Token
t) =
   String -> String -> [Token] -> [Token]
forall a b. String -> a -> b -> b
trace_ String
"-} found at " (Pos -> String
forall a. Show a => a -> String
show Pos
pos) ([Token] -> [Token]) -> [Token] -> [Token]
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 :: [a] -> [a] -> Bool
contains [a]
sub = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
sub) ([[a]] -> Bool) -> ([a] -> [[a]]) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
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
_ =
        String -> Pos -> [FoundThing] -> [FoundThing]
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
_
        | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ( (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"where")(String -> Bool) -> (Token -> String) -> Token -> Bool
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 :)
            =
              String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_  String
"findstuff data b1" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
              FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTDataGADT String
name Pos
pos
              FoundThing -> [FoundThing] -> [FoundThing]
forall a. a -> [a] -> [a]
: FoundThingType -> String -> [Token] -> [FoundThing]
getcons2 (String -> FoundThingType
FTConsGADT String
name) String
"" [Token]
xs [FoundThing] -> [FoundThing] -> [FoundThing]
forall a. [a] -> [a] -> [a]
++ [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
xs Scope
forall a. Maybe a
Nothing -- ++ (findstuff xs)
        | Bool
otherwise
            =
              String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_  String
"findstuff data otherwise" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
              FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTData String
name Pos
pos
              FoundThing -> [FoundThing] -> [FoundThing]
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
_  =
        String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff newtype" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTNewtype String
name Pos
pos
          FoundThing -> [FoundThing] -> [FoundThing]
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
_ =
        String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_  String
"findstuff type" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
        case (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"where")(String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          String -> [Token] -> [FoundThing] -> [FoundThing]
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) ->
          String -> ([Token], [Token]) -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff type b2 " ([Token]
ys, [Token]
r) ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
          FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTType String
name Pos
pos FoundThing -> [FoundThing] -> [FoundThing]
forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r Scope
forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"class" Pos
_ : [Token]
xs) Scope
_ =
        String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_  String
"findstuff class" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
        case (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"where")(String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff class b1 " [Token]
ys ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
          Maybe FoundThing -> [FoundThing]
forall a. Maybe a -> [a]
maybeToList (Maybe FoundThing -> [FoundThing])
-> Maybe FoundThing -> [FoundThing]
forall a b. (a -> b) -> a -> b
$ [Token] -> Maybe FoundThing
className [Token]
ys
        ([Token]
ys, [Token]
r) ->
          String -> ([Token], [Token]) -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff class b2 " ([Token]
ys, [Token]
r) ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
          [FoundThing]
-> (FoundThing -> [FoundThing]) -> Maybe FoundThing -> [FoundThing]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\n :: FoundThing
n@(FoundThing FoundThingType
_ String
name Pos
_) -> FoundThing
n FoundThing -> [FoundThing] -> [FoundThing]
forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r ((FoundThingType, String) -> Scope
forall a. a -> Maybe a
Just (FoundThingType
FTClass, String
name))) (Maybe FoundThing -> [FoundThing])
-> Maybe FoundThing -> [FoundThing]
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 ([Token] -> Maybe Token
forall a. [a] -> Maybe a
head'
                  ([Token] -> Maybe Token)
-> ([Token] -> [Token]) -> [Token] -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token -> Bool
isParenOpen
                  ([Token] -> [Token]) -> ([Token] -> [Token]) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
forall a. [a] -> [a]
reverse
                  ([Token] -> [Token]) -> ([Token] -> [Token]) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"=>", ShowS
utf8_to_char8_hack String
"⇒"])) (String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString)
                  ([Token] -> [Token]) -> ([Token] -> [Token]) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
forall a. [a] -> [a]
reverse) [Token]
lst of
              (Just (Token String
name Pos
p)) -> FoundThing -> Maybe FoundThing
forall a. a -> Maybe a
Just (FoundThing -> Maybe FoundThing) -> FoundThing -> Maybe FoundThing
forall a b. (a -> b) -> a -> b
$ FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTClass String
name Pos
p
              Maybe Token
_                     -> Maybe FoundThing
forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"instance" Pos
_ : [Token]
xs) Scope
_ =
        String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_  String
"findstuff instance" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
        case (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"where")(String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Token -> String
tokenString) [Token]
xs of
        ([Token]
ys, []) ->
          String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff instance b1 " [Token]
ys ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
          Maybe FoundThing -> [FoundThing]
forall a. Maybe a -> [a]
maybeToList (Maybe FoundThing -> [FoundThing])
-> Maybe FoundThing -> [FoundThing]
forall a b. (a -> b) -> a -> b
$ [Token] -> Maybe FoundThing
instanceName [Token]
ys
        ([Token]
ys, [Token]
r) ->
          String -> ([Token], [Token]) -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff instance b2 " ([Token]
ys, [Token]
r) ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
          [FoundThing]
-> (FoundThing -> [FoundThing]) -> Maybe FoundThing -> [FoundThing]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\n :: FoundThing
n@(FoundThing FoundThingType
_ String
name Pos
_) -> FoundThing
n FoundThing -> [FoundThing] -> [FoundThing]
forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
fromWhereOn [Token]
r ((FoundThingType, String) -> Scope
forall a. a -> Maybe a
Just (FoundThingType
FTInstance, String
name))) (Maybe FoundThing -> [FoundThing])
-> Maybe FoundThing -> [FoundThing]
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]
_) = FoundThing -> Maybe FoundThing
forall a. a -> Maybe a
Just (FoundThing -> Maybe FoundThing) -> FoundThing -> Maybe FoundThing
forall a b. (a -> b) -> a -> b
$ FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTInstance
            ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
a -> if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'-' else Char
a) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Token] -> String
concatTokens [Token]
lst) Pos
p
          instanceName [Token]
_ = Maybe FoundThing
forall a. Maybe a
Nothing
findstuff tokens :: [Token]
tokens@(Token String
"pattern" Pos
_ : Token String
name Pos
pos : Token String
"::" Pos
_ : [Token]
sig) Scope
_ =
        String -> [Token] -> [FoundThing] -> [FoundThing]
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 =
        String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff pattern" [Token]
tokens ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
        FoundThingType -> String -> Pos -> FoundThing
FoundThing FoundThingType
FTPattern String
name Pos
pos FoundThing -> [FoundThing] -> [FoundThing]
forall a. a -> [a] -> [a]
: [Token] -> Scope -> [FoundThing]
findstuff [Token]
xs Scope
scope
findstuff [Token]
xs Scope
scope =
  String -> [Token] -> [FoundThing] -> [FoundThing]
forall a b. String -> a -> b -> b
trace_ String
"findstuff rest " [Token]
xs ([FoundThing] -> [FoundThing]) -> [FoundThing] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$
  [Token] -> Scope -> [FoundThing]
findFunc [Token]
xs Scope
scope [FoundThing] -> [FoundThing] -> [FoundThing]
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 Token -> [Token] -> [Token]
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 =
          (Token -> FoundThing) -> [Token] -> [FoundThing]
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
tToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
found)
findFuncTypeDefs [Token]
found xs :: [Token]
xs@(Token String
"(" Pos
_ :[Token]
_) Scope
scope =
          case (Token -> Bool) -> [Token] -> ([Token], [Token])
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 ( (Token -> String) -> [Token] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Token String
x Pos
_) -> String
x) ([Token] -> String) -> [Token] -> String
forall a b. (a -> b) -> a -> b
$ [Token]
inner [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
rp] ) Pos
p
              in if (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Int -> Token -> Bool
isNewLine Maybe Int
forall a. Maybe a
Nothing) [Token]
inner
                   then []
                   else [Token] -> [Token] -> Scope -> [FoundThing]
findFuncTypeDefs [Token]
found (Token
merged Token -> [Token] -> [Token]
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 =
             ([Token] -> [FoundThing]) -> [[Token]] -> [FoundThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Token] -> Scope -> [FoundThing])
-> Scope -> [Token] -> [FoundThing]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Token] -> Scope -> [FoundThing]
findstuff Scope
scope ([Token] -> [FoundThing])
-> ([Token] -> [Token]) -> [Token] -> [FoundThing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
forall a. [a] -> [a]
tail')
             ([[Token]] -> [FoundThing]) -> [[Token]] -> [FoundThing]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Token] -> [[Token]]
splitByNL (Int -> Maybe Int
forall a. a -> Maybe a
Just ( [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
                                ([Int] -> Int) -> ([Token] -> [Int]) -> [Token] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
10000Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:)
                                ([Int] -> [Int]) -> ([Token] -> [Int]) -> [Token] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Int) -> [Token] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(NewLine Int
i) -> Int
i)
                                ([Token] -> [Int]) -> ([Token] -> [Token]) -> [Token] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Int -> Token -> Bool
isNewLine Maybe Int
forall a. Maybe a
Nothing) ([Token] -> Int) -> [Token] -> Int
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 (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile
       ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"`")(String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString)
       ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ( (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"=") (String -> Bool) -> (Token -> String) -> Token -> Bool
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 | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
"=" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (Token -> String) -> Token -> 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 | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
"=" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (Token -> String) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
tokenString) [Token]
xs]
findF [Token]
_ Scope
_ = []

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

tail' :: [a] -> [a]
tail' :: [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 FoundThing -> [FoundThing] -> [FoundThing]
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 FoundThing -> [FoundThing] -> [FoundThing]
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 FoundThing -> [FoundThing] -> [FoundThing]
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 FoundThing -> [FoundThing] -> [FoundThing]
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) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Maybe Int -> Token -> Bool
isNewLine Maybe Int
maybeIndent) [Token]
ts
  in (Token
nl Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
a) [Token] -> [[Token]] -> [[Token]]
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" String -> String -> Bool
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" String -> String -> Bool
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
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
xs,Int
n)(String, Int) -> [(String, Int)] -> [(String, Int)]
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}" String -> String -> Bool
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}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line then [(String, Int)] -> [(String, Int)]
unlit [(String, Int)]
ns else (String, Int)
t(String, Int) -> [(String, Int)] -> [(String, Int)]
forall 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 (String -> [String]) -> IO String -> IO [String]
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 [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
          -- filter . .. and hidden files .*
          [String]
contents <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Char
'.' (Char -> Bool) -> (String -> Char) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
p
          [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> IO [String]) -> [String] -> IO [[String]]
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 (String -> IO [String]) -> ShowS -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
(</>) String
p) [String]
contents
    else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
p | Bool
matchingSuffix ]
  where matchingSuffix :: Bool
matchingSuffix = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
p) [String]
suffixes

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

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