{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -funbox-strict-fields #-}

module FastTags.Tag (
    -- * types
    TagVal(..)
    , Type(..)
    , Tag(..)
    , Pos(..)
    , SrcPos(..)
    , UnstrippedTokens(..)
    -- * process
    , processFile
    , qualify
    , findSrcPrefix
    , process
    , tokenizeInput
    , processTokens
    -- * util
    , isHsFile
    , defaultModes
    , determineModes
    , ProcessMode(..)

    -- for testing
    , unstrippedTokensOf
    , stripNewlines
    , breakBlocks
    , whereBlock
) where

import Control.Arrow ((***))
import Control.DeepSeq (rnf, NFData)
import Control.Monad

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import Data.Functor ((<$>))
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe (maybeToList, isJust, fromMaybe)
import Data.Monoid ((<>), Monoid(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Data.Void (Void)

import qualified System.FilePath as FilePath

import FastTags.LexerTypes (LitMode(..))
import qualified FastTags.Lexer as Lexer
import qualified FastTags.Token as Token
import FastTags.Token (Token, Pos(..), SrcPos(..), TokenVal(..))
import qualified FastTags.Util as Util

-- * types

data TagVal = TagVal {
    TagVal -> Text
tvName     :: !Text
    , TagVal -> Type
tvType   :: !Type
    , TagVal -> Maybe Text
tvParent :: !(Maybe Text)
      -- ^ parent of this tag; parent can only be of type
      -- Class, Data or Family
    } deriving (Int -> TagVal -> ShowS
[TagVal] -> ShowS
TagVal -> String
(Int -> TagVal -> ShowS)
-> (TagVal -> String) -> ([TagVal] -> ShowS) -> Show TagVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagVal] -> ShowS
$cshowList :: [TagVal] -> ShowS
show :: TagVal -> String
$cshow :: TagVal -> String
showsPrec :: Int -> TagVal -> ShowS
$cshowsPrec :: Int -> TagVal -> ShowS
Show, TagVal -> TagVal -> Bool
(TagVal -> TagVal -> Bool)
-> (TagVal -> TagVal -> Bool) -> Eq TagVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagVal -> TagVal -> Bool
$c/= :: TagVal -> TagVal -> Bool
== :: TagVal -> TagVal -> Bool
$c== :: TagVal -> TagVal -> Bool
Eq, Eq TagVal
Eq TagVal
-> (TagVal -> TagVal -> Ordering)
-> (TagVal -> TagVal -> Bool)
-> (TagVal -> TagVal -> Bool)
-> (TagVal -> TagVal -> Bool)
-> (TagVal -> TagVal -> Bool)
-> (TagVal -> TagVal -> TagVal)
-> (TagVal -> TagVal -> TagVal)
-> Ord TagVal
TagVal -> TagVal -> Bool
TagVal -> TagVal -> Ordering
TagVal -> TagVal -> TagVal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagVal -> TagVal -> TagVal
$cmin :: TagVal -> TagVal -> TagVal
max :: TagVal -> TagVal -> TagVal
$cmax :: TagVal -> TagVal -> TagVal
>= :: TagVal -> TagVal -> Bool
$c>= :: TagVal -> TagVal -> Bool
> :: TagVal -> TagVal -> Bool
$c> :: TagVal -> TagVal -> Bool
<= :: TagVal -> TagVal -> Bool
$c<= :: TagVal -> TagVal -> Bool
< :: TagVal -> TagVal -> Bool
$c< :: TagVal -> TagVal -> Bool
compare :: TagVal -> TagVal -> Ordering
$ccompare :: TagVal -> TagVal -> Ordering
$cp1Ord :: Eq TagVal
Ord)

tagName :: Pos TagVal -> Text
tagName :: Pos TagVal -> Text
tagName = TagVal -> Text
tvName (TagVal -> Text) -> (Pos TagVal -> TagVal) -> Pos TagVal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos TagVal -> TagVal
forall a. Pos a -> a
valOf

tagLine :: Pos TagVal -> Token.Line
tagLine :: Pos TagVal -> Line
tagLine = SrcPos -> Line
posLine (SrcPos -> Line) -> (Pos TagVal -> SrcPos) -> Pos TagVal -> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos TagVal -> SrcPos
forall a. Pos a -> SrcPos
posOf

instance NFData TagVal where
    rnf :: TagVal -> ()
rnf (TagVal Text
x Type
y Maybe Text
z) = Text -> ()
forall a. NFData a => a -> ()
rnf Text
x () -> () -> ()
`seq` Type -> ()
forall a. NFData a => a -> ()
rnf Type
y () -> () -> ()
`seq` Maybe Text -> ()
forall a. NFData a => a -> ()
rnf Maybe Text
z

-- | The Ord instance is used to sort tags with the same name.  Given multiple
-- matches, vim will visit them in order, so this should be in the order of
-- interest.
--
-- We rely that Type < Constructor.  TODO how and where?  For sorting tags?
data Type =
    Function
    | Type
    | Constructor
    | Class
    | Module
    | Operator
    | Pattern
    | Family
    | Define -- ^ Preprocessor #define
    deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Eq Type
-> (Type -> Type -> Ordering)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Type)
-> (Type -> Type -> Type)
-> Ord Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
$cp1Ord :: Eq Type
Ord, Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show)

instance NFData Type where
    rnf :: Type -> ()
rnf Type
t = Type
t Type -> () -> ()
`seq` ()

data Tag =
    Tag !(Pos TagVal)
    -- | Just like Tag, except these should be deduplicated by their TagVal,
    -- where the one with the lowest line number will be preferred.
    -- The idea seems to be that functions will emit a tag for both the
    -- signature and definition.  TODO seems like a hack, why not just
    -- deduplicate all tags?  And I think I do that now with dropAdjacent.
    | RepeatableTag !(Pos TagVal)
    | Warning !(Pos String)
    deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord)

onTagVal :: (Pos TagVal -> Pos TagVal) -> Tag -> Tag
onTagVal :: (Pos TagVal -> Pos TagVal) -> Tag -> Tag
onTagVal Pos TagVal -> Pos TagVal
f (Tag Pos TagVal
t)           = Pos TagVal -> Tag
Tag (Pos TagVal -> Tag) -> Pos TagVal -> Tag
forall a b. (a -> b) -> a -> b
$ Pos TagVal -> Pos TagVal
f Pos TagVal
t
onTagVal Pos TagVal -> Pos TagVal
f (RepeatableTag Pos TagVal
t) = Pos TagVal -> Tag
RepeatableTag (Pos TagVal -> Tag) -> Pos TagVal -> Tag
forall a b. (a -> b) -> a -> b
$ Pos TagVal -> Pos TagVal
f Pos TagVal
t
onTagVal Pos TagVal -> Pos TagVal
_ w :: Tag
w@(Warning Pos String
_)     = Tag
w

-- | Partition Tag, RepeatableTag, and Warning.
partitionTags :: [Tag] -> ([Pos TagVal], [Pos TagVal], [Pos String])
partitionTags :: [Tag] -> ([Pos TagVal], [Pos TagVal], [Pos String])
partitionTags = [Pos TagVal]
-> [Pos TagVal]
-> [Pos String]
-> [Tag]
-> ([Pos TagVal], [Pos TagVal], [Pos String])
go [] [] []
    where
    go :: [Pos TagVal]
-> [Pos TagVal]
-> [Pos String]
-> [Tag]
-> ([Pos TagVal], [Pos TagVal], [Pos String])
go [Pos TagVal]
tags [Pos TagVal]
repeats [Pos String]
warns [] = ([Pos TagVal]
tags, [Pos TagVal]
repeats, [Pos String] -> [Pos String]
forall a. [a] -> [a]
reverse [Pos String]
warns)
    go [Pos TagVal]
tags [Pos TagVal]
repeats [Pos String]
warns (Tag
t:[Tag]
ts) = case Tag
t of
        Tag Pos TagVal
a           -> [Pos TagVal]
-> [Pos TagVal]
-> [Pos String]
-> [Tag]
-> ([Pos TagVal], [Pos TagVal], [Pos String])
go (Pos TagVal
aPos TagVal -> [Pos TagVal] -> [Pos TagVal]
forall a. a -> [a] -> [a]
:[Pos TagVal]
tags) [Pos TagVal]
repeats [Pos String]
warns [Tag]
ts
        RepeatableTag Pos TagVal
a -> [Pos TagVal]
-> [Pos TagVal]
-> [Pos String]
-> [Tag]
-> ([Pos TagVal], [Pos TagVal], [Pos String])
go [Pos TagVal]
tags (Pos TagVal
aPos TagVal -> [Pos TagVal] -> [Pos TagVal]
forall a. a -> [a] -> [a]
:[Pos TagVal]
repeats) [Pos String]
warns [Tag]
ts
        Warning Pos String
a       -> [Pos TagVal]
-> [Pos TagVal]
-> [Pos String]
-> [Tag]
-> ([Pos TagVal], [Pos TagVal], [Pos String])
go [Pos TagVal]
tags [Pos TagVal]
repeats (Pos String
aPos String -> [Pos String] -> [Pos String]
forall a. a -> [a] -> [a]
:[Pos String]
warns) [Tag]
ts

extractName :: Tag -> Maybe Text
extractName :: Tag -> Maybe Text
extractName (Tag Pos TagVal
t)           = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Pos TagVal -> Text
tagName Pos TagVal
t
extractName (RepeatableTag Pos TagVal
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Pos TagVal -> Text
tagName Pos TagVal
t
extractName (Warning Pos String
_)       = Maybe Text
forall a. Maybe a
Nothing

-- | Newlines have to remain in the tokens because 'breakBlocks' relies on
-- them.  But they make pattern matching on the tokens unreliable because
-- newlines might be anywhere.  A newtype makes sure that the tokens only get
-- stripped once and that I don't do any pattern matching on unstripped tokens.
newtype UnstrippedTokens = UnstrippedTokens [Token]
#if MIN_VERSION_base(4,11,0)
    deriving (Int -> UnstrippedTokens -> ShowS
[UnstrippedTokens] -> ShowS
UnstrippedTokens -> String
(Int -> UnstrippedTokens -> ShowS)
-> (UnstrippedTokens -> String)
-> ([UnstrippedTokens] -> ShowS)
-> Show UnstrippedTokens
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnstrippedTokens] -> ShowS
$cshowList :: [UnstrippedTokens] -> ShowS
show :: UnstrippedTokens -> String
$cshow :: UnstrippedTokens -> String
showsPrec :: Int -> UnstrippedTokens -> ShowS
$cshowsPrec :: Int -> UnstrippedTokens -> ShowS
Show, b -> UnstrippedTokens -> UnstrippedTokens
NonEmpty UnstrippedTokens -> UnstrippedTokens
UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
(UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens)
-> (NonEmpty UnstrippedTokens -> UnstrippedTokens)
-> (forall b.
    Integral b =>
    b -> UnstrippedTokens -> UnstrippedTokens)
-> Semigroup UnstrippedTokens
forall b. Integral b => b -> UnstrippedTokens -> UnstrippedTokens
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> UnstrippedTokens -> UnstrippedTokens
$cstimes :: forall b. Integral b => b -> UnstrippedTokens -> UnstrippedTokens
sconcat :: NonEmpty UnstrippedTokens -> UnstrippedTokens
$csconcat :: NonEmpty UnstrippedTokens -> UnstrippedTokens
<> :: UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
$c<> :: UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
Semigroup, Semigroup UnstrippedTokens
UnstrippedTokens
Semigroup UnstrippedTokens
-> UnstrippedTokens
-> (UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens)
-> ([UnstrippedTokens] -> UnstrippedTokens)
-> Monoid UnstrippedTokens
[UnstrippedTokens] -> UnstrippedTokens
UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [UnstrippedTokens] -> UnstrippedTokens
$cmconcat :: [UnstrippedTokens] -> UnstrippedTokens
mappend :: UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
$cmappend :: UnstrippedTokens -> UnstrippedTokens -> UnstrippedTokens
mempty :: UnstrippedTokens
$cmempty :: UnstrippedTokens
$cp1Monoid :: Semigroup UnstrippedTokens
Monoid)
#else
    deriving (Show, Monoid)
#endif

mapTokens :: ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens
mapTokens :: ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens
mapTokens [Token] -> [Token]
f (UnstrippedTokens [Token]
tokens) = [Token] -> UnstrippedTokens
UnstrippedTokens ([Token] -> [Token]
f [Token]
tokens)

unstrippedTokensOf :: UnstrippedTokens -> [Token]
unstrippedTokensOf :: UnstrippedTokens -> [Token]
unstrippedTokensOf (UnstrippedTokens [Token]
tokens) = [Token]
tokens

-- | Drop @n@ non-newline tokens.
dropTokens :: Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens :: Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
k = ([Token] -> [Token]) -> UnstrippedTokens -> UnstrippedTokens
mapTokens (Int -> [Token] -> [Token]
f Int
k)
    where
    f :: Int -> [Token] -> [Token]
    f :: Int -> [Token] -> [Token]
f Int
0 [Token]
xs                       = [Token]
xs
    f Int
_ []                       = []
    f Int
n (Pos SrcPos
_ (Newline Int
_) : [Token]
xs) = Int -> [Token] -> [Token]
f Int
n [Token]
xs
    f Int
n (Pos SrcPos
_ TokenVal
_           : [Token]
xs) = Int -> [Token] -> [Token]
f (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Token]
xs


