diff --git a/headergen.cabal b/headergen.cabal --- a/headergen.cabal +++ b/headergen.cabal @@ -1,5 +1,5 @@ name: headergen -version: 0.1.1.0 +version: 0.1.1.1 homepage: https://github.com/aka-bash0r/headergen synopsis: Creates a header for a haskell source file. description: The headergen package provides a small utility for @@ -21,11 +21,19 @@ source-repository this type: git location: https://github.com/aka-bash0r/headergen - tag: 0.1.1.0 + tag: 0.1.1.1 executable headergen main-is: Main.hs + other-modules: Headergen.Commands.Creation + , Headergen.Commands.Help + , Headergen.Commands.Initialization + , Headergen.Configuration + , Headergen.Messages + , Headergen.Template.Parser + , Headergen.Template + , Headergen.Utility build-depends: base >=4.8 && <4.9 , aeson >=0.9.0.1 && <0.10 , aeson-pretty >=0.7.2 && <0.8 diff --git a/src/Headergen/Commands/Creation.hs b/src/Headergen/Commands/Creation.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Commands/Creation.hs @@ -0,0 +1,80 @@ +{- | +Module : $Header$ +Description : Contains all definitions for creation comannd. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +Contains all definitions for creation command. +-} +module Headergen.Commands.Creation +( command +, help +) where + +import Data.Aeson +import qualified Data.ByteString.Lazy as BS + +import System.Directory +import System.FilePath.Posix +import System.IO + +import Headergen.Configuration +import Headergen.Messages +import Headergen.Utility (requestForAllowance, parentDirectory) + + +command :: [String] -> IO () +command [mod] = tryCreate (mod -<.> ".hs") +command _ = undefined -- TODO: implement help message + +help :: IO () +help = do + putStrLn " headergen create MODULE" + putStrLn " --> creates a new module in current working directory." + +-- | Try to create a new module file. +tryCreate mod = do + cwd <- getCurrentDirectory + traversePath mod cwd + +-- | Traverses the path up to root directory. +traversePath mod cwd = do + putStrLn ("Checking " ++ cwd ++ " ...") + let headerGenDef = cwd ".headergen.def" + exists <- doesFileExist headerGenDef + if exists + then do + h <- openFile headerGenDef ReadMode + cs <- BS.hGetContents h + let hgd = decode cs :: Maybe Configuration + case hgd of + Just a -> createHeader mod a + Nothing -> putStrLn corruptedMessage + hClose h + else case parentDirectory cwd of + Just a -> traversePath mod a + Nothing -> putStrLn noHeadergenDefMessage + +-- | Create the header. +createHeader mod conf = do + exists <- doesFileExist mod + if exists + then do + v <- requestForAllowance + if v + then writeHeader mod conf + else putStrLn noResourcesCreatedMessage + else writeHeader mod conf + +-- | Write the header to file. +writeHeader modFile conf = do + h <- openFile modFile WriteMode + hPutStr h (template conf) + hFlush h + hClose h + diff --git a/src/Headergen/Commands/Help.hs b/src/Headergen/Commands/Help.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Commands/Help.hs @@ -0,0 +1,51 @@ +{- | +Module : $Header$ +Description : Provides basic help functionality. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +Provides basic help functionality for the headergen executable. +-} +module Headergen.Commands.Help +( command +, help +) where + + +import Headergen.Messages + +import qualified Headergen.Commands.Creation as Creation +import qualified Headergen.Commands.Initialization as Initialization + + +command :: [String] -> IO () +command ["all" ] = do + command [] + Creation.help + Initialization.help + help +command ["init" ] = do + command [] + Initialization.help +command ["create"] = do + command [] + Creation.help +command ["help" ] = do + command [] + help +command _ = do + putStrLn "Usage: headergen {help [all|COMMAND]|init|create MODULE}" + putStrLn "" + +help :: IO () +help = do + putStrLn " headergen help" + putStrLn " --> shows this help information" + putStrLn " headergen help COMMAND" + putStrLn " --> shows detailed help information" + diff --git a/src/Headergen/Commands/Initialization.hs b/src/Headergen/Commands/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Commands/Initialization.hs @@ -0,0 +1,96 @@ +{- | +Module : $Header$ +Description : Contains all relevant definitions for the initialization command. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +Contains all relevant definitions for the initialization command. +-} +module Headergen.Commands.Initialization +( command +, help +) where + +import Control.Applicative +import Control.Monad + +import Data.Aeson () +import Data.Aeson.Encode.Pretty +import Data.Time.Calendar +import Data.Time.Clock + +import qualified Data.ByteString.Lazy as BS + +import System.Console.Haskeline +import System.Directory +import System.IO + +import Headergen.Configuration +import Headergen.Messages +import Headergen.Utility + + +command :: [String] -> IO () +command [] = initializeDefinition +command _ = undefined -- TODO: implement printing of help message. + + +help :: IO () +help = do + putStrLn " headergen init" + putStrLn " --> initializes a new .headergen.def." + +-- | Initialize a .headergen.def. +initializeDefinition = do + exists <- doesFileExist ".headergen.def" + if exists + then do + allowance <- requestForAllowance + if allowance + then do + hgd <- requestConfiguration + createHeadergenDef hgd + else + putStrLn noResourcesCreatedMessage + else do + hgd <- requestConfiguration + createHeadergenDef hgd + +-- | Request the configuration from console. +requestConfiguration = do + (year, _, _) <- date + runInputT defaultSettings $ do + mod <- getInputLine moduleMessage + desc <- getInputLine descriptionMessage + auth <- getInputLine authorMessage + let copyRightText = "(c) " ++ show year ++ " " ++ def auth "" + copyRight = copyRightMessage copyRightText + copyr <- getInputLine copyRight + lic <- getInputLine licenseMessage + maint <- getInputLine maintainerMessage + stab <- getInputLine stabilityMessage + portab <- getInputLine portabilityMessage + return ( Configuration (def mod "$Header$" ) + (def desc "" ) + (def auth "" ) + (def copyr copyRightText ) + (def lic "MIT" ) + (def maint "" ) + (def stab "unstable" ) + (def portab "non-portable (Portability is untested.)") ) + +-- | Create a .headergen.def in the current directory. +createHeadergenDef conf = do + file <- openFile ".headergen.def" WriteMode + BS.hPutStr file (encodePretty conf) + hFlush file + hClose file + +-- | Current date. +date = liftM (toGregorian . utctDay) getCurrentTime + diff --git a/src/Headergen/Configuration.hs b/src/Headergen/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Configuration.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : $Header$ +Description : +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +The 'Configuration' module contains all relevant information +-} +module Headergen.Configuration +( Configuration (..) +, createDictionary +) where + + +import Control.Applicative +import Control.Monad + +import Data.Aeson + +import Headergen.Template + + +-- | The configuration is used to read / write configuration to JSON. +data Configuration = Configuration + { getModule :: String + , getDescription :: String + , getAuthor :: String + , getCopyright :: String + , getLicense :: String + , getMaintainer :: String + , getStability :: String + , getPortability :: String + } + +instance ToJSON Configuration where + toJSON (Configuration mod desc auth copyr lic maint stab portab) = + object [ "module" .= mod + , "author" .= auth + , "description" .= desc + , "copyright" .= copyr + , "license" .= lic + , "maintainer" .= maint + , "stability" .= stab + , "portability" .= portab + ] + +instance FromJSON Configuration where + parseJSON (Object o) = + Configuration <$> o .: "module" + <*> o .: "description" + <*> o .: "author" + <*> o .: "copyright" + <*> o .: "license" + <*> o .: "maintainer" + <*> o .: "stability" + <*> o .: "portability" + parseJSON _ = + empty + +createDictionary :: Configuration -> Dictionary +createDictionary (Configuration mod des aut cop lic mai sta por) = + [ ("module" , mod) + , ("description", des) + , ("author" , aut) + , ("copyright" , cop) + , ("license" , lic) + , ("maintainer" , mai) + , ("stability" , sta) + , ("portability", por) + ] + diff --git a/src/Headergen/Messages.hs b/src/Headergen/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Messages.hs @@ -0,0 +1,111 @@ +{- | +Module : $Header$ +Description : Some message constants. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +This module defines some messages +-} + +module Headergen.Messages +( corruptedMessage +, noResourcesCreatedMessage +, noHeadergenDefMessage +, exitMessage + +, moduleMessage +, descriptionMessage +, authorMessage +, copyRightMessage +, licenseMessage +, maintainerMessage +, stabilityMessage +, portabilityMessage + +, template +) where + + +import Headergen.Configuration +import Headergen.Utility + + +-- | A message stating corruption of .headergen.def. +corruptedMessage :: String +corruptedMessage = + "The .headergen.def is corrupted.\n" ++ + exitMessage + +-- | A message stating that no resources have been created. +noResourcesCreatedMessage :: String +noResourcesCreatedMessage = + "No resources have been created.\n" ++ + exitMessage + +-- | A message stating that no .headergen.def was found. +noHeadergenDefMessage :: String +noHeadergenDefMessage = + "There is no .headergen.def in any parent directory.\n" ++ + exitMessage + +-- | A message stating exit of application. +exitMessage :: String +exitMessage = + "Exitting now.\n" + + +-- | A message stating that input for module definition is required. +moduleMessage :: String +moduleMessage = "Module [$Header$]: " + +-- | A message stating that input for description definition is required. +descriptionMessage :: String +descriptionMessage = "Description [ ]: " + +-- | A message stating that input for author definition is required. +authorMessage :: String +authorMessage = "Author [ ]: " + +-- | A message stating that input for copyright definition is required. +copyRightMessage :: String -> String +copyRightMessage crt = "Copyright [" ++ trimText 8 crt ++ "]: " + +-- | A message stating that input for license definition is required. +licenseMessage :: String +licenseMessage = "License [MIT ]: " + +-- | A message stating that input for maintainer definition is required. +maintainerMessage :: String +maintainerMessage = "Maintainer [ ]: " + +-- | A message stating that input for stability definition is required. +stabilityMessage :: String +stabilityMessage = "Stability [unstable]: " + +-- | A message stating that input for portability definition is required. +portabilityMessage :: String +portabilityMessage = "Portability [non-port]: " + + +-- | A template function creating a new header from a configuration. +template :: Configuration -> String +template (Configuration mod des aut cop lic mai sta por) = + "{- |\n" ++ + "Module : " ++ mod ++ "\n" ++ + "Description : " ++ des ++ "\n" ++ + "Author : " ++ aut ++ "\n" ++ + "Copyright : " ++ cop ++ "\n" ++ + "License : " ++ lic ++ "\n" ++ + "\n" ++ + "Maintainer : " ++ mai ++ "\n" ++ + "Stability : " ++ sta ++ "\n" ++ + "Portability : " ++ por ++ "\n" ++ + "\n" ++ + "TODO: module description\n" ++ + "-}\n\n" + diff --git a/src/Headergen/Template.hs b/src/Headergen/Template.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Template.hs @@ -0,0 +1,69 @@ +{- | +Module : $Header$ +Description : Template language syntax tree. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +This module contains the syntax tree for the templating language. +-} +module Headergen.Template +( KeyValue +, Dictionary + +, VariableName +, Template (..) + +, fillTemplate +) where + + +import Control.Applicative +import Control.Monad + + +-- | A key value pair. +type KeyValue = (String, String) +-- | A list of key value pairs. +type Dictionary = [KeyValue] + +-- | The name of a variable in a template. +type VariableName = String + + +-- | A template is used when +data Template + -- | A simple text element in the template. + = TemplateText String + -- | A variable to substitute in later process in the template. + | TemplateVariable VariableName + -- | A sequence of several elements in the template. + | TemplateSequence Template Template + -- | The end of a template. + | TemplateEOF + deriving (Show, Eq) + + +fillTemplate :: Dictionary -> Template -> Either String String +fillTemplate dict (TemplateEOF ) = Right "" +fillTemplate dict (TemplateVariable var ) = case dict `find` var of + Just v -> Right v + Nothing -> Left ("Variable " ++ var ++ " is not defined.") +fillTemplate dict (TemplateText text ) = Right text +fillTemplate dict (TemplateSequence left right) = do + l <- fillTemplate dict left + r <- fillTemplate dict right + return (l ++ r) + + +find ((key, value):xs) var = + if key == var + then Just value + else find xs var +find [] _ = + Nothing + diff --git a/src/Headergen/Template/Parser.hs b/src/Headergen/Template/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Template/Parser.hs @@ -0,0 +1,46 @@ +{- | +Module : $Header$ +Description : A parser for the template language. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +This package contains a simple parser for the templating language. +-} +module Headergen.Template.Parser +( parseTemplate +) where + + +import Control.Applicative +import Control.Monad + +import Headergen.Template + + +-- | Parse a template definition. +parseTemplate :: String -> Template +parseTemplate xs = parse xs [] + where + parse [] ys = + if null ys + then TemplateEOF + else TemplateSequence (TemplateText (reverse ys)) TemplateEOF + parse ('$':xs) ys = + let (zs, res) = parseVariable xs [] + rest = parse zs [] + in TemplateSequence (TemplateText (reverse ys)) (TemplateSequence (TemplateVariable res) rest) + parse (x :xs) ys = + parse xs (x:ys) + + parseVariable [] ys = ([] , reverse ys) + parseVariable (' ' :xs) ys = (' ' :xs, reverse ys) + parseVariable ('\t':xs) ys = ('\t':xs, reverse ys) + parseVariable ('\n':xs) ys = ('\n':xs, reverse ys) + parseVariable ('\r':xs) ys = ('\r':xs, reverse ys) + parseVariable (x :xs) ys = parseVariable xs (x:ys) + diff --git a/src/Headergen/Utility.hs b/src/Headergen/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Headergen/Utility.hs @@ -0,0 +1,76 @@ +{- | +Module : $Header$ +Description : Contains utility functions. +Author : Nils 'bash0r' Jonsson +Copyright : (c) 2015 Nils 'bash0r' Jonsson +License : MIT + +Maintainer : aka.bash0r@gmail.com +Stability : unstable +Portability : non-portable (Portability is untested.) + +Some utility functions. +-} +module Headergen.Utility +( alignText +, trimText +, def +, requestForAllowance +, parentDirectory +) where + + +import Data.List + +import System.Console.Haskeline +import System.FilePath.Posix + + +-- | Align message if it is less than n characters. +alignText :: (Num a) => Int -> String -> String +alignText n xs = + if genericLength xs < n + then alignText n (xs ++ " ") + else xs + +-- | Align text or cut text to be exact n characters. +trimText :: (Num a) => Int -> String -> String +trimText n crt = + if genericLength crt >= n + then take n crt + else alignText n crt + +-- | Try to get a value out of a Maybe String. +def :: Maybe String -> String -> String +def v d = + case v of + Just v -> + if null v + then d + else v + Nothing -> + d + +-- | Request the user for allowance to override a file. +requestForAllowance :: IO Bool +requestForAllowance = runInputT defaultSettings allowanceRequest + where + allowanceRequest = do + line <- getInputLine "File exists already. Override? [y/n] " + case line of + (Just "y") -> return True + (Just "n") -> return False + _ -> allowanceRequest + +-- | Try to get the parent directory of a given path. +parentDirectory :: FilePath -> Maybe FilePath +parentDirectory path = + let splitted = splitDirectories path + reversed = reverse splitted + dropped = drop 1 reversed + rereversed = reverse dropped + newPath = joinPath rereversed + in case newPath of + [] -> Nothing + otherwise -> Just otherwise + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,12 +19,6 @@ import Control.Monad import System.Environment -import System.FilePath.Posix - -import Headergen.Configuration -import Headergen.Messages -import Headergen.Template -import Headergen.Template.Parser import qualified Headergen.Commands.Creation as Creation import qualified Headergen.Commands.Help as Help