never executed always true always false

    1 module Parse.Whitespace where
    2 
    3 import AST.V0_16
    4 import qualified Cheapskate.Types as Markdown
    5 import qualified Data.Char as Char
    6 import Parse.IParser
    7 import qualified Parse.Markdown as Markdown
    8 import qualified Parse.State as State
    9 import qualified Reporting.Error.Syntax as Syntax
   10 import Text.Parsec hiding (newline, spaces, State)
   11 
   12 
   13 padded :: IParser a -> IParser (C2 before after a)
   14 padded p =
   15   do  pre <- whitespace
   16       out <- p
   17       post <- whitespace
   18       return $ C (pre, post) out
   19 
   20 
   21 spaces :: IParser Comments
   22 spaces =
   23   let
   24       blank = string " " >> return []
   25       comment = ((: []) <$> multiComment)
   26       space =
   27         blank
   28         <|> (const [CommentTrickOpener] <$> (try $ string "{--}"))
   29         <|> comment
   30         <?> Syntax.whitespace
   31   in
   32       concat <$> many1 space
   33 
   34 
   35 forcedWS :: IParser Comments
   36 forcedWS =
   37   choice
   38     [ (++) <$> spaces <*> (concat <$> many nl_space)
   39     , concat <$> many1 nl_space
   40     ]
   41   where
   42     nl_space =
   43       try ((++) <$> (concat <$> many1 newline) <*> option [] spaces)
   44 
   45 
   46 -- Just eats whitespace until the next meaningful character.
   47 dumbWhitespace :: IParser Comments
   48 dumbWhitespace =
   49   concat <$> many (spaces <|> newline)
   50 
   51 
   52 whitespace' :: IParser (Bool, Comments)
   53 whitespace' =
   54   option (False, []) ((,) True <$> forcedWS)
   55 
   56 
   57 whitespace :: IParser Comments
   58 whitespace =
   59   snd <$> whitespace'
   60 
   61 
   62 freshLine :: IParser Comments
   63 freshLine =
   64       concat <$> (try ((++) <$> many1 newline <*> many space_nl) <|> try (many1 space_nl)) <?> Syntax.freshLine
   65   where
   66     space_nl = try $ (++) <$> spaces <*> (concat <$> many1 newline)
   67 
   68 
   69 newline :: IParser Comments
   70 newline =
   71     (simpleNewline >> return []) <|> ((\x -> [x]) <$> lineComment) <?> Syntax.newline
   72 
   73 
   74 simpleNewline :: IParser ()
   75 simpleNewline =
   76   do  _ <- try (string "\r\n") <|> string "\n"
   77       updateState State.setNewline
   78       return ()
   79 
   80 
   81 trackNewline :: IParser a -> IParser (a, Multiline)
   82 trackNewline parser =
   83     do
   84         updateState State.pushNewlineContext
   85         a <- parser
   86         state <- getState
   87         updateState State.popNewlineContext
   88         return (a, if State.sawNewline state then SplitAll else JoinAll)
   89 
   90 
   91 lineComment :: IParser Comment
   92 lineComment =
   93   do  _ <- try (string "--")
   94       choice
   95         [ const CommentTrickCloser
   96             <$> try (char '}' >> many (char ' ') >> (simpleNewline <|> eof))
   97         , do
   98             (comment, ()) <-
   99               anyUntil $ simpleNewline <|> eof
  100             return $ LineComment comment
  101         ]
  102 
  103 
  104 restOfLine :: IParser (Maybe String)
  105 restOfLine =
  106     many (char ' ') *>
  107         choice
  108             [ Just . fst <$> (try (string "--") *> (anyUntil $ (lookAhead simpleNewline) <|> eof))
  109             , return Nothing
  110             ]
  111 
  112 
  113 docComment :: IParser String
  114 docComment =
  115   do  _ <- try (string "{-|")
  116       _ <- many (string " ")
  117       closeComment False
  118 
  119 
  120 docCommentAsMarkdown :: IParser Markdown.Blocks
  121 docCommentAsMarkdown =
  122     Markdown.parse <$> docComment
  123 
  124 
  125 multiComment :: IParser Comment
  126 multiComment =
  127   do  _ <- try (string "{-" <* notFollowedBy (string "|") )
  128       isCommentTrick <-
  129         choice
  130           [ char '-' >> return True
  131           , return False
  132           ]
  133       _ <- many (string " ")
  134       b <- closeComment False
  135       return $
  136         if isCommentTrick then
  137           CommentTrickBlock b
  138         else
  139           BlockComment $ trimIndent $ lines b
  140   where
  141       trimIndent [] = []
  142       trimIndent (l1:ls) =
  143           let
  144               leadingIndents =
  145                   map fst $ filter (uncurry (/=))
  146                       $ map (\l -> (length $ takeWhile Char.isSpace l, length l)) ls
  147 
  148               depth =
  149                   case leadingIndents of
  150                       [] -> 0
  151                       _ -> minimum leadingIndents
  152           in
  153               l1 : map (drop depth) ls
  154 
  155 
  156 closeComment :: Bool -> IParser String
  157 closeComment keepClosingPunc =
  158   uncurry (++) <$>
  159     anyUntil
  160       (choice
  161         [ try ((\a b -> if keepClosingPunc then concat (a ++ [b]) else "") <$> many (string " ") <*> string "-}") <?> "the end of a comment -}"
  162         , concat <$> sequence [ try (string "{-"), closeComment True, closeComment keepClosingPunc]
  163         ])
  164 
  165 
  166 anyUntil :: IParser a -> IParser (String, a)
  167 anyUntil end =
  168     go ""
  169   where
  170     next pre =
  171       do
  172         nextChar <- anyChar
  173         go (nextChar : pre)
  174 
  175     go pre =
  176       ((,) (reverse pre) <$> end) <|> next pre