data ProcessMode
    = ProcessVanilla
      -- ^ LitVanilla Haskell file - everything can produce tags
    | ProcessAlexHappy
      -- ^ Alex/Happy, only first and last braced blocks may produce tags
    deriving (ProcessMode -> ProcessMode -> Bool
(ProcessMode -> ProcessMode -> Bool)
-> (ProcessMode -> ProcessMode -> Bool) -> Eq ProcessMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProcessMode -> ProcessMode -> Bool
$c/= :: ProcessMode -> ProcessMode -> Bool
== :: ProcessMode -> ProcessMode -> Bool
$c== :: ProcessMode -> ProcessMode -> Bool
Eq, Eq ProcessMode
Eq ProcessMode
-> (ProcessMode -> ProcessMode -> Ordering)
-> (ProcessMode -> ProcessMode -> Bool)
-> (ProcessMode -> ProcessMode -> Bool)
-> (ProcessMode -> ProcessMode -> Bool)
-> (ProcessMode -> ProcessMode -> Bool)
-> (ProcessMode -> ProcessMode -> ProcessMode)
-> (ProcessMode -> ProcessMode -> ProcessMode)
-> Ord ProcessMode
ProcessMode -> ProcessMode -> Bool
ProcessMode -> ProcessMode -> Ordering
ProcessMode -> ProcessMode -> ProcessMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ProcessMode -> ProcessMode -> ProcessMode
$cmin :: ProcessMode -> ProcessMode -> ProcessMode
max :: ProcessMode -> ProcessMode -> ProcessMode
$cmax :: ProcessMode -> ProcessMode -> ProcessMode
>= :: ProcessMode -> ProcessMode -> Bool
$c>= :: ProcessMode -> ProcessMode -> Bool
> :: ProcessMode -> ProcessMode -> Bool
$c> :: ProcessMode -> ProcessMode -> Bool
<= :: ProcessMode -> ProcessMode -> Bool
$c<= :: ProcessMode -> ProcessMode -> Bool
< :: ProcessMode -> ProcessMode -> Bool
$c< :: ProcessMode -> ProcessMode -> Bool
compare :: ProcessMode -> ProcessMode -> Ordering
$ccompare :: ProcessMode -> ProcessMode -> Ordering
$cp1Ord :: Eq ProcessMode
Ord, Int -> ProcessMode -> ShowS
[ProcessMode] -> ShowS
ProcessMode -> String
(Int -> ProcessMode -> ShowS)
-> (ProcessMode -> String)
-> ([ProcessMode] -> ShowS)
-> Show ProcessMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProcessMode] -> ShowS
$cshowList :: [ProcessMode] -> ShowS
show :: ProcessMode -> String
$cshow :: ProcessMode -> String
showsPrec :: Int -> ProcessMode -> ShowS
$cshowsPrec :: Int -> ProcessMode -> ShowS
Show, Int -> ProcessMode
ProcessMode -> Int
ProcessMode -> [ProcessMode]
ProcessMode -> ProcessMode
ProcessMode -> ProcessMode -> [ProcessMode]
ProcessMode -> ProcessMode -> ProcessMode -> [ProcessMode]
(ProcessMode -> ProcessMode)
-> (ProcessMode -> ProcessMode)
-> (Int -> ProcessMode)
-> (ProcessMode -> Int)
-> (ProcessMode -> [ProcessMode])
-> (ProcessMode -> ProcessMode -> [ProcessMode])
-> (ProcessMode -> ProcessMode -> [ProcessMode])
-> (ProcessMode -> ProcessMode -> ProcessMode -> [ProcessMode])
-> Enum ProcessMode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ProcessMode -> ProcessMode -> ProcessMode -> [ProcessMode]
$cenumFromThenTo :: ProcessMode -> ProcessMode -> ProcessMode -> [ProcessMode]
enumFromTo :: ProcessMode -> ProcessMode -> [ProcessMode]
$cenumFromTo :: ProcessMode -> ProcessMode -> [ProcessMode]
enumFromThen :: ProcessMode -> ProcessMode -> [ProcessMode]
$cenumFromThen :: ProcessMode -> ProcessMode -> [ProcessMode]
enumFrom :: ProcessMode -> [ProcessMode]
$cenumFrom :: ProcessMode -> [ProcessMode]
fromEnum :: ProcessMode -> Int
$cfromEnum :: ProcessMode -> Int
toEnum :: Int -> ProcessMode
$ctoEnum :: Int -> ProcessMode
pred :: ProcessMode -> ProcessMode
$cpred :: ProcessMode -> ProcessMode
succ :: ProcessMode -> ProcessMode
$csucc :: ProcessMode -> ProcessMode
Enum, ProcessMode
ProcessMode -> ProcessMode -> Bounded ProcessMode
forall a. a -> a -> Bounded a
maxBound :: ProcessMode
$cmaxBound :: ProcessMode
minBound :: ProcessMode
$cminBound :: ProcessMode
Bounded)

-- * processFile

