git @ Cat's Eye Technologies Fountain / master src / Main.hs
master

Tree @master (Download .tar.gz)

Main.hs @master — raw · history · blame 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
-- Copyright (c) 2023-2024 Chris Pressey, Cat's Eye Technologies
-- This file is distributed under a BSD license.  See LICENSES directory:
-- SPDX-License-Identifier: LicenseRef-BSD-2-Clause-X-Fountain

module Main (main) where

import System.Environment
import System.Exit
import System.IO

import qualified Language.Fountain.Grammar as Grammar
import qualified Language.Fountain.Loader as Loader
import qualified Language.Fountain.Parser as Parser
import qualified Language.Fountain.Generator as Generator
import qualified Language.Fountain.Preprocessor as Preprocessor


data Flags = Flags {
    dumpState :: Bool,
    startSymbol :: Maybe String,
    suppressNewline :: Bool,
    seed :: Int
  } deriving (Show, Ord, Eq)

defaultFlags = Flags{
    dumpState = False,
    startSymbol = Nothing,
    suppressNewline = False,
    seed = 0
}

parseFlags flags ("--dump-state":rest) =
    parseFlags flags{ dumpState = True } rest
parseFlags flags ("--start-symbol":s:rest) =
    parseFlags flags{ startSymbol = Just s } rest
parseFlags flags ("--suppress-newline":rest) =
    parseFlags flags{ suppressNewline = True } rest
parseFlags flags ("--seed":seedStr:rest) =
    parseFlags flags{ seed = (read seedStr) :: Int } rest
parseFlags flags other = (flags, other)

getStartSymbol g flags = case startSymbol flags of
    Just x -> x
    Nothing -> (Grammar.startSymbol g)


main = do
    args <- getArgs
    let (flags, args') = parseFlags defaultFlags args
    let output = if (suppressNewline flags) then putStr else putStrLn
    case args' of
        ["load", grammarFileName] -> do
            grammar <- loadSource grammarFileName
            -- TODO: add flag to show internal format
            output $ Grammar.depictGrammar grammar
        ["preprocess", grammarFileName] -> do
            grammar <- loadSource grammarFileName
            let grammar' = Preprocessor.preprocessGrammarForGeneration grammar
            -- TODO: add flag to show internal format
            output $ Grammar.depictGrammar grammar'
        ("parse":grammarFileName:textFileName:initialParams) -> do
            grammar <- loadSource grammarFileName
            let grammar' = Preprocessor.preprocessGrammarForParsing grammar
            text <- loadText textFileName
            let start = getStartSymbol grammar' flags
            let initialState = Parser.constructState text initialParams
            let finalState = Parser.parseFrom grammar' start initialState
            output $ if (dumpState flags) then show finalState else formatParseResult $ Parser.obtainResult finalState
            exitWith $ either (\_msg -> ExitFailure 1) (\_remaining -> ExitSuccess) $ Parser.obtainResult finalState
        ("generate":grammarFileName:initialParams) -> do
            grammar <- loadSource grammarFileName
            let grammar' = Preprocessor.preprocessGrammarForGeneration grammar
            let start = getStartSymbol grammar' flags
            let initialState = Generator.constructState (seed flags) initialParams
            let finalState = Generator.generateFrom grammar' start initialState
            output $ if (dumpState flags) then show finalState else formatGenerateResult $ Generator.obtainResult finalState
            exitWith $ either (\_msg -> ExitFailure 1) (\_remaining -> ExitSuccess) $ Generator.obtainResult finalState
        _ -> usage

usage = abortWith
    (
        "Usage:\n" ++
        "    fountain {flags} load <fountain-filename>\n" ++
        "    fountain {flags} preprocess <fountain-filename>\n" ++
        "    fountain {flags} parse <fountain-filename> <text-filename> {params}\n" ++
        "    fountain {flags} generate <fountain-filename> {params}\n" ++
        "  where {flags} is any of:\n" ++
        "    --dump-state: dump the internal parse/generate state as part of output\n" ++
        "    --start-symbol <NT>: name of the nonterminal to start parsing/generating at\n" ++
        "      (default is the nonterminal that appears first in the grammar)\n" ++
        "    --suppress-newline: don't output a final newline after output\n" ++
        "    --seed <int>: seed for pseudo-random choices during backtracking (default 0)\n" ++
        "  and {params} is a list of arguments of the form `var=value` with which\n" ++
        "    variables will be initialized in the initial parse/generate state."
    )

loadSource fileName = do
    handle <- openFile fileName ReadMode
    -- hSetEncoding handle utf8
    text <- hGetContents handle
    case Loader.parseFountain text of
        Right g -> do
            return g
        Left err ->
            abortWith $ show err

loadText fileName = do
    handle <- if fileName == "--" then return stdin else openFile fileName ReadMode
    -- hSetEncoding handle utf8
    text <- hGetContents handle
    return text

abortWith msg = do
    hPutStrLn stderr msg
    exitWith $ ExitFailure 1

formatParseResult (Right "") = "Success"
formatParseResult (Right s) = "Remaining: " ++ (show s)
formatParseResult (Left _) = "Failure"

formatGenerateResult (Right s) = s
formatGenerateResult (Left _) = "Failure"