-- Based on a version of
-- (c) Bertram Felgenhauer, 2011

{- HLINT ignore "Avoid lambda" -}
{- HLINT ignore "Use camelCase" -}

{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Haskell.Template.Match where

import qualified Language.Haskell.Exts.SrcLoc     as S

import Control.Applicative              (Alternative (..))
import Control.Monad (
  MonadPlus (..),
  ap,
  liftM,
  msum,
  unless,
  void,
  when,
  )
import Control.Monad.State              (State, evalState, gets, put)
import Data.Function                    (on)
import Data.Generics
  (Data (..), GenericM, GenericM' (..), GenericQ, cast, gfoldlAccum, gmapQ)
import Data.List                        (insertBy)
import Data.Maybe                       (isJust)
import Language.Haskell.Exts.Syntax

data Where = OnlyTemplate | OnlySubmission
  deriving (Where -> Where -> Bool
(Where -> Where -> Bool) -> (Where -> Where -> Bool) -> Eq Where
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Where -> Where -> Bool
== :: Where -> Where -> Bool
$c/= :: Where -> Where -> Bool
/= :: Where -> Where -> Bool
Eq, Eq Where
Eq Where
-> (Where -> Where -> Ordering)
-> (Where -> Where -> Bool)
-> (Where -> Where -> Bool)
-> (Where -> Where -> Bool)
-> (Where -> Where -> Bool)
-> (Where -> Where -> Where)
-> (Where -> Where -> Where)
-> Ord Where
Where -> Where -> Bool
Where -> Where -> Ordering
Where -> Where -> Where
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
$ccompare :: Where -> Where -> Ordering
compare :: Where -> Where -> Ordering
$c< :: Where -> Where -> Bool
< :: Where -> Where -> Bool
$c<= :: Where -> Where -> Bool
<= :: Where -> Where -> Bool
$c> :: Where -> Where -> Bool
> :: Where -> Where -> Bool
$c>= :: Where -> Where -> Bool
>= :: Where -> Where -> Bool
$cmax :: Where -> Where -> Where
max :: Where -> Where -> Where
$cmin :: Where -> Where -> Where
min :: Where -> Where -> Where
Ord, Int -> Where -> ShowS
[Where] -> ShowS
Where -> String
(Int -> Where -> ShowS)
-> (Where -> String) -> ([Where] -> ShowS) -> Show Where
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Where -> ShowS
showsPrec :: Int -> Where -> ShowS
$cshow :: Where -> String
show :: Where -> String
$cshowList :: [Where] -> ShowS
showList :: [Where] -> ShowS
Show)

data What
  = CompleteModule
  | Declaration
  | HeadOfModule
  | ModuleImport
  | Pragma
  deriving (What -> What -> Bool
(What -> What -> Bool) -> (What -> What -> Bool) -> Eq What
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: What -> What -> Bool
== :: What -> What -> Bool
$c/= :: What -> What -> Bool
/= :: What -> What -> Bool
Eq, Eq What
Eq What
-> (What -> What -> Ordering)
-> (What -> What -> Bool)
-> (What -> What -> Bool)
-> (What -> What -> Bool)
-> (What -> What -> Bool)
-> (What -> What -> What)
-> (What -> What -> What)
-> Ord What
What -> What -> Bool
What -> What -> Ordering
What -> What -> What
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
$ccompare :: What -> What -> Ordering
compare :: What -> What -> Ordering
$c< :: What -> What -> Bool
< :: What -> What -> Bool
$c<= :: What -> What -> Bool
<= :: What -> What -> Bool
$c> :: What -> What -> Bool
> :: What -> What -> Bool
$c>= :: What -> What -> Bool
>= :: What -> What -> Bool
$cmax :: What -> What -> What
max :: What -> What -> What
$cmin :: What -> What -> What
min :: What -> What -> What
Ord, Int -> What -> ShowS
[What] -> ShowS
What -> String
(Int -> What -> ShowS)
-> (What -> String) -> ([What] -> ShowS) -> Show What
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> What -> ShowS
showsPrec :: Int -> What -> ShowS
$cshow :: What -> String
show :: What -> String
$cshowList :: [What] -> ShowS
showList :: [What] -> ShowS
Show)

data Location
   = SrcSpanInfo What Where S.SrcSpanInfo
   | SrcSpanInfoPair What S.SrcSpanInfo S.SrcSpanInfo
  deriving (Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
/= :: Location -> Location -> Bool
Eq, Eq Location
Eq Location
-> (Location -> Location -> Ordering)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Location)
-> (Location -> Location -> Location)
-> Ord Location
Location -> Location -> Bool
Location -> Location -> Ordering
Location -> Location -> Location
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
$ccompare :: Location -> Location -> Ordering
compare :: Location -> Location -> Ordering
$c< :: Location -> Location -> Bool
< :: Location -> Location -> Bool
$c<= :: Location -> Location -> Bool
<= :: Location -> Location -> Bool
$c> :: Location -> Location -> Bool
> :: Location -> Location -> Bool
$c>= :: Location -> Location -> Bool
>= :: Location -> Location -> Bool
$cmax :: Location -> Location -> Location
max :: Location -> Location -> Location
$cmin :: Location -> Location -> Location
min :: Location -> Location -> Location
Ord, Int -> Location -> ShowS
[Location] -> ShowS
Location -> String
(Int -> Location -> ShowS)
-> (Location -> String) -> ([Location] -> ShowS) -> Show Location
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Location -> ShowS
showsPrec :: Int -> Location -> ShowS
$cshow :: Location -> String
show :: Location -> String
$cshowList :: [Location] -> ShowS
showList :: [Location] -> ShowS
Show)

data Result a = Continue | Fail [Location] | Ok a
    deriving (Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
/= :: Result a -> Result a -> Bool
Eq, Eq (Result a)
Eq (Result a)
-> (Result a -> Result a -> Ordering)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Result a)
-> (Result a -> Result a -> Result a)
-> Ord (Result a)
Result a -> Result a -> Bool
Result a -> Result a -> Ordering
Result a -> Result a -> Result a
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
forall {a}. Ord a => Eq (Result a)
forall a. Ord a => Result a -> Result a -> Bool
forall a. Ord a => Result a -> Result a -> Ordering
forall a. Ord a => Result a -> Result a -> Result a
$ccompare :: forall a. Ord a => Result a -> Result a -> Ordering
compare :: Result a -> Result a -> Ordering
$c< :: forall a. Ord a => Result a -> Result a -> Bool
< :: Result a -> Result a -> Bool
$c<= :: forall a. Ord a => Result a -> Result a -> Bool
<= :: Result a -> Result a -> Bool
$c> :: forall a. Ord a => Result a -> Result a -> Bool
> :: Result a -> Result a -> Bool
$c>= :: forall a. Ord a => Result a -> Result a -> Bool
>= :: Result a -> Result a -> Bool
$cmax :: forall a. Ord a => Result a -> Result a -> Result a
max :: Result a -> Result a -> Result a
$cmin :: forall a. Ord a => Result a -> Result a -> Result a
min :: Result a -> Result a -> Result a
Ord, Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
showsPrec :: Int -> Result a -> ShowS
$cshow :: forall a. Show a => Result a -> String
show :: Result a -> String
$cshowList :: forall a. Show a => [Result a] -> ShowS
showList :: [Result a] -> ShowS
Show)