-- | Read tags from one file.
processFile :: FilePath -> Bool -> IO ([Pos TagVal], [String])
processFile :: String -> Bool -> IO ([Pos TagVal], [String])
processFile String
fn Bool
trackPrefixes = String -> Bool -> ByteString -> ([Pos TagVal], [String])
process String
fn Bool
trackPrefixes (ByteString -> ([Pos TagVal], [String]))
-> IO ByteString -> IO ([Pos TagVal], [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fn

-- * qualify

-- | Each tag is split into a one qualified with its module name and one
-- without.
--
-- TODO I could mark it static, to put in a file: mark, which would make vim
-- prioritize it for same-file tags, but I think it already does that, so maybe
-- this isn't necessary?
qualify :: Bool -> Maybe Text -> Pos TagVal -> Pos TagVal
qualify :: Bool -> Maybe Text -> Pos TagVal -> Pos TagVal
qualify Bool
fullyQualify Maybe Text
srcPrefix (Token.Pos SrcPos
pos (TagVal Text
name Type
typ Maybe Text
_)) =
    SrcPos -> TagVal -> Pos TagVal
forall a. SrcPos -> a -> Pos a
Token.Pos SrcPos
pos TagVal :: Text -> Type -> Maybe Text -> TagVal
TagVal
        { tvName :: Text
tvName   = Text
qualified
        , tvType :: Type
tvType   = Type
typ
        , tvParent :: Maybe Text
tvParent = Maybe Text
forall a. Maybe a
Nothing
        }
    where
    qualified :: Text
qualified = case Type
typ of
        Type
Module -> Text
module_
        Type
_ -> Text
module_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    module_ :: Text
module_
        | Bool
fullyQualify = Text -> Text -> Text -> Text
T.replace Text
"/" Text
"." (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
            (Text -> Text)
-> (Text -> Text -> Text) -> Maybe Text -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id Text -> Text -> Text
dropPrefix Maybe Text
srcPrefix (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
file
        | Bool
otherwise = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeFileName String
file
    file :: String
file = ShowS
FilePath.dropExtension ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SrcPos -> String
Token.posFile SrcPos
pos

dropPrefix :: Text -> Text -> Text
dropPrefix :: Text -> Text -> Text
dropPrefix Text
prefix Text
txt = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
txt Text -> Text
forall a. a -> a
id (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
prefix Text
txt

findSrcPrefix :: [Text] -> Pos a -> Maybe Text
findSrcPrefix :: [Text] -> Pos a -> Maybe Text
findSrcPrefix [Text]
prefixes (Token.Pos SrcPos
pos a
_) =
    (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Text -> Text -> Bool
`T.isPrefixOf` Text
file) [Text]
prefixes
    where file :: Text
file = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.dropExtension ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SrcPos -> String
Token.posFile SrcPos
pos

-- | Process one file's worth of tags.
process :: FilePath -> Bool -> ByteString -> ([Pos TagVal], [String])
process :: String -> Bool -> ByteString -> ([Pos TagVal], [String])
process String
fn Bool
trackPrefixes ByteString
input =
    case String -> Bool -> LitMode Void -> ByteString -> Either Text [Token]
tokenizeInput String
fn Bool
trackPrefixes LitMode Void
litMode ByteString
input of
        Left Text
msg   -> ([], [Text -> String
T.unpack Text
msg])
        Right [Token]
toks -> ProcessMode -> [Token] -> ([Pos TagVal], [String])
processTokens ProcessMode
procMode [Token]
toks
    where
    (ProcessMode
procMode, LitMode Void
litMode) = (ProcessMode, LitMode Void)
-> Maybe (ProcessMode, LitMode Void) -> (ProcessMode, LitMode Void)
forall a. a -> Maybe a -> a
fromMaybe (ProcessMode, LitMode Void)
defaultModes (Maybe (ProcessMode, LitMode Void) -> (ProcessMode, LitMode Void))
-> Maybe (ProcessMode, LitMode Void) -> (ProcessMode, LitMode Void)
forall a b. (a -> b) -> a -> b
$ String -> Maybe (ProcessMode, LitMode Void)
determineModes String
fn

tokenizeInput :: FilePath -> Bool -> LitMode Void -> BS.ByteString
    -> Either Text [Token]
tokenizeInput :: String -> Bool -> LitMode Void -> ByteString -> Either Text [Token]
tokenizeInput String
fn Bool
trackPrefixes LitMode Void
mode =
    String -> LitMode Void -> Bool -> ByteString -> Either Text [Token]
Lexer.tokenize String
fn LitMode Void
mode Bool
trackPrefixes

processTokens :: ProcessMode -> [Token] -> ([Pos TagVal], [String])
processTokens :: ProcessMode -> [Token] -> ([Pos TagVal], [String])
processTokens ProcessMode
mode =
    [Tag] -> ([Pos TagVal], [String])
splitAndRemoveRepeats
    ([Tag] -> ([Pos TagVal], [String]))
-> ([Token] -> [Tag]) -> [Token] -> ([Pos TagVal], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
blockTags
    ([UnstrippedTokens] -> [Tag])
-> ([Token] -> [UnstrippedTokens]) -> [Token] -> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ProcessMode -> UnstrippedTokens -> [UnstrippedTokens]
breakBlocks ProcessMode
mode
    (UnstrippedTokens -> [UnstrippedTokens])
-> ([Token] -> UnstrippedTokens) -> [Token] -> [UnstrippedTokens]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [Token] -> UnstrippedTokens
UnstrippedTokens
    where
    splitAndRemoveRepeats :: [Tag] -> ([Pos TagVal], [String])
    splitAndRemoveRepeats :: [Tag] -> ([Pos TagVal], [String])
splitAndRemoveRepeats [Tag]
tags =
        ( [Pos TagVal]
earliestRepeats [Pos TagVal] -> [Pos TagVal] -> [Pos TagVal]
forall a. [a] -> [a] -> [a]
++ [Pos TagVal]
newTags
        , (Pos String -> String) -> [Pos String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Pos String -> String
forall a. Pos a -> a
valOf [Pos String]
warnings
        )
        where
        ([Pos TagVal]
newTags, [Pos TagVal]
repeatableTags, [Pos String]
warnings) = [Tag] -> ([Pos TagVal], [Pos TagVal], [Pos String])
partitionTags [Tag]
tags
        -- For RepeatableTag s with duplicate keys, pick the one with the lowest
        -- posLine.
        earliestRepeats :: [Pos TagVal]
        earliestRepeats :: [Pos TagVal]
earliestRepeats = Map TagVal (Pos TagVal) -> [Pos TagVal]
forall k a. Map k a -> [a]
Map.elems (Map TagVal (Pos TagVal) -> [Pos TagVal])
-> Map TagVal (Pos TagVal) -> [Pos TagVal]
forall a b. (a -> b) -> a -> b
$ (Pos TagVal -> Pos TagVal -> Pos TagVal)
-> [(TagVal, Pos TagVal)] -> Map TagVal (Pos TagVal)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Pos TagVal -> Pos TagVal -> Pos TagVal
minLine ([(TagVal, Pos TagVal)] -> Map TagVal (Pos TagVal))
-> [(TagVal, Pos TagVal)] -> Map TagVal (Pos TagVal)
forall a b. (a -> b) -> a -> b
$
            (Pos TagVal -> TagVal) -> [Pos TagVal] -> [(TagVal, Pos TagVal)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Util.keyOn Pos TagVal -> TagVal
forall a. Pos a -> a
valOf [Pos TagVal]
repeatableTags
        minLine :: Pos TagVal -> Pos TagVal -> Pos TagVal
minLine Pos TagVal
x Pos TagVal
y
            | Pos TagVal -> Line
tagLine Pos TagVal
x Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
< Pos TagVal -> Line
tagLine Pos TagVal
y = Pos TagVal
x
            | Bool
otherwise             = Pos TagVal
y

startIdentChar :: Char -> Bool
startIdentChar :: Char -> Bool
startIdentChar Char
'_' = Bool
True
startIdentChar Char
c   = Char -> Bool
Char.isAlpha Char
c

identChar :: Bool -> Char -> Bool
identChar :: Bool -> Char -> Bool
identChar Bool
considerDot Char
c = case Char
c of
    Char
'\'' -> Bool
True
    Char
'_'  -> Bool
True
    Char
'#'  -> Bool
True
    Char
'.'  -> Bool
considerDot
    Char
c'   -> Char -> Bool
Char.isAlphaNum Char
c'

isHaskellOp :: Text -> Bool
isHaskellOp :: Text -> Bool
isHaskellOp Text
str = case Text -> Maybe Char
Util.headt Text
str of
    Maybe Char
Nothing  -> Bool
False
    Just Char
':' -> Bool
False
    Just Char
_   -> (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
haskellOpChar Text
str

isHaskellConstructorOp :: Text -> Bool
isHaskellConstructorOp :: Text -> Bool
isHaskellConstructorOp Text
str = case Text -> Maybe (Char, Text)
T.uncons Text
str of
    Maybe (Char, Text)
Nothing        -> Bool
False
    Just (Char
':', Text
xs) -> (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
haskellOpChar Text
xs
    Just (Char, Text)
_         -> Bool
False

haskellOpChar :: Char -> Bool
haskellOpChar :: Char -> Bool
haskellOpChar Char
c = case Char
c of
    Char
'_'   -> Bool
False
    Char
'-'   -> Bool
True
    Char
'!'   -> Bool
True
    Char
'#'   -> Bool
True
    Char
'$'   -> Bool
True
    Char
'%'   -> Bool
True
    Char
'&'   -> Bool
True
    Char
'*'   -> Bool
True
    Char
'+'   -> Bool
True
    Char
'.'   -> Bool
True
    Char
'/'   -> Bool
True
    Char
'<'   -> Bool
True
    Char
'='   -> Bool
True
    Char
'>'   -> Bool
True
    Char
'?'   -> Bool
True
    Char
'@'   -> Bool
True
    Char
'^'   -> Bool
True
    Char
'|'   -> Bool
True
    Char
'~'   -> Bool
True
    Char
':'   -> Bool
True
    Char
'\\'  -> Bool
True
    Char
other -> GeneralCategory -> Bool
Util.isSymbolCharacterCategory (Char -> GeneralCategory
Char.generalCategory Char
other)

isTypeVarStart :: Text -> Bool
isTypeVarStart :: Text -> Bool
isTypeVarStart Text
x = case Text -> Maybe Char
Util.headt Text
x of
    Just Char
c -> Char -> Bool
Char.isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    Maybe Char
_ -> Bool
False

-- | Break the input up into blocks based on indentation.
breakBlocks :: ProcessMode -> UnstrippedTokens -> [UnstrippedTokens]
breakBlocks :: ProcessMode -> UnstrippedTokens -> [UnstrippedTokens]
breakBlocks ProcessMode
mode
    = ([Token] -> UnstrippedTokens) -> [[Token]] -> [UnstrippedTokens]
forall a b. (a -> b) -> [a] -> [b]
map [Token] -> UnstrippedTokens
UnstrippedTokens
    ([[Token]] -> [UnstrippedTokens])
-> (UnstrippedTokens -> [[Token]])
-> UnstrippedTokens
-> [UnstrippedTokens]
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
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
    ([[Token]] -> [[Token]])
-> (UnstrippedTokens -> [[Token]]) -> UnstrippedTokens -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [[Token]]
go
    ([Token] -> [[Token]])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripSemicolonsNotInBraces
    ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case ProcessMode
mode of
        ProcessMode
ProcessVanilla -> [Token] -> [Token]
forall a. a -> a
id
        ProcessMode
ProcessAlexHappy -> ([Token] -> [Token] -> [Token]) -> ([Token], [Token]) -> [Token]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
(++) (([Token], [Token]) -> [Token])
-> ([Token] -> ([Token], [Token])) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> ([Token], [Token])
firstLastBracedBlock)
    ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripToplevelHscDirectives
    ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
filterBlank
    ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnstrippedTokens -> [Token]
unstrippedTokensOf
    where
    go :: [Token] -> [[Token]]
    go :: [Token] -> [[Token]]
go []     = []
    go [Token]
tokens = [Token]
pre [Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
: [Token] -> [[Token]]
go [Token]
post
        where ([Token]
pre, [Token]
post) = [Token] -> ([Token], [Token])
breakBlock [Token]
tokens
    -- Blank lines mess up the indentation.
    filterBlank :: [Token] -> [Token]
    filterBlank :: [Token] -> [Token]
filterBlank [] = []
    filterBlank (Pos SrcPos
_ (Newline Int
_) : xs :: [Token]
xs@(Pos SrcPos
_ (Newline Int
_) : [Token]
_)) =
        [Token] -> [Token]
filterBlank [Token]
xs
    filterBlank (Token
x:[Token]
xs) = Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
filterBlank [Token]
xs

-- | Collect tokens between toplevel braces. Motivated by Alex/Happy
-- file format that uses braced blocks to separate Haskell source from
-- other directives.
firstLastBracedBlock :: [Token] -> ([Token], [Token])
firstLastBracedBlock :: [Token] -> ([Token], [Token])
firstLastBracedBlock [Token]
tokens =
    ([Token]
first, [Token]
last)
    where
    ([Token]
first, [Token]
rest) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward Int
0 [] [Token]
tokens
    last :: [Token]
last          = Int -> [Token] -> [Token] -> [Token]
backward Int
0 [] ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
rest
    forward :: Int -> [Token] -> [Token] -> ([Token], [Token])
    forward :: Int -> [Token] -> [Token] -> ([Token], [Token])
forward  Int
_ [Token]
acc []                       = ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc, [])
    forward  Int
0 [Token]
acc (Pos SrcPos
_ TokenVal
LBrace      : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward Int
1 [Token]
acc [Token]
ts
    forward  Int
0 [Token]
acc (Token
_                 : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward Int
0 [Token]
acc [Token]
ts
    forward  Int
1 [Token]
acc (Pos SrcPos
_ TokenVal
RBrace      : [Token]
ts) = ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc, [Token]
ts)
    forward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
LBrace)  : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    forward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
HSCEnum) : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    forward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
RBrace)  : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    forward !Int
n [Token]
acc (Token
t                 : [Token]
ts) = Int -> [Token] -> [Token] -> ([Token], [Token])
forward Int
n (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts

    backward :: Int -> [Token] -> [Token] -> [Token]
    backward :: Int -> [Token] -> [Token] -> [Token]
backward  Int
_ [Token]
acc []                       = [Token]
acc
    backward  Int
0 [Token]
acc (Pos SrcPos
_ TokenVal
RBrace      : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward Int
1 [Token]
acc [Token]
ts
    backward  Int
0 [Token]
acc (Token
_                 : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward Int
0 [Token]
acc [Token]
ts
    backward  Int
1 [Token]
acc (Pos SrcPos
_ TokenVal
LBrace      : [Token]
_)  = [Token]
acc
    backward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
LBrace)  : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    backward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
HSCEnum) : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    backward !Int
n [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
RBrace)  : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts
    backward !Int
n [Token]
acc (Token
t                 : [Token]
ts) = Int -> [Token] -> [Token] -> [Token]
backward Int
n (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts

-- | Take until a newline, then take lines until the indent established after
-- that newline decreases. Or, alternatively, if "{" is encountered then count
-- it as a block until closing "}" is found taking nesting into account.
breakBlock :: [Token] -> ([Token], [Token])
breakBlock :: [Token] -> ([Token], [Token])
breakBlock = [Token] -> [Token] -> ([Token], [Token])
go []
    where
    go :: [Token] -> [Token] -> ([Token], [Token])
    go :: [Token] -> [Token] -> ([Token], [Token])
go [Token]
acc [] = ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc, [])
    go [Token]
acc (Pos SrcPos
_ Newline{} : t :: Token
t@(Pos SrcPos
_ TokenVal
KWModule) : [Token]
ts) =
        ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
importList, Int -> [Token] -> [Token]
forall a. Int -> [a] -> [a]
drop Int
1 [Token]
rest)
        where
        ([Token]
importList, [Token]
rest) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenVal
KWWhere) (TokenVal -> Bool) -> (Token -> TokenVal) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenVal
forall a. Pos a -> a
valOf) [Token]
ts
    go [Token]
acc (t :: Token
t@(Pos SrcPos
_ TokenVal
tok) : [Token]
ts) = case TokenVal
tok of
        Newline Int
indent -> [Token] -> Int -> [Token] -> ([Token], [Token])
collectIndented [Token]
acc Int
indent [Token]
ts
        TokenVal
LBrace         -> [Token]
-> ([Token] -> [Token] -> ([Token], [Token]))
-> [Token]
-> Int
-> ([Token], [Token])
forall b.
Show b =>
[Token]
-> ([Token] -> [Token] -> ([Token], [b]))
-> [Token]
-> Int
-> ([Token], [b])
collectBracedBlock (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token] -> [Token] -> ([Token], [Token])
go [Token]
ts Int
1
        TokenVal
HSCEnum        -> [Token]
-> ([Token] -> [Token] -> ([Token], [Token]))
-> [Token]
-> Int
-> ([Token], [Token])
forall b.
Show b =>
[Token]
-> ([Token] -> [Token] -> ([Token], [b]))
-> [Token]
-> Int
-> ([Token], [b])
collectBracedBlock (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token] -> [Token] -> ([Token], [Token])
go [Token]
ts Int
1
        TokenVal
_              -> [Token] -> [Token] -> ([Token], [Token])
go (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) [Token]
ts

    collectIndented :: [Token] -> Int -> [Token] -> ([Token], [Token])
    collectIndented :: [Token] -> Int -> [Token] -> ([Token], [Token])
collectIndented [Token]
acc Int
indent = [Token] -> [Token] -> ([Token], [Token])
goIndented [Token]
acc
        where
        goIndented :: [Token] -> [Token] -> ([Token], [Token])
goIndented [Token]
acc' [Token]
ts' = case [Token]
ts' of
            Pos SrcPos
_ Newline{} : Pos SrcPos
_ TokenVal
KWModule : [Token]
_ ->
                ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc', [Token]
ts')

            []     -> ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc', [])
            Token
t : [Token]
ts -> case Token
t of
                Pos SrcPos
_ (Newline Int
n) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
indent ->
                    ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc', [Token]
ts')
                Pos SrcPos
_ TokenVal
LBrace ->
                    [Token]
-> ([Token] -> [Token] -> ([Token], [Token]))
-> [Token]
-> Int
-> ([Token], [Token])
forall b.
Show b =>
[Token]
-> ([Token] -> [Token] -> ([Token], [b]))
-> [Token]
-> Int
-> ([Token], [b])
collectBracedBlock (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc') [Token] -> [Token] -> ([Token], [Token])
goIndented [Token]
ts Int
1
                Token
_ ->
                    [Token] -> [Token] -> ([Token], [Token])
goIndented (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc') [Token]
ts

    collectBracedBlock
        :: Show b
        => [Token]
        -> ([Token] -> [Token] -> ([Token], [b]))
        -> [Token]
        -> Int
        -> ([Token], [b])
    collectBracedBlock :: [Token]
-> ([Token] -> [Token] -> ([Token], [b]))
-> [Token]
-> Int
-> ([Token], [b])
collectBracedBlock [Token]
acc [Token] -> [Token] -> ([Token], [b])
cont = [Token] -> [Token] -> Int -> ([Token], [b])
forall a.
(Eq a, Num a) =>
[Token] -> [Token] -> a -> ([Token], [b])
goBraced [Token]
acc
        where
        goBraced :: [Token] -> [Token] -> a -> ([Token], [b])
goBraced [Token]
acc' []       a
_ = ([Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc', [])
        goBraced [Token]
acc' [Token]
ts       a
0 = [Token] -> [Token] -> ([Token], [b])
cont [Token]
acc' [Token]
ts
        goBraced [Token]
acc' (Token
t : [Token]
ts) a
n = [Token] -> [Token] -> a -> ([Token], [b])
goBraced (Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc') [Token]
ts (a -> ([Token], [b])) -> a -> ([Token], [b])
forall a b. (a -> b) -> a -> b
$! case Token
t of
            Pos SrcPos
_ TokenVal
LBrace -> a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
            Pos SrcPos
_ TokenVal
RBrace -> a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1
            Token
_            -> a
n

stripToplevelHscDirectives :: [Token] -> [Token]
stripToplevelHscDirectives :: [Token] -> [Token]
stripToplevelHscDirectives = [Token] -> [Token]
scan
    where
    scan :: [Token] -> [Token]
    scan :: [Token] -> [Token]
scan = \case
        []                            -> []
        Pos SrcPos
_ TokenVal
HSCDirectiveBraced : [Token]
ts -> Int -> [Token] -> [Token]
skip Int
1 [Token]
ts
        Token
t : [Token]
ts                        -> Token
t Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
scan [Token]
ts

    skip :: Int -> [Token] -> [Token]
    skip :: Int -> [Token] -> [Token]
skip Int
_  []                              = []
    skip Int
0  [Token]
ts                              = [Token] -> [Token]
scan [Token]
ts
    skip !Int
n (Pos SrcPos
_ TokenVal
HSCDirectiveBraced : [Token]
ts) = Int -> [Token] -> [Token]
skip (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Token]
ts
    skip !Int
n (Pos SrcPos
_ TokenVal
LBrace       : [Token]
ts)       = Int -> [Token] -> [Token]
skip (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Token]
ts
    skip !Int
n (Pos SrcPos
_ TokenVal
RBrace       : [Token]
ts)       = Int -> [Token] -> [Token]
skip (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Token]
ts
    skip !Int
n (Token
_                  : [Token]
ts)       = Int -> [Token] -> [Token]
skip Int
n [Token]
ts

stripSemicolonsNotInBraces :: [Token] -> [Token]
stripSemicolonsNotInBraces :: [Token] -> [Token]
stripSemicolonsNotInBraces =
    Bool -> Int -> Int -> [Token] -> [Token]
go Bool
False Int
0 Int
0
    where
    go  :: Bool -- Whether inside let or where block or case expression
        -> Int -- Indent of last newline
        -> Int -- Parenthesis nesting depth
        -> [Token]
        -> [Token]
    go :: Bool -> Int -> Int -> [Token] -> [Token]
go !Bool
_     !Int
_ !Int
_ []                                                       = []
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWWhere)     : tok' :: Token
tok'@(Pos SrcPos
_ TokenVal
LBrace) : [Token]
ts)     = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
tok' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
_     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWWhere)     : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
True Int
k Int
n [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWLet)       : tok' :: Token
tok'@(Pos SrcPos
_ TokenVal
LBrace) : [Token]
ts)     = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
tok' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
_     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWLet)       : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
True Int
k Int
n [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWDo)        : tok' :: Token
tok'@(Pos SrcPos
_ TokenVal
LBrace) : [Token]
ts)     = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
tok' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
_     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWDo)        : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
True Int
k Int
n [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWOf)        : tok' :: Token
tok'@(Pos SrcPos
_ TokenVal
LBrace) : [Token]
ts)     = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
tok' Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
_     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWOf)        : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
True Int
k Int
n [Token]
ts
    go !Bool
