brittany/doc/showcases/Parser.md

Input

contains some very long lines and strange formatting of the list/monad-comprehension:

parseCalUnits :: forall m . (MonadMultiReader ParserWrapperGuard m, MonadMultiState ParserFileCache m, MonadIO m) => [GenericParser] -> [FilePath] -> m (Either Text [CalUnit])
parseCalUnits parsers inputs = fmap (fmap join . sequence) $ inputs `forM` \path -> do
  readCachedFile path (\raw -> parseChunks $ createChunks $ (Text.pack path, raw))
 where

  createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])]
  createChunks (file, input) = fmap ((,) file) $ groupBy (\a b -> grouper (snd a) (snd b)) $ dropWhile (lineIsSpace . snd) $ zip [1 ..] $ lineMapper <$> Text.lines input
   where
    headerParser :: Parser (Text, Bool, Text)
    headerParser =
      [ (Text.pack name, isMain, Text.pack typ)
        | _ <- string "node", _ <- many1 $ oneOf " \t",
          isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t")),
          name <- many1 $ noneOf " \t\r\n:",
          _ <- many $ oneOf " \t",
          _ <- char ':',
          _ <- many $ oneOf " \t",
          typ <- many1 $ satisfy $ not . isSpace,
          _ <- many $ oneOf " \t",
          _ <- eof ]
    lineMapper :: Text -> InputLine
    lineMapper line = case runParser headerParser () "" line of
      Left  _e -> NormalLine line
      Right (n, m, t) -> HeaderLine n m t
    lineIsSpace :: InputLine -> Bool
    lineIsSpace (NormalLine x) = Text.null $ Text.strip x
    lineIsSpace _ = False
    grouper :: InputLine -> InputLine -> Bool
    grouper _ HeaderLine{} = False
    grouper _ _ = True

  parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit])
  parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes)
   where
    findParser :: Text -> Maybe GenericParser
    findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers
    parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit
    parseNode file ((n, HeaderLine name isMain typ):rlines) = do
      (GenericParser p) <- case findParser typ of
        Nothing -> left $ Text.pack "could not find parser for node \"" <> name <> Text.pack "\" of type \"" <> typ <> Text.pack "\" at " <> file <> Text.pack (": " ++ show n ++ ".")
        Just x -> return x
      let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines
      ParserDataStore dstore version <- _pfc_store <$> mGet
      let postfix = Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")"
      parsed <- bimapEitherT (<>postfix) id $ hoistEither $ parser_parse p file firstLine $ Text.unlines $ [ fst $ Text.breakOn (Text.pack "--") line | (_, NormalLine line) <- rlines ]
      let oldDat = case M.lookup name dstore of
            Nothing -> parser_zero p $> version
            Just s -> case decodeOrFail s of
              Right (rest, _, decoded) | BSL.null rest -> decoded
              _ -> parser_zero p $> version
      let (newDat, delta) = parser_diff p version oldDat (parsed $> version)
      pfc <- mGet
      mSet $ pfc { _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore) version }
      let calUnit = parser_build p version name (newDat, delta)
      return $ CalUnit isMain calUnit
    parseNode file ((n, _):_) = left $ Text.pack "expected node definition at " <> file <> Text.pack (": " ++ show n ++ ".")
    parseNode file _ = left $ Text.pack "expected node definition at " <> file <> Text.pack "."
~~~~.hs

### Brittany 0.8.0.1 output on default settings

~~~~.hs
parseCalUnits
  :: forall m
   . ( MonadMultiReader ParserWrapperGuard m
     , MonadMultiState ParserFileCache m
     , MonadIO m
     )
  => [GenericParser]
  -> [FilePath]
  -> m (Either Text [CalUnit])
parseCalUnits parsers inputs =
  fmap (fmap join . sequence) $ inputs `forM` \path -> do
    readCachedFile
      path
      (\raw -> parseChunks $ createChunks $ (Text.pack path, raw))
 where

  createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])]
  createChunks (file, input) =
    fmap ((,) file)
      $   groupBy (\a b -> grouper (snd a) (snd b))
      $   dropWhile (lineIsSpace . snd)
      $   zip [1 ..]
      $   lineMapper
      <$> Text.lines input
   where
    headerParser :: Parser (Text, Bool, Text)
    headerParser =
      [ (Text.pack name, isMain, Text.pack typ)
      | _      <- string "node"
      , _      <- many1 $ oneOf " \t"
      , isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t"))
      , name   <- many1 $ noneOf " \t\r\n:"
      , _      <- many $ oneOf " \t"
      , _      <- char ':'
      , _      <- many $ oneOf " \t"
      , typ    <- many1 $ satisfy $ not . isSpace
      , _      <- many $ oneOf " \t"
      , _      <- eof
      ]
    lineMapper :: Text -> InputLine
    lineMapper line = case runParser headerParser () "" line of
      Left  _e        -> NormalLine line
      Right (n, m, t) -> HeaderLine n m t
    lineIsSpace :: InputLine -> Bool
    lineIsSpace (NormalLine x) = Text.null $ Text.strip x
    lineIsSpace _              = False
    grouper :: InputLine -> InputLine -> Bool
    grouper _ HeaderLine{} = False
    grouper _ _            = True

  parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit])
  parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes)
   where
    findParser :: Text -> Maybe GenericParser
    findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers
    parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit
    parseNode file ((n, HeaderLine name isMain typ):rlines) = do
      (GenericParser p) <- case findParser typ of
        Nothing ->
          left
            $  Text.pack "could not find parser for node \""
            <> name
            <> Text.pack "\" of type \""
            <> typ
            <> Text.pack "\" at "
            <> file
            <> Text.pack (": " ++ show n ++ ".")
        Just x -> return x
      let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines
      ParserDataStore dstore version <- _pfc_store <$> mGet
      let postfix =
            Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")"
      parsed <-
        bimapEitherT (<>postfix) id
        $ hoistEither
        $ parser_parse p file firstLine
        $ Text.unlines
        $ [ fst $ Text.breakOn (Text.pack "--") line
          | (_, NormalLine line) <- rlines
          ]
      let oldDat = case M.lookup name dstore of
            Nothing -> parser_zero p $> version
            Just s  -> case decodeOrFail s of
              Right (rest, _, decoded) | BSL.null rest -> decoded
              _ -> parser_zero p $> version
      let (newDat, delta) = parser_diff p version oldDat (parsed $> version)
      pfc <- mGet
      mSet $ pfc
        { _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore)
                                       version
        }
      let calUnit = parser_build p version name (newDat, delta)
      return $ CalUnit isMain calUnit
    parseNode file ((n, _):_) =
      left $ Text.pack "expected node definition at " <> file <> Text.pack
        (": " ++ show n ++ ".")
    parseNode file _ =
      left $ Text.pack "expected node definition at " <> file <> Text.pack "."