newtype M a = M { forall a. M a -> State Location (Result a)
runM :: State Location (Result a) }

instance Monad M where
  return :: forall a. a -> M a
return = a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  M a
a >>= :: forall a b. M a -> (a -> M b) -> M b
>>= a -> M b
b = State Location (Result b) -> M b
forall a. State Location (Result a) -> M a
M (State Location (Result b) -> M b)
-> State Location (Result b) -> M b
forall a b. (a -> b) -> a -> b
$ do
    Result a
a' <- M a -> State Location (Result a)
forall a. M a -> State Location (Result a)
runM M a
a
    case Result a
a' of
      Ok a
a'' -> M b -> State Location (Result b)
forall a. M a -> State Location (Result a)
runM (a -> M b
b a
a'')
      Fail [Location]
loc -> Result b -> State Location (Result b)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result b -> State Location (Result b))
-> Result b -> State Location (Result b)
forall a b. (a -> b) -> a -> b
$ [Location] -> Result b
forall a. [Location] -> Result a
Fail [Location]
loc
      Result a
Continue -> Result b -> State Location (Result b)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return   Result b
forall a. Result a
Continue

instance Functor M where
  fmap :: forall a b. (a -> b) -> M a -> M b
fmap = (a -> b) -> M a -> M b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative M where
  pure :: forall a. a -> M a
pure = State Location (Result a) -> M a
forall a. State Location (Result a) -> M a
M (State Location (Result a) -> M a)
-> (a -> State Location (Result a)) -> a -> M a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> State Location (Result a))
-> (a -> Result a) -> a -> State Location (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a
forall a. a -> Result a
Ok
  <*> :: forall a b. M (a -> b) -> M a -> M b
(<*>) = M (a -> b) -> M a -> M b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance MonadPlus M where
  mzero :: forall a. M a
mzero = State Location (Result a) -> M a
forall a. State Location (Result a) -> M a
M (State Location (Result a) -> M a)
-> State Location (Result a) -> M a
forall a b. (a -> b) -> a -> b
$ Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
Continue
  M a
a mplus :: forall a. M a -> M a -> M a
`mplus` M a
b = State Location (Result a) -> M a
forall a. State Location (Result a) -> M a
M (State Location (Result a) -> M a)
-> State Location (Result a) -> M a
forall a b. (a -> b) -> a -> b
$ do
    Result a
a' <- M a -> State Location (Result a)
forall a. M a -> State Location (Result a)
runM M a
a
    case Result a
a' of
      Result a
Continue -> M a -> State Location (Result a)
forall a. M a -> State Location (Result a)
runM M a
b
      Fail [Location]
la  -> do
        Result a
b' <- M a -> State Location (Result a)
forall a. M a -> State Location (Result a)
runM M a
b
        case Result a
b' of
          Ok a
_ -> Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
b'
          Fail [Location]
lb -> Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> State Location (Result a))
-> Result a -> State Location (Result a)
forall a b. (a -> b) -> a -> b
$ [Location] -> Result a
forall a. [Location] -> Result a
Fail ([Location] -> Result a) -> [Location] -> Result a
forall a b. (a -> b) -> a -> b
$ [Location]
la [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location]
lb
          Result a
_    -> Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
a' -- Propagate failure information
      Result a
_ -> Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
a'

instance Alternative M where
  <|> :: forall a. M a -> M a -> M a
(<|>) = M a -> M a -> M a
forall a. M a -> M a -> M a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
  empty :: forall a. M a
empty = M a
forall a. M a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | underline the part of the input that is in the span,
-- and add some lines of contexts before and after. Returns lines.
highlight_ssi :: S.SrcSpanInfo -> Int -> String -> [String ]
highlight_ssi :: SrcSpanInfo -> Int -> String -> [String]
highlight_ssi SrcSpanInfo
info Int
context String
input =
  let spanI :: SrcSpan
spanI = SrcSpanInfo -> SrcSpan
S.srcInfoSpan SrcSpanInfo
info
      start :: (Int, Int)
start@(Int
start_line, Int
_) = SrcSpan -> (Int, Int)
S.srcSpanStart SrcSpan
spanI
      end :: (Int, Int)
