diff --git a/hsx.cabal b/hsx.cabal --- a/hsx.cabal +++ b/hsx.cabal @@ -1,14 +1,14 @@ Name: hsx -Version: 0.9.1 +Version: 0.10.0 License: BSD3 License-File: LICENSE Author: Niklas Broberg, Joel Bjornson -Maintainer: Niklas Broberg +Maintainer: Niklas Broberg Stability: Experimental Category: Language -Synopsis: HSX (Haskell Source with XML) allows literal XML syntax to be used in Haskell source code. -Description: HSX (Haskell Source with XML) allows literal XML syntax to be used in Haskell source code. +Synopsis: HSX (Haskell Source with XML) allows literal XML syntax in Haskell source code. +Description: HSX (Haskell Source with XML) allows literal XML syntax in Haskell source code. The trhsx preprocessor translates .hsx source files into ordinary .hs files. Literal XML syntax is translated into function calls for creating XML values of the appropriate @@ -27,11 +27,16 @@ Achieving that is not as simple as it may seem, but the XMLGenerator module provides all the necessary machinery. -Homepage: http://code.haskell.com/HSP +Homepage: http://patch-tag.com/r/nibro/hsx Tested-With: GHC==6.8.3, GHC==6.10.1 -Cabal-Version: >= 1.2.3 +Cabal-Version: >= 1.6 Build-Type: Simple + +source-repository head + type: darcs + location: http://patch-tag.com/r/nibro/hsx + Flag base4 diff --git a/src/HSX/Transform.hs b/src/HSX/Transform.hs --- a/src/HSX/Transform.hs +++ b/src/HSX/Transform.hs @@ -14,11 +14,13 @@ ----------------------------------------------------------------------------- module HSX.Transform ( - transform -- :: HsModule -> HsModule + transform -- :: HsModule -> HsModule + , transformExp ) where import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Build +import Language.Haskell.Exts.SrcLoc (noLoc) import Data.List (union) import Debug.Trace (trace) @@ -126,7 +128,7 @@ fmap (ClassDecl s c n ns ds) $ mapM transformClassDecl cdecls -- TH splices are expressions and can contain regular patterns SpliceDecl srcloc e -> - fmap (SpliceDecl srcloc) $ transformExp e + fmap (SpliceDecl srcloc) $ transformExpM e -- Type signatures, type, newtype or data declarations, infix declarations, -- type and data families and instances, foreign imports and exports, -- and default declarations; none can contain regular patterns. @@ -176,7 +178,7 @@ -- Add the postponed patterns to the right-hand side by placing -- them in a let-expression to make them lazily evaluated. -- Then transform the whole right-hand side as an expression. - rhs' <- transformExp $ addLetDecls srcloc rnps rhs + rhs' <- transformExpM $ addLetDecls srcloc rnps rhs case guards of -- There were no guards before, and none should be added, -- so we still have an unguarded right-hand side @@ -190,7 +192,7 @@ -- Add the postponed patterns to the right-hand side by placing -- them in a let-expression to make them lazily evaluated. -- Then transform the whole right-hand side as an expression. - rhs' <- transformExp $ addLetDecls s rnps rhs + rhs' <- transformExpM $ addLetDecls s rnps rhs -- Now there are guards, so first we need to transform those oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs -- ... and then prepend the newly generated ones, as statements @@ -217,8 +219,19 @@ -- and @do@-expressions. All other expressions simply transform their -- sub-expressions, if any. -- Of special interest are of course also any xml expressions. -transformExp :: Exp -> HsxM Exp -transformExp e = case e of +transformExp :: Exp -> Exp +transformExp e = + let (e', _) = runHsxM $ transformExpM e + in e' + +-- | Transform expressions by traversing subterms. +-- Of special interest are expressions that contain patterns as subterms, +-- i.e. @let@, @case@ and lambda expressions, and also list comprehensions +-- and @do@-expressions. All other expressions simply transform their +-- sub-expressions, if any. +-- Of special interest are of course also any xml expressions. +transformExpM :: Exp -> HsxM Exp +transformExpM e = case e of -- A standard xml tag should be transformed into an element of the -- XML datatype. Attributes should be made into a set of mappings, -- and children should be transformed. @@ -254,10 +267,10 @@ -- PCDATA should be lifted as a string into the XML datatype. XPcdata pcdata -> do setXmlTransformed - return $ strE pcdata + return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "String"))) -- Escaped expressions should be treated as just expressions. XExpTag e -> do setXmlTransformed - e' <- transformExp e + e' <- transformExpM e return $ paren $ metaAsChild e' -- Patterns as arguments to a lambda expression could be regular, @@ -274,7 +287,7 @@ -- ... and put it all in a case expression, which -- can then be transformed in the normal way. e = if null rns then rhs else caseE texp [alt1] - rhs' <- transformExp e + rhs' <- transformExpM e return $ Lambda s ps rhs' -- A let expression can contain regular patterns in the declarations, -- or in the expression that makes up the body of the let. @@ -283,7 +296,7 @@ -- in a special way due to scoping, see later documentation. -- The body is transformed as a normal expression. ds' <- transformLetDecls ds - e' <- transformExp e + e' <- transformExpM e return $ letE ds' e' -- Bindings of implicit parameters can appear either in ordinary let -- expressions (GHC), in dlet expressions (Hugs) or in a with clause @@ -291,12 +304,12 @@ -- is transformed as a normal expression in all cases. Let (IPBinds is) e -> do is' <- mapM transformIPBind is - e' <- transformExp e + e' <- transformExpM e return $ Let (IPBinds is') e' -- A case expression can contain regular patterns in the expression -- that is the subject of the casing, or in either of the alternatives. Case e alts -> do - e' <- transformExp e + e' <- transformExpM e alts' <- mapM transformAlt alts return $ Case e' alts' -- A do expression can contain regular patterns in its statements. @@ -309,11 +322,11 @@ -- A list comprehension can contain regular patterns in the result -- expression, or in any of its statements. ListComp e stmts -> do - e' <- transformExp e + e' <- transformExpM e stmts' <- fmap concat $ mapM transformQualStmt stmts return $ ListComp e' stmts' ParComp e stmtss -> do - e' <- transformExp e + e' <- transformExpM e stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss return $ ParComp e' stmtss' Proc s pat rhs -> do @@ -326,29 +339,29 @@ -- ... and put it all in a case expression, which -- can then be transformed in the normal way. e = if null rns then rhs else caseE texp [alt1] - rhs' <- transformExp e + rhs' <- transformExpM e return $ Lambda s ps rhs' -- All other expressions simply transform their immediate subterms. InfixApp e1 op e2 -> transform2exp e1 e2 (\e1 e2 -> InfixApp e1 op e2) App e1 e2 -> transform2exp e1 e2 App - NegApp e -> fmap NegApp $ transformExp e + NegApp e -> fmap NegApp $ transformExpM e If e1 e2 e3 -> transform3exp e1 e2 e3 If - Tuple es -> fmap Tuple $ mapM transformExp es - List es -> fmap List $ mapM transformExp es - Paren e -> fmap Paren $ transformExp e - LeftSection e op -> do e' <- transformExp e + Tuple es -> fmap Tuple $ mapM transformExpM es + List es -> fmap List $ mapM transformExpM es + Paren e -> fmap Paren $ transformExpM e + LeftSection e op -> do e' <- transformExpM e return $ LeftSection e' op - RightSection op e -> fmap (RightSection op) $ transformExp e + RightSection op e -> fmap (RightSection op) $ transformExpM e RecConstr n fus -> fmap (RecConstr n) $ mapM transformFieldUpdate fus - RecUpdate e fus -> do e' <- transformExp e + RecUpdate e fus -> do e' <- transformExpM e fus' <- mapM transformFieldUpdate fus return $ RecUpdate e' fus' - EnumFrom e -> fmap EnumFrom $ transformExp e + EnumFrom e -> fmap EnumFrom $ transformExpM e EnumFromTo e1 e2 -> transform2exp e1 e2 EnumFromTo EnumFromThen e1 e2 -> transform2exp e1 e2 EnumFromThen EnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 EnumFromThenTo - ExpTypeSig s e t -> do e' <- transformExp e + ExpTypeSig s e t -> do e' <- transformExpM e return $ ExpTypeSig s e' t SpliceExp s -> fmap SpliceExp $ transformSplice s LeftArrApp e1 e2 -> transform2exp e1 e2 LeftArrApp @@ -356,9 +369,9 @@ LeftArrHighApp e1 e2 -> transform2exp e1 e2 LeftArrHighApp RightArrHighApp e1 e2 -> transform2exp e1 e2 RightArrHighApp - CorePragma s e -> fmap (CorePragma s) $ transformExp e - SCCPragma s e -> fmap (SCCPragma s) $ transformExp e - GenPragma s a b e -> fmap (GenPragma s a b) $ transformExp e + CorePragma s e -> fmap (CorePragma s) $ transformExpM e + SCCPragma s e -> fmap (SCCPragma s) $ transformExpM e + GenPragma s a b e -> fmap (GenPragma s a b) $ transformExpM e _ -> return e -- Warning - will not work inside TH brackets! where -- | Transform expressions appearing in child position of an xml tag. @@ -367,29 +380,29 @@ transformChild :: Exp -> HsxM Exp transformChild e = do -- Transform the expression - te <- transformExp e + te <- transformExpM e -- ... and apply the overloaded toXMLs to it return $ metaAsChild te transformFieldUpdate :: FieldUpdate -> HsxM FieldUpdate transformFieldUpdate (FieldUpdate n e) = - fmap (FieldUpdate n) $ transformExp e + fmap (FieldUpdate n) $ transformExpM e transformFieldUpdate fup = return fup transformSplice :: Splice -> HsxM Splice transformSplice s = case s of - ParenSplice e -> fmap ParenSplice $ transformExp e + ParenSplice e -> fmap ParenSplice $ transformExpM e _ -> return s transform2exp :: Exp -> Exp -> (Exp -> Exp -> a) -> HsxM a -transform2exp e1 e2 f = do e1' <- transformExp e1 - e2' <- transformExp e2 +transform2exp e1 e2 f = do e1' <- transformExpM e1 + e2' <- transformExpM e2 return $ f e1' e2' transform3exp :: Exp -> Exp -> Exp -> (Exp -> Exp -> Exp -> a) -> HsxM a -transform3exp e1 e2 e3 f = do e1' <- transformExp e1 - e2' <- transformExp e2 - e3' <- transformExp e3 +transform3exp e1 e2 e3 f = do e1' <- transformExpM e1 + e2' <- transformExpM e2 + e3' <- transformExpM e3 return $ f e1' e2' e3' mkAttr :: XAttr -> Exp @@ -462,7 +475,7 @@ -- regular patterns there... transformIPBind :: IPBind -> HsxM IPBind transformIPBind (IPBind s n e) = - fmap (IPBind s n) $ transformExp e + fmap (IPBind s n) $ transformExpM e ------------------------------------------------------------------------------------ -- Statements of various kinds @@ -502,7 +515,7 @@ -- Add the postponed patterns to the right-hand side by placing -- them in a let-expression to make them lazily evaluated. -- Then transform the whole right-hand side as an expression. - e' <- transformExp $ addLetDecls s (concat rnpss) e + e' <- transformExpM $ addLetDecls s (concat rnpss) e return $ Generator s p'' e':lt ++ gs' where monadify :: Guard -> Stmt -- To monadify is to create a statement guard, only that the @@ -510,7 +523,7 @@ -- the value gotten from the guard. monadify (s,p,e) = genStmt s p (metaReturn $ paren e) -- Qualifiers are simply wrapped expressions and are treated as such. - Qualifier e -> fmap (\e -> [Qualifier $ e]) $ transformExp e + Qualifier e -> fmap (\e -> [Qualifier $ e]) $ transformExpM e -- Let statements suffer from the same problem as let expressions, so -- the declarations should be treated in the same special way. LetStmt (BDecls ds) -> @@ -526,10 +539,10 @@ transformQualStmt qs = case qs of -- For qual statments in list comprehensions we just pass on the baton QualStmt s -> fmap (map QualStmt) $ transformStmt ListCompStmt s - ThenTrans e -> fmap (return . ThenTrans) $ transformExp e + ThenTrans e -> fmap (return . ThenTrans) $ transformExpM e ThenBy e f -> fmap return $ transform2exp e f ThenBy - GroupBy e -> fmap (return . GroupBy) $ transformExp e - GroupUsing f -> fmap (return . GroupUsing) $ transformExp f + GroupBy e -> fmap (return . GroupBy) $ transformExpM e + GroupUsing f -> fmap (return . GroupUsing) $ transformExpM f GroupByUsing e f -> fmap return $ transform2exp e f GroupByUsing ------------------------------------------------------------------------------------------ @@ -565,7 +578,7 @@ -- Add the postponed patterns to the right-hand side by placing -- them in a let-expression to make them lazily evaluated. -- Then transform the whole right-hand side as an expression. - rhs' <- transformExp $ addLetDecls s rnps rhs + rhs' <- transformExpM $ addLetDecls s rnps rhs case guards of -- There were no guards before, and none should be added, -- so we still have an unguarded right-hand side @@ -580,7 +593,7 @@ -- Add the postponed patterns to the right-hand side by placing -- them in a let-expression to make them lazily evaluated. -- Then transform the whole right-hand side as an expression. - rhs' <- transformExp $ addLetDecls s rnps rhs + rhs' <- transformExpM $ addLetDecls s rnps rhs -- Now there are guards, so first we need to transform those oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs -- ... and then prepend the newly generated ones, as statements @@ -961,7 +974,7 @@ -- Transforming any other patterns simply means transforming -- their subparts. PViewPat e p -> do - e' <- liftTr $ transformExp e + e' <- liftTr $ transformExpM e tr1pat p (PViewPat e') (trPattern s) PVar _ -> return p PLit _ -> return p @@ -1128,10 +1141,10 @@ -- First the alternative if we actually -- match the given pattern let alt1 = alt s p -- foo -> Just (mf foo) - (app (var just_name) $ + (app (con just_name) $ tuple (map (retVar b) vs)) -- .. and finally an alternative for not matching the pattern. - alt2 = alt s wildcard (var nothing_name) -- _ -> Nothing + alt2 = alt s wildcard (con nothing_name) -- _ -> Nothing -- ... and that pattern could itself contain regular patterns -- so we must transform away these. alt1' <- liftTr $ transformAlt alt1 @@ -1191,10 +1204,10 @@ -- First the alternative if we actually -- match the given pattern let alt1 = altGW s p gs -- foo -> Just (mf foo) - (app (var just_name) $ + (app (con just_name) $ tuple (map (retVar b) vs)) noBinds -- .. and finally an alternative for not matching the pattern. - alt2 = alt s wildcard (var nothing_name) -- _ -> Nothing + alt2 = alt s wildcard (con nothing_name) -- _ -> Nothing -- ... and that pattern could itself contain regular patterns -- so we must transform away these. alt1' <- liftTr $ transformAlt alt1 @@ -1366,10 +1379,10 @@ vals2 = map (varOrId vs2) allvs -- ... apply either Left or Right to the returned value ret1 = metaReturn $ tuple -- return (Left harp_val1, (foo, id, ...)) - [app (var left_name) + [app (con left_name) (var v1), tuple vals1] ret2 = metaReturn $ tuple -- return (Right harp_val2, (id, bar, ...)) - [app (var right_name) + [app (con right_name) (var v2), tuple vals2] -- ... and do all these things in do-expressions exp1 = doE [g1, qualStmt ret1] @@ -1428,7 +1441,7 @@ -- Then we need a basic matching function that always matches, -- and that binds the value matched to the variable in question. let e = paren $ lamE s [pvar v] $ -- (\v -> Just (mf v)) - app (var just_name) + app (con just_name) (paren $ retVar linear v) -- Lift the function into the matcher monad, and bind it to its name, -- then add it the declaration to the store. @@ -1450,7 +1463,7 @@ n <- genMatchName -- ... and then a function that always matches, discarding the result let e = paren $ lamE s [wildcard] $ -- (\_ -> Just ()) - app (var just_name) unit_con + app (con just_name) unit_con -- ... which we lift, bind, and add to the store. pushDecl $ nameBind s n $ -- harp_matchX = baseMatch (\_ -> Just ()) app baseMatchFun e @@ -1588,7 +1601,7 @@ (g, val) = mkGenExp s nvt -- (harp_valX, (foo, bar, ...)) <- harp_matchY -- ... and apply a Just to its value ret1 = metaReturn $ tuple -- return (Just harp_val1, (foo, bar, ...)) - [app (var just_name) + [app (con just_name) (var val), varTuple vs] -- ... and do those two steps in a do-expression exp1 = doE [g, qualStmt ret1] -- do .... @@ -1596,7 +1609,7 @@ ids = map (const idFun) vs -- (id, id, ...) -- ... and the value should be Nothing. ret2 = metaReturn $ tuple -- return (Nothing, (id, id, ...)) - [var nothing_name, tuple ids] -- i.e. no vars were bound + [con nothing_name, tuple ids] -- i.e. no vars were bound -- The order of the arguments to the choice (+++) operator -- is determined by greed... mc = if greedy @@ -1832,10 +1845,10 @@ Just p -> pParen $ metaPJust p metaJust :: Exp -> Exp -metaJust e = app (var just_name) e +metaJust e = app (con just_name) e metaNothing :: Exp -metaNothing = var nothing_name +metaNothing = con nothing_name metaMkMaybe :: Maybe Exp -> Exp metaMkMaybe me = case me of @@ -1848,6 +1861,9 @@ consFun = Con cons idFun = function "id" +con :: Name -> Exp +con = Con . UnQual + cons :: QName cons = Special Cons @@ -1857,10 +1873,10 @@ append = Symbol "++" just_name, nothing_name, left_name, right_name :: Name -just_name = Ident "Just" +just_name = Ident "Just" nothing_name = Ident "Nothing" -left_name = Ident "Left" -right_name = Ident "Right" +left_name = Ident "Left" +right_name = Ident "Right" ------------------------------------------------------------------------ -- Help functions for meta programming xml diff --git a/src/HSX/XMLGenerator.hs b/src/HSX/XMLGenerator.hs --- a/src/HSX/XMLGenerator.hs +++ b/src/HSX/XMLGenerator.hs @@ -51,22 +51,22 @@ -- | Generate XML values in some XMLGenerator monad. class Monad m => XMLGen m where - type XML m - data Child m - data Attribute m - genElement :: Name -> [XMLGenT m [Attribute m]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m) - genEElement :: Name -> [XMLGenT m [Attribute m]] -> XMLGenT m (XML m) + type XMLType m + data ChildType m + data AttributeType m + genElement :: Name -> [XMLGenT m [AttributeType m]] -> [XMLGenT m [ChildType m]] -> XMLGenT m (XMLType m) + genEElement :: Name -> [XMLGenT m [AttributeType m]] -> XMLGenT m (XMLType m) genEElement n ats = genElement n ats [] - xmlToChild :: XML m -> Child m - pcdataToChild :: String -> Child m + xmlToChild :: XMLType m -> ChildType m + pcdataToChild :: String -> ChildType m -- | Type synonyms to avoid writing out the XMLnGenT all the time -type GenXML m = XMLGenT m (XML m) -type GenXMLList m = XMLGenT m [XML m] -type GenChild m = XMLGenT m (Child m) -type GenChildList m = XMLGenT m [Child m] -type GenAttribute m = XMLGenT m (Attribute m) -type GenAttributeList m = XMLGenT m [Attribute m] +type GenXML m = XMLGenT m (XMLType m) +type GenXMLList m = XMLGenT m [XMLType m] +type GenChild m = XMLGenT m (ChildType m) +type GenChildList m = XMLGenT m [ChildType m] +type GenAttribute m = XMLGenT m (AttributeType m) +type GenAttributeList m = XMLGenT m [AttributeType m] -- | Embed values as child nodes of an XML element. The parent type will be clear -- from the context so it is not mentioned. @@ -86,19 +86,21 @@ instance EmbedAsChild m c => EmbedAsChild m [c] where asChild = liftM concat . mapM asChild -instance XMLGen m => EmbedAsChild m (Child m) where +instance XMLGen m => EmbedAsChild m (ChildType m) where asChild = return . return #if __GLASGOW_HASKELL__ >= 610 -instance (XMLGen m, XML m ~ x) => EmbedAsChild m x where +instance (XMLGen m, XMLType m ~ x) => EmbedAsChild m x where #else -instance (XMLGen m) => EmbedAsChild m (XML m) where +instance (XMLGen m) => EmbedAsChild m (XMLType m) where #endif asChild = return . return . xmlToChild instance XMLGen m => EmbedAsChild m String where asChild = return . return . pcdataToChild +instance XMLGen m => EmbedAsChild m () where + asChild _ = return [] -- | Similarly embed values as attributes of an XML element. class XMLGen m => EmbedAsAttr m a where @@ -112,7 +114,7 @@ v <- XMLGenT $ typeCastM m1a asAttr (a := v) -instance XMLGen m => EmbedAsAttr m (Attribute m) where +instance XMLGen m => EmbedAsAttr m (AttributeType m) where asAttr = return . return instance EmbedAsAttr m a => EmbedAsAttr m [a] where @@ -120,12 +122,13 @@ class (XMLGen m, - SetAttr m (XML m), - AppendChild m (XML m), - EmbedAsChild m (XML m), - EmbedAsChild m [XML m], + SetAttr m (XMLType m), + AppendChild m (XMLType m), + EmbedAsChild m (XMLType m), + EmbedAsChild m [XMLType m], EmbedAsChild m String, EmbedAsChild m Char, -- for overlap purposes + EmbedAsChild m (), EmbedAsAttr m (Attr String String), EmbedAsAttr m (Attr String Int), EmbedAsAttr m (Attr String Bool) @@ -135,10 +138,13 @@ -- This is certainly true, but we want the various generators to explicitly state it, -- in order to get the error messages right. instance (XMLGen m, - SetAttr m (XML m), - AppendChild m (XML m), + SetAttr m (XMLType m), + AppendChild m (XMLType m), + EmbedAsChild m (XMLType m), + EmbedAsChild m [XMLType m], EmbedAsChild m String, EmbedAsChild m Char, + EmbedAsChild m (), EmbedAsAttr m (Attr String String), EmbedAsAttr m (Attr String Int), EmbedAsAttr m (Attr String Bool)