_     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
KWIn)        : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
False Int
k Int
n [Token]
ts
    go !Bool
_     !Int
_ !Int
n (tok :: Token
tok@(Pos SrcPos
_ (Newline Int
k)) : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
False Int
k Int
n [Token]
ts
    go !Bool
_     !Int
_  Int
0 (     Pos SrcPos
_ TokenVal
Semicolon    : tok :: Token
tok@(Pos SrcPos
_ (Newline Int
k)) : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
False Int
k Int
0 [Token]
ts
    go  Bool
False !Int
k  Int
0 (     Pos SrcPos
p TokenVal
Semicolon    : [Token]
ts)                           = SrcPos -> TokenVal -> Token
forall a. SrcPos -> a -> Pos a
Pos SrcPos
p (Int -> TokenVal
Newline Int
k) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
False Int
k Int
0 [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LParen)      : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
SpliceStart) : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBracket)    : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBrace)      : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBanana)     : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k (Int -> Int
inc Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RParen)      : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k (Int -> Int
dec Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBracket)    : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k (Int -> Int
dec Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBrace)      : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k (Int -> Int
dec Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBanana)     : [Token]
ts)                           = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k (Int -> Int
dec Int
n) [Token]
ts
    go !Bool
b     !Int
k !Int
n (Token
tok : [Token]
ts)                                               = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k Int
n       [Token]
ts

    skipBalancedParens
        :: Bool -- Whether inside where block or after equals sign
        -> Int -- Indent of last newline
        -> Int -- Parenthesis nesting depth
        -> [Token]
        -> [Token]
    skipBalancedParens :: Bool -> Int -> Int -> [Token] -> [Token]
skipBalancedParens Bool
b Int
k = Int -> [Token] -> [Token]
skip
        where
        skip :: Int -> [Token] -> [Token]
        skip :: Int -> [Token] -> [Token]
skip Int
_  []                          = []
        skip Int
0  [Token]
ts                          = Bool -> Int -> Int -> [Token] -> [Token]
go Bool
b Int
k Int
0 [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LParen)      : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
inc Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
SpliceStart) : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
inc Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBracket)    : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
inc Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBrace)      : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
inc Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBanana)     : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
inc Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RParen)      : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
dec Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBracket)    : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
dec Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBrace)      : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
dec Int
n) [Token]
ts
        skip !Int
n (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBanana)     : [Token]
ts) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip (Int -> Int
dec Int
n) [Token]
ts
        skip !Int
n (Token
tok : [Token]
ts)                     = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token] -> [Token]
skip Int
n [Token]
ts

    inc :: Int -> Int
    inc :: Int -> Int
inc Int
n = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    dec :: Int -> Int
    dec :: Int -> Int
dec Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

explodeToplevelBracedBlocks :: [Token] -> [[Token]]
explodeToplevelBracedBlocks :: [Token] -> [[Token]]
explodeToplevelBracedBlocks [Token]
toks =
    case [Token]
toks of
      Pos SrcPos
_ TokenVal
LBrace : [Token]
toks' -> ([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
$ [Token] -> Int -> [Token] -> [[Token]]
go [] Int
1 [Token]
toks'
      [Token]
_                    -> [[Token]
toks]
    where
    go :: [Token] -> Int -> [Token] -> [[Token]]
    go :: [Token] -> Int -> [Token] -> [[Token]]
