]> git.wincent.com - docvim.git/blob - lib/Docvim/Visitor.hs
6ed3a7da16a2a679c2bb074b288a2bded9bcc2c8
[docvim.git] / lib / Docvim / Visitor.hs
1 {-# LANGUAGE LambdaCase #-}
2 {-# LANGUAGE FlexibleContexts #-}
3
4 module Docvim.Visitor (endBlock, extract, extractBlocks) where
5
6 import Control.Applicative (Alternative, (<|>), empty)
7 import Control.Monad ((>=>))
8 import Control.Monad.Writer (runWriter, tell)
9 import Data.Data.Lens
10 import Docvim.AST
11 import qualified Data.DList as DList
12
13 -- | Returns True if a node marks the end of a region/block.
14 endBlock :: Node -> Bool
15 endBlock = \case
16   CommandAnnotation _    -> True
17   CommandsAnnotation     -> True
18   FooterAnnotation       -> True
19   FunctionAnnotation _   -> True
20   FunctionsAnnotation    -> True
21   MappingAnnotation _    -> True
22   MappingsAnnotation     -> True
23   OptionAnnotation {}    -> True
24   OptionsAnnotation      -> True
25   PluginAnnotation {}    -> True
26   _                      -> False
27
28 extract :: ([Node] -> ([[a]], [Node])) -> Node -> (Node, [a])
29 extract extractNodes = toList . runWriter . postorder uniplate extractor
30   where
31     toList (ast, dlist) = (ast, concat $ DList.toList dlist)
32     extractor (DocBlock nodes) = do
33       let (extracted, remainder) = extractNodes nodes
34       tell (DList.fromList extracted)
35       return (DocBlock remainder)
36     extractor node = return node
37
38 extractBlocks :: Alternative f => (a -> Maybe (a -> Bool)) -> [a] -> (f [a], [a])
39 extractBlocks start = go
40   where
41     go     [] = (empty, [])
42     go (x:xs) = maybe no_extract extract (start x)
43       where
44         no_extract = (extracted, x:unextracted)
45           where
46             ~(extracted, unextracted) = go xs
47         extract stop = (pure (x:block) <|> extracted, unextracted)
48           where
49             ~(block, remainder) = break stop xs
50             ~(extracted, unextracted) = go remainder
51
52 postorder :: Monad m => ((a -> m c) -> (a -> m b)) -> (b -> m c) -> (a -> m c)
53 postorder t f = go
54   where
55     go = t go >=> f