diff --git a/curry-frontend.cabal b/curry-frontend.cabal --- a/curry-frontend.cabal +++ b/curry-frontend.cabal @@ -1,42 +1,50 @@ Name: curry-frontend -Version: 0.2.11 +Version: 0.2.12 Cabal-Version: >= 1.6 -Synopsis: Compile the functional logic language Curry to several intermediate formats +Synopsis: Compile the functional logic language Curry to several + intermediate formats Description: The Curry Frontend consists of the executable program "cymake". - It is used by various backends to compile Curry programs to - an internal representation. + It is used by various backends to compile Curry programs to + an internal representation. The code is a stripped-down version of an early version of - the Muenster Curry Compiler + the Muenster Curry Compiler () Category: Language License: OtherLicense License-File: LICENSE Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel -Maintainer: Holger Siegel -Bug-Reports: mailto:hsi@informatik.uni-kiel.de -Homepage: http://curry-language.org +Maintainer: Björn Peemöller +Bug-Reports: http://www-ps.informatik.uni-kiel.de/redmine/projects/curry-frontend +Homepage: http://www.curry-language.org Build-Type: Simple Stability: experimental Extra-Source-Files: LIESMICH -Data-Files: src/currydoc.css +Data-Files: src/currydoc.css +Flag split-syb + Description: Has the syb functionality been split into the package syb? + Default: True Executable cymake - hs-source-dirs: src - Main-is: cymake.hs - Build-Depends: base >= 3 && < 4, - curry-base >= 0.2.8, - mtl, old-time, containers, pretty - ghc-options: -fwarn-unused-binds -fwarn-unused-imports -auto-all + hs-source-dirs: src + Main-is: cymake.hs + if flag(split-syb) + Build-Depends: base == 4.*, syb + else + Build-Depends: base == 3.* + Build-Depends: + curry-base >= 0.2.9 && < 0.3 + , mtl, old-time, containers, pretty + ghc-options: -Wall Other-Modules: Curry.Syntax.Lexer, Curry.Syntax.LexComb Curry.Syntax.Parser, Curry.Syntax.LLParseComb Curry.Syntax.ShowModule, Curry.Syntax.Pretty Curry.Syntax, Curry.Syntax.Type - Curry.Syntax.Unlit, + Curry.Syntax.Unlit, Curry.Syntax.Utils, Curry.Syntax.Frontend, - CurryBuilder, IL.Type + CurryBuilder, IL.Type CurryCompilerOpts, Modules, Subst, Arity CurryDeps, Eval, IL.Pretty, NestEnv, SyntaxCheck, Base Exports, IL.Scope, SyntaxColoring, CurryEnv @@ -44,20 +52,20 @@ IL.XML, PatchPrelude, TopEnv, CaseCompletion Imports, TypeCheck, - InterfaceCheck, + InterfaceCheck, Types, PrecCheck TypeSubst, GenAbstractCurry Typing GenFlatCurry, KindCheck, Qual - SCC, Utils, GetOpt + SCC, Utils Lift, ScopeEnv, WarnCheck - Desugar, + Desugar, Simplify Library hs-source-dirs: src Build-Depends: filepath - Exposed-Modules: + Exposed-Modules: Curry.Files.CymakePath Other-Modules: Paths_curry_frontend diff --git a/src/Curry/Files/CymakePath.hs b/src/Curry/Files/CymakePath.hs --- a/src/Curry/Files/CymakePath.hs +++ b/src/Curry/Files/CymakePath.hs @@ -4,7 +4,12 @@ import System.FilePath import Paths_curry_frontend +-- | Retrieve the version number of cymake +cymakeVersion :: String cymakeVersion = showVersion version + +-- | Retrieve the location of the cymake executable +getCymake :: IO String getCymake = do cymakeDir <- getBinDir return (cymakeDir "cymake") diff --git a/src/Curry/Syntax.hs b/src/Curry/Syntax.hs --- a/src/Curry/Syntax.hs +++ b/src/Curry/Syntax.hs @@ -5,27 +5,26 @@ (c) 2009, Holger Siegel. -} -module Curry.Syntax(module Curry.Syntax.Type, - parseModule, parseHeader - ) where +module Curry.Syntax + ( module Curry.Syntax.Type + , parseModule + , parseHeader + ) where import Control.Monad import Data.List import Curry.Base.MessageMonad import Curry.Syntax.Type - import qualified Curry.Syntax.Parser as CSP - import Curry.Syntax.Unlit - - +-- | Parses a curry module. parseModule :: Bool -> FilePath -> String -> MsgMonad Module parseModule likeFlat fn = unlitLiterate fn >=> CSP.parseSource likeFlat fn - +-- | Pares a curry header parseHeader :: FilePath -> String -> MsgMonad Module parseHeader fn = unlitLiterate fn >=> CSP.parseHeader fn @@ -36,6 +35,7 @@ | isLiterateSource fn = unlit fn s | otherwise = return s +-- | Compute if a file contains literate curry by its extension isLiterateSource :: FilePath -> Bool isLiterateSource fn = litExt `isSuffixOf` fn diff --git a/src/Curry/Syntax/LexComb.lhs b/src/Curry/Syntax/LexComb.lhs --- a/src/Curry/Syntax/LexComb.lhs +++ b/src/Curry/Syntax/LexComb.lhs @@ -9,8 +9,8 @@ The module \texttt{LexComb} provides the basic types and combinators to implement the lexers. The combinators use continuation passing code in a monadic style. The first argument of the continuation function is -the string to be parsed, the second is the current position, and the -third is a flag which signals the lexer that it is lexing the +the current position, and the second is the string to be parsed. The third +argument is a flag which signals the lexer that it is lexing the beginning of a line and therefore has to check for layout tokens. The fourth argument is a stack of indentations that is used to handle nested layout groups. @@ -66,7 +66,7 @@ > popContext :: P a -> P a > popContext cont pos s bol (_:ctxt) = cont pos s bol ctxt -> popContext cont pos s bol [] = +> popContext cont pos s bol [] = > error "parse error: popping layout from empty context stack. \ > \Perhaps you have inserted too many '}'?" diff --git a/src/CurryCompilerOpts.hs b/src/CurryCompilerOpts.hs --- a/src/CurryCompilerOpts.hs +++ b/src/CurryCompilerOpts.hs @@ -1,6 +1,5 @@ -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- +-- ----------------------------------------------------------------------------- +-- | -- CurryCompilerOpts - Defines data structures containing options for -- compiling Curry programs (see module "CurryCompiler") -- @@ -8,160 +7,160 @@ -- Martin Engelke (men@informatik.uni-kiel.de) -- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de) -- +-- ----------------------------------------------------------------------------- + module CurryCompilerOpts where -import GetOpt ---import Options (Dump(..)) +import System.Console.GetOpt -------------------------------------------------------------------------------- - --- Data type for recording compiler options +-- | Data type for recording compiler options data Options - = Options{ force :: Bool, -- force compilation - html :: Bool, -- generate Html code - importPaths :: [FilePath], -- directories for searching imports - output :: Maybe FilePath, -- name of output file - noInterface :: Bool, -- do not create an interface file - noVerb :: Bool, -- verbosity on/off - noWarn :: Bool, -- warnings on/off - noOverlapWarn :: Bool, -- "overlap" warnings on/off - flat :: Bool, -- generate FlatCurry code - extendedFlat :: Bool, -- generate FlatCurry code with extensions - flatXml :: Bool, -- generate flat XML code - abstract :: Bool, -- generate typed AbstracCurry code - untypedAbstract :: Bool, -- generate untyped AbstractCurry code - parseOnly :: Bool, -- generate source representation - withExtensions :: Bool, -- enable extended functionalities - dump :: [Dump], -- dumps - writeToSubdir :: Bool -- should output be written to subdir? - } deriving Show + = Options + { force :: Bool -- ^ force compilation + , html :: Bool -- ^ generate Html code + , importPaths :: [FilePath] -- ^ directories for searching imports + , output :: Maybe FilePath -- ^ name of output file + , noInterface :: Bool -- ^ do not create an interface file + , noVerb :: Bool -- ^ verbosity on/off + , noWarn :: Bool -- ^ warnings on/off + , noOverlapWarn :: Bool -- ^ "overlap" warnings on/off + , flat :: Bool -- ^ generate FlatCurry code + , extendedFlat :: Bool -- ^ generate FlatCurry code with extensions + , flatXml :: Bool -- ^ generate flat XML code + , abstract :: Bool -- ^ generate typed AbstracCurry code + , untypedAbstract :: Bool -- ^ generate untyped AbstractCurry code + , parseOnly :: Bool -- ^ generate source representation + , withExtensions :: Bool -- ^ enable extended functionalities + , dump :: [Dump] -- ^ dumps + , writeToSubdir :: Bool -- ^ should the output be written to the subdir? + } deriving Show --- Default compiler options -defaultOpts = Options{ force = False, - html = False, - importPaths = [], - output = Nothing, - noInterface = False, - noVerb = False, - noWarn = False, - noOverlapWarn = False, - extendedFlat = False, - flat = False, - flatXml = False, - abstract = False, - untypedAbstract = False, - parseOnly = False, - withExtensions = False, - dump = [], - writeToSubdir = True - } +-- | Default compiler options +defaultOpts = Options + { force = False + , html = False + , importPaths = [] + , output = Nothing + , noInterface = False + , noVerb = False + , noWarn = False + , noOverlapWarn = False + , extendedFlat = False + , flat = False + , flatXml = False + , abstract = False + , untypedAbstract = False + , parseOnly = False + , withExtensions = False + , dump = [] + , writeToSubdir = True + } --- Data type for representing all available options (needed to read and parse --- the options from the command line; see module "GetOpt") -data Option = Help | Force | Html - | ImportPath FilePath | Output FilePath - | NoInterface | NoVerb | NoWarn | NoOverlapWarn - | FlatXML | Flat | ExtFlat - | Abstract | UntypedAbstract | ParseOnly - | WithExtensions - | Dump [Dump] - | WriteToSubdir - deriving Eq +-- | Data type for representing all available options (needed to read and parse +-- the options from the command line; see module 'GetOpt') +data Option + = Help | Force | Html + | ImportPath FilePath | Output FilePath + | NoInterface | NoVerb | NoWarn | NoOverlapWarn + | FlatXML | Flat | ExtFlat | Abstract | UntypedAbstract | ParseOnly + | WithExtensions + | Dump [Dump] + | WriteToSubdir + deriving Eq --- All available compiler options -options = [Option "f" ["force"] (NoArg Force) - "force compilation of dependent files", - Option "" ["html"] (NoArg Html) - "generate html code", - Option "i" ["import-dir"] (ReqArg ImportPath "DIR") - "search for imports in DIR", - Option "o" ["output"] (ReqArg Output "FILE") - "write code to FILE", - Option "" ["no-intf"] (NoArg NoInterface) - "do not create an interface file", - Option "" ["no-verb"] (NoArg NoVerb) - "do not print compiler messages", - Option "" ["no-warn"] (NoArg NoWarn) - "do not print warnings", - Option "" ["no-overlap-warn"] (NoArg NoOverlapWarn) - "do not print warnings for overlapping rules", - Option "" ["flat"] (NoArg Flat) - "generate FlatCurry code", - Option "" ["extflat"] (NoArg ExtFlat) - "generate FlatCurry code with source references", - Option "" ["xml"] (NoArg FlatXML) - "generate flat xml code", - Option "" ["acy"] (NoArg Abstract) - "generate (type infered) AbstractCurry code", - Option "" ["uacy"] (NoArg UntypedAbstract) - "generate untyped AbstractCurry code", - Option "" ["parse-only"] (NoArg ParseOnly) - "generate source representation", - Option "e" ["extended"] (NoArg WithExtensions) - "enable extended Curry functionalities", - Option "" ["dump-all"] (NoArg (Dump [minBound..maxBound])) - "dump everything", - Option "" ["dump-renamed"] (NoArg (Dump [DumpRenamed])) - "dump source code after renaming", - Option "" ["dump-types"] (NoArg (Dump [DumpTypes])) - "dump types after type-checking", - Option "" ["dump-desugared"] (NoArg (Dump [DumpDesugared])) - "dump source code after desugaring", - Option "" ["dump-simplified"] (NoArg (Dump [DumpSimplified])) - "dump source code after simplification", - Option "" ["dump-lifted"] (NoArg (Dump [DumpLifted])) - "dump source code after lambda-lifting", - Option "" ["dump-il"] (NoArg (Dump [DumpIL])) - "dump intermediate language before lifting", - Option "" ["dump-case"] (NoArg (Dump [DumpCase])) - "dump intermediate language after case simplification", - Option "?h" ["help"] (NoArg Help) - "display this help and exit", - Option "" ["no-hidden-subdir"] (NoArg WriteToSubdir) - "write all output to hidden .curry subdirectory" - ] +-- | All available compiler options +options = + [ Option "f" ["force"] (NoArg Force) + "force compilation of dependent files" + , Option "" ["html"] (NoArg Html) + "generate html code" + , Option "i" ["import-dir"] (ReqArg ImportPath "DIR") + "search for imports in DIR" + , Option "o" ["output"] (ReqArg Output "FILE") + "write code to FILE" + , Option "" ["no-intf"] (NoArg NoInterface) + "do not create an interface file" + , Option "" ["no-verb"] (NoArg NoVerb) + "do not print compiler messages" + , Option "" ["no-warn"] (NoArg NoWarn) + "do not print warnings" + , Option "" ["no-overlap-warn"] (NoArg NoOverlapWarn) + "do not print warnings for overlapping rules" + , Option "" ["flat"] (NoArg Flat) + "generate FlatCurry code" + , Option "" ["extended-flat"] (NoArg ExtFlat) + "generate FlatCurry code with source references" + , Option "" ["xml"] (NoArg FlatXML) + "generate flat xml code" + , Option "" ["acy"] (NoArg Abstract) + "generate (type infered) AbstractCurry code" + , Option "" ["uacy"] (NoArg UntypedAbstract) + "generate untyped AbstractCurry code" + , Option "" ["parse-only"] (NoArg ParseOnly) + "generate source representation" + , Option "e" ["extended"] (NoArg WithExtensions) + "enable extended Curry functionalities" + , Option "" ["dump-all"] (NoArg (Dump [minBound..maxBound])) + "dump everything" + , Option "" ["dump-renamed"] (NoArg (Dump [DumpRenamed])) + "dump source code after renaming" + , Option "" ["dump-types"] (NoArg (Dump [DumpTypes])) + "dump types after type-checking" + , Option "" ["dump-desugared"] (NoArg (Dump [DumpDesugared])) + "dump source code after desugaring" + , Option "" ["dump-simplified"] (NoArg (Dump [DumpSimplified])) + "dump source code after simplification" + , Option "" ["dump-lifted"] (NoArg (Dump [DumpLifted])) + "dump source code after lambda-lifting" + , Option "" ["dump-il"] (NoArg (Dump [DumpIL])) + "dump intermediate language before lifting" + , Option "" ["dump-case"] (NoArg (Dump [DumpCase])) + "dump intermediate language after case simplification" + , Option "?h" ["help"] (NoArg Help) + "display this help and exit" + , Option "" ["no-hidden-subdir"] (NoArg WriteToSubdir) + "write all output to hidden .curry subdirectory" + ] --- Inserts an option (type 'Option') into the options record (type 'Options') +-- | Marks an 'Option' as selected in the 'Options' record selectOption :: Option -> Options -> Options -selectOption Force opts = opts{ force = True } -selectOption (ImportPath dir) opts - = opts{ importPaths = dir:(importPaths opts) } -selectOption (Output file) opts = opts{ output = Just file } -selectOption NoInterface opts = opts{ noInterface = True } -selectOption NoVerb opts = opts{ noVerb = True } -selectOption NoWarn opts = opts{ noWarn = True } -selectOption NoOverlapWarn opts = opts{ noOverlapWarn = True } -selectOption Flat opts = opts{ flat = True } -selectOption ExtFlat opts = opts{ extendedFlat = True } -selectOption Html opts = opts{ html = True } -selectOption FlatXML opts = opts{ flatXml = True } -selectOption Abstract opts = opts{ abstract = True } -selectOption UntypedAbstract opts = opts{ untypedAbstract = True } -selectOption ParseOnly opts = opts{ parseOnly = True } -selectOption WithExtensions opts = opts{ withExtensions = True } -selectOption (Dump ds) opts = opts{ dump = ds ++ dump opts } -selectOption WriteToSubdir opts = opts{ writeToSubdir = False } +selectOption Force opts = opts { force = True } +selectOption (ImportPath dir) opts + = opts { importPaths = dir:(importPaths opts) } +selectOption (Output file) opts = opts { output = Just file } +selectOption NoInterface opts = opts { noInterface = True } +selectOption NoVerb opts = opts { noVerb = True } +selectOption NoWarn opts = opts { noWarn = True } +selectOption NoOverlapWarn opts = opts { noOverlapWarn = True } +selectOption Flat opts = opts { flat = True } +selectOption ExtFlat opts = opts { extendedFlat = True } +selectOption Html opts = opts { html = True } +selectOption FlatXML opts = opts { flatXml = True } +selectOption Abstract opts = opts { abstract = True } +selectOption UntypedAbstract opts = opts { untypedAbstract = True } +selectOption ParseOnly opts = opts { parseOnly = True } +selectOption WithExtensions opts = opts { withExtensions = True } +selectOption (Dump ds) opts = opts { dump = ds ++ dump opts } +selectOption WriteToSubdir opts = opts { writeToSubdir = False } -------------------------------------------------------------------------------- - --- Data type for representing code dumps --- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case' --- expansion -data Dump = DumpRenamed -- dump source after renaming - | DumpTypes -- dump types after typechecking - | DumpDesugared -- dump source after desugaring - | DumpSimplified -- dump source after simplification - | DumpLifted -- dump source after lambda-lifting - | DumpIL -- dump IL code after translation - | DumpCase -- dump IL code after case elimination - deriving (Eq,Bounded,Enum,Show) - +-- | Data type for representing code dumps +-- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case' +-- expansion +data Dump + = DumpRenamed -- ^ dump source after renaming + | DumpTypes -- ^ dump types after typechecking + | DumpDesugared -- ^ dump source after desugaring + | DumpSimplified -- ^ dump source after simplification + | DumpLifted -- ^ dump source after lambda-lifting + | DumpIL -- ^ dump IL code after translation + | DumpCase -- ^ dump IL code after case elimination + deriving (Eq,Bounded,Enum,Show) ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- diff --git a/src/GetOpt.hs b/src/GetOpt.hs deleted file mode 100644 --- a/src/GetOpt.hs +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------------------ --- A Haskell port of GNU's getopt library --- --- Sven Panne Oct. 1996 (small changes Dec. 1997) --- --- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't --- already know it, you probably don't want to hear about it...) and the recognition of --- long options with a single dash (e.g. '-help' is recognised as '--help', as long as --- there is no short option 'h'). --- --- Other differences between GNU's getopt and this implementation: --- * To enforce a coherent description of options and arguments, there are explanation --- fields in the option/argument descriptor. --- * Error messages are now more informative, but no longer POSIX compliant... :-( --- --- And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines, --- we need only 195 here, including a 46 line example! :-) ------------------------------------------------------------------------------------------ - -module GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where - -import Data.List(isPrefixOf) - -data ArgOrder a -- what to do with options following non-options: - = RequireOrder -- no option processing after first non-option - | Permute -- freely intersperse options and non-options - | ReturnInOrder (String -> a) -- wrap non-options into options - -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user - -data ArgDescr a -- description of an argument option: - = NoArg a -- no argument expected - | ReqArg (String -> a) String -- option requires argument - | OptArg (Maybe String -> a) String -- optional argument - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr - table = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds) - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z - sameLen xs = flushLeft ((maximum . map length) xs) xs - flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] - -fmtOpt :: OptDescr a -> (String,String,String) -fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos), - sepBy ", " (map (fmtLong ad) los), - descr) - where sepBy sep [] = "" - sepBy sep [x] = x - sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad -fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the commandline arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt _ _ [] = ([],[],[]) -getOpt ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[]) - procNextOpt EndOfOpts Permute = ([],rest,[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[]) - procNextOpt (OptErr e) _ = (os,xs,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,es) = getOpt ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext "--" rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-':x:xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt xs rest optDescr = long ads arg rest - where (opt,arg) = break (=='=') xs - options = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = ("--"++opt) - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg a ] ('=':xs) rest = (errNoArg optStr,rest) - long [ReqArg f d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (errUnrec optStr,rest) - --- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -shortOpt x xs rest optDescr = short ads xs rest - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[x] - - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg f d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) - short [] [] rest = (errUnrec optStr,rest) - short [] xs rest = (errUnrec optStr,('-':xs):rest) - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> OptKind a -errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n") - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") - -{- ------------------------------------------------------------------------------------------ --- and here a small and hopefully enlightening example: - -data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show - -options :: [OptDescr Flag] -options = - [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", - Option ['V','?'] ["version","release"] (NoArg Version) "show version info", - Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", - Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] - -out :: Maybe String -> Flag -out Nothing = Output "stdout" -out (Just o) = Output o - -test :: ArgOrder Flag -> [String] -> String -test order cmdline = case getOpt order options cmdline of - (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" - (_,_,errs) -> concat errs ++ usageInfo header options - where header = "Usage: foobar [OPTION...] files..." - --- example runs: --- putStr (test RequireOrder ["foo","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["foo","-v"]) --- ==> options=[Verbose] args=["foo"] --- putStr (test (ReturnInOrder Arg) ["foo","-v"]) --- ==> options=[Arg "foo", Verbose] args=[] --- putStr (test Permute ["foo","--","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["-?o","--name","bar","--na=baz"]) --- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] --- putStr (test Permute ["--ver","foo"]) --- ==> option `--ver' is ambiguous; could be one of: --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump --- -n USER --name=USER only dump USER's files ------------------------------------------------------------------------------------------ --} diff --git a/src/Modules.lhs b/src/Modules.lhs --- a/src/Modules.lhs +++ b/src/Modules.lhs @@ -29,7 +29,7 @@ > import Control.Monad > import Curry.Base.MessageMonad -> import Curry.Base.Position +> import Curry.Base.Position as P > import Curry.Base.Ident > import Curry.Files.Filenames @@ -411,7 +411,7 @@ > importPrelude fn (Module m es ds) = > Module m es (if m == preludeMIdent then ds else ds') > where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds] -> ds' = ImportDecl (first fn) preludeMIdent +> ds' = ImportDecl (P.first fn) preludeMIdent > (preludeMIdent `elem` map importedModule ids) > Nothing Nothing : ds > importedModule (ImportDecl _ m q asM is) = fromMaybe m asM @@ -449,10 +449,10 @@ > compileInterface paths ctxt mEnv m fn = > do > mintf <- readFlatInterface fn -> let intf = fromMaybe (errorAt (first fn) (interfaceNotFound m)) mintf +> let intf = fromMaybe (errorAt (P.first fn) (interfaceNotFound m)) mintf > (Prog mod _ _ _ _) = intf > m' = mkMIdent [mod] -> unless (m' == m) (errorAt (first fn) (wrongInterface m m')) +> unless (m' == m) (errorAt (P.first fn) (wrongInterface m m')) > mEnv' <- loadFlatInterfaces paths ctxt mEnv intf > return (bindFlatInterface intf mEnv') @@ -468,7 +468,7 @@ > foldM (loadInterface paths ((mkMIdent [m]):ctxt)) > mEnv > (map (\i -> (p, mkMIdent [i])) is) -> where p = first m +> where p = P.first m Interface files are updated by the Curry builder when necessary. @@ -676,7 +676,7 @@ > = (name == "[]" || name == "()") && mod == "Prelude" > isSpecialPreludeType _ = False > -> pos = first m +> pos = P.first m > ts' = filter (not . isSpecialPreludeType) ts diff --git a/src/cymake.hs b/src/cymake.hs --- a/src/cymake.hs +++ b/src/cymake.hs @@ -1,111 +1,97 @@ -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- +-- ----------------------------------------------------------------------------- +-- | -- cymake - The Curry builder -- -- Command line tool for generating Curry representations (e.g. -- FlatCurry, AbstractCurry) for a Curry source file including -- all imported modules. -- --- September 2005, --- Martin Engelke (men@informatik.uni-kiel.de) +-- September 2005, Martin Engelke (men@informatik.uni-kiel.de) -- +-- ----------------------------------------------------------------------------- module Main(main) where - - import Data.List import Data.Maybe -import System.IO +import System.Console.GetOpt import System.Environment(getArgs, getProgName) import System.Exit(ExitCode(..), exitWith) +import System.IO import Control.Monad (unless) -import GetOpt import CurryBuilder(buildCurry) import CurryCompilerOpts import CurryHtml import Curry.Files.CymakePath (cymakeVersion) -------------------------------------------------------------------------------- --- The command line tool. +-- | The command line tool cymake main :: IO () -main = do prog <- getProgName - args <- getArgs - cymake prog args - - -------------------------------------------------------------------------------- +main = do + prog <- getProgName + args <- getArgs + cymake prog args --- Checks the command line arguments and invokes the builder. +-- | Checks the command line arguments and invokes the curry builder cymake :: String -> [String] -> IO () -cymake prog args - | elem Help opts = printUsage prog - | null files = badUsage prog ["no files"] - | null errs' && not (elem Html opts) = do - unless (noVerb options') - (putStrLn $ "This is cymake, version " ++ cymakeVersion) - mapM_ (buildCurry options') files - | null errs' = do - let importFiles = nub $ importPaths opts' - outputFile = maybe "" id (output opts') - mapM_ (source2html importFiles outputFile) files - - | otherwise = badUsage prog errs' - where - (opts, files, errs) = getOpt Permute options args - opts' = foldr selectOption defaultOpts opts - options' = if flat opts' || flatXml opts' - || abstract opts' || untypedAbstract opts' || parseOnly opts' - then opts' - else opts'{ flat = True } - errs' = errs ++ check options' files - +cymake prog args + | elem Help opts = printUsage prog + | null files = badUsage prog ["no files"] + | null errs' + && not (elem Html opts) = do + unless (noVerb options') + (putStrLn $ "This is cymake, version " ++ cymakeVersion) + mapM_ (buildCurry options') files + | null errs' = do + let importFiles = nub $ importPaths opts' + outputFile = maybe "" id (output opts') + mapM_ (source2html importFiles outputFile) files + | otherwise = badUsage prog errs' + where + (opts, files, errs) = getOpt Permute options args + opts' = foldr selectOption defaultOpts opts + options' = if flat opts' || flatXml opts' || abstract opts' + || untypedAbstract opts' || parseOnly opts' + then opts' + else opts'{ flat = True } + errs' = errs ++ check options' files --- Prints usage information of the command line tool. +-- | Prints usage information of the command line tool. printUsage :: String -> IO () -printUsage prog - = do putStrLn (usageInfo header options) - exitWith ExitSuccess - where - header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..." - +printUsage prog = do + putStrLn (usageInfo header options) + exitWith ExitSuccess + where header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..." --- Prints errors +-- | Prints errors badUsage :: String -> [String] -> IO () -badUsage prog errs - = do mapM (\err -> putErrLn (prog ++ ": " ++ err)) errs - abortWith ["Try '" ++ prog ++ " -" ++ "-help' for more information"] - +badUsage prog errs = do + putErrsLn $ map (\err -> prog ++ ": " ++ err) errs + abortWith ["Try '" ++ prog ++ " -" ++ "-help' for more information"] --- Checks options and files. +-- | Checks options and files and return a list of error messages check :: Options -> [String] -> [String] check opts files - | null files + | null files = ["no files"] | isJust (output opts) && length files > 1 = ["cannot specify -o with multiple targets"] | otherwise = [] - -------------------------------------------------------------------------------- --- Error handling - --- Prints an error message on 'stderr' +-- | Prints an error message on 'stderr' putErrLn :: String -> IO () putErrLn = hPutStrLn stderr --- Prints a list of error messages on 'stderr' +-- | Prints a list of error messages on 'stderr' putErrsLn :: [String] -> IO () putErrsLn = mapM_ putErrLn --- Prints a list of error messages on 'stderr' and aborts the program +-- | Prints a list of error messages on 'stderr' and aborts the program with +-- exit code 1 abortWith :: [String] -> IO a abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1) - -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- -----------------------------------------------------------------------------