blob: 57a415fe60383d306db99c96eadcdadf8994a143 [file] [log] [blame]
{-# LANGUAGE OverloadedStrings #-}
-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Anansi.Main
( defaultMain
) where
import Prelude hiding (FilePath)
import Control.Applicative
import Control.Monad.Writer
import Data.ByteString (ByteString)
import qualified Data.ByteString
import Data.List (sortBy)
import qualified Data.Map
import Data.Ord (comparing)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text
import Data.Version (showVersion)
import qualified Filesystem
import Filesystem.Path (FilePath)
import qualified Filesystem.Path.CurrentOS as FP
import Options
import System.Argv0 (getArgv0)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO hiding (withFile, FilePath)
import Anansi.Parser
import Anansi.Tangle
import Anansi.Types
import Paths_anansi (version)
data MainOptions = MainOptions
{ optShowVersion :: Bool
, optShowNumericVersion :: Bool
, optOutputPath :: FilePath
}
data TangleOptions = TangleOptions
{ optNoLines :: Bool
}
data WeaveOptions = WeaveOptions
instance Options MainOptions where
defineOptions = pure MainOptions
<*> simpleOption "version" False
"Display information about this program, then exit"
<*> simpleOption "numeric-version" False
"Display the numeric version of Anansi, then exit."
<*> defineOption optionType_filePath (\o -> o
{ optionShortFlags = ['o']
, optionLongFlags = ["output", "out"]
, optionDescription = "Output path (a directory when tangling, a file when weaving)."
})
instance Options TangleOptions where
defineOptions = pure TangleOptions
<*> simpleOption "disable-line-pragmas" False
"Disable generating #line pragmas in tangled code. This works\
\ around a bug in Haddock."
instance Options WeaveOptions where
defineOptions = pure WeaveOptions
optionType_filePath :: OptionType FilePath
optionType_filePath = optionType "path" FP.empty
(Right . FP.decodeString)
(show . either Data.Text.unpack Data.Text.unpack . FP.toText)
getUsage :: IO String
getUsage = do
argv0 <- getArgv0
let name = either Data.Text.unpack Data.Text.unpack (FP.toText argv0)
return ("Usage: " ++ name ++ " [OPTION...] <tangle|weave> input-file\n")
loomInfo :: Data.Map.Map Text Loom -> String
loomInfo looms = unlines lines' where
loomNames = sortBy nameKey (Data.Map.keys looms)
lines' = ["Available looms are:"] ++ indent 2 loomNames
indent n = map (\x -> replicate n ' ' ++ Data.Text.unpack x)
-- sort loom names so anansi-foo comes after anansi.bar
nameKey = comparing (Data.Text.split (== '.'))
withFile :: FilePath -> (Handle -> IO a) -> IO a
withFile path io = if FP.null path
then io stdout
else Filesystem.withFile path WriteMode io
tangleMain :: MainOptions -> TangleOptions -> [String] -> IO ()
tangleMain mainOpts opts args = do
checkVersionOpts mainOpts
(_, doc) <- parseInput args
let enableLines = not (optNoLines opts)
case optOutputPath mainOpts of
"" -> tangle debugTangle enableLines doc
path -> tangle (realTangle path) enableLines doc
weaveMain :: Data.Map.Map Text Loom -> MainOptions -> WeaveOptions -> [String] -> IO ()
weaveMain looms mainOpts _ args = do
checkVersionOpts mainOpts
(inputName, doc) <- parseInput args
loomName <- case documentLoomName doc of
Just name -> return name
Nothing -> do
hPutStrLn stderr ("Document "
++ show inputName
++ " does't specify a loom (use :loom).")
hPutStrLn stderr (loomInfo looms)
exitFailure
loom <- case Data.Map.lookup loomName looms of
Just loom -> return loom
Nothing -> do
hPutStrLn stderr ("Loom "
++ show loomName
++ " not recognized.")
hPutStrLn stderr (loomInfo looms)
exitFailure
withFile (optOutputPath mainOpts) (\h -> Data.ByteString.hPut h (weave loom doc))
checkVersionOpts :: MainOptions -> IO ()
checkVersionOpts opts = do
when (optShowVersion opts) $ do
putStrLn ("anansi_" ++ showVersion version)
exitSuccess
when (optShowNumericVersion opts) $ do
putStrLn (showVersion version)
exitSuccess
parseInput :: [String] -> IO (String, Document)
parseInput [] = do
getUsage >>= hPutStrLn stderr
hPutStrLn stderr "An input file is required.\n"
exitFailure
parseInput [inputName] = do
parsed <- parse Filesystem.readFile (fromString inputName)
case parsed of
Left err -> do
hPutStrLn stderr ("Parse error while processing document " ++ show inputName)
hPutStrLn stderr (formatError err)
exitFailure
Right doc -> return (inputName, doc)
parseInput _ = do
getUsage >>= hPutStrLn stderr
hPutStrLn stderr "More than one input file provided.\n"
exitFailure
-- | Run Anansi with the provided looms. Loom names are namespaced by their
-- package name, such as @\"anansi.noweb\"@ or @\"anansi-hscolour.html\"@.
-- If your looms aren't available on Hackage, a Java-style name such as
-- @\"com.mycompany.myformat\"@ is a good alternative.
defaultMain :: Data.Map.Map Text Loom -> IO ()
defaultMain looms = do
let subcommands =
[ subcommand "tangle" tangleMain
, subcommand "weave" (weaveMain looms)
]
argv <- getArgs
let parsed = parseSubcommand subcommands argv
case parsedSubcommand parsed of
Just cmd -> cmd
Nothing -> case parsedError parsed of
Just err -> do
getUsage >>= hPutStrLn stderr
hPutStr stderr (parsedHelp parsed)
hPutStrLn stderr (loomInfo looms)
hPutStrLn stderr err
exitFailure
Nothing -> do
getUsage >>= hPutStrLn stdout
hPutStr stdout (parsedHelp parsed)
hPutStrLn stdout (loomInfo looms)
exitSuccess
debugTangle :: FilePath -> ByteString -> IO ()
debugTangle path bytes = do
let strPath = either Data.Text.unpack Data.Text.unpack (FP.toText path)
putStr "\n"
putStrLn strPath
putStrLn (replicate (fromIntegral (length strPath)) '=')
Data.ByteString.putStr bytes
realTangle :: FilePath -> FilePath -> ByteString -> IO ()
realTangle root path bytes = do
let fullpath = FP.append root path
Filesystem.createTree (FP.parent fullpath)
Filesystem.withFile fullpath ReadWriteMode $ \h -> do
equal <- fileContentsEqual h bytes
unless equal $ do
hSetFileSize h 0
Data.ByteString.hPut h bytes
fileContentsEqual :: Handle -> ByteString -> IO Bool
fileContentsEqual h bytes = do
hSeek h SeekFromEnd 0
size <- hTell h
hSeek h AbsoluteSeek 0
if size /= toInteger (Data.ByteString.length bytes)
then return False
else do
-- FIXME: 'Int' overflow?
contents <- Data.ByteString.hGet h (fromInteger size)
hSeek h AbsoluteSeek 0
return (bytes == contents)
formatError :: ParseError -> String
formatError err = concat [filename, ":", line, ": ", message] where
pos = parseErrorPosition err
filename = either Data.Text.unpack Data.Text.unpack (FP.toText (positionFile pos))
line = show (positionLine pos)
message = Data.Text.unpack (parseErrorMessage err)