{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Retrie.CPP
( CPP(..)
, addImportsCPP
, parseCPPFile
, parseCPP
, printCPP
, cppFork
) where
import Data.Char (isSpace)
import Data.Function (on)
import Data.Functor.Identity
import Data.List (nubBy, sortOn)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Debug.Trace
import Retrie.ExactPrint
import Retrie.GHC
import Retrie.Replace
data CPP a
= NoCPP a
| CPP Text [AnnotatedImports] [a]
instance Functor CPP where
fmap :: (a -> b) -> CPP a -> CPP b
fmap a -> b
f (NoCPP a
x) = b -> CPP b
forall a. a -> CPP a
NoCPP (a -> b
f a
x)
fmap a -> b
f (CPP Text
orig [AnnotatedImports]
is [a]
xs) = Text -> [AnnotatedImports] -> [b] -> CPP b
forall a. Text -> [AnnotatedImports] -> [a] -> CPP a
CPP Text
orig [AnnotatedImports]
is ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs)
instance Foldable CPP where
foldMap :: (a -> m) -> CPP a -> m
foldMap a -> m
f (NoCPP a
x) = a -> m
f a
x
foldMap a -> m
f (CPP Text
_ [AnnotatedImports]
_ [a]
xs) = (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f [a]
xs
instance Traversable CPP where
traverse :: (a -> f b) -> CPP a -> f (CPP b)
traverse a -> f b
f (NoCPP a
x) = b -> CPP b
forall a. a -> CPP a
NoCPP (b -> CPP b) -> f b -> f (CPP b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
traverse a -> f b
f (CPP Text
orig [AnnotatedImports]
is [a]
xs) = Text -> [AnnotatedImports] -> [b] -> CPP b
forall a. Text -> [AnnotatedImports] -> [a] -> CPP a
CPP Text
orig [AnnotatedImports]
is ([b] -> CPP b) -> f [b] -> f (CPP b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f [a]
xs
addImportsCPP
:: [AnnotatedImports]
-> CPP AnnotatedModule
-> CPP AnnotatedModule
addImportsCPP :: [AnnotatedImports] -> CPP AnnotatedModule -> CPP AnnotatedModule
addImportsCPP [AnnotatedImports]
is (NoCPP AnnotatedModule
m) =
AnnotatedModule -> CPP AnnotatedModule
forall a. a -> CPP a
NoCPP (AnnotatedModule -> CPP AnnotatedModule)
-> AnnotatedModule -> CPP AnnotatedModule
forall a b. (a -> b) -> a -> b
$ Identity AnnotatedModule -> AnnotatedModule
forall a. Identity a -> a
runIdentity (Identity AnnotatedModule -> AnnotatedModule)
-> Identity AnnotatedModule -> AnnotatedModule
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located HsModule -> TransformT Identity (Located HsModule))
-> Identity AnnotatedModule
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
m ((Located HsModule -> TransformT Identity (Located HsModule))
-> Identity AnnotatedModule)
-> (Located HsModule -> TransformT Identity (Located HsModule))
-> Identity AnnotatedModule
forall a b. (a -> b) -> a -> b
$ [AnnotatedImports]
-> Located HsModule -> TransformT Identity (Located HsModule)
forall (m :: * -> *).
Monad m =>
[AnnotatedImports]
-> Located HsModule -> TransformT m (Located HsModule)
insertImports [AnnotatedImports]
is
addImportsCPP [AnnotatedImports]
is (CPP Text
orig [AnnotatedImports]
is' [AnnotatedModule]
ms) = Text
-> [AnnotatedImports] -> [AnnotatedModule] -> CPP AnnotatedModule
forall a. Text -> [AnnotatedImports] -> [a] -> CPP a
CPP Text
orig ([AnnotatedImports]
is[AnnotatedImports] -> [AnnotatedImports] -> [AnnotatedImports]
forall a. [a] -> [a] -> [a]
++[AnnotatedImports]
is') [AnnotatedModule]
ms
parseCPPFile
:: (FilePath -> String -> IO AnnotatedModule)
-> FilePath
-> IO (CPP AnnotatedModule)
parseCPPFile :: (FilePath -> FilePath -> IO AnnotatedModule)
-> FilePath -> IO (CPP AnnotatedModule)
parseCPPFile FilePath -> FilePath -> IO AnnotatedModule
p FilePath
fp =
FilePath -> IO Text
Text.readFile FilePath
fp IO Text
-> (Text -> IO (CPP AnnotatedModule)) -> IO (CPP AnnotatedModule)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO AnnotatedModule)
-> Text -> IO (CPP AnnotatedModule)
forall (m :: * -> *).
Monad m =>
(FilePath -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP (FilePath -> FilePath -> IO AnnotatedModule
p FilePath
fp)
parseCPP
:: Monad m
=> (String -> m AnnotatedModule)
-> Text -> m (CPP AnnotatedModule)
parseCPP :: (FilePath -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP FilePath -> m AnnotatedModule
p Text
orig
| (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
isCPP (Text -> [Text]
Text.lines Text
orig) =
Text
-> [AnnotatedImports] -> [AnnotatedModule] -> CPP AnnotatedModule
forall a. Text -> [AnnotatedImports] -> [a] -> CPP a
CPP Text
orig [] ([AnnotatedModule] -> CPP AnnotatedModule)
-> m [AnnotatedModule] -> m (CPP AnnotatedModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m AnnotatedModule) -> [Text] -> m [AnnotatedModule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> m AnnotatedModule
p (FilePath -> m AnnotatedModule)
-> (Text -> FilePath) -> Text -> m AnnotatedModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack) (Text -> [Text]
cppFork Text
orig)
| Bool
otherwise = AnnotatedModule -> CPP AnnotatedModule
forall a. a -> CPP a
NoCPP (AnnotatedModule -> CPP AnnotatedModule)
-> m AnnotatedModule -> m (CPP AnnotatedModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m AnnotatedModule
p (Text -> FilePath
Text.unpack Text
orig)
printCPP :: [Replacement] -> CPP AnnotatedModule -> String
printCPP :: [Replacement] -> CPP AnnotatedModule -> FilePath
printCPP [Replacement]
_ (NoCPP AnnotatedModule
m) = AnnotatedModule -> FilePath
forall ast. Annotate ast => Annotated (Located ast) -> FilePath
printA AnnotatedModule
m
printCPP [Replacement]
repls (CPP Text
orig [AnnotatedImports]
is [AnnotatedModule]
ms) = Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
case [AnnotatedImports]
is of
[] -> Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
"" Int
1 Int
1 [(RealSrcSpan, FilePath)]
sorted [Text]
origLines
[AnnotatedImports]
_ ->
Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice
([Text] -> Text
Text.unlines [Text]
newHeader)
([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
revHeader Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int
1
[(RealSrcSpan, FilePath)]
sorted
([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
revDecls)
where
sorted :: [(RealSrcSpan, FilePath)]
sorted = ((RealSrcSpan, FilePath) -> RealSrcSpan)
-> [(RealSrcSpan, FilePath)] -> [(RealSrcSpan, FilePath)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (RealSrcSpan, FilePath) -> RealSrcSpan
forall a b. (a, b) -> a
fst
[ (RealSrcSpan
r, FilePath
replReplacement)
| Replacement{FilePath
SrcSpan
replReplacement :: Replacement -> FilePath
replOriginal :: Replacement -> FilePath
replLocation :: Replacement -> SrcSpan
replOriginal :: FilePath
replLocation :: SrcSpan
replReplacement :: FilePath
..} <- [Replacement]
repls
, Just RealSrcSpan
r <- [SrcSpan -> Maybe RealSrcSpan
getRealSpan SrcSpan
replLocation]
]
origLines :: [Text]
origLines = Text -> [Text]
Text.lines Text
orig
mbName :: Maybe ModuleName
mbName = Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName (Located HsModule -> SrcSpanLess (Located HsModule)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located HsModule -> SrcSpanLess (Located HsModule))
-> Located HsModule -> SrcSpanLess (Located HsModule)
forall a b. (a -> b) -> a -> b
$ AnnotatedModule -> Located HsModule
forall ast. Annotated ast -> ast
astA (AnnotatedModule -> Located HsModule)
-> AnnotatedModule -> Located HsModule
forall a b. (a -> b) -> a -> b
$ [AnnotatedModule] -> AnnotatedModule
forall a. [a] -> a
head [AnnotatedModule]
ms)
importLines :: [Text]
importLines = Identity [Text] -> [Text]
forall a. Identity a -> a
runIdentity (Identity [Text] -> [Text]) -> Identity [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Annotated [Text] -> [Text])
-> Identity (Annotated [Text]) -> Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated [Text] -> [Text]
forall ast. Annotated ast -> ast
astA (Identity (Annotated [Text]) -> Identity [Text])
-> Identity (Annotated [Text]) -> Identity [Text]
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> ([LImportDecl GhcPs] -> TransformT Identity [Text])
-> Identity (Annotated [Text])
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA (Maybe ModuleName -> [AnnotatedImports] -> AnnotatedImports
filterAndFlatten Maybe ModuleName
mbName [AnnotatedImports]
is) (([LImportDecl GhcPs] -> TransformT Identity [Text])
-> Identity (Annotated [Text]))
-> ([LImportDecl GhcPs] -> TransformT Identity [Text])
-> Identity (Annotated [Text])
forall a b. (a -> b) -> a -> b
$
(LImportDecl GhcPs -> TransformT Identity Text)
-> [LImportDecl GhcPs] -> TransformT Identity [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((LImportDecl GhcPs -> TransformT Identity Text)
-> [LImportDecl GhcPs] -> TransformT Identity [Text])
-> (LImportDecl GhcPs -> TransformT Identity Text)
-> [LImportDecl GhcPs]
-> TransformT Identity [Text]
forall a b. (a -> b) -> a -> b
$ (Annotated (LImportDecl GhcPs) -> Text)
-> TransformT Identity (Annotated (LImportDecl GhcPs))
-> TransformT Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Text
Text.pack (FilePath -> Text)
-> (Annotated (LImportDecl GhcPs) -> FilePath)
-> Annotated (LImportDecl GhcPs)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (FilePath -> FilePath)
-> (Annotated (LImportDecl GhcPs) -> FilePath)
-> Annotated (LImportDecl GhcPs)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated (LImportDecl GhcPs) -> FilePath
forall ast. Annotate ast => Annotated (Located ast) -> FilePath
printA) (TransformT Identity (Annotated (LImportDecl GhcPs))
-> TransformT Identity Text)
-> (LImportDecl GhcPs
-> TransformT Identity (Annotated (LImportDecl GhcPs)))
-> LImportDecl GhcPs
-> TransformT Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs
-> TransformT Identity (Annotated (LImportDecl GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA
p :: Text -> Bool
p Text
t = Text -> Bool
isImport Text
t Bool -> Bool -> Bool
|| Text -> Bool
isModule Text
t Bool -> Bool -> Bool
|| Text -> Bool
isPragma Text
t
([Text]
revDecls, [Text]
revHeader) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
p ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
origLines)
newHeader :: [Text]
newHeader = [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
revHeader [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
importLines
splice :: Text -> Int -> Int -> [(RealSrcSpan, String)] -> [Text] -> [Text]
splice :: Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
_ Int
_ Int
_ [(RealSrcSpan, FilePath)]
_ [] = []
splice Text
prefix Int
_ Int
_ [] (Text
t:[Text]
ts) = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ts
splice Text
prefix Int
l Int
c rs :: [(RealSrcSpan, FilePath)]
rs@((RealSrcSpan
r, FilePath
repl):[(RealSrcSpan, FilePath)]
rs') ts :: [Text]
ts@(Text
t:[Text]
ts')
| RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l =
Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
"" (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
1 [(RealSrcSpan, FilePath)]
rs [Text]
ts'
| RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l Bool -> Bool -> Bool
|| RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
c =
Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
prefix Int
l Int
c [(RealSrcSpan, FilePath)]
rs' [Text]
ts
| ([Text]
old, Text
ln:[Text]
lns) <- Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) [Text]
ts =
let
start :: Int
start = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
r
end :: Int
end = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
r
prefix' :: Text
prefix' = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c) Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
repl
ln' :: Text
ln' = Int -> Text -> Text
Text.drop (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c) Text
ln
errMsg :: FilePath
errMsg = [FilePath] -> FilePath
unlines
[ FilePath
"Refusing to rewrite across CPP directives."
, FilePath
""
, FilePath
"Location: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
locStr
, FilePath
""
, FilePath
"Original:"
, FilePath
""
, Text -> FilePath
Text.unpack Text
orig
, FilePath
""
, FilePath
"Replacement:"
, FilePath
""
, FilePath
repl
]
orig :: Text
orig =
[Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
old) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Int -> Text -> Text
Text.take (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c) Text
ln]
locStr :: FilePath
locStr = FastString -> FilePath
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
r) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
start
in
if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
isCPP [Text]
old
then FilePath -> [Text] -> [Text]
forall a. FilePath -> a -> a
trace FilePath
errMsg ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
prefix Int
l Int
c [(RealSrcSpan, FilePath)]
rs' [Text]
ts
else Text -> Int -> Int -> [(RealSrcSpan, FilePath)] -> [Text] -> [Text]
splice Text
prefix' (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
r) Int
end [(RealSrcSpan, FilePath)]
rs' (Text
ln'Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
lns)
| Bool
otherwise = FilePath -> [Text]
forall a. HasCallStack => FilePath -> a
error FilePath
"printCPP: impossible replacement past end of file"
cppFork :: Text -> [Text]
cppFork :: Text -> [Text]
cppFork = CPPTree -> [Text]
cppTreeToList (CPPTree -> [Text]) -> (Text -> CPPTree) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CPPTree
mkCPPTree
data CPPTree
= Node [Text] CPPTree CPPTree
| Leaf [Text]
data CPPBranch
= CPPTrue
| CPPFalse
| CPPOmit
mkCPPTree :: Text -> CPPTree
mkCPPTree :: Text -> CPPTree
mkCPPTree = Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
False [] [] ([Text] -> CPPTree) -> (Text -> [Text]) -> Text -> CPPTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
where
go :: Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go :: Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
_ [CPPBranch]
_ [Text]
suffix [] = [Text] -> CPPTree
Leaf [Text]
suffix
go Bool
True [] [Text]
suffix [Text]
ls =
[Text] -> CPPTree
Leaf ([Text] -> [Text] -> [Text]
blankifyAndReverse [Text]
suffix [Text]
ls)
go Bool
seenImport [CPPBranch]
st [Text]
suffix (Text
l:[Text]
ls) =
case Text -> Maybe CPPCond
extractCPPCond Text
l of
Just CPPCond
If ->
case [CPPBranch]
st of
(CPPBranch
_:[CPPBranch]
st') -> [CPPBranch] -> CPPTree
emptyLine [CPPBranch]
st'
[] -> FilePath -> CPPTree
forall a. HasCallStack => FilePath -> a
error FilePath
"mkCPPTree: if with empty stack"
Just CPPCond
ElIf ->
case [CPPBranch]
st of
(CPPBranch
CPPOmit:[CPPBranch]
_) -> [CPPBranch] -> CPPTree
emptyLine [CPPBranch]
st
(CPPBranch
CPPFalse:[CPPBranch]
st') -> [CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPOmitCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st')
(CPPBranch
CPPTrue:[CPPBranch]
st') ->
let
omittedSuffix :: [Text]
omittedSuffix = Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
suffix) Text
""
in
[Text] -> CPPTree -> CPPTree -> CPPTree
Node
[]
([CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPOmitCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st'))
(Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport (CPPBranch
CPPTrueCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st') (Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
omittedSuffix) [Text]
ls)
[] -> FilePath -> CPPTree
forall a. HasCallStack => FilePath -> a
error FilePath
"mkCPPTree: else with empty stack"
Just CPPCond
Else ->
case [CPPBranch]
st of
(CPPBranch
CPPOmit:[CPPBranch]
_) -> [CPPBranch] -> CPPTree
emptyLine [CPPBranch]
st
(CPPBranch
CPPTrue:[CPPBranch]
st') -> [CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPFalseCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st')
(CPPBranch
CPPFalse:[CPPBranch]
st') -> [CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPTrueCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st')
[] -> FilePath -> CPPTree
forall a. HasCallStack => FilePath -> a
error FilePath
"mkCPPTree: else with empty stack"
Just CPPCond
EndIf ->
case [CPPBranch]
st of
(CPPBranch
CPPOmit:[CPPBranch]
_) -> [CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPOmitCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st)
(CPPBranch
CPPFalse:[CPPBranch]
_) -> [CPPBranch] -> CPPTree
emptyLine (CPPBranch
CPPOmitCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st)
[CPPBranch]
_ ->
[Text] -> CPPTree -> CPPTree -> CPPTree
Node
[Text]
suffix
(Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport (CPPBranch
CPPTrueCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st) [Text
""] [Text]
ls)
(Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport (CPPBranch
CPPFalseCPPBranch -> [CPPBranch] -> [CPPBranch]
forall a. a -> [a] -> [a]
:[CPPBranch]
st) [Text
""] [Text]
ls)
Maybe CPPCond
Nothing ->
case [CPPBranch]
st of
(CPPBranch
CPPOmit:[CPPBranch]
_) -> Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport' [CPPBranch]
st (Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
suffix) [Text]
ls
(CPPBranch
CPPFalse:[CPPBranch]
_) -> Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport' [CPPBranch]
st (Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
suffix) [Text]
ls
[CPPBranch]
_ -> Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport' [CPPBranch]
st (Text -> Text
blankCPP Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
suffix) [Text]
ls
where
emptyLine :: [CPPBranch] -> CPPTree
emptyLine [CPPBranch]
st' = Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree
go Bool
seenImport [CPPBranch]
st' (Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
suffix) [Text]
ls
seenImport' :: Bool
seenImport' = Bool
seenImport Bool -> Bool -> Bool
|| Text -> Bool
isImport Text
l
blankifyAndReverse :: [Text] -> [Text] -> [Text]
blankifyAndReverse :: [Text] -> [Text] -> [Text]
blankifyAndReverse [Text]
suffix [] = [Text]
suffix
blankifyAndReverse [Text]
suffix (Text
l:[Text]
ls) = [Text] -> [Text] -> [Text]
blankifyAndReverse (Text -> Text
blankCPP Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
suffix) [Text]
ls
cppTreeToList :: CPPTree -> [Text]
cppTreeToList :: CPPTree -> [Text]
cppTreeToList CPPTree
t = [Text] -> CPPTree -> [Text] -> [Text]
go [] CPPTree
t []
where
go :: [Text] -> CPPTree -> [Text] -> [Text]
go [Text]
rest (Leaf [Text]
suffix) = ([Text] -> Text
Text.unlines ([Text]
suffix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
rest) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
go [Text]
rest (Node [Text]
suffix CPPTree
l CPPTree
r) =
let rest' :: [Text]
rest' = [Text]
suffix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
rest
in [Text] -> CPPTree -> [Text] -> [Text]
go [Text]
rest' CPPTree
l ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> CPPTree -> [Text] -> [Text]
go [Text]
rest' CPPTree
r
data CPPCond = If | ElIf | Else | EndIf
extractCPPCond :: Text -> Maybe CPPCond
Text
t
| Just (Char
'#',Text
t') <- Text -> Maybe (Char, Text)
Text.uncons Text
t =
case Text -> [Text]
Text.words Text
t' of
(Text
"if":[Text]
_) -> CPPCond -> Maybe CPPCond
forall a. a -> Maybe a
Just CPPCond
If
(Text
"else":[Text]
_) -> CPPCond -> Maybe CPPCond
forall a. a -> Maybe a
Just CPPCond
Else
(Text
"elif":[Text]
_) -> CPPCond -> Maybe CPPCond
forall a. a -> Maybe a
Just CPPCond
ElIf
(Text
"endif":[Text]
_) -> CPPCond -> Maybe CPPCond
forall a. a -> Maybe a
Just CPPCond
EndIf
[Text]
_ -> Maybe CPPCond
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe CPPCond
forall a. Maybe a
Nothing
blankCPP :: Text -> Text
blankCPP :: Text -> Text
blankCPP Text
t
| Text -> Bool
isCPP Text
t = Text
""
| Bool
otherwise = Text
t
isCPP :: Text -> Bool
isCPP :: Text -> Bool
isCPP = Text -> Text -> Bool
Text.isPrefixOf Text
"#"
isImport :: Text -> Bool
isImport :: Text -> Bool
isImport = Text -> Text -> Bool
Text.isPrefixOf Text
"import"
isModule :: Text -> Bool
isModule :: Text -> Bool
isModule = Text -> Text -> Bool
Text.isPrefixOf Text
"module"
isPragma :: Text -> Bool
isPragma :: Text -> Bool
isPragma = Text -> Text -> Bool
Text.isPrefixOf Text
"{-#"
insertImports
:: Monad m
=> [AnnotatedImports]
-> Located HsModule
-> TransformT m (Located HsModule)
insertImports :: [AnnotatedImports]
-> Located HsModule -> TransformT m (Located HsModule)
insertImports [AnnotatedImports]
is (L SrcSpan
l HsModule
m) = do
[LImportDecl GhcPs]
imps <- AnnotatedImports -> TransformT m [LImportDecl GhcPs]
forall ast (m :: * -> *).
(Data ast, Monad m) =>
Annotated ast -> TransformT m ast
graftA (AnnotatedImports -> TransformT m [LImportDecl GhcPs])
-> AnnotatedImports -> TransformT m [LImportDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> [AnnotatedImports] -> AnnotatedImports
filterAndFlatten (Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> Maybe (Located ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (Located ModuleName)
forall pass. HsModule pass -> Maybe (Located ModuleName)
hsmodName HsModule
m) [AnnotatedImports]
is
let
deduped :: [LImportDecl GhcPs]
deduped = (LImportDecl GhcPs -> LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
eqImportDecl (ImportDecl GhcPs -> ImportDecl GhcPs -> Bool)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> LImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) ([LImportDecl GhcPs] -> [LImportDecl GhcPs])
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsModule -> [LImportDecl GhcPs]
forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports HsModule
m [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
imps
Located HsModule -> TransformT m (Located HsModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located HsModule -> TransformT m (Located HsModule))
-> Located HsModule -> TransformT m (Located HsModule)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsModule -> Located HsModule
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsModule
m { hsmodImports :: [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
deduped }
filterAndFlatten :: Maybe ModuleName -> [AnnotatedImports] -> AnnotatedImports
filterAndFlatten :: Maybe ModuleName -> [AnnotatedImports] -> AnnotatedImports
filterAndFlatten Maybe ModuleName
mbName [AnnotatedImports]
is =
Identity AnnotatedImports -> AnnotatedImports
forall a. Identity a -> a
runIdentity (Identity AnnotatedImports -> AnnotatedImports)
-> Identity AnnotatedImports -> AnnotatedImports
forall a b. (a -> b) -> a -> b
$ AnnotatedImports
-> ([LImportDecl GhcPs] -> TransformT Identity [LImportDecl GhcPs])
-> Identity AnnotatedImports
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA ([AnnotatedImports] -> AnnotatedImports
forall a. Monoid a => [a] -> a
mconcat [AnnotatedImports]
is) (([LImportDecl GhcPs] -> TransformT Identity [LImportDecl GhcPs])
-> Identity AnnotatedImports)
-> ([LImportDecl GhcPs] -> TransformT Identity [LImportDecl GhcPs])
-> Identity AnnotatedImports
forall a b. (a -> b) -> a -> b
$ [LImportDecl GhcPs] -> TransformT Identity [LImportDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LImportDecl GhcPs] -> TransformT Identity [LImportDecl GhcPs])
-> ([LImportDecl GhcPs] -> [LImportDecl GhcPs])
-> [LImportDecl GhcPs]
-> TransformT Identity [LImportDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ModuleName -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
externalImps Maybe ModuleName
mbName
where
externalImps :: Maybe ModuleName -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
externalImps :: Maybe ModuleName -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
externalImps (Just ModuleName
mn) = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
mn) (ModuleName -> Bool)
-> (LImportDecl GhcPs -> ModuleName) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> (LImportDecl GhcPs -> Located ModuleName)
-> LImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName (ImportDecl GhcPs -> Located ModuleName)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> Located ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> ImportDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
externalImps Maybe ModuleName
_ = [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. a -> a
id
eqImportDecl :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
eqImportDecl :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
eqImportDecl ImportDecl GhcPs
x ImportDecl GhcPs
y =
(ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ModuleName -> ModuleName -> Bool)
-> (ImportDecl GhcPs -> ModuleName)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> Located ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool)
-> (ImportDecl GhcPs -> ImportDeclQualifiedStyle)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (Maybe (Located ModuleName) -> Maybe (Located ModuleName) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe (Located ModuleName) -> Maybe (Located ModuleName) -> Bool)
-> (ImportDecl GhcPs -> Maybe (Located ModuleName))
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Maybe (Located ModuleName)
forall pass. ImportDecl pass -> Maybe (Located ModuleName)
ideclAs) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (Maybe (Bool, Located [LIE GhcPs])
-> Maybe (Bool, Located [LIE GhcPs]) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe (Bool, Located [LIE GhcPs])
-> Maybe (Bool, Located [LIE GhcPs]) -> Bool)
-> (ImportDecl GhcPs -> Maybe (Bool, Located [LIE GhcPs]))
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Maybe (Bool, Located [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (Maybe StringLiteral -> Maybe StringLiteral -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe StringLiteral -> Maybe StringLiteral -> Bool)
-> (ImportDecl GhcPs -> Maybe StringLiteral)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool)
-> (ImportDecl GhcPs -> Bool)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Bool
forall pass. ImportDecl pass -> Bool
ideclSource) ImportDecl GhcPs
x ImportDecl GhcPs
y
Bool -> Bool -> Bool
&& (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool)
-> (ImportDecl GhcPs -> Bool)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Bool
forall pass. ImportDecl pass -> Bool
ideclSafe) ImportDecl GhcPs
x ImportDecl GhcPs
y