Main.hs

-- Generate views of a sequence of preskeletons

-- Copyright (c) 2009 The MITRE Corporation
--
-- This program is free software: you can redistribute it and/or
-- modify it under the terms of the BSD License as published by the
-- University of California.

module Main (main) where

import Numeric
import System.IO
import System.IO.Error
import System.Console.GetOpt
import CPSA.Lib.CPSA (PosHandle, SExpr, Pos)
import CPSA.Lib.Entry
import CPSA.Graph.Config
import CPSA.Graph.Loader
import CPSA.Graph.CompactView
import CPSA.Graph.ExpandedView
import CPSA.Graph.LaTeXView

-- Runtime parameters

data Params = Params
    { file :: Maybe FilePath,   -- Nothing specifies standard output
      format :: Format,         -- Output format
      prefix :: Bool,           -- Use prefix notation?
      scripted :: Bool,         -- Use scripting?
      margin :: Int }           -- Output line length
    deriving Show

data Format = XML | SVG | LaTeX deriving Show

main :: IO ()
main =
    do
      (p, params) <- start options interp
      sexprs <- readSExprs p
      preskels <- try (loadDefs sexprs)
      case preskels of
        Left err -> abort (ioeGetErrorString err)
        Right (_, []) ->
            abort "Empty input"
        Right (cmts, preskels) ->
            do
              h <- outputHandle (file params)
              let conf = config (prefix params) (scripted params)
              case format params of
                LaTeX ->
                    do
                      hPutStrLn h "\\documentclass[12pt]{article}"
                      hPutStrLn h ("% " ++ cpsaVersion)
                      let pp = printer $ conf False
                      latexView h (margin params) pp cmts preskels
                _ ->
                    do
                      hPutStrLn h "<?xml version=\"1.0\"?>"
                      hPutStrLn h ("<!-- " ++ cpsaVersion ++ " -->")
                      case format params of
                        XML -> expandedView h (conf False)
                               (margin params) cmts preskels
                        SVG -> compactView h (conf True) preskels
                        LaTeX -> error "Bad case in main"

readSExprs :: PosHandle -> IO [SExpr Pos]
readSExprs p =
    loop []
    where
      loop xs =
          do
            x <- gentlyReadSExpr p
            case x of
              Nothing ->
                  return $ reverse xs
              Just x ->
                  loop (x:xs)

-- Command line option flags
data Flag
    = Help                      -- Help
    | Info                      -- Version information
    | Expanded                  -- Select expanded format in XML
    | Scripted                  -- Ensable scripting
    | Compact                   -- Select compact format in SVG
    | Text                      -- Select text format in LaTeX
    | Margin String             -- Output line length
    | InfixFlag                 -- Select output notation
    | Output String             -- Output file name
      deriving Show

defaultMargin :: Int
defaultMargin = optMargin defaultOptions

options :: [OptDescr Flag]
options =
    [ Option ['o'] ["output"]   (ReqArg Output "FILE") "output FILE",
      Option ['x'] ["expanded"] (NoArg Expanded)
      "use expanded format (default)",
      Option ['z'] ["zoom"]     (NoArg Scripted)
      "enable diagram scaling",
      Option ['c'] ["compact"]  (NoArg Compact)        "use compact format",
      Option ['l'] ["latex"]    (NoArg Text)           "use LaTeX format",
      Option ['m'] ["margin"]   (ReqArg Margin "INT")
      ("set output margin (default " ++ show defaultMargin ++ ")"),
      Option ['i'] ["infix"]    (NoArg InfixFlag) "output uses infix notation",
      Option ['h'] ["help"]     (NoArg Help)           "show help message",
      Option ['v'] ["version"]  (NoArg Info)           "show version number" ]

-- Interpret option flags
interp :: [Flag] -> IO Params
interp flags =
    loop flags (Params { file = Nothing, -- By default, no output file
                         format = XML,   -- and use expanded format
                         prefix = True,
                         scripted = False,
                         margin = defaultMargin })
    where
      loop [] params = return params
      loop (Output name : flags) params
          | file params == Nothing =
              loop flags $ params { file = Just name }
      loop (Expanded : flags) params =
          loop flags $ params { format = XML }
      loop (Scripted : flags) params =
          loop flags $ params { scripted = True }
      loop (Compact : flags) params =
          loop flags $ params { format = SVG }
      loop (Text : flags) params =
          loop flags $ params { format = LaTeX }
      loop (InfixFlag : flags) params =
          loop flags $ params { prefix = False }
      loop (Margin value : flags) params =
          case readDec value of
            [(margin, "")] ->
                loop flags $ params { margin = margin }
            _ ->
                do
                  msg <- usage options ["Bad value for margin\n"]
                  abort msg
      loop (Info : _) _ =
          success cpsaVersion
      loop (Help : _) _ =
          do                    -- Show help then exit with success
            msg <- usage options []
            success msg
      loop _ _ =
           do                   -- Show help then exit with failure
             msg <- usage options ["Bad option combination\n"]
             abort msg

-- Default configuration.  The lengths are in points, however the more
-- natural choice is a font relative unit of length such as ems,
-- however FireFox doesn't support these units yet.
config :: Bool -> Bool -> Bool -> Config
config prefix scripts compact =
    Config { units = "pt",
             font = font,
             stroke = 0.08 * font,
             dash = 0.50 * font,
             gap = 0.20 * font,
             tx = 4.16 * font,
             ty = 6.25 * font,
             ta = 1.75 * font,
             td = 1.16 * font,
             dx = 8.33 * font,
             dy = 6.25 * font,
             mx = 3.33 * font,
             my = 3.33 * font,
             br = 0.50 * font,
             compact = compact,
             notation = if prefix then Prefix else Infix,
             scripts = scripts }
    where
      font = 12