end@(Int
end_line, Int
_) = SrcSpan -> (Int, Int)
S.srcSpanEnd SrcSpan
spanI
      ([(Int, String)]
pre_mid, [(Int, String)]
post) = Int -> [(Int, String)] -> ([(Int, String)], [(Int, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
end_line ([(Int, String)] -> ([(Int, String)], [(Int, String)]))
-> [(Int, String)] -> ([(Int, String)], [(Int, String)])
forall a b. (a -> b) -> a -> b
$ [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ Int
1 .. ] ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
input
      ([(Int, String)]
pre, [(Int, String)]
mid) = Int -> [(Int, String)] -> ([(Int, String)], [(Int, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
start_line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, String)]
pre_mid
      underlined :: [String]
underlined = do
        (Int
row, String
line) <- [(Int, String)]
mid
        let under :: String
under = do
              (Int
col, Char
_) <- [Int] -> String -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] String
line
              let here :: (Int, Int)
here = (Int
row,Int
col)
              Char -> String
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String) -> Char -> String
forall a b. (a -> b) -> a -> b
$ if (Int, Int)
start (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
here Bool -> Bool -> Bool
&& (Int, Int)
here (Int, Int) -> (Int, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int, Int)
end then Char
'^' else Char
' '
        [String
line, String
under]
      ekat :: Int -> [a] -> [a]
ekat Int
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
  in  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [ ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a b. (a, b) -> b
snd ([(Int, String)] -> [String]) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, String)] -> [(Int, String)]
forall a. Int -> [a] -> [a]
ekat Int
context [(Int, String)]
pre
         , [String]
underlined
         , ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a b. (a, b) -> b
snd ([(Int, String)] -> [String]) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, String)] -> [(Int, String)]
forall a. Int -> [a] -> [a]
take Int
context [(Int, String)]
post
         ]

data DeclarationKind l =
    TypeDeclaration {
        forall l. DeclarationKind l -> String
name  :: String
      }
  | FunctionDeclaration {
      name    :: String,
      forall l. DeclarationKind l -> (Rhs l, [Pat l], Maybe (Binds l))
funPart :: (Rhs l, [Pat l], Maybe (Binds l))
    }
  | Unnamed {
      forall l. DeclarationKind l -> Decl l
decl :: Decl l
  }

instance Eq (DeclarationKind l) where
  k1 :: DeclarationKind l
k1@TypeDeclaration {} == :: DeclarationKind l -> DeclarationKind l -> Bool
== k2 :: DeclarationKind l
k2@TypeDeclaration {} =
    DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k2
  k1 :: DeclarationKind l
k1@FunctionDeclaration {} == k2 :: DeclarationKind l
k2@FunctionDeclaration {} =
    DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k2
  Unnamed {} == Unnamed {} = Bool
True
  DeclarationKind l
_       == DeclarationKind l
_       = Bool
False

instance Ord l => Ord (DeclarationKind l) where
  k1 :: DeclarationKind l
k1@TypeDeclaration {} compare :: DeclarationKind l -> DeclarationKind l -> Ordering
`compare` k2 :: DeclarationKind l
k2@TypeDeclaration {} =
    DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k2
  k1 :: DeclarationKind l