go [Token]
acc  Int
_   []                          = [[Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc]
    go [Token]
acc  Int
0   [Token]
ts                          = [[Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc, [Token]
ts]
    go [Token]
acc !Int
n   (tok :: Token
tok@(Pos SrcPos
_ TokenVal
LBrace)   : [Token]
ts) = [Token] -> Int -> [Token] -> [[Token]]
go (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Token]
ts
    go [Token]
acc  Int
1   (     Pos SrcPos
_ TokenVal
RBrace    : [Token]
ts) = [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc [Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
: [Token] -> Int -> [Token] -> [[Token]]
go [] Int
0 [Token]
ts
    go [Token]
acc !Int
n   (tok :: Token
tok@(Pos SrcPos
_ TokenVal
RBrace)   : [Token]
ts) = [Token] -> Int -> [Token] -> [[Token]]
go (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Token]
ts
    go [Token]
acc  n :: Int
n@Int
1 (     Pos SrcPos
_ TokenVal
Semicolon : [Token]
ts) = [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
acc [Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
: [Token] -> Int -> [Token] -> [[Token]]
go [] Int
n [Token]
ts
    go [Token]
acc !Int
n   (Token
tok                  : [Token]
ts) = [Token] -> Int -> [Token] -> [[Token]]
go (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
acc) Int
n [Token]
ts

-- * extract tags

patternRecordFieldNames :: [Token] -> ([Tag], [Token])
patternRecordFieldNames :: [Token] -> ([Tag], [Token])
patternRecordFieldNames = [Tag] -> [Token] -> ([Tag], [Token])
go []
  where
    go :: [Tag] -> [Token] -> ([Tag], [Token])
go [Tag]
acc [Token]
ts =
        case [Token]
ts of
            Pos SrcPos
pos (T Text
name) : [Token]
rest -> [Tag] -> [Token] -> ([Tag], [Token])
go (SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Pattern Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Tag]
acc) [Token]
rest
            Pos SrcPos
_ TokenVal
Comma      : [Token]
rest -> [Tag] -> [Token] -> ([Tag], [Token])
go [Tag]
acc [Token]
rest
            [Token]
_                       -> ([Tag]
acc, [Token]
ts)

-- | Get all the tags in one indented block.
-- TODO clean this up to require less nesting, and dropDataContext duplication
blockTags :: UnstrippedTokens -> [Tag]
blockTags :: UnstrippedTokens -> [Tag]
blockTags UnstrippedTokens
unstripped = case UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
unstripped of
    [] -> []
    Pos SrcPos
_ TokenVal
SpliceStart : [Token]
_ -> []
    Pos SrcPos
_ TokenVal
ToplevelSplice : [Token]
_ -> []
    Pos SrcPos
pos (CppDefine Text
name) : [Token]
_ ->
        [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
name Type
Define]
    Pos SrcPos
_ TokenVal
HSCEnum : [Token]
rest ->
        [Token] -> [Tag]
hsc2hsEnum [Token]
rest
    Pos SrcPos
_ TokenVal
KWModule : Pos SrcPos
pos (T Text
name) : [Token]
_ ->
        [SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos ((Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
name)) Type
Module]
    stripped :: [Token]
stripped@(Pos SrcPos
_       (T Text
"pattern") : Pos SrcPos
_ TokenVal
DoubleColon : [Token]
_) ->
        [Token] -> [Tag]
toplevelFunctionTags [Token]
stripped
    (Pos SrcPos
_ (T Text
"pattern") : Pos SrcPos
pos (T Text
name) : Pos SrcPos
_ TokenVal
LBrace : [Token]
rest)
        | ([Tag]
fieldNames, Pos SrcPos
_ TokenVal
RBrace : Pos SrcPos
_ TokenVal
Equals : [Token]
_) <- [Token] -> ([Tag], [Token])
patternRecordFieldNames [Token]
rest ->
        SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Pattern Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Tag]
fieldNames
    stripped :: [Token]
stripped@(Pos SrcPos
prevPos (T Text
"pattern") : [Token]
toks) ->
        case Maybe Tag
tag of
            Maybe Tag
Nothing -> [Token] -> [Tag]
toplevelFunctionTags [Token]
stripped
            Just Tag
x  -> [Tag
x]
        where
        (Maybe Tag
tag, SrcPos
_, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeName Type
Pattern SrcPos
prevPos
            String
"pattern * =" [Token]
toks
    Pos SrcPos
_ TokenVal
KWForeign : [Token]
decl -> [Token] -> [Tag]
foreignTags [Token]
decl
    -- newtype instance * = ...
    Pos SrcPos
prevPos TokenVal
KWNewtype : Pos SrcPos
_ TokenVal
KWInstance : [Token]
toks ->
        (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
familyNameTag) ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ SrcPos -> UnstrippedTokens -> [Tag]
newtypeTags SrcPos
pos (UnstrippedTokens -> [Tag]) -> UnstrippedTokens -> [Tag]
forall a b. (a -> b) -> a -> b
$
            Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
2 UnstrippedTokens
unstripped
        where
        (Maybe Tag
familyNameTag, SrcPos
pos) =
            SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName SrcPos
prevPos String
"newtype instance * =" [Token]
toks
    -- newtype X * = X *
    Pos SrcPos
prevPos TokenVal
KWNewtype : [Token]
toks ->
        Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
tag
            [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
tag) (SrcPos -> UnstrippedTokens -> [Tag]
newtypeTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1 UnstrippedTokens
unstripped))
        where
        (Maybe Tag
tag, SrcPos
pos, [Token]
_) =
            (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeName Type
Type SrcPos
prevPos String
"newtype * =" [Token]
toks
    -- type family X ...
    Pos SrcPos
prevPos TokenVal
KWType : Pos SrcPos
_ TokenVal
KWFamily : [Token]
toks -> Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
tag
        where
        (Maybe Tag
tag, SrcPos
_,  [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeFamilyName Type
Family SrcPos
prevPos
            String
"type family * =" [Token]
toks
    -- type instance X * = ...
    -- No tags in type family instances
    Pos SrcPos
_ TokenVal
KWType : Pos SrcPos
_ TokenVal
KWInstance : [Token]
_ -> []
    -- type X * = ...
    Pos SrcPos
prevPos TokenVal
KWType : [Token]
toks
        -- If there’s no equals sign then this is definitely not a type synonym declaration.
        | [Token] -> Bool
containsEquals [Token]
toks
        -> Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
tag
        | Bool
otherwise
        -> []
        where
        (Maybe Tag
tag, SrcPos
_, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeName Type
Type SrcPos
prevPos
            String
"type * =" [Token]
toks
    -- data family X ...
    Pos SrcPos
prevPos TokenVal
KWData : Pos SrcPos
_ TokenVal
KWFamily : [Token]
toks ->
        (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
tag) ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
tag
        where
        (Maybe Tag
tag, SrcPos
_, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeFamilyName Type
Family SrcPos
prevPos
            String
"data family * =" [Token]
toks
    -- data instance * = ...
    -- data instance * where ...
    Pos SrcPos
prevPos TokenVal
KWData : Pos SrcPos
_ TokenVal
KWInstance : [Token]
toks ->
        (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
familyNameTag) ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$
            SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
2 UnstrippedTokens
unstripped)
        where
        (Maybe Tag
familyNameTag, SrcPos
pos) =
            SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName SrcPos
prevPos String
"data instance * =" [Token]
toks
    -- data X * = X { X :: *, X :: * }
    -- data X * where ...
    Pos SrcPos
prevPos TokenVal
KWData : [Token]
toks ->
        Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
tag
            [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
tag)
                (SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1 UnstrippedTokens
unstripped))
        where
        (Maybe Tag
tag, SrcPos
pos, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeName Type
Type SrcPos
prevPos
            String
"data * =" [Token]
toks
    -- class * => X where X :: * ...
    Pos SrcPos
pos TokenVal
KWClass : [Token]
_ -> SrcPos -> UnstrippedTokens -> [Tag]
classTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1 UnstrippedTokens
unstripped)

    Pos SrcPos
_ TokenVal
KWInfix : [Token]
_ -> []
    Pos SrcPos
_ TokenVal
KWInfixl : [Token]
_ -> []
    Pos SrcPos
_ TokenVal
KWInfixr : [Token]
_ -> []
    -- Deriving introduces no new names, just ignore it
    Pos SrcPos
_ TokenVal
KWDeriving : [Token]
_ -> []
    -- instance * where data * = X :: * ...
    Pos SrcPos
pos TokenVal
KWInstance : [Token]
_ -> SrcPos -> UnstrippedTokens -> [Tag]
instanceTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1 UnstrippedTokens
unstripped)
    -- x, y, z :: *
    [Token]
stripped -> [Token] -> [Tag]
toplevelFunctionTags [Token]
stripped

isTypeFamilyName :: Text -> Bool
isTypeFamilyName :: Text -> Bool
isTypeFamilyName =
    Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Char
c -> Char -> Bool
Char.isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (Maybe Char -> Bool) -> (Text -> Maybe Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Char
Util.headt

isTypeName  :: Text -> Bool
isTypeName :: Text -> Bool
isTypeName Text
x = case Text -> Maybe Char
Util.headt Text
x of
    Just Char
c -> Char -> Bool
Char.isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
    Maybe Char
_ -> Bool
False

dropDataContext :: [Token] -> [Token]
dropDataContext :: [Token] -> [Token]
dropDataContext = [Token] -> [Token]
stripParensKindsTypeVars ([Token] -> [Token]) -> ([Token] -> [Token]) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripOptContext

recordVanillaOrInfixName
    :: (Text -> Bool)               -- ^ Predicate for names to select
    -> Type                         -- ^ Tope of detecte tag
    -> SrcPos                       -- ^ Previous position to report in errors
    -> String                       -- ^ Context to report in errors
    -> [Token]                      -- ^ Tokens to analyze
    -> (Maybe Tag, SrcPos, [Token]) -- ^ Possibly detected tag and rest of the tokens
recordVanillaOrInfixName :: (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isVanillaName Type
tokenType SrcPos
prevPos String
context [Token]
tokens =
    case [Token] -> [Token]
dropDataContext [Token]
tokens of
        [Token]
toks | Type
Type <- Type
tokenType
             , Just (SrcPos
pos, Text
name, [Token]
rest) <- [Token] -> Maybe (SrcPos, Text, [Token])
extractSpecialTypeName [Token]
toks ->
            (Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
tokenType, SrcPos
pos, [Token]
rest)
        Pos SrcPos
_ TokenVal
RParen   : [Token]
_                -> (Maybe Tag
forall a. Maybe a
Nothing, SrcPos
prevPos, [Token]
tokens)
        Pos SrcPos
_ TokenVal
LBracket : [Token]
_                -> (Maybe Tag
forall a. Maybe a
Nothing, SrcPos
prevPos, [Token]
tokens)
        Pos SrcPos
_ TokenVal
Equals   : [Token]
_                -> (Maybe Tag
forall a. Maybe a
Nothing, SrcPos
prevPos, [Token]
tokens)
        Pos SrcPos
_ TokenVal
Comma    : [Token]
_                -> (Maybe Tag
forall a. Maybe a
Nothing, SrcPos
prevPos, [Token]
tokens)
        Token
tok : [Token]
toks ->
            case Token
tok of
                Pos SrcPos
pos (TokenVal -> Maybe Text
tokToName -> Just Text
name) | Text -> Bool
isVanillaName Text
name ->
                    (Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
tokenType, SrcPos
pos, [Token]
toks)
                Token
_ -> case [Token] -> [Token]
dropInfixTypeStart ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
toks of
                    Pos SrcPos
pos (TokenVal -> Maybe Text
tokToName -> Just Text
name) : [Token]
rest ->
                        (Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
tokenType, SrcPos
pos, [Token]
rest)
                    [Token]
rest -> (Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> [Token] -> Tag
unexp SrcPos
pos [Token]
rest, SrcPos
pos, Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
toks)
                        where pos :: SrcPos
pos = Token -> SrcPos
forall a. Pos a -> SrcPos
posOf Token
tok
        [] -> (Tag -> Maybe Tag
forall a. a -> Maybe a
Just (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> [Token] -> Tag
unexp SrcPos
prevPos [], SrcPos
prevPos, [])
    where
    unexp :: SrcPos -> [Token] -> Tag
unexp SrcPos
pos [Token]
rest = SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected SrcPos
pos ([Token] -> UnstrippedTokens
UnstrippedTokens [Token]
tokens) [Token]
rest String
context

extractSpecialTypeName :: [Token] -> Maybe (SrcPos, Text, [Token])
extractSpecialTypeName :: [Token] -> Maybe (SrcPos, Text, [Token])
extractSpecialTypeName (Pos SrcPos
pos TokenVal
LBracket : Pos SrcPos
_ TokenVal
RBracket : [Token]
rest) = (SrcPos, Text, [Token]) -> Maybe (SrcPos, Text, [Token])
forall a. a -> Maybe a
Just (SrcPos
pos, Text
"[]", [Token]
rest)
extractSpecialTypeName (Pos SrcPos
pos TokenVal
LParen   : ([Token] -> (Int, [Token])
tupleCommas -> (Int
commas, Pos SrcPos
_ TokenVal
RParen : [Token]
rest))) =
    (SrcPos, Text, [Token]) -> Maybe (SrcPos, Text, [Token])
forall a. a -> Maybe a
Just (SrcPos
pos, Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
commas Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")", [Token]
rest)
extractSpecialTypeName ([Token] -> (Int, [Token])
tupleCommas -> (Int
commas, Pos SrcPos
pos TokenVal
RParen : [Token]
rest)) =
    (SrcPos, Text, [Token]) -> Maybe (SrcPos, Text, [Token])
forall a. a -> Maybe a
Just (SrcPos
pos, Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
commas Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")", [Token]
rest)
extractSpecialTypeName [Token]
_ = Maybe (SrcPos, Text, [Token])
forall a. Maybe a
Nothing

tupleCommas :: [Token] -> (Int, [Token])
tupleCommas :: [Token] -> (Int, [Token])
tupleCommas = Int -> Bool -> [Token] -> (Int, [Token])
go Int
0 Bool
True
    where
    go :: Int -> Bool -> [Token] -> (Int, [Token])
    go :: Int -> Bool -> [Token] -> (Int, [Token])
go !Int
n Bool
False (Pos SrcPos
_ TokenVal
Comma : [Token]
rest) = Int -> Bool -> [Token] -> (Int, [Token])
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
True [Token]
rest
    go !Int
n Bool
False [Token]
rest                 = (Int
n, [Token]
rest)
    go !Int
n Bool
True  (Pos SrcPos
_ TokenVal
Comma : [Token]
rest) =
        Int -> Bool -> [Token] -> (Int, [Token])
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Bool
True [Token]
rest
    go !Int
n Bool
True  rest' :: [Token]
rest'@(Pos SrcPos
_ (T Text
name) : [Token]
rest)
        | Text -> Bool
isTypeVarStart Text
name = Int -> Bool -> [Token] -> (Int, [Token])
go Int
n Bool
False [Token]
rest
        | Bool
otherwise           = (Int
n, [Token]
rest')
    go !Int
n Bool
_     [Token]
rest = (Int
n, [Token]
rest)

-- same as dropWhile with counting
dropInfixTypeStart :: [Token] -> [Token]
dropInfixTypeStart :: [Token] -> [Token]
dropInfixTypeStart = (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token -> Bool
f
    where
    f :: Token -> Bool
f (Pos SrcPos
_ (T Text
name)) = Text -> Bool
isInfixTypePrefix Text
name
    f (Pos SrcPos
_ TokenVal
Backtick) = Bool
True
    f (Pos SrcPos
_ TokenVal
LParen)   = Bool
True
    f Token
_                = Bool
False

    isInfixTypePrefix :: Text -> Bool
    isInfixTypePrefix :: Text -> Bool
isInfixTypePrefix = Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Char -> Bool
Char.isLower (Maybe Char -> Bool) -> (Text -> Maybe Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Char
Util.headt

-- | It's easier to scan for tokens without pesky newlines popping up
-- everywhere.  But I need to keep the newlines in in case I hit a @where@
-- and need to call 'breakBlocks' again.
stripNewlines :: UnstrippedTokens -> [Token]
stripNewlines :: UnstrippedTokens -> [Token]
stripNewlines = (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
isNewline) ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnstrippedTokens -> [Token]
unstrippedTokensOf

-- | hsc2hs's '#enum ... \n' or '#{enum...}' definition.
hsc2hsEnum :: [Token] -> [Tag]
hsc2hsEnum :: [Token] -> [Tag]
hsc2hsEnum = \case
    Token
_ : Pos SrcPos
_ TokenVal
Comma : Token
_ : Pos SrcPos
_ TokenVal
Comma : [Token]
rest -> [Token] -> [Tag]
extractValues [Token]
rest
    [Token]
_ -> []
    where
    -- Values are not really functions, they're constants like x = 0 but there's
    -- no tag type for that.
    valueTyp :: Type
valueTyp = Type
Function
    extractValues :: [Token] -> [Tag]
    extractValues :: [Token] -> [Tag]
extractValues = \case
        Pos SrcPos
_ TokenVal
Comma : [Token]
rest ->
            [Token] -> [Tag]
extractValues [Token]
rest
        Pos SrcPos
p (T Text
name) : Pos SrcPos
_ TokenVal
Equals : [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
p Text
name Type
valueTyp
                Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
extractValues (TokenVal -> [Token] -> [Token]
dropUntil TokenVal
Comma ([Token] -> [Token]
stripBalancedParens [Token]
rest))
        Pos SrcPos
p (T Text
name) : [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
p (Text -> Text
translateName Text
name) Type
valueTyp Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
extractValues [Token]
rest
        [Token]
_ -> []
    translateName :: Text -> Text
    translateName :: Text -> Text
translateName
        = Text -> Text
TL.toStrict
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText
        (Builder -> Text) -> (Text -> Builder) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Builder) -> Builder
forall a b. (a, b) -> b
snd
        ((Bool, Builder) -> Builder)
-> (Text -> (Bool, Builder)) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Builder) -> Char -> (Bool, Builder))
-> (Bool, Builder) -> Text -> (Bool, Builder)
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (Bool, Builder) -> Char -> (Bool, Builder)
addChar (Bool
False, Builder
forall a. Monoid a => a
mempty)
    addChar :: (Bool, TLB.Builder) -> Char -> (Bool, TLB.Builder)
    addChar :: (Bool, Builder) -> Char -> (Bool, Builder)
addChar (Bool
_, Builder
acc) Char
'_' = (Bool
True, Builder
acc)
    addChar (Bool
b, Builder
acc) Char
c   = (Bool
False, Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TLB.singleton Char
c')
        where
        c' :: Char
c' = if Bool
b then Char -> Char
Char.toUpper Char
c else Char -> Char
Char.toLower Char
c

-- | Tags from foreign import.
--
-- e.g. @foreign import ccall safe \"name\" c_name :: ...@ will produce a tag
-- for @c_name@.
foreignTags :: [Token] -> [Tag]
foreignTags :: [Token] -> [Tag]
foreignTags [Token]
decl = case [Token]
decl of
    Pos SrcPos
_ TokenVal
KWImport : [Token]
decl'
        | Pos SrcPos
pos (T Text
name) : [Token]
_ <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
Util.dropBefore Token -> Bool
isDoubleColon [Token]
decl' ->
            [SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Function]
    [Token]
_ -> []
    where
    isDoubleColon :: Token -> Bool
isDoubleColon (Pos SrcPos
_ TokenVal
DoubleColon) = Bool
True
    isDoubleColon Token
_ = Bool
False

toplevelFunctionTags :: [Token] -> [Tag]
toplevelFunctionTags :: [Token] -> [Tag]
toplevelFunctionTags [Token]
toks = case [Tag]
tags of
    -- Tags of toplevel functions are all repeatable, even the ones that come
    -- from the type signature because there will definitely be tags from the
    -- body and they should be sorted out if type signature is present.
    [] -> [Token] -> [Tag]
functionTagsNoSig [Token]
toks
    [Tag]
ts -> (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map Tag -> Tag
toRepeatableTag [Tag]
ts
    where
    -- first try to detect tags from type signature, if it fails then
    -- do the actual work of detecting from body
    ([Tag]
tags, [Token]
_) = ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
ExpectFunctions [Token]
toks
    toRepeatableTag :: Tag -> Tag
    toRepeatableTag :: Tag -> Tag
toRepeatableTag (Tag Pos TagVal
t) = Pos TagVal -> Tag
RepeatableTag Pos TagVal
t
    toRepeatableTag Tag
t       = Tag
t

functionTagsNoSig :: [Token] -> [Tag]
functionTagsNoSig :: [Token] -> [Tag]
functionTagsNoSig [Token]
allToks
    -- If there’s no equals sign then this is definitely not a function/operator declaration.
    | [Token] -> Bool
containsEquals [Token]
allToks
    = [Token] -> [Tag]
go' [Token]
allToks
    | Bool
otherwise
    = []
    where
    go' :: [Token] -> [Tag]
    go' :: [Token] -> [Tag]
go' (Pos SrcPos
_ T{} : Pos SrcPos
pos TokenVal
tok : [Token]
_)
        | Just Text
opName <- ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpNameExcludingBangPatSyms ExpectedFuncName
ExpectFunctions TokenVal
tok
        = [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
opName Type
Operator]
    go' [Token]
ts = [Token] -> [Tag]
go [Token]
ts

    go :: [Token] -> [Tag]
    go :: [Token] -> [Tag]
go []                           = []
    go (Pos SrcPos
_ TokenVal
LParen : Pos SrcPos
_ T{} : Pos SrcPos
_ TokenVal
Backtick : Pos SrcPos
pos' (T Text
name')
            : Pos SrcPos
_ TokenVal
Backtick : Pos SrcPos
_ T{} : Pos SrcPos
_ TokenVal
RParen : [Token]
_)
        | ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
ExpectFunctions Text
name' =
            [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos' Text
name' Type
Function]
    go (Pos SrcPos
_ TokenVal
LParen : Pos SrcPos
_ T{} : Pos SrcPos
pos' TokenVal
tok : Pos SrcPos
_ T{} : Pos SrcPos
_ TokenVal
RParen : [Token]
_)
        | Just Text
name' <- ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpName ExpectedFuncName
ExpectFunctions TokenVal
tok
        = [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos' Text
name' Type
Operator]
    go toks :: [Token]
toks@(Pos SrcPos
_ TokenVal
LParen : [Token]
_)      = [Token] -> [Tag]
go ([Token] -> [Tag]) -> [Token] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedParens [Token]
toks
    go toks :: [Token]
toks@(Pos SrcPos
_ TokenVal
LBrace : [Token]
_)      = [Token] -> [Tag]
go ([Token] -> [Tag]) -> [Token] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedBraces [Token]
toks
    go toks :: [Token]
toks@(Pos SrcPos
_ TokenVal
LBracket : [Token]
_)    = [Token] -> [Tag]
go ([Token] -> [Tag]) -> [Token] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedBrackets [Token]
toks
    -- This function does not analyze type signatures.
    go (Pos SrcPos
_ TokenVal
DoubleColon : [Token]
_)      = []
    go (Pos SrcPos
_ TokenVal
ExclamationMark : [Token]
ts) = [Token] -> [Tag]
go [Token]
ts
    go (Pos SrcPos
_ TokenVal
Tilde : [Token]
ts)           = [Token] -> [Tag]
go [Token]
ts
    go (Pos SrcPos
_ TokenVal
At : [Token]
ts)              = [Token] -> [Tag]
go [Token]
ts
    go (Pos SrcPos
_ TokenVal
Equals : [Token]
_)           = [Token] -> [Tag]
functionOrOp [Token]
allToks
    go (Pos SrcPos
_ TokenVal
Pipe : [Token]
_)             = [Token] -> [Tag]
functionOrOp [Token]
allToks
    go (Pos SrcPos
_ TokenVal
Backtick : Pos SrcPos
pos' (T Text
name') : [Token]
_)
        | ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
ExpectFunctions Text
name' =
            [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos' Text
name' Type
Function]
    go (Pos SrcPos
pos TokenVal
tok : [Token]
_)
        | Just Text
name <- ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpNameExcludingBangPatSyms ExpectedFuncName
ExpectFunctions TokenVal
tok
        = [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
name Type
Operator]
    go (Pos SrcPos
pos TokenVal
Dot : [Token]
_)            = [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
"." Type
Operator]
    go (Token
_ : [Token]
ts)                     = [Token] -> [Tag]
go [Token]
ts
    stripOpeningParens :: [Token] -> [Token]
    stripOpeningParens :: [Token] -> [Token]
stripOpeningParens = (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
LParen) (TokenVal -> Bool) -> (Token -> TokenVal) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenVal
forall a. Pos a -> a
valOf)
    functionOrOp :: [Token] -> [Tag]
    functionOrOp :: [Token] -> [Tag]
functionOrOp [Token]
toks = case [Token] -> [Token]
stripOpeningParens [Token]
toks of
         Pos SrcPos
pos (T Text
name) : [Token]
_
             | ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
ExpectFunctions Text
name ->
                [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
name Type
Function]
         Pos SrcPos
pos TokenVal
tok : [Token]
_ -> case ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpName ExpectedFuncName
ExpectFunctions TokenVal
tok of
             Just Text
name -> [SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
name Type
Operator]
             Maybe Text
Nothing   -> []
         [] -> []

tokToOpNameExcludingBangPatSyms :: ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpNameExcludingBangPatSyms :: ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpNameExcludingBangPatSyms ExpectedFuncName
expectation TokenVal
tok =
    case (ExpectedFuncName
expectation, TokenVal -> Maybe Text
tokToNameExcludingBangPatSyms TokenVal
tok) of
        (ExpectedFuncName
ExpectFunctions, res :: Maybe Text
res@(Just Text
name))
            | Text -> Bool
isHaskellOp Text
name -> Maybe Text
res
        (ExpectedFuncName
ExpectConstructors, res :: Maybe Text
res@(Just Text
name))
            | Text -> Bool
isHaskellConstructorOp Text
name -> Maybe Text
res
        (ExpectedFuncName, Maybe Text)
_ -> Maybe Text
forall a. Maybe a
Nothing

tokToNameExcludingBangPatSyms :: TokenVal -> Maybe Text
tokToNameExcludingBangPatSyms :: TokenVal -> Maybe Text
tokToNameExcludingBangPatSyms (T Text
"_")         = Maybe Text
forall a. Maybe a
Nothing
tokToNameExcludingBangPatSyms (T Text
name)        = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
tokToNameExcludingBangPatSyms TokenVal
Dot             = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"."
tokToNameExcludingBangPatSyms TokenVal
_               = Maybe Text
forall a. Maybe a
Nothing

tokToOpName :: ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpName :: ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpName ExpectedFuncName
expectation TokenVal
tok = case (ExpectedFuncName
expectation, TokenVal -> Maybe Text
tokToName TokenVal
tok) of
    (ExpectedFuncName
ExpectFunctions, res :: Maybe Text
res@(Just Text
name))
        | Text -> Bool
isHaskellOp Text
name -> Maybe Text
res
    (ExpectedFuncName
ExpectConstructors, res :: Maybe Text
res@(Just Text
name))
        | Text -> Bool
isHaskellConstructorOp Text
name -> Maybe Text
res
    (ExpectedFuncName, Maybe Text)
_ -> Maybe Text
forall a. Maybe a
Nothing

tokToName :: TokenVal -> Maybe Text
tokToName :: TokenVal -> Maybe Text
tokToName TokenVal
ExclamationMark = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"!"
tokToName TokenVal
Tilde           = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"~"
tokToName TokenVal
x               = TokenVal -> Maybe Text
tokToNameExcludingBangPatSyms TokenVal
x

-- | Get tags from a function type declaration: token , token , token ::
-- Return the tokens left over.
functionTags :: ExpectedFuncName -- ^ expect constructors or functions
    -> [Token] -> ([Tag], [Token])
functionTags :: ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
constructors = [Tag] -> [Token] -> ([Tag], [Token])
go []
    where
    (Type
opTag, Type
funcTag) = case ExpectedFuncName
constructors of
        ExpectedFuncName
ExpectConstructors -> (Type
Constructor, Type
Constructor)
        ExpectedFuncName
ExpectFunctions    -> (Type
Operator, Type
Function)
    go :: [Tag] -> [Token] -> ([Tag], [Token])
    go :: [Tag] -> [Token] -> ([Tag], [Token])
go [Tag]
tags (Pos SrcPos
_ TokenVal
LParen : Token
opTok : Pos SrcPos
_ TokenVal
RParen : Pos SrcPos
_ TokenVal
DoubleColon : [Token]
rest) =
        ([Tag] -> [Tag]
forall a. [a] -> [a]
reverse ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Tag] -> Type -> Token -> [Tag]
mkOpTag [Tag]
tags Type
opTag Token
opTok, [Token]
rest)
    go [Tag]
tags (Pos SrcPos
pos (T Text
name) : Pos SrcPos
_ TokenVal
DoubleColon : [Token]
rest)
        | ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
constructors Text
name =
            ([Tag] -> [Tag]
forall a. [a] -> [a]
reverse ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
funcTag Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Tag]
tags, [Token]
rest)
    go [Tag]
tags (Pos SrcPos
_ TokenVal
LParen : Token
opTok : Pos SrcPos
_ TokenVal
RParen : Pos SrcPos
_ TokenVal
Comma : [Token]
rest) =
        [Tag] -> [Token] -> ([Tag], [Token])
go ([Tag] -> Type -> Token -> [Tag]
mkOpTag [Tag]
tags Type
opTag Token
opTok) [Token]
rest
    go [Tag]
tags (Pos SrcPos
pos (T Text
name) : Pos SrcPos
_ TokenVal
Comma : [Token]
rest)
        | ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
constructors Text
name =
            [Tag] -> [Token] -> ([Tag], [Token])
go (SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
funcTag Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Tag]
tags) [Token]
rest
    go [Tag]
tags [Token]
tokens = ([Tag]
tags, [Token]
tokens)

    mkOpTag :: [Tag] -> Type -> Token -> [Tag]
    mkOpTag :: [Tag] -> Type -> Token -> [Tag]
mkOpTag [Tag]
tags Type
opTag' (Pos SrcPos
pos TokenVal
tok) =
        case ExpectedFuncName -> TokenVal -> Maybe Text
tokToOpName ExpectedFuncName
constructors TokenVal
tok of
            Just Text
name -> SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
opTag' Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Tag]
tags
            Maybe Text
Nothing   -> [Tag]
tags

data ExpectedFuncName = ExpectFunctions | ExpectConstructors

functionName :: ExpectedFuncName -> Text -> Bool
functionName :: ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
expect = Text -> Bool
isFunction
    where
    isFunction :: Text -> Bool
isFunction Text
text = case Text -> Maybe (Char, Text)
T.uncons Text
text of
        Just (Char
'_', Text
cs)
            | Text -> Bool
T.null Text
cs -> Bool
False
        Just (Char
c, Text
cs) ->
            Char -> Bool
firstChar Char
c Bool -> Bool -> Bool
&& Char -> Bool
startIdentChar Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Bool -> Char -> Bool
identChar Bool
True) Text
cs
        Maybe (Char, Text)
Nothing      -> Bool
False
    firstChar :: Char -> Bool
firstChar = case ExpectedFuncName
expect of
        ExpectedFuncName
ExpectFunctions    -> \Char
c -> Char -> Bool
Char.isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
        ExpectedFuncName
ExpectConstructors -> Char -> Bool
Char.isUpper

-- | * = X *
newtypeTags :: SrcPos -> UnstrippedTokens -> [Tag]
newtypeTags :: SrcPos -> UnstrippedTokens -> [Tag]
newtypeTags SrcPos
_ UnstrippedTokens
unstripped
    | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case { Pos SrcPos
_ TokenVal
KWWhere -> Bool
True; Token
_ -> Bool
False })
            (UnstrippedTokens -> [Token]
unstrippedTokensOf UnstrippedTokens
unstripped) =
        (UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
gadtTags (UnstrippedTokens -> [UnstrippedTokens]
whereBlock UnstrippedTokens
unstripped)
newtypeTags SrcPos
prevPos UnstrippedTokens
unstripped =
    case TokenVal -> [Token] -> [Token]
dropUntil TokenVal
Equals ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
unstripped of
        Pos SrcPos
pos (T Text
name) : [Token]
rest ->
            let constructor :: Tag
constructor = SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor
            in  case [Token]
rest of
                Pos SrcPos
_ TokenVal
LBrace : Pos SrcPos
funcPos (T Text
funcName) : [Token]
_ ->
                    [Tag
constructor, SrcPos -> Text -> Type -> Tag
mkTag SrcPos
funcPos Text
funcName Type
Function]
                [Token]
_ ->
                    [Tag
constructor]
        [Token]
rest -> [SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected SrcPos
prevPos UnstrippedTokens
unstripped [Token]
rest String
"newtype * ="]

-- | [] (empty data declaration)
-- * = X { X :: *, X :: * }
-- * where X :: * X :: *
-- * = X | X
dataConstructorTags :: SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags :: SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags SrcPos
prevPos UnstrippedTokens
unstripped
    -- GADT
    | (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case { Pos SrcPos
_ TokenVal
KWWhere -> Bool
True; Token
_ -> Bool
False })
            (UnstrippedTokens -> [Token]
unstrippedTokensOf UnstrippedTokens
unstripped) =
        (UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
gadtTags (UnstrippedTokens -> [UnstrippedTokens]
whereBlock UnstrippedTokens
unstripped)
    -- plain ADT
    | Bool
otherwise = case UnstrippedTokens -> [Token]
strip UnstrippedTokens
unstripped of
        [] -> [] -- empty data declaration
        [Token]
rest | Just (Pos SrcPos
pos (T Text
name), [Token]
rest') <- [Token] -> Maybe (Token, [Token])
extractInfixConstructor [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest'
        [Token]
rest | Just (SrcPos
pos, Text
name, [Token]
rest') <- [Token] -> Maybe (SrcPos, Text, [Token])
extractSpecialTypeName [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest'
        Pos SrcPos
pos (T Text
name) : [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest
        Pos SrcPos
_ TokenVal
LParen : Pos SrcPos
pos (T Text
name) : Pos SrcPos
_ TokenVal
RParen : [Token]
rest ->
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest
        [Token]
rest -> [SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected SrcPos
prevPos UnstrippedTokens
unstripped [Token]
rest String
"data * = *"]
    where
    strip :: UnstrippedTokens -> [Token]
    strip :: UnstrippedTokens -> [Token]
strip = [Token] -> [Token]
stripOptBang ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripDatatypeContext ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenVal -> [Token] -> [Token]
dropUntil TokenVal
Equals
          ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnstrippedTokens -> [Token]
stripNewlines
    collectRest :: [Token] -> [Tag]
    collectRest :: [Token] -> [Tag]
collectRest [Token]
tokens
        | (tags :: [Tag]
tags@(Tag
_:[Tag]
_), [Token]
rest) <- ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
ExpectFunctions [Token]
tokens =
            [Tag]
tags [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ [Token] -> [Tag]
collectRest ([Token] -> [Token]
dropUntilNextField [Token]
rest)
    collectRest toks :: [Token]
toks@(Pos SrcPos
_ TokenVal
LParen : [Token]
_) =
        [Token] -> [Tag]
collectRest ([Token] -> [Tag]) -> [Token] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedParens [Token]
toks -- dropUntilNextField rest
    collectRest (Pos SrcPos
pipePos TokenVal
Pipe : [Token]
rest)
        | Just (Pos SrcPos
pos (T Text
name), [Token]
rest'') <- [Token] -> Maybe (Token, [Token])
extractInfixConstructor [Token]
rest' =
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest''
        | Just (SrcPos
pos, Text
name, [Token]
rest'') <- [Token] -> Maybe (SrcPos, Text, [Token])
extractSpecialTypeName [Token]
rest' =
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest [Token]
rest''
        | Pos SrcPos
pos (T Text
name) : [Token]
rest'' <- [Token]
rest'
        , ExpectedFuncName -> Text -> Bool
functionName ExpectedFuncName
ExpectConstructors Text
name =
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor
                Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest ([Token] -> [Token]
dropUntilNextCaseOrRecordStart [Token]
rest'')
        | Pos SrcPos
_ TokenVal
LParen : Pos SrcPos
pos (T Text
name) : Pos SrcPos
_ TokenVal
RParen : [Token]
rest'' <- [Token]
rest'
        , Text -> Bool
isHaskellConstructorOp Text
name =
            SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Constructor
                Tag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
: [Token] -> [Tag]
collectRest ([Token] -> [Token]
dropUntilNextCaseOrRecordStart [Token]
rest'')
        | Bool
otherwise =
            [SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected SrcPos
pipePos UnstrippedTokens
unstripped [Token]
rest String
"| not followed by tokens"]
        where
        rest' :: [Token]
rest' = [Token] -> [Token]
stripOptBang ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripDatatypeContext [Token]
rest
    collectRest (Token
_ : [Token]
rest) = [Token] -> [Tag]
collectRest [Token]
rest
    collectRest [] = []

    stripOptBang :: [Token] -> [Token]
    stripOptBang :: [Token] -> [Token]
stripOptBang (Pos SrcPos
_ TokenVal
ExclamationMark : [Token]
rest) = [Token]
rest
    stripOptBang [Token]
ts = [Token]
ts

    extractInfixConstructor :: [Token] -> Maybe (Token, [Token])
    extractInfixConstructor :: [Token] -> Maybe (Token, [Token])
extractInfixConstructor = [Token] -> Maybe (Token, [Token])
extract ([Token] -> Maybe (Token, [Token]))
-> ([Token] -> [Token]) -> [Token] -> Maybe (Token, [Token])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripTypeParam
        where
        extract :: [Token] -> Maybe (Token, [Token])
        extract :: [Token] -> Maybe (Token, [Token])
extract (tok :: Token
tok@(Pos SrcPos
_ (T Text
name)) : [Token]
rest)
            | Text -> Bool
isHaskellConstructorOp Text
name = (Token, [Token]) -> Maybe (Token, [Token])
forall a. a -> Maybe a
Just (Token
tok, [Token] -> [Token]
stripTypeParam [Token]
rest)
        extract (Pos SrcPos
_ TokenVal
Backtick : tok :: Token
tok@(Pos SrcPos
_ TokenVal
_) : Pos SrcPos
_ TokenVal
Backtick : [Token]
rest) =
            (Token, [Token]) -> Maybe (Token, [Token])
forall a. a -> Maybe a
Just (Token
tok, [Token] -> [Token]
stripTypeParam [Token]
rest)
        extract [Token]
_ = Maybe (Token, [Token])
forall a. Maybe a
Nothing

        stripTypeParam :: [Token] -> [Token]
        stripTypeParam :: [Token] -> [Token]
stripTypeParam input :: [Token]
input@(Pos SrcPos
_ TokenVal
LParen : [Token]
_) =
            [Token] -> [Token]
stripBalancedParens [Token]
input
        stripTypeParam input :: [Token]
input@(Pos SrcPos
_ TokenVal
LBracket : [Token]
_) =
            [Token] -> [Token]
stripBalancedBrackets [Token]
input
        stripTypeParam [Token]
ts = (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Token -> Bool
isTypeParam ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> [Token] -> [Token]
forall a. Int -> [a] -> [a]
drop Int
1 [Token]
ts

        isTypeParam :: Token -> Bool
        isTypeParam :: Token -> Bool
isTypeParam (Pos SrcPos
_ (T Text
name)) = Text -> Bool
isTypeVarStart Text
name
        isTypeParam Token
_                = Bool
False

    dropUntilNextCaseOrRecordStart :: [Token] -> [Token]
    dropUntilNextCaseOrRecordStart :: [Token] -> [Token]
dropUntilNextCaseOrRecordStart = (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced ((TokenVal -> Bool) -> [Token] -> [Token])
-> (TokenVal -> Bool) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (Bool -> Bool) -> (TokenVal -> Bool) -> TokenVal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case { TokenVal
Pipe -> Bool
True; TokenVal
LBrace -> Bool
True; TokenVal
_ -> Bool
False }

    dropUntilNextField :: [Token] -> [Token]
    dropUntilNextField :: [Token] -> [Token]
dropUntilNextField = (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced ((TokenVal -> Bool) -> [Token] -> [Token])
-> (TokenVal -> Bool) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (Bool -> Bool) -> (TokenVal -> Bool) -> TokenVal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case { TokenVal
Comma -> Bool
True; TokenVal
RBrace -> Bool
True; TokenVal
Pipe -> Bool
True; TokenVal
_ -> Bool
False }

stripDatatypeContext :: [Token] -> [Token]
stripDatatypeContext :: [Token] -> [Token]
stripDatatypeContext = [Token] -> [Token]
stripOptContext ([Token] -> [Token]) -> ([Token] -> [Token]) -> [Token] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [Token]
stripOptForall

stripOptForall :: [Token] -> [Token]
stripOptForall :: [Token] -> [Token]
stripOptForall (Pos SrcPos
_ (T Text
"forall") : [Token]
rest) = TokenVal -> [Token] -> [Token]
dropUntil TokenVal
Dot [Token]
rest
stripOptForall [Token]
xs                          = [Token]
xs

stripParensKindsTypeVars :: [Token] -> [Token]
stripParensKindsTypeVars :: [Token] -> [Token]
stripParensKindsTypeVars (Pos SrcPos
_ TokenVal
LParen : [Token]
xs)  =
    [Token] -> [Token]
stripParensKindsTypeVars [Token]
xs
stripParensKindsTypeVars (Pos SrcPos
_ TokenVal
DoubleColon : [Token]
xs) =
    [Token] -> [Token]
stripParensKindsTypeVars ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Int -> [Token] -> [Token]
forall a. Int -> [a] -> [a]
drop Int
1 ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$
    (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced (\case { TokenVal
RParen -> Bool
False; TokenVal
_ -> Bool
True }) [Token]
xs
stripParensKindsTypeVars (Pos SrcPos
_ (T Text
name) : [Token]
xs)
    | Text -> Bool
isTypeVarStart Text
name = [Token] -> [Token]
stripParensKindsTypeVars [Token]
xs
stripParensKindsTypeVars [Token]
xs = [Token]
xs

stripOptContext :: [Token] -> [Token]
stripOptContext :: [Token] -> [Token]
stripOptContext ([Token] -> [Token]
stripBalancedParens -> Pos SrcPos
_ TokenVal
Implies : [Token]
xs) = [Token]
xs
stripOptContext [Token]
origToks = [Token] -> [Token]
go [Token]
origToks
    where
    go :: [Token] -> [Token]
go (Pos SrcPos
_ TokenVal
Implies : [Token]
xs)    = [Token]
xs
    go (Pos SrcPos
_ TokenVal
Equals : [Token]
_)      = [Token]
origToks
    go (Pos SrcPos
_ TokenVal
Pipe : [Token]
_)        = [Token]
origToks
    go (Pos SrcPos
_ TokenVal
LBrace : [Token]
_)      = [Token]
origToks
    go (Pos SrcPos
_ TokenVal
RBrace : [Token]
_)      = [Token]
origToks
    go toks :: [Token]
toks@(Pos SrcPos
_ TokenVal
LParen : [Token]
_) = [Token] -> [Token]
go ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedParens [Token]
toks
    go (Pos SrcPos
_ TokenVal
DoubleColon : [Token]
_) = [Token]
origToks
    go (Token
_ : [Token]
xs)                = [Token] -> [Token]
go [Token]
xs
    go []                      = [Token]
origToks

-- | Drop all tokens for which @pred@ returns True, also drop () or []
-- parenthesized expressions.
dropWithStrippingBalanced :: (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced :: (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced TokenVal -> Bool
p = [Token] -> [Token]
go
    where
    go :: [Token] -> [Token]
go input :: [Token]
input@(Pos SrcPos
_ TokenVal
LParen : [Token]
_)   = [Token] -> [Token]
go ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedParens [Token]
input
    go input :: [Token]
input@(Pos SrcPos
_ TokenVal
LBracket : [Token]
_) = [Token] -> [Token]
go ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripBalancedBrackets [Token]
input
    go (Pos SrcPos
_ TokenVal
tok : [Token]
xs) | TokenVal -> Bool
p TokenVal
tok   = [Token] -> [Token]
go [Token]
xs
    go [Token]
xs = [Token]
xs

stripBalancedParens :: [Token] -> [Token]
stripBalancedParens :: [Token] -> [Token]
stripBalancedParens = TokenVal -> TokenVal -> [Token] -> [Token]
stripBalanced TokenVal
LParen TokenVal
RParen

stripBalancedBrackets :: [Token] -> [Token]
stripBalancedBrackets :: [Token] -> [Token]
stripBalancedBrackets = TokenVal -> TokenVal -> [Token] -> [Token]
stripBalanced TokenVal
LBracket TokenVal
RBracket

stripBalancedBraces :: [Token] -> [Token]
stripBalancedBraces :: [Token] -> [Token]
stripBalancedBraces = TokenVal -> TokenVal -> [Token] -> [Token]
stripBalanced TokenVal
LBrace TokenVal
RBrace

stripBalanced :: TokenVal -> TokenVal -> [Token] -> [Token]
stripBalanced :: TokenVal -> TokenVal -> [Token] -> [Token]
stripBalanced TokenVal
open TokenVal
close (Pos SrcPos
_ TokenVal
tok : [Token]
xs)
    | TokenVal
tok TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
open = Int -> [Token] -> [Token]
go Int
1 [Token]
xs
    where
    go :: Int -> [Token] -> [Token]
    go :: Int -> [Token] -> [Token]
go Int
0 [Token]
ys = [Token]
ys
    go !Int
n (Pos SrcPos
_ TokenVal
tok' : [Token]
ys)
        | TokenVal
tok' TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
open  = Int -> [Token] -> [Token]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Token]
ys
        | TokenVal
tok' TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
close = Int -> [Token] -> [Token]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Token]
ys
    go !Int
n (Token
_: [Token]
ys) = Int -> [Token] -> [Token]
go Int
n [Token]
ys
    go Int
_  []      = []
stripBalanced TokenVal
_ TokenVal
_ [Token]
xs = [Token]
xs

gadtTags :: UnstrippedTokens -> [Tag]
gadtTags :: UnstrippedTokens -> [Tag]
gadtTags UnstrippedTokens
unstripped = case [Token] -> [Token]
dropDataContext [Token]
rest of
    Pos SrcPos
_ TokenVal
LBrace : [Token]
rest' -> [Tag]
constructorTag [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ [Token] -> [Tag]
collectFields [Token]
rest'
    [Token]
_                    -> [Tag]
constructorTag
    where
    ([Tag]
constructorTag, [Token]
rest) =
        ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
ExpectConstructors ([Token] -> ([Tag], [Token])) -> [Token] -> ([Tag], [Token])
forall a b. (a -> b) -> a -> b
$ UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
unstripped
    collectFields :: [Token] -> [Tag]
    collectFields :: [Token] -> [Tag]
collectFields (Pos SrcPos
_ TokenVal
Comma : [Token]
rest) = [Token] -> [Tag]
collectFields [Token]
rest
    collectFields (Pos SrcPos
_ TokenVal
RBrace : [Token]
_)   = []
    collectFields [Token]
tokens
        | (tags :: [Tag]
tags@(Tag
_:[Tag]
_), [Token]
rest) <- ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
ExpectFunctions [Token]
tokens =
            [Tag]
tags [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ [Token] -> [Tag]
collectFields ([Token] -> [Token]
dropUntilNextField [Token]
rest)
        | Bool
otherwise = []
    dropUntilNextField :: [Token] -> [Token]
    dropUntilNextField :: [Token] -> [Token]
dropUntilNextField = (TokenVal -> Bool) -> [Token] -> [Token]
dropWithStrippingBalanced ((TokenVal -> Bool) -> [Token] -> [Token])
-> (TokenVal -> Bool) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (Bool -> Bool) -> (TokenVal -> Bool) -> TokenVal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case { TokenVal
Comma -> Bool
True; TokenVal
RBrace -> Bool
True; TokenVal
_ -> Bool
False }

-- | * => X where X :: * ...
classTags :: SrcPos -> UnstrippedTokens -> [Tag]
classTags :: SrcPos -> UnstrippedTokens -> [Tag]
classTags SrcPos
prevPos UnstrippedTokens
unstripped =
    Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList Maybe Tag
classTag
        [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
classTag)
            ((UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
classBodyTags (UnstrippedTokens -> [UnstrippedTokens]
whereBlock UnstrippedTokens
wherePart))
    where
    (UnstrippedTokens
classPart, UnstrippedTokens
wherePart) = TokenVal
-> UnstrippedTokens -> (UnstrippedTokens, UnstrippedTokens)
spanUntil TokenVal
KWWhere UnstrippedTokens
unstripped
    (Maybe Tag
classTag, SrcPos
_, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeName Type
Class SrcPos
prevPos
        String
"class * =>" ([Token] -> (Maybe Tag, SrcPos, [Token]))
-> [Token] -> (Maybe Tag, SrcPos, [Token])
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
stripUntilImplies ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
classPart

stripUntilImplies :: [Token] -> [Token]
stripUntilImplies :: [Token] -> [Token]
stripUntilImplies [Token]
xs = case TokenVal -> [Token] -> [Token]
dropUntil TokenVal
Implies [Token]
xs of
    []  -> [Token]
xs
    [Token]
xs' -> [Token]
xs'

classBodyTags :: UnstrippedTokens -> [Tag]
classBodyTags :: UnstrippedTokens -> [Tag]
classBodyTags UnstrippedTokens
unstripped = case UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
unstripped of
    Pos SrcPos
_ TokenVal
KWType : Pos SrcPos
pos (T Text
name) : [Token]
_ -> [SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Family]
    Pos SrcPos
_ TokenVal
KWData : Pos SrcPos
pos (T Text
name) : [Token]
_ -> [SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
Family]
    [Token]
tokens -> ([Tag], [Token]) -> [Tag]
forall a b. (a, b) -> a
fst (([Tag], [Token]) -> [Tag]) -> ([Tag], [Token]) -> [Tag]
forall a b. (a -> b) -> a -> b
$ ExpectedFuncName -> [Token] -> ([Tag], [Token])
functionTags ExpectedFuncName
ExpectFunctions [Token]
tokens

-- | Skip to the where and split the indented block below it.
whereBlock :: UnstrippedTokens -> [UnstrippedTokens]
whereBlock :: UnstrippedTokens -> [UnstrippedTokens]
whereBlock =
    ([Token] -> [UnstrippedTokens]) -> [[Token]] -> [UnstrippedTokens]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ProcessMode -> UnstrippedTokens -> [UnstrippedTokens]
breakBlocks ProcessMode
ProcessVanilla (UnstrippedTokens -> [UnstrippedTokens])
-> ([Token] -> UnstrippedTokens) -> [Token] -> [UnstrippedTokens]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> UnstrippedTokens
UnstrippedTokens) ([[Token]] -> [UnstrippedTokens])
-> (UnstrippedTokens -> [[Token]])
-> UnstrippedTokens
-> [UnstrippedTokens]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Token] -> [[Token]]
explodeToplevelBracedBlocks ([Token] -> [[Token]])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [[Token]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    TokenVal -> [Token] -> [Token]
dropUntil TokenVal
KWWhere ([Token] -> [Token])
-> (UnstrippedTokens -> [Token]) -> UnstrippedTokens -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    UnstrippedTokens -> [Token]
unstrippedTokensOf

instanceTags :: SrcPos -> UnstrippedTokens -> [Tag]
instanceTags :: SrcPos -> UnstrippedTokens -> [Tag]
instanceTags SrcPos
prevPos UnstrippedTokens
unstripped =
    -- instances can offer nothing but some fresh data constructors since
    -- the actual datatype is really declared in the class declaration
    (UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
newtypeDecl ((UnstrippedTokens -> UnstrippedTokens)
-> [UnstrippedTokens] -> [UnstrippedTokens]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1) ((UnstrippedTokens -> Bool)
-> [UnstrippedTokens] -> [UnstrippedTokens]
forall a. (a -> Bool) -> [a] -> [a]
filter UnstrippedTokens -> Bool
isNewtypeDecl [UnstrippedTokens]
block))
    [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ (UnstrippedTokens -> [Tag]) -> [UnstrippedTokens] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnstrippedTokens -> [Tag]
dataDecl ((UnstrippedTokens -> UnstrippedTokens)
-> [UnstrippedTokens] -> [UnstrippedTokens]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1) ((UnstrippedTokens -> Bool)
-> [UnstrippedTokens] -> [UnstrippedTokens]
forall a. (a -> Bool) -> [a] -> [a]
filter UnstrippedTokens -> Bool
isDataDecl [UnstrippedTokens]
block))
    where
    newtypeDecl :: UnstrippedTokens -> [Tag]
newtypeDecl UnstrippedTokens
toks = (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
parent) ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ SrcPos -> UnstrippedTokens -> [Tag]
newtypeTags SrcPos
pos UnstrippedTokens
toks
        where
        (Maybe Tag
parent, SrcPos
pos) = SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName SrcPos
prevPos String
"newtype instance * ="
            (UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
toks)
    dataDecl :: UnstrippedTokens -> [Tag]
dataDecl UnstrippedTokens
toks = (Tag -> Tag) -> [Tag] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Tag -> Tag -> Tag
addParent Maybe Tag
parent) ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags SrcPos
pos UnstrippedTokens
toks
        where
        (Maybe Tag
parent, SrcPos
pos) = SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName SrcPos
prevPos String
"data instance * ="
            (UnstrippedTokens -> [Token]
stripNewlines UnstrippedTokens
toks)
    block :: [UnstrippedTokens]
block = UnstrippedTokens -> [UnstrippedTokens]
whereBlock UnstrippedTokens
unstripped

    isNewtypeDecl :: UnstrippedTokens -> Bool
    isNewtypeDecl :: UnstrippedTokens -> Bool
isNewtypeDecl (UnstrippedTokens (Pos SrcPos
_ TokenVal
KWNewtype : [Token]
_)) = Bool
True
    isNewtypeDecl UnstrippedTokens
_ = Bool
False

    isDataDecl :: UnstrippedTokens -> Bool
    isDataDecl :: UnstrippedTokens -> Bool
isDataDecl (UnstrippedTokens (Pos SrcPos
_ TokenVal
KWData : [Token]
_)) = Bool
True
    isDataDecl UnstrippedTokens
_ = Bool
False

extractFamilyName :: SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName :: SrcPos -> String -> [Token] -> (Maybe Tag, SrcPos)
extractFamilyName SrcPos
prevPos String
context [Token]
toks = (Maybe Tag
tag, SrcPos
pos)
    where
    (Maybe Tag
tag, SrcPos
pos, [Token]
_) = (Text -> Bool)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
recordVanillaOrInfixName Text -> Bool
isTypeFamilyName Type
Family SrcPos
prevPos
        String
context [Token]
toks

-- * util

addParent :: Maybe Tag -> Tag -> Tag
addParent :: Maybe Tag -> Tag -> Tag
addParent Maybe Tag
parent = (Pos TagVal -> Pos TagVal) -> Tag -> Tag
onTagVal Pos TagVal -> Pos TagVal
f
    where
    f :: Pos TagVal -> Pos TagVal
f (Pos SrcPos
pos (TagVal Text
name Type
typ Maybe Text
_)) =
        SrcPos -> TagVal -> Pos TagVal
forall a. SrcPos -> a -> Pos a
Pos SrcPos
pos (Text -> Type -> Maybe Text -> TagVal
TagVal Text
name Type
typ Maybe Text
parentName)
    parentName :: Maybe Text
    parentName :: Maybe Text
parentName = Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Tag -> Maybe Text
extractName (Tag -> Maybe Text) -> Maybe Tag -> Maybe (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Tag
parent

mkTag :: SrcPos -> Text -> Type -> Tag
mkTag :: SrcPos -> Text -> Type -> Tag
mkTag SrcPos
pos Text
name Type
typ = Pos TagVal -> Tag
Tag (Pos TagVal -> Tag) -> Pos TagVal -> Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> TagVal -> Pos TagVal
forall a. SrcPos -> a -> Pos a
Pos SrcPos
pos (Text -> Type -> Maybe Text -> TagVal
TagVal Text
name Type
typ Maybe Text
forall a. Maybe a
Nothing)

mkRepeatableTag :: SrcPos -> Text -> Type -> Tag
mkRepeatableTag :: SrcPos -> Text -> Type -> Tag
mkRepeatableTag SrcPos
pos Text
name Type
typ =
    Pos TagVal -> Tag
RepeatableTag (Pos TagVal -> Tag) -> Pos TagVal -> Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> TagVal -> Pos TagVal
forall a. SrcPos -> a -> Pos a
Pos SrcPos
pos TagVal :: Text -> Type -> Maybe Text -> TagVal
TagVal
        { tvName :: Text
tvName   = Text
name
        , tvType :: Type
tvType   = Type
typ
        , tvParent :: Maybe Text
tvParent = Maybe Text
forall a. Maybe a
Nothing
        }

warning :: SrcPos -> String -> Tag
warning :: SrcPos -> String -> Tag
warning SrcPos
pos String
warn = Pos String -> Tag
Warning (Pos String -> Tag) -> Pos String -> Tag
forall a b. (a -> b) -> a -> b
$ SrcPos -> String -> Pos String
forall a. SrcPos -> a -> Pos a
Pos SrcPos
pos (String -> Pos String) -> String -> Pos String
forall a b. (a -> b) -> a -> b
$ SrcPos -> String
forall a. Show a => a -> String
show SrcPos
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
warn

unexpected :: SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected :: SrcPos -> UnstrippedTokens -> [Token] -> String -> Tag
unexpected SrcPos
prevPos (UnstrippedTokens [Token]
tokensBefore) [Token]
tokensHere String
declaration =
    SrcPos -> String -> Tag
warning SrcPos
pos (String
"unexpected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
thing String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
declaration)
    where
    thing :: String
thing = String -> (Token -> String) -> Maybe Token -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"end of block" (TokenVal -> String
forall a. Show a => a -> String
show (TokenVal -> String) -> (Token -> TokenVal) -> Token -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenVal
forall a. Pos a -> a
valOf) ([Token] -> Maybe Token
forall a. [a] -> Maybe a
Util.mhead [Token]
tokensHere)
    pos :: SrcPos
pos
        | Just Token
t <- [Token] -> Maybe Token
forall a. [a] -> Maybe a
Util.mhead [Token]
tokensHere = Token -> SrcPos
forall a. Pos a -> SrcPos
posOf Token
t
        | Just Token
t <- [Token] -> Maybe Token
forall a. [a] -> Maybe a
Util.mlast [Token]
tokensBefore = Token -> SrcPos
forall a. Pos a -> SrcPos
posOf Token
t
        | Bool
otherwise = SrcPos
prevPos

isNewline :: Token -> Bool
isNewline :: Token -> Bool
isNewline (Pos SrcPos
_ (Newline Int
_)) = Bool
True
isNewline Token
_                   = Bool
False

containsEquals :: [Token] -> Bool
containsEquals :: [Token] -> Bool
containsEquals = (Token -> Bool) -> [Token] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case { Pos SrcPos
_ TokenVal
Equals -> Bool
True; Token
_ -> Bool
False; })

dropUntil :: TokenVal -> [Token] -> [Token]
dropUntil :: TokenVal -> [Token] -> [Token]
dropUntil TokenVal
token = Int -> [Token] -> [Token]
forall a. Int -> [a] -> [a]
drop Int
1 ([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]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
token) (TokenVal -> Bool) -> (Token -> TokenVal) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenVal
forall a. Pos a -> a
valOf)

spanUntil :: TokenVal -> UnstrippedTokens
    -> (UnstrippedTokens, UnstrippedTokens)
spanUntil :: TokenVal
-> UnstrippedTokens -> (UnstrippedTokens, UnstrippedTokens)
spanUntil TokenVal
token
    = ([Token] -> UnstrippedTokens
UnstrippedTokens ([Token] -> UnstrippedTokens)
-> ([Token] -> UnstrippedTokens)
-> ([Token], [Token])
-> (UnstrippedTokens, UnstrippedTokens)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Token] -> UnstrippedTokens
UnstrippedTokens)
    (([Token], [Token]) -> (UnstrippedTokens, UnstrippedTokens))
-> (UnstrippedTokens -> ([Token], [Token]))
-> UnstrippedTokens
-> (UnstrippedTokens, UnstrippedTokens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenVal -> TokenVal -> Bool
forall a. Eq a => a -> a -> Bool
== TokenVal
token) (TokenVal -> Bool) -> (Token -> TokenVal) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenVal
forall a. Pos a -> a
valOf)
    ([Token] -> ([Token], [Token]))
-> (UnstrippedTokens -> [Token])
-> UnstrippedTokens
-> ([Token], [Token])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnstrippedTokens -> [Token]
unstrippedTokensOf

-- | Crude predicate for Haskell files
isHsFile :: FilePath -> Bool
isHsFile :: String -> Bool
isHsFile = Maybe (ProcessMode, LitMode Void) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ProcessMode, LitMode Void) -> Bool)
-> (String -> Maybe (ProcessMode, LitMode Void)) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (ProcessMode, LitMode Void)
determineModes

defaultModes :: (ProcessMode, LitMode Void)
defaultModes :: (ProcessMode, LitMode Void)
defaultModes = (ProcessMode
ProcessVanilla, LitMode Void
forall a. LitMode a
LitVanilla)

determineModes :: FilePath -> Maybe (ProcessMode, LitMode Void)
determineModes :: String -> Maybe (ProcessMode, LitMode Void)
determineModes String
x = case ShowS
FilePath.takeExtension String
x of
    String
".hs"  -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode, LitMode Void)
defaultModes
    String
".hsc" -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode, LitMode Void)
defaultModes
    String
".lhs" -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode
ProcessVanilla, LitMode Void
forall a. LitMode a
LitOutside)
    String
".x"   -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode
ProcessAlexHappy, LitMode Void
forall a. LitMode a
LitVanilla)
    String
".y"   -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode
ProcessAlexHappy, LitMode Void
forall a. LitMode a
LitVanilla)
    String
".lx"  -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode
ProcessAlexHappy, LitMode Void
forall a. LitMode a
LitOutside)
    String
".ly"  -> (ProcessMode, LitMode Void) -> Maybe (ProcessMode, LitMode Void)
forall a. a -> Maybe a
Just (ProcessMode
ProcessAlexHappy, LitMode Void
forall a. LitMode a
LitOutside)
    String
_      -> Maybe (ProcessMode, LitMode Void)
forall a. Maybe a
Nothing