{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module FastTags.Tag (
TagVal(..)
, Type(..)
, Tag(..)
, Pos(..)
, SrcPos(..)
, UnstrippedTokens(..)
, processFile
, qualify
, findSrcPrefix
, process
, tokenizeInput
, processTokens
, isHsFile
, defaultModes
, determineModes
, ProcessMode(..)
, 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
data TagVal = TagVal {
TagVal -> Text
tvName :: !Text
, TagVal -> Type
tvType :: !Type
, TagVal -> Maybe Text
tvParent :: !(Maybe Text)
} 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
data Type =
Function
| Type
| Constructor
| Class
| Module
| Operator
| Pattern
| Family
| 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)
| 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
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
(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
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
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
| ProcessAlexHappy
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 :: 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 :: 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 :: 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
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
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
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
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
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
-> Int
-> Int
-> [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
-> Int
-> Int
-> [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
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)
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
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
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
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
Pos SrcPos
_ TokenVal
KWType : Pos SrcPos
_ TokenVal
KWInstance : [Token]
_ -> []
Pos SrcPos
prevPos TokenVal
KWType : [Token]
toks
| [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
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
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
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
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]
_ -> []
Pos SrcPos
_ TokenVal
KWDeriving : [Token]
_ -> []
Pos SrcPos
pos TokenVal
KWInstance : [Token]
_ -> SrcPos -> UnstrippedTokens -> [Tag]
instanceTags SrcPos
pos (Int -> UnstrippedTokens -> UnstrippedTokens
dropTokens Int
1 UnstrippedTokens
unstripped)
[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)
-> Type
-> SrcPos
-> String
-> [Token]
-> (Maybe Tag, SrcPos, [Token])
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])
(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)
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
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
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
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
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
[] -> [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
([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
| [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
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
functionTags :: ExpectedFuncName
-> [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
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 * ="]
dataConstructorTags :: SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags :: SrcPos -> UnstrippedTokens -> [Tag]
dataConstructorTags SrcPos
prevPos 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)
| Bool
otherwise = case UnstrippedTokens -> [Token]
strip UnstrippedTokens
unstripped of
[] -> []
[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
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
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 }
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
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 =
(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)
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
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
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