k1@FunctionDeclaration {} `compare` k2 :: DeclarationKind l
k2@FunctionDeclaration {} =
    DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` DeclarationKind l -> String
forall l. DeclarationKind l -> String
name DeclarationKind l
k2
  Unnamed Decl l
d1 `compare` Unnamed Decl l
d2 = Decl l
d1 Decl l -> Decl l -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Decl l
d2
  TypeDeclaration {}     `compare` DeclarationKind l
_ = Ordering
GT
  FunctionDeclaration {} `compare` DeclarationKind l
_ = Ordering
GT
  Unnamed {}             `compare` DeclarationKind l
_ = Ordering
LT

type Decl' l b = (DeclarationKind l, b)

partitionByKind
  :: Ord l
  => [Decl' l b]
  -> ([Decl' l b], [Decl' l b], [Decl' l b])
partitionByKind :: forall l b.
Ord l =>
[Decl' l b] -> ([Decl' l b], [Decl' l b], [Decl' l b])
partitionByKind []     = ([], [], [])
partitionByKind (Decl' l b
n:[Decl' l b]
ns) = case Decl' l b -> DeclarationKind l
forall a b. (a, b) -> a
fst Decl' l b
n of
  TypeDeclaration {} ->
    (Decl' l b -> [Decl' l b] -> [Decl' l b]
forall {b}.
(DeclarationKind l, b)
-> [(DeclarationKind l, b)] -> [(DeclarationKind l, b)]
insert' Decl' l b
n [Decl' l b]
ts, [Decl' l b]
fs, [Decl' l b]
us)
  FunctionDeclaration {} ->
    ([Decl' l b]
ts, Decl' l b -> [Decl' l b] -> [Decl' l b]
forall {b}.
(DeclarationKind l, b)
-> [(DeclarationKind l, b)] -> [(DeclarationKind l, b)]
insert' Decl' l b
n [Decl' l b]
fs, [Decl' l b]
us)
  Unnamed {} ->
    ([Decl' l b]
ts, [Decl' l b]
fs, Decl' l b -> [Decl' l b] -> [Decl' l b]
forall {b}.
(DeclarationKind l, b)
-> [(DeclarationKind l, b)] -> [(DeclarationKind l, b)]
insert' Decl' l b
n [Decl' l b]
us)
  where
    ([Decl' l b]
ts, [Decl' l b]
fs, [Decl' l b]
us) = [Decl' l b] -> ([Decl' l b], [Decl' l b], [Decl' l b])
forall l b.
Ord l =>
[Decl' l b] -> ([Decl' l b], [Decl' l b], [Decl' l b])
partitionByKind [Decl' l b]
ns
    insert' :: (DeclarationKind l, b)
-> [(DeclarationKind l, b)] -> [(DeclarationKind l, b)]
insert'      = ((DeclarationKind l, b) -> (DeclarationKind l, b) -> Ordering)
-> (DeclarationKind l, b)
-> [(DeclarationKind l, b)]
-> [(DeclarationKind l, b)]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy (DeclarationKind l -> DeclarationKind l -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DeclarationKind l -> DeclarationKind l -> Ordering)
-> ((DeclarationKind l, b) -> DeclarationKind l)
-> (DeclarationKind l, b)
-> (DeclarationKind l, b)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (DeclarationKind l, b) -> DeclarationKind l
forall a b. (a, b) -> a
fst)

-- fail, returning most recently seen location
failLoc :: forall a . M a
failLoc :: forall a. M a
failLoc = State Location (Result a) -> M a
forall a. State Location (Result a) -> M a
M (State Location (Result a) -> M a)
-> State Location (Result a) -> M a
forall a b. (a -> b) -> a -> b
$ (Location -> Result a) -> State Location (Result a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Location -> Result a) -> State Location (Result a))
-> (Location -> Result a) -> State Location (Result a)
forall a b. (a -> b) -> a -> b
$ [Location] -> Result a
forall a. [Location] -> Result a
Fail ([Location] -> Result a)
-> (Location -> [Location]) -> Location -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
:[])

continue :: forall a . M a
continue :: forall a. M a
continue = State Location (Result a) -> M a
forall a. State Location (Result a) -> M a
M (State Location (Result a) -> M a)
-> State Location (Result a) -> M a
forall a b. (a -> b) -> a -> b
$ Result a -> State Location (Result a)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
forall a. Result a
Continue

onlyTemplate :: Annotated a => What -> a S.SrcSpanInfo -> Location
onlyTemplate :: forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlyTemplate What
w = What -> Where -> SrcSpanInfo -> Location
SrcSpanInfo What
w Where
OnlyTemplate (SrcSpanInfo -> Location)
-> (a SrcSpanInfo -> SrcSpanInfo) -> a SrcSpanInfo -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a SrcSpanInfo -> SrcSpanInfo
forall l. a l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann

onlySubmission :: Annotated a => What -> a S.SrcSpanInfo -> Location
onlySubmission :: forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlySubmission What
w = What -> Where -> SrcSpanInfo -> Location
SrcSpanInfo What
w Where
OnlySubmission (SrcSpanInfo -> Location)
-> (a SrcSpanInfo -> SrcSpanInfo) -> a SrcSpanInfo -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a SrcSpanInfo -> SrcSpanInfo
forall l. a l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann

-- match reference to "undefined"
matchUndef :: forall a . Maybe (Exp a) -> Bool
matchUndef :: forall a. Maybe (Exp a) -> Bool
matchUndef (Just (Var a
_ (UnQual a
_ (Ident a
_ String
"undefined")))) = Bool
True
matchUndef Maybe (Exp a)
_ = Bool
False

{-|
Stores src span locations in state.
In contrast to 'matchSrcSpanInfo' it checks also arguments of constructors for
existing 'S.SrcSpanInfo'.
(uses 'matchSrcSpanInfo')
-}
matchSrcSpanInfoSub :: (Data a, Data b) => What -> a -> b -> M ()
matchSrcSpanInfoSub :: forall a b. (Data a, Data b) => What -> a -> b -> M ()
matchSrcSpanInfoSub What
w a
f1 b
f2 = do
  let fs1 :: [Maybe SrcSpanInfo]
fs1 = (Maybe SrcSpanInfo -> Bool)
-> [Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe SrcSpanInfo -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo])
-> [Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> Maybe SrcSpanInfo)
-> a -> [Maybe SrcSpanInfo]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ d -> Maybe SrcSpanInfo
forall d. Data d => d -> Maybe SrcSpanInfo
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
f1
      fs2 :: [Maybe SrcSpanInfo]
fs2 = (Maybe SrcSpanInfo -> Bool)
-> [Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe SrcSpanInfo -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo])
-> [Maybe SrcSpanInfo] -> [Maybe SrcSpanInfo]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> Maybe SrcSpanInfo)
-> b -> [Maybe SrcSpanInfo]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> b -> [u]
gmapQ d -> Maybe SrcSpanInfo
forall d. Data d => d -> Maybe SrcSpanInfo
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
f2
  (Maybe SrcSpanInfo -> Maybe SrcSpanInfo -> M ())
-> (Maybe SrcSpanInfo, Maybe SrcSpanInfo) -> M ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (What -> Maybe SrcSpanInfo -> Maybe SrcSpanInfo -> M ()
matchSrcSpanInfo What
w) ((Maybe SrcSpanInfo, Maybe SrcSpanInfo) -> M ())
-> [(Maybe SrcSpanInfo, Maybe SrcSpanInfo)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Maybe SrcSpanInfo]
-> [Maybe SrcSpanInfo] -> [(Maybe SrcSpanInfo, Maybe SrcSpanInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe SrcSpanInfo]
fs1 [Maybe SrcSpanInfo]
fs2
  What -> Maybe SrcSpanInfo -> Maybe SrcSpanInfo -> M ()
matchSrcSpanInfo What
w (a -> Maybe SrcSpanInfo
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
f1) (b -> Maybe SrcSpanInfo
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
f2)

-- match locations: store given locations
matchSrcSpanInfo :: What -> Maybe S.SrcSpanInfo -> Maybe S.SrcSpanInfo -> M ()
matchSrcSpanInfo :: What -> Maybe SrcSpanInfo -> Maybe SrcSpanInfo -> M ()
matchSrcSpanInfo What
w (Just SrcSpanInfo
this) (Just SrcSpanInfo
that) =
  State Location (Result ()) -> M ()
forall a. State Location (Result a) -> M a
M (() -> Result ()
forall a. a -> Result a
Ok (() -> Result ())
-> StateT Location Identity () -> State Location (Result ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> StateT Location Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (What -> SrcSpanInfo -> SrcSpanInfo -> Location
SrcSpanInfoPair What
w SrcSpanInfo
this SrcSpanInfo
that))
matchSrcSpanInfo What
w (Just SrcSpanInfo
this) Maybe SrcSpanInfo
Nothing =
  State Location (Result ()) -> M ()
forall a. State Location (Result a) -> M a
M (() -> Result ()
forall a. a -> Result a
Ok (() -> Result ())
-> StateT Location Identity () -> State Location (Result ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> StateT Location Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (What -> Where -> SrcSpanInfo -> Location
SrcSpanInfo What
w Where
OnlyTemplate SrcSpanInfo
this))
matchSrcSpanInfo What
w Maybe SrcSpanInfo
Nothing (Just SrcSpanInfo
that) =
  State Location (Result ()) -> M ()
forall a. State Location (Result a) -> M a
M (() -> Result ()
forall a. a -> Result a
Ok (() -> Result ())
-> StateT Location Identity () -> State Location (Result ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Location -> StateT Location Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (What -> Where -> SrcSpanInfo -> Location
SrcSpanInfo What
w Where
OnlySubmission SrcSpanInfo
that))
matchSrcSpanInfo What
_ Maybe SrcSpanInfo
_ Maybe SrcSpanInfo
_ = M ()
forall a. M a
continue

getFunctionName
  :: Decl l
  -> [(DeclarationKind l, Decl l)]
getFunctionName :: forall l. Decl l -> [(DeclarationKind l, Decl l)]
getFunctionName Decl l
d = case Decl l
d of
  TypeSig l
x [Name l]
xs Type l
tf ->
    [ (String -> DeclarationKind l
forall l. String -> DeclarationKind l
TypeDeclaration String
n, l -> [Name l] -> Type l -> Decl l
forall l. l -> [Name l] -> Type l -> Decl l
TypeSig l
x [Name l
i] Type l
tf)
    | i :: Name l
i@(Ident l
_ String
n) <- [Name l]
xs]
  PatBind l
_ (PVar l
_ (Ident l
_ String
n)) Rhs l
rhs Maybe (Binds l)
where_ ->
    [(String -> (Rhs l, [Pat l], Maybe (Binds l)) -> DeclarationKind l
forall l.
String -> (Rhs l, [Pat l], Maybe (Binds l)) -> DeclarationKind l
FunctionDeclaration String
n (Rhs l
rhs, [], Maybe (Binds l)
where_), Decl l
d)]
  FunBind l
_ [Match l]
xs ->
    [ (String -> (Rhs l, [Pat l], Maybe (Binds l)) -> DeclarationKind l
forall l.
String -> (Rhs l, [Pat l], Maybe (Binds l)) -> DeclarationKind l
FunctionDeclaration String
n (Rhs l
rhs, [Pat l]
vs, Maybe (Binds l)
where_), l -> [Match l] -> Decl l
forall l. l -> [Match l] -> Decl l
FunBind l
s [Match l
m])
    | m :: Match l
m@(Match l
s (Ident l
_ String
n) [Pat l]
vs Rhs l
rhs Maybe (Binds l)
where_) <- [Match l]
xs]
  Decl l
_ -> [(Decl l -> DeclarationKind l
forall l. Decl l -> DeclarationKind l
Unnamed Decl l
d, Decl l
d)]

matchList
  :: (Annotated a, Data (a S.SrcSpanInfo))
  => What
  -> [a S.SrcSpanInfo]
  -> [a S.SrcSpanInfo]
  -> [Location]
matchList :: forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
w (a SrcSpanInfo
x:[a SrcSpanInfo]
xs) (a SrcSpanInfo
y:[a SrcSpanInfo]
ys) = What -> a SrcSpanInfo -> a SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w a SrcSpanInfo
x a SrcSpanInfo
y [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
w [a SrcSpanInfo]
xs [a SrcSpanInfo]
ys
matchList What
_ []     []     = []
matchList What
w (a SrcSpanInfo
x:[a SrcSpanInfo]
xs) []     = What -> a SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlyTemplate   What
w a SrcSpanInfo
x Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
w [a SrcSpanInfo]
xs []
matchList What
w []     (a SrcSpanInfo
y:[a SrcSpanInfo]
ys) = What -> a SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlySubmission What
w a SrcSpanInfo
y Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
w [] [a SrcSpanInfo]
ys

matchMaybe
  :: (Annotated a, Data (a S.SrcSpanInfo))
  => What
  -> Maybe (a S.SrcSpanInfo)
  -> Maybe (a S.SrcSpanInfo)
  -> [Location]
matchMaybe :: forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What
-> Maybe (a SrcSpanInfo) -> Maybe (a SrcSpanInfo) -> [Location]
matchMaybe What
_ Maybe (a SrcSpanInfo)
Nothing   Maybe (a SrcSpanInfo)
Nothing   = []
matchMaybe What
w Maybe (a SrcSpanInfo)
Nothing   (Just a SrcSpanInfo
w2) = [What -> a SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlySubmission What
w a SrcSpanInfo
w2]
matchMaybe What
w (Just a SrcSpanInfo
w1) Maybe (a SrcSpanInfo)
Nothing   = [What -> a SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlyTemplate What
w a SrcSpanInfo
w1]
matchMaybe What
w (Just a SrcSpanInfo
w1) (Just a SrcSpanInfo
w2) = What -> a SrcSpanInfo -> a SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w a SrcSpanInfo
w1 a SrcSpanInfo
w2

-- match a bunch of declarations.
matchDecl :: [Decl S.SrcSpanInfo] -> [Decl S.SrcSpanInfo] -> [Location]
matchDecl :: [Decl SrcSpanInfo] -> [Decl SrcSpanInfo] -> [Location]
matchDecl [Decl SrcSpanInfo]
ds1 [Decl SrcSpanInfo]
ds2 =
  [Location]
types [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location]
functions [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location]
unnamed
  where
    types :: [Location]
types     = What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
Declaration [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1t [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2t
    functions :: [Location]
functions = What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
Declaration [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1f [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2f
    unnamed :: [Location]
unnamed   = What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
Declaration [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1u [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2u
    ([(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1t, [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1f, [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1u) = [Decl SrcSpanInfo]
-> ([(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)],
    [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)],
    [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)])
forall {l} {t :: * -> *}.
(Ord l, Foldable t) =>
t (Decl l)
-> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)])
splitNamed [Decl SrcSpanInfo]
ds1
    ([(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2t, [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2f, [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2u) = [Decl SrcSpanInfo]
-> ([(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)],
    [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)],
    [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)])
forall {l} {t :: * -> *}.
(Ord l, Foldable t) =>
t (Decl l)
-> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)])
splitNamed [Decl SrcSpanInfo]
ds2
    splitNamed :: t (Decl l)
-> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)])
splitNamed t (Decl l)
ds = [Decl' l (Decl l)]
-> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)])
forall l b.
Ord l =>
[Decl' l b] -> ([Decl' l b], [Decl' l b], [Decl' l b])
partitionByKind ([Decl' l (Decl l)]
 -> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)]))
-> [Decl' l (Decl l)]
-> ([Decl' l (Decl l)], [Decl' l (Decl l)], [Decl' l (Decl l)])
forall a b. (a -> b) -> a -> b
$ (Decl l -> [Decl' l (Decl l)]) -> t (Decl l) -> [Decl' l (Decl l)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl l -> [Decl' l (Decl l)]
forall l. Decl l -> [(DeclarationKind l, Decl l)]
getFunctionName t (Decl l)
ds

go
  :: What
  -> [(DeclarationKind S.SrcSpanInfo, Decl S.SrcSpanInfo)]
  -> [(DeclarationKind S.SrcSpanInfo, Decl S.SrcSpanInfo)]
  -> [Location]
go :: What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w ds1 :: [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1@((DeclarationKind SrcSpanInfo
n1, Decl SrcSpanInfo
d1) : [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1') ds2 :: [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2@((DeclarationKind SrcSpanInfo
n2, Decl SrcSpanInfo
d2) : [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2')
  | Unnamed {} <- DeclarationKind SrcSpanInfo
n1 = What -> Decl SrcSpanInfo -> Decl SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w Decl SrcSpanInfo
d1 Decl SrcSpanInfo
d2 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
  | Unnamed {} <- DeclarationKind SrcSpanInfo
n2 = What -> Decl SrcSpanInfo -> Decl SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w Decl SrcSpanInfo
d1 Decl SrcSpanInfo
d2 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
  | String
n1' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2' = case DeclarationKind SrcSpanInfo
n1 of
      -- allow replacing 'foo = undefined' by one or more bindings of 'foo'.
      FunctionDeclaration String
_ (rhs1 :: Rhs SrcSpanInfo
rhs1@(UnGuardedRhs SrcSpanInfo
_ Exp SrcSpanInfo
u), [Pat SrcSpanInfo]
vs1, Maybe (Binds SrcSpanInfo)
w1) -> case DeclarationKind SrcSpanInfo
n2 of
        FunctionDeclaration String
_ (Rhs SrcSpanInfo
rhs2, [Pat SrcSpanInfo]
vs2, Maybe (Binds SrcSpanInfo)
w2) ->
          What -> [Pat SrcSpanInfo] -> [Pat SrcSpanInfo] -> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
w [Pat SrcSpanInfo]
vs1 [Pat SrcSpanInfo]
vs2
          [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ (if Maybe (Exp SrcSpanInfo) -> Bool
forall a. Maybe (Exp a) -> Bool
matchUndef (Exp SrcSpanInfo -> Maybe (Exp SrcSpanInfo)
forall a. a -> Maybe a
Just Exp SrcSpanInfo
u)
               then []
               else What -> Rhs SrcSpanInfo -> Rhs SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w Rhs SrcSpanInfo
rhs1 Rhs SrcSpanInfo
rhs2)
          [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
          [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> Maybe (Binds SrcSpanInfo)
-> Maybe (Binds SrcSpanInfo)
-> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What
-> Maybe (a SrcSpanInfo) -> Maybe (a SrcSpanInfo) -> [Location]
matchMaybe What
w Maybe (Binds SrcSpanInfo)
w1 Maybe (Binds SrcSpanInfo)
w2
        DeclarationKind SrcSpanInfo
_ -> What -> Decl SrcSpanInfo -> Decl SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w Decl SrcSpanInfo
d1 Decl SrcSpanInfo
d2 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
      DeclarationKind SrcSpanInfo
_ -> What -> Decl SrcSpanInfo -> Decl SrcSpanInfo -> [Location]
forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w Decl SrcSpanInfo
d1 Decl SrcSpanInfo
d2 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
  | String
n1' String -> String -> Bool
forall a. Ord a => a -> a -> Bool
< String
n2' = What -> Decl SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlyTemplate   What
w Decl SrcSpanInfo
d1 Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1' [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2
  | Bool
otherwise = What -> Decl SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlySubmission What
w Decl SrcSpanInfo
d2 Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: What
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
-> [Location]
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds1  [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
ds2'
  where
    n1' :: String
n1' = DeclarationKind SrcSpanInfo -> String
forall l. DeclarationKind l -> String
name DeclarationKind SrcSpanInfo
n1
    n2' :: String
n2' = DeclarationKind SrcSpanInfo -> String
forall l. DeclarationKind l -> String
name DeclarationKind SrcSpanInfo
n2
go What
_ [] [] = []
go What
w [] [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
fs = What -> Decl SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlySubmission What
w (Decl SrcSpanInfo -> Location)
-> ((DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)
    -> Decl SrcSpanInfo)
-> (DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)
-> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeclarationKind SrcSpanInfo, Decl SrcSpanInfo) -> Decl SrcSpanInfo
forall a b. (a, b) -> b
snd ((DeclarationKind SrcSpanInfo, Decl SrcSpanInfo) -> Location)
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)] -> [Location]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
fs
go What
w [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
fs [] = What -> Decl SrcSpanInfo -> Location
forall (a :: * -> *).
Annotated a =>
What -> a SrcSpanInfo -> Location
onlyTemplate   What
w (Decl SrcSpanInfo -> Location)
-> ((DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)
    -> Decl SrcSpanInfo)
-> (DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)
-> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeclarationKind SrcSpanInfo, Decl SrcSpanInfo) -> Decl SrcSpanInfo
forall a b. (a, b) -> b
snd ((DeclarationKind SrcSpanInfo, Decl SrcSpanInfo) -> Location)
-> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)] -> [Location]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DeclarationKind SrcSpanInfo, Decl SrcSpanInfo)]
fs

withCast
  :: (Data a, Data b, Data t1, Data t2)
  => (t1 -> t2 -> [Location]) -> a -> b -> M c
withCast :: forall a b t1 t2 c.
(Data a, Data b, Data t1, Data t2) =>
(t1 -> t2 -> [Location]) -> a -> b -> M c
withCast t1 -> t2 -> [Location]
m a
a b
b = case (a -> Maybe t1
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a, b -> Maybe t2
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b) of
  (Just t1
a', Just t2
b') -> State Location (Result c) -> M c
forall a. State Location (Result a) -> M a
M (State Location (Result c) -> M c)
-> State Location (Result c) -> M c
forall a b. (a -> b) -> a -> b
$ Result c -> State Location (Result c)
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result c -> State Location (Result c))
-> Result c -> State Location (Result c)
forall a b. (a -> b) -> a -> b
$ [Location] -> Result c
forall a. [Location] -> Result a
Fail ([Location] -> Result c) -> [Location] -> Result c
forall a b. (a -> b) -> a -> b
$ t1 -> t2 -> [Location]
m t1
a' t2
b'
  (Maybe t1, Maybe t2)
_                  -> M c
forall a. M a
continue

-- match syntax trees
match :: Data a => What -> a -> GenericM M
match :: forall a. Data a => What -> a -> GenericM M
match What
w a
f1 a
f2 = do
  [M ()] -> M ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
    -- 1. locations (see above)
    M () -> M ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ What -> a -> a -> M ()
forall a b. (Data a, Data b) => What -> a -> b -> M ()
matchSrcSpanInfoSub What
w a
f1 a
f2,

    -- 2. declarations (see above)
    ([Decl SrcSpanInfo] -> [Decl SrcSpanInfo] -> [Location])
-> a -> a -> M ()
forall a b t1 t2 c.
(Data a, Data b, Data t1, Data t2) =>
(t1 -> t2 -> [Location]) -> a -> b -> M c
withCast [Decl SrcSpanInfo] -> [Decl SrcSpanInfo] -> [Location]
matchDecl a
f1 a
f2,

    -- 3. undefined  may be replaced by any expression
    Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (Exp SrcSpanInfo) -> Bool
forall a. Maybe (Exp a) -> Bool
matchUndef (a -> Maybe (Exp SrcSpanInfo)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
f1 :: Maybe (Exp S.SrcSpanInfo))) M ()
forall a. M a
continue,

    -- otherwise, compare constructors and match arguments
    do  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Constr
forall a. Data a => a -> Constr
toConstr a
f1 Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
/= a -> Constr
forall a. Data a => a -> Constr
toConstr a
f2) M ()
forall a. M a
failLoc
        M a -> M ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (GenericQ (GenericM M) -> GenericQ (GenericM M)
forall (m :: * -> *).
Monad m =>
GenericQ (GenericM m) -> GenericQ (GenericM m)
gzipWithM' (What -> a -> GenericM M
forall a. Data a => What -> a -> GenericM M
match What
w) a
f1 a
f2)
    ]
  a -> M a
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return a
f2

matchLocation :: (Data a, Data b) => What -> a -> b -> [Location]
matchLocation :: forall a b. (Data a, Data b) => What -> a -> b -> [Location]
matchLocation What
w a
f1 b
f2=
  case State Location (Result b) -> Location -> Result b
forall s a. State s a -> s -> a
evalState (M b -> State Location (Result b)
forall a. M a -> State Location (Result a)
runM (What -> a -> GenericM M
forall a. Data a => What -> a -> GenericM M
match What
w a
f1 b
f2)) (Location -> Result b) -> Location -> Result b
forall a b. (a -> b) -> a -> b
$ What -> SrcSpanInfo -> SrcSpanInfo -> Location
SrcSpanInfoPair What
w SrcSpanInfo
S.noSrcSpan SrcSpanInfo
S.noSrcSpan of
    Fail [Location]
loc -> [Location]
loc
    Ok b
_     -> []
    Result b
Continue -> []

matchModule :: Module S.SrcSpanInfo -> Module S.SrcSpanInfo -> M ()
matchModule :: Module SrcSpanInfo -> Module SrcSpanInfo -> M ()
matchModule (Module SrcSpanInfo
_ Maybe (ModuleHead SrcSpanInfo)
h1 [ModulePragma SrcSpanInfo]
p1 [ImportDecl SrcSpanInfo]
i1 [Decl SrcSpanInfo]
d1) (Module SrcSpanInfo
_ Maybe (ModuleHead SrcSpanInfo)
h2 [ModulePragma SrcSpanInfo]
p2 [ImportDecl SrcSpanInfo]
i2 [Decl SrcSpanInfo]
d2) = do
  let r :: [Location]
r = What
-> Maybe (ModuleHead SrcSpanInfo)
-> Maybe (ModuleHead SrcSpanInfo)
-> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What
-> Maybe (a SrcSpanInfo) -> Maybe (a SrcSpanInfo) -> [Location]
matchMaybe What
HeadOfModule Maybe (ModuleHead SrcSpanInfo)
h1 Maybe (ModuleHead SrcSpanInfo)
h2
        [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [ModulePragma SrcSpanInfo]
-> [ModulePragma SrcSpanInfo]
-> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
Pragma [ModulePragma SrcSpanInfo]
p1 [ModulePragma SrcSpanInfo]
p2
        [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ What
-> [ImportDecl SrcSpanInfo]
-> [ImportDecl SrcSpanInfo]
-> [Location]
forall (a :: * -> *).
(Annotated a, Data (a SrcSpanInfo)) =>
What -> [a SrcSpanInfo] -> [a SrcSpanInfo] -> [Location]
matchList What
ModuleImport [ImportDecl SrcSpanInfo]
i1 [ImportDecl SrcSpanInfo]
i2
        [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Decl SrcSpanInfo] -> [Decl SrcSpanInfo] -> [Location]
matchDecl [Decl SrcSpanInfo]
d1 [Decl SrcSpanInfo]
d2
  if [Location] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Location]
r
    then State Location (Result ()) -> M ()
forall a. State Location (Result a) -> M a
M (State Location (Result ()) -> M ())
-> State Location (Result ()) -> M ()
forall a b. (a -> b) -> a -> b
$ Result () -> State Location (Result ())
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result () -> State Location (Result ()))
-> Result () -> State Location (Result ())
forall a b. (a -> b) -> a -> b
$ () -> Result ()
forall a. a -> Result a
Ok ()
    else State Location (Result ()) -> M ()
forall a. State Location (Result a) -> M a
M (State Location (Result ()) -> M ())
-> State Location (Result ()) -> M ()
forall a b. (a -> b) -> a -> b
$ Result () -> State Location (Result ())
forall a. a -> StateT Location Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result () -> State Location (Result ()))
-> Result () -> State Location (Result ())
forall a b. (a -> b) -> a -> b
$ [Location] -> Result ()
forall a. [Location] -> Result a
Fail [Location]
r
matchModule Module SrcSpanInfo
m1 Module SrcSpanInfo
m2 = do
  What -> Module SrcSpanInfo -> Module SrcSpanInfo -> M ()
forall a b. (Data a, Data b) => What -> a -> b -> M ()
matchSrcSpanInfoSub What
CompleteModule Module SrcSpanInfo
m1 Module SrcSpanInfo
m2
  M ()
forall a. M a
failLoc

-- | test whether @m2@ is a suitable template for @m1@
-- in case of an error, the returned '[Location]' gives the mismatching
-- positions in the template
test :: Module S.SrcSpanInfo -> Module S.SrcSpanInfo -> Result ()
test :: Module SrcSpanInfo -> Module SrcSpanInfo -> Result ()
test Module SrcSpanInfo
m1 Module SrcSpanInfo
m2 =
  -- first: parse using haskell-src.
  -- ParseOk m1' = parseModule m1
  -- ParseOk m2' = parseModule m2
  State Location (Result ()) -> Location -> Result ()
forall s a. State s a -> s -> a
evalState (M () -> State Location (Result ())
forall a. M a -> State Location (Result a)
runM (Module SrcSpanInfo -> Module SrcSpanInfo -> M ()
matchModule Module SrcSpanInfo
m1 Module SrcSpanInfo
m2)) (Location -> Result ()) -> Location -> Result ()
forall a b. (a -> b) -> a -> b
$ What -> SrcSpanInfo -> SrcSpanInfo -> Location
SrcSpanInfoPair What
CompleteModule SrcSpanInfo
S.noSrcSpan SrcSpanInfo
S.noSrcSpan
------------------------------------------------------------------------------
-- | Twin map for monadic transformation
--
-- Unlike gzipWithM, process constructor arguments from left to right.
gzipWithM' :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
gzipWithM' :: forall (m :: * -> *).
Monad m =>
GenericQ (GenericM m) -> GenericQ (GenericM m)
gzipWithM' GenericQ (GenericM m)
f a
x a
y = case (forall e. Data e => [GenericM' m] -> e -> ([GenericM' m], m e))
-> [GenericM' m] -> a -> ([GenericM' m], m a)
forall a d (m :: * -> *).
(Data d, Monad m) =>
(forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d)
gmapAccumM' [GenericM' m] -> e -> ([GenericM' m], m e)
forall e. Data e => [GenericM' m] -> e -> ([GenericM' m], m e)
forall {a} {m :: * -> *}.
Data a =>
[GenericM' m] -> a -> ([GenericM' m], m a)
perkid [GenericM' m]
funs a
y of
                    ([], m a
c) -> m a
c
                    ([GenericM' m], m a)
_       -> String -> m a
forall a. HasCallStack => String -> a
error String
"gzipWithM"
 where
  perkid :: [GenericM' m] -> a -> ([GenericM' m], m a)
perkid (GenericM' m
a:[GenericM' m]
as) a
d = ([GenericM' m]
as, GenericM' m -> GenericM m
forall (m :: * -> *). GenericM' m -> GenericM m
unGM GenericM' m
a a
d)
  funs :: [GenericM' m]
funs = (forall d. Data d => d -> GenericM' m) -> a -> [GenericM' m]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ (\d
k -> GenericM m -> GenericM' m
forall (m :: * -> *). GenericM m -> GenericM' m
GM (d -> GenericM m
GenericQ (GenericM m)
f d
k)) a
x

-- | gmapM with accumulation
--
-- Unlike gmapAccumM, process constructor arguments from left to right.
gmapAccumM' :: forall a d m . (Data d, Monad m)
           => (forall e. Data e => a -> e -> (a, m e))
           -> a -> d -> (a, m d)
gmapAccumM' :: forall a d (m :: * -> *).
(Data d, Monad m) =>
(forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d)
gmapAccumM' forall e. Data e => a -> e -> (a, m e)
f (a
a ::a) (d
d :: d) = (forall e r. Data e => a -> m (e -> r) -> e -> (a, m r))
-> (forall g. a -> g -> (a, m g)) -> a -> d -> (a, m d)
forall d a (c :: * -> *).
Data d =>
(forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))
-> (forall g. a -> g -> (a, c g)) -> a -> d -> (a, c d)
gfoldlAccum a -> m (e -> r) -> e -> (a, m r)
forall e r. Data e => a -> m (e -> r) -> e -> (a, m r)
forall e r. Data r => a -> m (r -> e) -> r -> (a, m e)
k a -> g -> (a, m g)
forall g. a -> g -> (a, m g)
forall {m :: * -> *} {a} {a}. Monad m => a -> a -> (a, m a)
t a
a d
d :: (a, m d)
 where
  k :: forall e r . Data r => a -> m (r -> e) -> r -> (a, m e)
  k :: forall e r. Data r => a -> m (r -> e) -> r -> (a, m e)
k a
x m (r -> e)
y r
z = let (a
x',m r
z') = a -> r -> (a, m r)
forall e. Data e => a -> e -> (a, m e)
f a
x r
z
             in (a
x', m (r -> e)
y m (r -> e) -> ((r -> e) -> m e) -> m e
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r -> e
y' -> m r
z' m r -> (r -> m e) -> m e
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r
z'' -> e -> m e
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> e
y' r
z''))
  t :: a -> a -> (a, m a)
t a
x a
y = (a
x, a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y)