hydrogen-cli-0.14: src/H/Dump.hs

module H.Dump where

import H.Common

import Hydrogen.Parsing hiding (parse, token)
import Hydrogen.Syntax.Parser
import Hydrogen.Syntax.Types
import Hydrogen.Data
import qualified Hydrogen.MultiMap as MultiMap

main :: Tool
main _ args = do

    let (options, switches, files) = getOpts args [
            '1' ~: switch "tokens"
          , '2' ~: switch "layout"
          , '3' ~: switch "values"
          , '4' ~: switch "program"
          , 's' ~: optarg "spaces"
          , 'c' ~: optarg "comments"
          , 'O' ~: optarg "opening-braces"
          , 'C' ~: optarg "closing-braces"
          , 'i' ~: optarg "indent-token"
          , 'S' ~: optarg "special"
          , 'X' ~: optarg "special-syntax"
          , 'F' ~: optarg "fold-specials"
          ]

        tokenizerConfig = foldl setConfig def (MultiMap.toList' options)
          where
            setConfig b = \case
                ("spaces", x) -> b { cfgSpaces = x }
                ("special", x) -> b { cfgSpecialCharacters = x }
                ("comments", x) -> b { cfgComments = x }
                ("fold-specials", x) -> b { cfgFoldSpecials = x }
                ("opening-braces", x) -> b { cfgOpeningBraces = x }
                ("closing-braces", x) -> b { cfgClosingBraces = x }
                ("special-syntax", x) -> b { cfgSpecialSemantics = x }
                _ -> b
        layoutConfig = foldl setConfig def (MultiMap.toList' options)
          where
            setConfig b = \case
                ("indent-token", x) -> b { cfgIndentToken = x }
                _ -> b

        layoutConfig' = layoutConfig {
              cfgValueTokens = readValue
            , cfgBlockTransformer = \case
                Block Grouping "" [] -> Value (mkValue ()) ""
                x -> x
            }

        report = concatMap showMessage . nub
          where
            showMessage (pos, message) = printf "%4d%4d %s\n"
                (sourceLine pos) (sourceColumn pos) message

        func
          | switches ? "tokens"
                = either report showTokens . parseTokens tokenizerConfig "-"
          | switches ? "layout"
                = either report showLayout . parse' tokenizerConfig layoutConfig "-"
          | switches ? "values"
                = either report showLayout . parse' tokenizerConfig layoutConfig' "-"
          | switches ? "program"
                = either report showLayout . parse' tokenizerConfig layoutConfig' "-"
          | otherwise
                = const "Need -1, -2, -3, or -4"

        showTokens = concatMap showToken
        showToken (pos, token) = printf "%4d%4d %s\n"
            (sourceLine pos) (sourceColumn pos) (show token)

        showLayout = concat . showPOPs "" []
        showPOPs indent backlog = \case
            (pos, pop) : ps -> case pop of
                Token t k x -> printf "%4d%4d %s%s %s %s\n"
                    (sourceLine pos) (sourceColumn pos) indent (show t) k x
                    : showPOPs indent backlog ps
                Block t x pops -> printf "%4d%4d %s%s %s\n"
                    (sourceLine pos) (sourceColumn pos) indent (show t) x
                    : showPOPs ("  " ++ indent) (ps : backlog) pops
                Value v s -> printf "%4d%4d %s%s (%s)\n"
                    (sourceLine pos) (sourceColumn pos) indent (show v) s
                    : showPOPs indent backlog ps

            [] | null backlog -> []
               | otherwise -> showPOPs (drop 2 indent) (tail backlog) (head backlog)
        
    onFiles (putStr . func) files