module Language.Haskell.Modules.Fold
( foldModule
, foldHeader
, foldExports
, foldImports
, foldDecls
, echo
, echo2
, ignore
, ignore2
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.State (get, put, runState, State)
import Data.Char (isSpace)
import Data.List (tails)
import Data.Monoid ((<>), Monoid)
import Data.Sequence (Seq, (|>))
import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl, ExportSpec, ExportSpec(..), ExportSpecList(ExportSpecList), ImportDecl, Module(..), ModuleHead(..), ModuleName, ModulePragma, WarningText)
import Language.Haskell.Exts.Comments (Comment(..))
import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..))
import Language.Haskell.Modules.ModuVerse (ModuleInfo(ModuleInfo))
import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText)
type ModulePragma = A.ModulePragma SrcSpanInfo
type ModuleName = A.ModuleName SrcSpanInfo
type WarningText = A.WarningText SrcSpanInfo
type ExportSpec = A.ExportSpec SrcSpanInfo
type ImportDecl = A.ImportDecl SrcSpanInfo
type Decl = A.Decl SrcSpanInfo
class Spans a where
spans :: a -> [SrcSpanInfo]
instance Spans (A.Module SrcSpanInfo) where
spans (A.Module _sp mh ps is ds) =
concatMap spans ps ++ maybe [] spans mh ++ concatMap spans is ++ concatMap spans ds
spans _ = error "spans XML module"
instance Spans (A.ModuleHead SrcSpanInfo) where
spans (A.ModuleHead _ n mw me) = spans n ++ maybe [] spans mw ++ maybe [] spans me
instance Spans (A.ExportSpecList SrcSpanInfo) where
spans (A.ExportSpecList _ es) = concatMap spans es
instance Spans (A.ExportSpec SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
instance Spans (A.ModulePragma SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
instance Spans (A.ImportDecl SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
instance Spans (A.Decl SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
instance Spans (A.ModuleName SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
instance Spans (A.WarningText SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]
fixSpan :: SrcSpanInfo -> SrcSpanInfo
fixSpan sp =
if srcSpanEndColumn (srcInfoSpan sp) == 0
then sp {srcInfoSpan = (srcInfoSpan sp) {srcSpanEndColumn = 1}}
else sp
data St
= St { loc_ :: SrcLoc
, text_ :: String
, comms_ :: [Comment]
, sps_ :: [SrcSpanInfo] }
deriving (Show)
setSpanEnd :: SrcLoc -> SrcSpan -> SrcSpan
setSpanEnd loc sp = sp {srcSpanEndLine = srcLine loc, srcSpanEndColumn = srcColumn loc}
adjustSpans :: String -> [Comment] -> [SrcSpanInfo] -> [SrcSpanInfo]
adjustSpans _ _ [] = []
adjustSpans _ _ [x] = [x]
adjustSpans text comments sps@(x : _) =
fst $ runState f (St (SrcLoc (srcFilename (srcLoc x)) 1 1) text comments sps)
where
f = do st <- get
let b = loc_ st
case sps_ st of
(ss1 : ssis) ->
do skip
st' <- get
let e = loc_ st'
case e >= endLoc ss1 of
True ->
do put (st' {sps_ = ssis})
sps' <- f
let ss1' = ss1 {srcInfoSpan = setSpanEnd b (srcInfoSpan ss1)}
return (ss1' : sps')
False ->
do case text_ st' of
"" -> return (sps_ st')
(c : t') -> do put (st' {text_ = t', loc_ = increaseSrcLoc [c] e})
f
sss -> return sss
skip :: State St ()
skip = do loc1 <- loc_ <$> get
skipWhite
skipComment
loc2 <- loc_ <$> get
when (loc1 /= loc2) skip
skipWhite :: State St ()
skipWhite = do st <- get
case span isSpace (text_ st) of
("", _) -> return ()
(space, t') ->
let loc' = increaseSrcLoc space (loc_ st) in
put (st {loc_ = loc', text_ = t'})
skipComment :: State St ()
skipComment = do st <- get
case comms_ st of
(Comment _ csp _ : cs)
| srcLoc csp <= loc_ st ->
case srcPairText (loc_ st) (endLoc csp) (text_ st) of
("", _) -> return ()
(comm, t') ->
let loc' = increaseSrcLoc comm (loc_ st) in
put (st {loc_ = loc',
text_ = t',
comms_ = cs})
_ -> return ()
foldModule :: forall r. (Show r) =>
(String -> r -> r)
-> (ModulePragma -> String -> String -> String -> r -> r)
-> (ModuleName -> String -> String -> String -> r -> r)
-> (WarningText -> String -> String -> String -> r -> r)
-> (String -> r -> r)
-> (ExportSpec -> String -> String -> String -> r -> r)
-> (String -> r -> r)
-> (ImportDecl -> String -> String -> String -> r -> r)
-> (Decl -> String -> String -> String -> r -> r)
-> (String -> r -> r)
-> ModuleInfo
-> r
-> r
foldModule _ _ _ _ _ _ _ _ _ _ (ModuleInfo (A.XmlPage _ _ _ _ _ _ _) _ _ _) _ = error "XmlPage: unsupported"
foldModule _ _ _ _ _ _ _ _ _ _ (ModuleInfo (A.XmlHybrid _ _ _ _ _ _ _ _ _) _ _ _) _ = error "XmlHybrid: unsupported"
foldModule topf pragmaf namef warnf pref exportf postf importf declf sepf (ModuleInfo (m@(A.Module (SrcSpanInfo (SrcSpan path _ _ _ _) _) mh ps is ds)) text comments _) r0 =
(\ (_, (_, _, _, r)) -> r) $ runState doModule (text, (SrcLoc path 1 1), spans m, r0)
where
doModule =
do doSep topf
doList pragmaf ps
maybe (return ()) doHeader mh
(tl, l, sps, r) <- get
put (tl, l, adjustSpans text comments sps, r)
doList importf is
doList declf ds
doTail sepf
doHeader (A.ModuleHead sp n mw me) =
do doItem namef n
maybe (return ()) (doItem warnf) mw
doSep pref
maybe (return ()) (\ (A.ExportSpecList _ es) -> doList exportf es) me
doClose postf sp
doClose f sp =
do (tl, l, sps, r) <- get
case l < endLoc sp of
True ->
let (p, s) = srcPairText l (endLoc sp) tl in
put (s, endLoc sp, sps, f p r)
False -> return ()
doTail f =
do (tl, l, sps, r) <- get
put (tl, l, sps, f tl r)
doSep :: (String -> r -> r) -> State (String, SrcLoc, [SrcSpanInfo], r) ()
doSep f =
do p <- get
case p of
(tl, l, sps@(sp : _), r) ->
do let l' = srcLoc sp
case l <= l' of
True ->
let (b, a) = srcPairText l l' tl in
put (a, l', sps, f b r)
False -> return ()
_ -> error $ "foldModule - out of spans: " ++ show p
doList :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> [a] -> State (String, SrcLoc, [SrcSpanInfo], r) ()
doList _ [] = return ()
doList f (x : xs) = doItem f x >> doList f xs
doItem :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> a -> State (String, SrcLoc, [SrcSpanInfo], r) ()
doItem f x =
do (tl, l, (sp : sps'), r) <- get
let
(pre, tl') = srcPairText l (srcLoc sp) tl
l' = endLoc sp
(s, tl'') = srcPairText (srcLoc sp) l' tl'
l'' = adjust1 tl'' l'
(post, tl''') = srcPairText l' l'' tl''
put (tl''', l'', sps', f x pre s post r)
_adjust :: String -> SrcLoc -> SrcLoc
_adjust a l =
l'
where
w = takeWhile isSpace a
w' = take (length (takeWhile (elem '\n') (tails w))) w
l' = increaseSrcLoc w' l
adjust1 :: String -> SrcLoc -> SrcLoc
adjust1 a l =
l'
where
w = takeWhile isSpace a
w' = case span (/= '\n') w of
(w'', '\n' : _) -> w'' ++ ['\n']
(w'', "") -> w''
_ -> error "Impossible: span stopped on the wrong char"
l' = increaseSrcLoc w' l
foldHeader :: forall r. (Show r) =>
(String -> r -> r)
-> (ModulePragma -> String -> String -> String -> r -> r)
-> (ModuleName -> String -> String -> String -> r -> r)
-> (WarningText -> String -> String -> String -> r -> r)
-> ModuleInfo -> r -> r
foldHeader topf pragmaf namef warnf m r0 =
foldModule topf pragmaf namef warnf ignore2 ignore ignore2 ignore ignore ignore2 m r0
foldExports :: forall r. (Show r) =>
(String -> r -> r)
-> (ExportSpec -> String -> String -> String -> r -> r)
-> (String -> r -> r)
-> ModuleInfo -> r -> r
foldExports pref exportf postf m r0 =
foldModule ignore2 ignore ignore ignore pref exportf postf ignore ignore ignore2 m r0
foldImports :: forall r. (Show r) =>
(ImportDecl -> String -> String -> String -> r -> r)
-> ModuleInfo -> r -> r
foldImports importf m r0 =
foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 importf ignore ignore2 m r0
foldDecls :: forall r. (Show r) =>
(Decl -> String -> String -> String -> r -> r)
-> (String -> r -> r)
-> ModuleInfo -> r -> r
foldDecls declf sepf m r0 =
foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 ignore declf sepf m r0
echo :: Monoid m => t -> m -> m -> m -> Seq m -> Seq m
echo _ pref s suff r = r |> pref <> s <> suff
echo2 :: Monoid m => m -> Seq m -> Seq m
echo2 s r = r |> s
ignore :: t -> m -> m -> m -> r -> r
ignore _ _ _ _ r = r
ignore2 :: m -> r -> r
ignore2 _ r = r