LensMenu.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  UI.LensMenu
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Menu functions for generated lens executables.
--
-----------------------------------------------------------------------------

module UI.LensMenu where

import Data.Type
import Data.Spine
import Data.Equal
import Generics.Pointless.Lenses
import Language.XML.HaXmlAliases
import Language.XML.Type2Xml
import Language.XML.Xml2Type
import System.IO
import System.Environment
import System.Console.GetOpt
import UI.Menu

data Options = Options
	{
		  optInputSourceFile	:: Maybe FilePath
		, optInputTargetFile    :: Maybe FilePath
		, optOutputFile	        :: Maybe FilePath
		, optDirection          :: Bool
	}

startOpt :: Options
startOpt = Options
	{ optInputSourceFile	= Nothing
	, optInputTargetFile	= Nothing
	, optOutputFile		= Nothing
	, optDirection		= False
	}

options :: Opts Options
options =
   [ Option "h" ["help"]
        (NoArg (\opt -> exitHelp options))
        "Show usage info"
   , Option "s" ["source"]
        (ReqArg (\arg opt -> return opt { optInputSourceFile = Just arg }) "FILE")
        "Input XML Source File"
   , Option "t" ["target"]
        (ReqArg (\arg opt -> return opt { optInputTargetFile = Just arg }) "FILE")
        "Input XML Target File"
   , Option "o" ["output"]
        (ReqArg (\arg opt -> return opt { optOutputFile = Just arg }) "FILE")
        "Output XML File (default: stdout)"
   , Option "f" ["forward"]
        (NoArg (\opt -> return opt { optDirection = True }))
        "Run the bidirectional transformation in the forward direction (requires an source file)"
   , Option "b" ["backward"]
	(NoArg (\opt -> return opt { optDirection = False }))
	"Run the bidirectional transformation in the backward direction (requires a source file and a modified target file)"
   ]

lensmenu :: FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()
lensmenu srcSchema tgtSchema srcType tgtType lns = do
	argv <- getArgs
	opts <- parseOptions startOpt options argv
	if optDirection opts
		then forward opts srcSchema tgtSchema srcType tgtType lns
		else backward opts srcSchema tgtSchema srcType tgtType lns

forward :: Options -> FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()
forward opts srcSchema tgtSchema srcType tgtType lns = do
	putStrLn "Running forward transformation..."
	-- parse XML Source File
	s <- run "input XML source file missing" $ optInputSourceFile opts
	srcFile <- readFile s
	let srcDoc = parseXml s srcFile
	-- translate XML source into an Haskell value
	src <- run "Error translating XML source file" $ xml2value srcType srcDoc
	-- run forward transformation
	let tgt = get lns src
	-- print output XML target
	outputHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optOutputFile opts)
	tgtDoc <- run "Error printing XML target file" $ value2xml tgtSchema tgtType tgt
	hPutStrLn outputHandle $ renderXml tgtDoc
	hClose outputHandle

backward :: Options -> FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()
backward opts srcSchema tgtSchema srcType tgtType lns = do
	putStrLn "Running backward transformation..."
	-- parse XML Source File
	s <- run "input XML source file missing" $ optInputSourceFile opts
	srcFile <- readFile s
	let srcDoc = parseXml s srcFile
	-- translate XML source into an Haskell value
	src <- run "Error translating XML source file" $ xml2value srcType srcDoc
	-- parse XML Target File
	t <- run "input XML target file missing" $ optInputTargetFile opts
	tgtFile <- readFile t
	let tgtDoc = parseXml t tgtFile
	-- translate XML target into an Haskell value
	tgt <- run "Error translating XML target file" $ xml2value tgtType tgtDoc
	-- run backward transformation
	let src' = put lns (tgt,src)
	-- print output XML target
	outputHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optOutputFile opts)
	srcDoc' <- run "Error printing XML modified source file" $ value2xml srcSchema srcType src'
	hPutStrLn outputHandle $ renderXml srcDoc'
	hClose outputHandle