diff --git a/hsx.cabal b/hsx.cabal --- a/hsx.cabal +++ b/hsx.cabal @@ -1,8 +1,8 @@ Name: hsx -Version: 0.6.2 +Version: 0.7.0 License: BSD3 License-File: LICENSE -Author: Niklas Broberg, Joel Björnson +Author: Niklas Broberg, Joel Bjornson Maintainer: Niklas Broberg Stability: Experimental @@ -29,15 +29,23 @@ Homepage: http://code.google.com/hsp -Build-Depends: base>3 && <5, mtl, haskell-src-exts >= 1.5, utf8-string -Build-Type: Simple Tested-With: GHC==6.8.3, GHC==6.10.1 Cabal-Version: >= 1.2.3 +Build-Type: Simple -Hs-Source-Dirs: src -Exposed-Modules: HSX.XMLGenerator, HSX.Transform +Flag base4 -Extensions: MultiParamTypeClasses, +Library + Build-depends: mtl, haskell-src-exts >= 1.5, utf8-string + if flag(base4) + Build-depends: base >= 4 && < 5 + cpp-options: -DBASE4 + else + Build-depends: base >= 3 && < 4 + Hs-Source-Dirs: src + Exposed-Modules: HSX.XMLGenerator, HSX.Transform + + Extensions: MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances, UndecidableInstances, @@ -49,6 +57,6 @@ TypeOperators, CPP -Executable: trhsx -Main-Is: Trhsx.hs -Hs-Source-Dirs: src +Executable trhsx + Main-Is: Trhsx.hs + Hs-Source-Dirs: src diff --git a/src/HSX/Transform.hs b/src/HSX/Transform.hs --- a/src/HSX/Transform.hs +++ b/src/HSX/Transform.hs @@ -1260,7 +1260,7 @@ flatten S = consFun -- (:) flatten (L mt) = let f = flatten mt - r = paren $ metaMap f + r = paren $ metaMap [f] in paren $ foldCompFun `metaComp` r -- (foldComp . (map $flatten)) flatten (E mt1 mt2) = let f1 = flatten mt1 @@ -1782,18 +1782,18 @@ -- meta-level functions, i.e. functions that represent functions, -- and that take arguments representing arguments... whew! -metaReturn, metaConst, metaMap, metaUnzip :: Exp -> Exp +metaReturn, metaConst, metaUnzip :: Exp -> Exp metaReturn e = metaFunction "return" [e] metaConst e = metaFunction "const" [e] -metaMap e = metaFunction "map" [e] metaUnzip e = metaFunction "unzip" [e] metaEither, metaMaybe :: Exp -> Exp -> Exp metaEither e1 e2 = metaFunction "either" [e1,e2] metaMaybe e1 e2 = metaFunction "maybe" [e1,e2] -metaConcat :: [Exp] -> Exp +metaConcat, metaMap :: [Exp] -> Exp metaConcat es = metaFunction "concat" [listE es] +metaMap = metaFunction "map" metaAppend :: Exp -> Exp -> Exp metaAppend l1 l2 = infixApp l1 appendOp l2 @@ -1870,7 +1870,7 @@ metaGenElement name ats mat cs = let (d,n) = xNameParts name ne = tuple [metaMkMaybe $ fmap strE d, strE n] - m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaAsAttr x)) mat + m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat attrs = m $ listE $ map metaAsAttr ats in metaFunction "genElement" [ne, attrs, listE cs] @@ -1879,13 +1879,16 @@ metaGenEElement name ats mat = let (d,n) = xNameParts name ne = tuple [metaMkMaybe $ fmap strE d, strE n] - m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaAsAttr x)) mat + m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat attrs = m $ listE $ map metaAsAttr ats in metaFunction "genEElement" [ne, attrs] -- | Create an attribute by applying the overloaded @asAttr@ metaAsAttr :: Exp -> Exp metaAsAttr e = metaFunction "asAttr" [e] + +argAsAttr :: Exp +argAsAttr = var $ name "asAttr" -- | Create a property from an attribute and a value. metaAssign :: Exp -> Exp -> Exp diff --git a/src/HSX/XMLGenerator.hs b/src/HSX/XMLGenerator.hs --- a/src/HSX/XMLGenerator.hs +++ b/src/HSX/XMLGenerator.hs @@ -32,6 +32,10 @@ unXMLGenT :: XMLGenT m a -> m a unXMLGenT (XMLGenT ma) = ma +-- | map the inner monad +mapXMLGenT :: (m a -> n b) -> XMLGenT m a -> XMLGenT n b +mapXMLGenT f (XMLGenT m) = XMLGenT (f m) + instance MonadTrans XMLGenT where lift = XMLGenT @@ -46,6 +50,7 @@ genEElement :: Name -> [XMLGenT m [Attribute m]] -> XMLGenT m (XML m) genEElement n ats = genElement n ats [] xmlToChild :: XML m -> Child m + pcdataToChild :: String -> Child m -- | Type synonyms to avoid writing out the XMLnGenT all the time type GenXML m = XMLGenT m (XML m) @@ -77,6 +82,9 @@ instance (XMLGen m) => EmbedAsChild m (XML m) where #endif asChild = return . return . xmlToChild + +instance XMLGen m => EmbedAsChild m String where + asChild = return . return . pcdataToChild -- | Similarly embed values as attributes of an XML element. diff --git a/src/Trhsx.hs b/src/Trhsx.hs --- a/src/Trhsx.hs +++ b/src/Trhsx.hs @@ -1,17 +1,28 @@ +{-# LANGUAGE CPP #-} module Main where import Language.Haskell.Exts hiding (parse) import Prelude hiding (readFile, writeFile) -import System.IO.UTF8 (readFile, writeFile) +import System.IO.UTF8 (readFile, writeFile,hPutStrLn) +import System.IO (stderr) import HSX.Transform +import System.Exit (exitFailure) import System.Environment (getArgs) import Data.List (isPrefixOf) +#ifdef BASE4 +import Control.OldException (handle,ErrorCall(..)) +#else +import Control.Exception (handle,ErrorCall(..)) +#endif + +showSrcLoc (SrcLoc {srcFilename=srcFilename,srcLine=srcLine,srcColumn=srcColumn}) = + srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn checkParse :: ParseResult b -> b checkParse p = case p of ParseOk m -> m - ParseFailed loc s -> error $ "Error at " ++ show loc ++ ":\n" ++ s + ParseFailed loc s -> error $ showSrcLoc loc ++ ": " ++ s transformFile :: String -> String -> String -> IO () transformFile origfile infile outfile = do @@ -41,11 +52,12 @@ main :: IO () main = do args <- getArgs - case args of - [origfile, infile, outfile] -> transformFile origfile infile outfile - [infile, outfile] -> transformFile infile infile outfile - [infile] -> testFile infile - _ -> putStrLn usageString + handle (\(ErrorCall text) -> hPutStrLn stderr text >> exitFailure ) $ + case args of + [origfile, infile, outfile] -> transformFile origfile infile outfile + [infile, outfile] -> transformFile infile infile outfile + [infile] -> testFile infile + _ -> putStrLn usageString process :: FilePath -> String -> String process fp fc = prettyPrintWithMode (defaultMode {linePragmas=True}) $