hsx2hs (empty) → 0.11.0
raw patch · 6 files changed
+2220/−0 lines, 6 filesdep +basedep +haskell-src-extsdep +haskell-src-metasetup-changed
Dependencies added: base, haskell-src-exts, haskell-src-meta, mtl, template-haskell, utf8-string
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- hsx2hs.cabal +73/−0
- src/Language/Haskell/HSX/QQ.hs +77/−0
- src/Language/Haskell/HSX/Transform.hs +1962/−0
- src/hsx2hs.hs +78/−0
+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsx2hs.cabal view
@@ -0,0 +1,73 @@+Name: hsx2hs+Version: 0.11.0+License: BSD3+License-File: LICENSE+Author: Niklas Broberg, Joel Bjornson+Maintainer: Niklas Broberg <niklas.broberg@gmail.com>++Stability: Experimental+Category: Language+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+ forms.+ + trhsx transforms literal XML syntax into a series of function calls. Any project+ can make use of the syntax by providing definitions for those functions, and the+ XML values produced will be of the types specified. This works for any types, since+ trhsx doesn't make any assumptions, or inserts any information depending on types.+ + XMLGenerator defines a few typeclasses that together cover the functions injected by the+ preprocessor. A project that uses these classes to provide the semantics for the injected+ syntax will be able to use any functions written in terms of these, allowing better code + reusability than if each project defines its own semantics for the XML syntax. Also, the classes+ makes it possible to use the literal syntax at different types within the same module.+ Achieving that is not as simple as it may seem, but the XMLGenerator module provides all the+ necessary machinery.+ +Homepage: http://patch-tag.com/r/nibro/hsx++Tested-With: GHC==6.8.3, GHC==6.10.1+Cabal-Version: >= 1.6+Build-Type: Simple++source-repository head+ type: darcs+ location: http://patch-tag.com/r/nibro/hsx+++Flag base4++Library+ Build-depends: mtl >= 2.0 && < 2.2,+ haskell-src-exts >= 1.13,+ haskell-src-meta >= 0.6 && < 0.7,+ template-haskell == 2.7.*,+ utf8-string == 0.3.*++ if flag(base4)+ Build-depends: base >= 4 && < 5+ cpp-options: -DBASE4+ else+ Build-depends: base >= 3 && < 4+ Hs-Source-Dirs: src+ Exposed-Modules: Language.Haskell.HSX.Transform+ Language.Haskell.HSX.QQ++ Extensions: MultiParamTypeClasses,+ FunctionalDependencies,+ OverlappingInstances,+ UndecidableInstances,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ TypeFamilies,+ TypeSynonymInstances,+ FlexibleContexts,+ TypeOperators,+ CPP++Executable hsx2hs+ Main-Is: hsx2hs.hs+ Hs-Source-Dirs: src
+ src/Language/Haskell/HSX/QQ.hs view
@@ -0,0 +1,77 @@+{- | this module provides a QuasiQuoter that supports the HSX syntax.++-- Module : Language.Haskell.HSX.Tranform+-- Copyright : (c) Niklas Broberg 2004-2012+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com+-- Stability : experimental+-- Portability : portable+--++You will need to enable the QuasiQuotes extension for it to work, which you can do by adding this to the top of your file:++ {-\# LANGUAGE QuasiQuotes \#-}++Here is a simple example that generates an HTML fragment:++> import Data.Char (toUpper)+> import HSX.QQ (hsx)+> import HSX.XMLGenerator+>+> html :: (XMLGenerator m) => XMLGenT m (XMLType m)+> html = [hsx| <p><% map toUpper "hello, world!" %></p> |]++The syntax used by the hsx QuasiQuoter is the same as what is used by+@trhsx@. It is mostly normal XML syntax which a few key differences:++ 1. strings inside tags and attributes are automatically escaped -- you do not need to do <, etc.++ 2. The <% %> syntax is used to embed the result of evaluating a Haskell expression into the XML++Values are embedde using the 'EmbedAsChild' and 'EmbedAsAttr'+classes. Additional instances can be added to support application+specific types.++-}+module Language.Haskell.HSX.QQ+ ( hsx+ )+ where+++import qualified Language.Haskell.Exts.Syntax as Hs+import Language.Haskell.Exts hiding (Exp, parse, parseExp)+import Language.Haskell.HSX.Transform (transformExp)+import Language.Haskell.Meta.Parse hiding (parseHsExp, parseExp)+import Language.Haskell.Meta.Syntax.Translate (toExp)+import Language.Haskell.TH (Exp, ExpQ)+import Language.Haskell.TH.Quote (QuasiQuoter(..))++-- | QuasiQuoter which can be used to parse HSX syntax+hsx :: QuasiQuoter+hsx = QuasiQuoter { quoteExp = parseHsxExp+ , quotePat = error "the hsx QuasiQuoter can only be used on expressions."+ , quoteType = error "the hsx QuasiQuoter can only be used on expressions."+ , quoteDec = error "the hsx QuasiQuoter can only be used on expressions."+ }++parseHsxExp :: String -> ExpQ+parseHsxExp = either (error . show) (return . toExp . transformExp) . parseHsExp++parseExp :: String -> Either String Exp+parseExp = either Left (Right . toExp . transformExp) . parseHsExp++parseHsExp :: String -> Either String Hs.Exp+parseHsExp = either Left (Right . transformExp) . parseResultToEither . parseExpWithMode parseMode++parseMode :: ParseMode+parseMode = ParseMode "" allExtensions False True (Just baseFixities)++allExtensions :: [Extension]+allExtensions =+ [RecursiveDo,ParallelListComp,MultiParamTypeClasses,FunctionalDependencies,RankNTypes,ExistentialQuantification,+ ScopedTypeVariables,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls,KindSignatures,+ BangPatterns,TemplateHaskell,ForeignFunctionInterface,Arrows,Generics,NamedFieldPuns,PatternGuards,+ MagicHash,TypeFamilies,StandaloneDeriving,TypeOperators,RecordWildCards,GADTs,UnboxedTuples,+ PackageImports,QuasiQuotes,TransformListComp,ViewPatterns,XmlSyntax,RegularPatterns]
+ src/Language/Haskell/HSX/Transform.hs view
@@ -0,0 +1,1962 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.HSX.Tranform+-- Copyright : (c) Niklas Broberg 2004-2012+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Functions for transforming abstract Haskell code extended with regular+-- patterns into semantically equivalent normal abstract Haskell code. In+-- other words, we transform away regular patterns.+-----------------------------------------------------------------------------++module Language.Haskell.HSX.Transform (+ 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)++-----------------------------------------------------------------------------+-- A monad for threading a boolean value through the boilerplate code,+-- to signal whether a transformation has taken place or not.++newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))++instance Monad HsxM where+ return x = MkHsxM (\s -> (x,s))+ (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s+ (MkHsxM f') = k a+ in f' s')++getHsxState :: HsxM HsxState+getHsxState = MkHsxM (\s -> (s, s))++setHsxState :: HsxState -> HsxM ()+setHsxState s = MkHsxM (\_ -> ((),s))++instance Functor HsxM where+ fmap f hma = do a <- hma+ return $ f a++-----++type HsxState = (Bool, Bool)++initHsxState :: HsxState+initHsxState = (False, False)++setHarpTransformed :: HsxM ()+setHarpTransformed =+ do (_,x) <- getHsxState+ setHsxState (True,x)++setXmlTransformed :: HsxM ()+setXmlTransformed =+ do (h,_) <- getHsxState+ setHsxState (h,True)++runHsxM :: HsxM a -> (a, (Bool, Bool))+runHsxM (MkHsxM f) = f initHsxState++-----------------------------------------------------------------------------+-- Traversing and transforming the syntax tree+++-- | Transform away occurences of regular patterns from an abstract+-- Haskell module, preserving semantics.+transform :: Module -> Module+transform (Module s m pragmas warn mes is decls) =+ let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls+ -- We may need to add an import for Match.hs that defines the matcher monad+ imps1 = if harp+ then (:) $ ImportDecl s match_mod True False Nothing+ (Just match_qual_mod)+ Nothing+ else id+ imps2 = {- if hsx+ then (:) $ ImportDecl s hsx_data_mod False+ Nothing+ Nothing+ else -} id -- we no longer want to import HSP.Data+ in Module s m pragmas warn mes (imps1 $ imps2 is) decls'++-----------------------------------------------------------------------------+-- Declarations++-- | Transform a declaration by transforming subterms that could+-- contain regular patterns.+transformDecl :: Decl -> HsxM Decl+transformDecl d = case d of+ -- Pattern binds can contain regular patterns in the pattern being bound+ -- as well as on the right-hand side and in declarations in a where clause+ PatBind srcloc pat mty rhs decls -> do+ -- Preserve semantics of irrefutable regular patterns by postponing+ -- their evaluation to a let-expression on the right-hand side+ let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+ -- Transform the pattern itself+ ([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']+ -- Transform the right-hand side, and add any generated guards+ -- and let expressions to it+ rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs+ -- Transform declarations in the where clause, adding any generated+ -- declarations to it+ decls' <- case decls of+ BDecls ds -> do ds' <- transformLetDecls ds+ return $ BDecls $ decls'' ++ ds'+ _ -> error "Cannot bind implicit parameters in the \+ \ \'where\' clause of a function using regular patterns."+ return $ PatBind srcloc pat'' mty rhs' decls'++ -- Function binds can contain regular patterns in their matches+ FunBind ms -> fmap FunBind $ mapM transformMatch ms+ -- Instance declarations can contain regular patterns in the+ -- declarations of functions inside it+ InstDecl s c n ts idecls ->+ fmap (InstDecl s c n ts) $ mapM transformInstDecl idecls+ -- Class declarations can contain regular patterns in the+ -- declarations of automatically instantiated functions+ ClassDecl s c n ns ds cdecls ->+ 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) $ 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.+ -- Note that we don't transform inside rules pragmas!+ _ -> return d++transformInstDecl :: InstDecl -> HsxM InstDecl+transformInstDecl d = case d of+ InsDecl decl -> fmap InsDecl $ transformDecl decl+ _ -> return d++transformClassDecl :: ClassDecl -> HsxM ClassDecl+transformClassDecl d = case d of+ ClsDecl decl -> fmap ClsDecl $ transformDecl decl+ _ -> return d++++-- | Transform a function "match" by generating pattern guards and+-- declarations representing regular patterns in the argument list.+-- Subterms, such as guards and the right-hand side, are also traversed+-- transformed.+transformMatch :: Match -> HsxM Match+transformMatch (Match srcloc name pats mty rhs decls) = do+ -- Preserve semantics of irrefutable regular patterns by postponing+ -- their evaluation to a let-expression on the right-hand side+ let (pats', rnpss) = unzip $ renameIrrPats pats+ -- Transform the patterns that stand as arguments to the function+ (pats'', attrGuards, guards, decls'') <- transformPatterns srcloc pats'+ -- Transform the right-hand side, and add any generated guards+ -- and let expressions to it+ rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs+ -- Transform declarations in the where clause, adding any generated+ -- declarations to it+ decls' <- case decls of+ BDecls ds -> do ds' <- transformLetDecls ds+ return $ BDecls $ decls'' ++ ds'+ _ -> error "Cannot bind implicit parameters in the \+ \ \'where\' clause of a function using regular patterns."++ return $ Match srcloc name pats'' mty rhs' decls'+-- | Transform and update guards and right-hand side of a function or+-- pattern binding. The supplied list of guards is prepended to the+-- original guards, and subterms are traversed and transformed.+mkRhs :: SrcLoc -> [Guard] -> [(Name, Pat)] -> Rhs -> HsxM Rhs+mkRhs srcloc guards rnps (UnGuardedRhs rhs) = do+ -- 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' <- 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+ [] -> return $ UnGuardedRhs rhs'+ -- There are guards to add. These should be added as pattern+ -- guards, i.e. as statements.+ _ -> return $ GuardedRhss [GuardedRhs srcloc (map mkStmtGuard guards) rhs']+mkRhs _ guards rnps (GuardedRhss gdrhss) = fmap GuardedRhss $ mapM (mkGRhs guards rnps) gdrhss+ where mkGRhs :: [Guard] -> [(Name, Pat)] -> GuardedRhs -> HsxM GuardedRhs+ mkGRhs gs rnps (GuardedRhs s oldgs rhs) = do+ -- 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' <- 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+ return $ GuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'++-- | Place declarations of postponed regular patterns in a let-expression to+-- make them lazy, in order to make them behave as irrefutable patterns.+addLetDecls :: SrcLoc -> [(Name, Pat)] -> Exp -> Exp+addLetDecls s [] e = e -- no declarations to add+addLetDecls s rnps e =+ -- Place all postponed patterns in the same let-expression+ letE (map (mkDecl s) rnps) e++-- | Make pattern binds from postponed regular patterns+mkDecl :: SrcLoc -> (Name, Pat) -> Decl+mkDecl srcloc (n,p) = patBind srcloc p (var n)++------------------------------------------------------------------------------------+-- Expressions++-- | 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.+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.+ XTag _ name attrs mattr cs -> do+ -- Hey Pluto, look, we have XML in our syntax tree!+ setXmlTransformed+ let -- ... make tuples of the attributes+ as = map mkAttr attrs+ -- ... transform the children+ cs' <- mapM transformChild cs+ -- ... and lift the values into the XML datatype.+ return $ paren $ metaGenElement name as mattr cs'++ -- An empty xml tag should be transformed just as a standard tag,+ -- only that there are no children,+ XETag _ name attrs mattr -> do+ -- ... 'tis the season to be jolly, falalalalaaaa....+ setXmlTransformed+ let -- ... make tuples of the attributes+ as = map mkAttr attrs+ -- ... and lift the values into the XML datatype.+ return $ paren $ metaGenEElement name as mattr++ -- A child tag should be transformed into an application+ -- of asChild to a list of children.+ XChildTag _ cs -> do+ -- After all, it IS christmas!+ setXmlTransformed+ -- ... transform the children+ cs' <- mapM transformChild cs+ -- ... and make them into a list+ return $ paren $ metaAsChild $ listE cs'++ -- PCDATA should be lifted as a string into the XML datatype.+ XPcdata pcdata -> do setXmlTransformed+ return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "String")))+ -- Escaped expressions should be treated as just expressions.+ XExpTag e -> do setXmlTransformed+ e' <- transformExpM e+ return $ paren $ metaAsChild e'++ -- Patterns as arguments to a lambda expression could be regular,+ -- but we cannot put the evaluation here since a lambda expression+ -- can have neither guards nor a where clause. Thus we must postpone+ -- them to a case expressions on the right-hand side.+ Lambda s pats rhs -> do+ let -- First rename regular patterns+ (ps, rnpss) = unzip $ renameRPats pats+ -- ... group them up to one big tuple+ (rns, rps) = unzip (concat rnpss)+ alt1 = alt s (pTuple rps) rhs+ texp = varTuple rns+ -- ... 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' <- 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.+ Let (BDecls ds) e -> do+ -- Declarations appearing in a let expression must be transformed+ -- in a special way due to scoping, see later documentation.+ -- The body is transformed as a normal expression.+ ds' <- transformLetDecls ds+ 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+ -- (both). Such bindings are transformed in a special way. The body+ -- is transformed as a normal expression in all cases.+ Let (IPBinds is) e -> do+ is' <- mapM transformIPBind is+ 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' <- transformExpM e+ alts' <- mapM transformAlt alts+ return $ Case e' alts'+ -- A do expression can contain regular patterns in its statements.+ Do stmts -> do+ stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts+ return $ Do stmts'+ MDo stmts -> do+ stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts+ return $ MDo stmts'+ -- A list comprehension can contain regular patterns in the result+ -- expression, or in any of its statements.+ ListComp e stmts -> do+ e' <- transformExpM e+ stmts' <- fmap concat $ mapM transformQualStmt stmts+ return $ ListComp e' stmts'+ ParComp e stmtss -> do+ e' <- transformExpM e+ stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss+ return $ ParComp e' stmtss'+ Proc s pat rhs -> do+ let -- First rename regular patterns+ ([p], [rnps]) = unzip $ renameRPats [pat]+ -- ... group them up to one big tuple+ (rns, rps) = unzip rnps+ alt1 = alt s (pTuple rps) rhs+ texp = varTuple rns+ -- ... 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' <- transformExpM e+ return $ Proc s p 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 $ transformExpM e+ If e1 e2 e3 -> transform3exp e1 e2 e3 If+ 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) $ transformExpM e+ RecConstr n fus -> fmap (RecConstr n) $ mapM transformFieldUpdate fus+ RecUpdate e fus -> do e' <- transformExpM e+ fus' <- mapM transformFieldUpdate fus+ return $ RecUpdate e' fus'+ 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' <- transformExpM e+ return $ ExpTypeSig s e' t+ SpliceExp s -> fmap SpliceExp $ transformSplice s+ LeftArrApp e1 e2 -> transform2exp e1 e2 LeftArrApp+ RightArrApp e1 e2 -> transform2exp e1 e2 RightArrApp+ LeftArrHighApp e1 e2 -> transform2exp e1 e2 LeftArrHighApp+ RightArrHighApp e1 e2 -> transform2exp e1 e2 RightArrHighApp++ 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.+ -- Expressions are first transformed, then wrapped in a call to+ -- @toXml@.+ transformChild :: Exp -> HsxM Exp+ transformChild e = do+ -- Transform the expression+ te <- transformExpM e+ -- ... and apply the overloaded toXMLs to it+ return $ metaAsChild te++transformFieldUpdate :: FieldUpdate -> HsxM FieldUpdate+transformFieldUpdate (FieldUpdate n e) =+ fmap (FieldUpdate n) $ transformExpM e+transformFieldUpdate fup = return fup++transformSplice :: Splice -> HsxM Splice+transformSplice s = case s of+ ParenSplice e -> fmap ParenSplice $ transformExpM e+ _ -> return s++transform2exp :: Exp -> Exp -> (Exp -> Exp -> a) -> HsxM a+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' <- transformExpM e1+ e2' <- transformExpM e2+ e3' <- transformExpM e3+ return $ f e1' e2' e3'++mkAttr :: XAttr -> Exp+mkAttr (XAttr name e) =+ paren (metaMkName name `metaAssign` (stringTypeSig e))+ where+ stringTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))+ stringTypeSig e = e++-- | Transform pattern bind declarations inside a @let@-expression by transforming+-- subterms that could appear as regular patterns, as well as transforming the bound+-- pattern itself. The reason we need to do this in a special way is scoping, i.e.+-- in the expression @let a | Just b <- match a = list in b@ the variable b will not+-- be in scope after the @in@. And besides, we would be on thin ice even if it was in+-- scope since we are referring to the pattern being bound in the guard that will+-- decide if the pattern will be bound... yikes, why does Haskell allow guards on+-- pattern binds to refer to the patterns being bound, could that ever lead to anything+-- but an infinite loop??+transformLetDecls :: [Decl] -> HsxM [Decl]+transformLetDecls ds = do+ -- We need to rename regular patterns in pattern bindings, since we need to+ -- separate the generated declaration sets. This since we need to add them not+ -- to the actual binding but rather to the declaration that will be the guard+ -- of the binding.+ let ds' = renameLetDecls ds+ transformLDs 0 0 ds'+ where transformLDs :: Int -> Int -> [Decl] -> HsxM [Decl]+ transformLDs k l ds = case ds of+ [] -> return []+ (d:ds) -> case d of+ PatBind srcloc pat mty rhs decls -> do+ -- We need to transform all pattern bindings in a set of+ -- declarations in the same context w.r.t. generating fresh+ -- variable names, since they will all be in scope at the same time.+ ([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns srcloc [pat])+ decls' <- case decls of+ -- Any declarations already in place should be left where they+ -- are since they probably refer to the generating right-hand+ -- side of the pattern bind. If they don't, we're in trouble...+ BDecls decls -> fmap BDecls $ transformLetDecls decls+ -- If they are implicit parameter bindings we simply transform+ -- them as such.+ IPBinds decls -> fmap IPBinds $ mapM transformIPBind decls+ -- The generated guard, if any, should be a declaration, and the+ -- generated declarations should be associated with it.+ let gs' = case gs of+ [] -> []+ [g] -> [mkDeclGuard g ws]+ _ -> error "This should not happen since we have called renameLetDecls already!"+ -- Generated attribute guards should also be added as declarations,+ -- but with no where clauses.+ ags' = map (flip mkDeclGuard $ []) ags+ -- We must transform the right-hand side as well, but there are+ -- no new guards, nor any postponed patterns, to supply at this time.+ rhs' <- mkRhs srcloc [] [] rhs+ -- ... and then we should recurse with the new gensym argument.+ ds' <- transformLDs k' l' ds+ -- The generated guards, which should be at most one, should be+ -- added as declarations rather than as guards due to the+ -- scoping issue described above.+ return $ (PatBind srcloc pat' mty rhs' decls') : ags' ++ gs' ++ ds'++ -- We only need to treat pattern binds separately, other declarations+ -- can be transformed normally.+ d -> do d' <- transformDecl d+ ds' <- transformLDs k l ds+ return $ d':ds'+++-- | Transform binding of implicit parameters by transforming the expression on the+-- right-hand side. The left-hand side can only be an implicit parameter, so no+-- regular patterns there...+transformIPBind :: IPBind -> HsxM IPBind+transformIPBind (IPBind s n e) =+ fmap (IPBind s n) $ transformExpM e++------------------------------------------------------------------------------------+-- Statements of various kinds++-- | A simple annotation datatype for statement contexts.+data StmtType = DoStmt | GuardStmt | ListCompStmt++-- | Transform statements by traversing and transforming subterms.+-- Since generator statements have slightly different semantics+-- depending on their context, statements are annotated with their+-- context to ensure that the semantics of the resulting statement+-- sequence is correct. The return type is a list since generated+-- guards will be added as statements on the same level as the+-- statement to be transformed.+transformStmt :: StmtType -> Stmt -> HsxM [Stmt]+transformStmt t s = case s of+ -- Generators can have regular patterns in the result pattern on the+ -- left-hand side and in the generating expression.+ Generator s p e -> do+ let -- We need to treat generated guards differently depending+ -- on the context of the statement.+ guardFun = case t of+ DoStmt -> monadify+ ListCompStmt -> monadify+ GuardStmt -> mkStmtGuard+ -- Preserve semantics of irrefutable regular patterns by postponing+ -- their evaluation to a let-expression on the right-hand side+ ([p'], rnpss) = unzip $ renameIrrPats [p]+ -- Transform the pattern itself+ ([p''], ags, gs, ds) <- transformPatterns s [p']+ -- Put the generated declarations in a let-statement+ let lt = case ds of+ [] -> []+ _ -> [letStmt ds]+ -- Perform the designated trick on the generated guards.+ gs' = map guardFun (ags ++ gs)+ -- 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' <- 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+ -- generation must take place in a monad, so we need to "return"+ -- 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]) $ 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) ->+ fmap (\ds -> [letStmt ds]) $ transformLetDecls ds+ -- If the bindings are of implicit parameters we simply transform them as such.+ LetStmt (IPBinds is) ->+ fmap (\is -> [LetStmt (IPBinds is)]) $ mapM transformIPBind is+ RecStmt stmts ->+ fmap (return . RecStmt . concat) $ mapM (transformStmt t) stmts+++transformQualStmt :: QualStmt -> HsxM [QualStmt]+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) $ transformExpM e+ ThenBy e f -> fmap return $ transform2exp e f ThenBy+ GroupBy e -> fmap (return . GroupBy) $ transformExpM e+ GroupUsing f -> fmap (return . GroupUsing) $ transformExpM f+ GroupByUsing e f -> fmap return $ transform2exp e f GroupByUsing++------------------------------------------------------------------------------------------+-- Case alternatives++-- | Transform alternatives in a @case@-expression. Patterns are+-- transformed, while other subterms are traversed further.+transformAlt :: Alt -> HsxM Alt+transformAlt (Alt srcloc pat rhs decls) = do+ -- Preserve semantics of irrefutable regular patterns by postponing+ -- their evaluation to a let-expression on the right-hand side+ let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+ -- Transform the pattern itself+ ([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']+ -- Transform the right-hand side, and add any generated guards+ -- and let expressions to it.+ rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs+ -- Transform declarations in the where clause, adding any generated+ -- declarations to it.+ decls' <- case decls of+ BDecls ds -> do ds' <- mapM transformDecl ds+ return $ BDecls $ decls'' ++ ds+ _ -> error "Cannot bind implicit parameters in the \+ \ \'where\' clause of a function using regular patterns."++ return $ Alt srcloc pat'' rhs' decls'++ -- Transform and update guards and right-hand side of a case-expression.+ -- The supplied list of guards is prepended to the original guards, and+ -- subterms are traversed and transformed.+ where mkGAlts :: SrcLoc -> [Guard] -> [(Name, Pat)] -> GuardedAlts -> HsxM GuardedAlts+ mkGAlts s guards rnps (UnGuardedAlt rhs) = do+ -- 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' <- 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+ [] -> return $ UnGuardedAlt rhs'+ -- There are guards to add. These should be added as pattern+ -- guards, i.e. as statements.+ _ -> return $ GuardedAlts [GuardedAlt s (map mkStmtGuard guards) rhs']+ mkGAlts s gs rnps (GuardedAlts galts) =+ fmap GuardedAlts $ mapM (mkGAlt gs rnps) galts+ where mkGAlt :: [Guard] -> [(Name, Pat)] -> GuardedAlt -> HsxM GuardedAlt+ mkGAlt gs rnps (GuardedAlt s oldgs rhs) = do+ -- 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' <- 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+ return $ GuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'++----------------------------------------------------------------------------------+-- Guards++-- In some places, a guard will be a declaration instead of the+-- normal statement, so we represent it in a generic fashion.+type Guard = (SrcLoc, Pat, Exp)++mkStmtGuard :: Guard -> Stmt+mkStmtGuard (s, p, e) = genStmt s p e++mkDeclGuard :: Guard -> [Decl] -> Decl+mkDeclGuard (s, p, e) ds = patBindWhere s p e ds++----------------------------------------------------------------------------------+-- Rewriting expressions before transformation.+-- Done in a monad for gensym capability.++newtype RN a = RN (RNState -> (a, RNState))++type RNState = Int++initRNState = 0++instance Monad RN where+ return a = RN $ \s -> (a,s)+ (RN f) >>= k = RN $ \s -> let (a,s') = f s+ (RN g) = k a+ in g s'++instance Functor RN where+ fmap f rna = do a <- rna+ return $ f a+++runRename :: RN a -> a+runRename (RN f) = let (a,_) = f initRNState+ in a++getRNState :: RN RNState+getRNState = RN $ \s -> (s,s)++setRNState :: RNState -> RN ()+setRNState s = RN $ \_ -> ((), s)++genVarName :: RN Name+genVarName = do+ k <- getRNState+ setRNState $ k+1+ return $ name $ "harp_rnvar" ++ show k+++type NameBind = (Name, Pat)++-- Some generic functions on monads for traversing subterms++rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename1pat p f rn = do (q, ms) <- rn p+ return (f q, ms)++rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename2pat p1 p2 f rn = do (q1, ms1) <- rn p1+ (q2, ms2) <- rn p2+ return $ (f q1 q2, ms1 ++ ms2)++renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+renameNpat ps f rn = do (qs, mss) <- fmap unzip $ mapM rn ps+ return (f qs, concat mss)+++++-- | Generate variables as placeholders for any regular patterns, in order+-- to place their evaluation elsewhere. We must likewise move the evaluation+-- of Tags because attribute lookups are force evaluation.+renameRPats :: [Pat] -> [(Pat, [NameBind])]+renameRPats ps = runRename $ mapM renameRP ps++renameRP :: Pat -> RN (Pat, [NameBind])+renameRP p = case p of+ -- We must rename regular patterns and Tag expressions+ PRPat _ -> rename p+ PXTag _ _ _ _ _ -> rename p+ PXETag _ _ _ _ -> rename p+ -- The rest of the rules simply try to rename regular patterns in+ -- their immediate subpatterns.+ PNeg p -> rename1pat p PNeg renameRP+ PInfixApp p1 n p2 -> rename2pat p1 p2+ (\p1 p2 -> PInfixApp p1 n p2)+ renameRP+ PApp n ps -> renameNpat ps (PApp n) renameRP+ PTuple ps -> renameNpat ps PTuple renameRP+ PList ps -> renameNpat ps PList renameRP+ PParen p -> rename1pat p PParen renameRP+ PRec n pfs -> renameNpat pfs (PRec n) renameRPf+ PAsPat n p -> rename1pat p (PAsPat n) renameRP+ PIrrPat p -> rename1pat p PIrrPat renameRP+ PXPatTag p -> rename1pat p PXPatTag renameRP+ PatTypeSig s p t -> rename1pat p (\p -> PatTypeSig s p t) renameRP+ _ -> return (p, [])++ where renameRPf :: PatField -> RN (PatField, [NameBind])+ renameRPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameRP+ renameRPf pf = return (pf, [])++ renameAttr :: PXAttr -> RN (PXAttr, [NameBind])+ renameAttr (PXAttr s p) = rename1pat p (PXAttr s) renameRP++ rename :: Pat -> RN (Pat, [NameBind])+ rename p = do -- Generate a fresh variable+ n <- genVarName+ -- ... and return that, along with the association of+ -- the variable with the old pattern+ return (pvar n, [(n,p)])++-- | Rename declarations appearing in @let@s or @where@ clauses.+renameLetDecls :: [Decl] -> [Decl]+renameLetDecls ds =+ let -- Rename all regular patterns bound in pattern bindings.+ (ds', smss) = unzip $ runRename $ mapM renameLetDecl ds+ -- ... and then generate declarations for the associations+ gs = map (\(s,n,p) -> mkDecl s (n,p)) (concat smss)+ -- ... which should be added to the original list of declarations.+ in ds' ++ gs++ where renameLetDecl :: Decl -> RN (Decl, [(SrcLoc, Name, Pat)])+ renameLetDecl d = case d of+ -- We need only bother about pattern bindings.+ PatBind srcloc pat mty rhs decls -> do+ -- Rename any regular patterns that appear in the+ -- pattern being bound.+ (p, ms) <- renameRP pat+ let sms = map (\(n,p) -> (srcloc, n, p)) ms+ return $ (PatBind srcloc p mty rhs decls, sms)+ _ -> return (d, [])+++-- | Move irrefutable regular patterns into a @let@-expression instead,+-- to make sure that the semantics of @~@ are preserved.+renameIrrPats :: [Pat] -> [(Pat, [NameBind])]+renameIrrPats ps = runRename (mapM renameIrrP ps)++renameIrrP :: Pat -> RN (Pat, [(Name, Pat)])+renameIrrP p = case p of+ -- We should rename any regular pattern appearing+ -- inside an irrefutable pattern.+ PIrrPat p -> do (q, ms) <- renameRP p+ return $ (PIrrPat q, ms)+ -- The rest of the rules simply try to rename regular patterns in+ -- irrefutable patterns in their immediate subpatterns.+ PNeg p -> rename1pat p PNeg renameIrrP+ PInfixApp p1 n p2 -> rename2pat p1 p2+ (\p1 p2 -> PInfixApp p1 n p2)+ renameIrrP+ PApp n ps -> renameNpat ps (PApp n) renameIrrP+ PTuple ps -> renameNpat ps PTuple renameIrrP+ PList ps -> renameNpat ps PList renameIrrP+ PParen p -> rename1pat p PParen renameIrrP+ PRec n pfs -> renameNpat pfs (PRec n) renameIrrPf+ PAsPat n p -> rename1pat p (PAsPat n) renameIrrP+ PatTypeSig s p t -> rename1pat p (\p -> PatTypeSig s p t) renameIrrP++ -- Hsx+ PXTag s n attrs mat ps -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs+ (mat', ns1) <- case mat of+ Nothing -> return (Nothing, [])+ Just at -> do (at', ns) <- renameIrrP at+ return (Just at', ns)+ (q, ns) <- renameNpat ps (PXTag s n attrs' mat') renameIrrP+ return (q, concat nss ++ ns1 ++ ns)+ PXETag s n attrs mat -> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs+ (mat', ns1) <- case mat of+ Nothing -> return (Nothing, [])+ Just at -> do (at', ns) <- renameIrrP at+ return (Just at', ns)+ return $ (PXETag s n as mat', concat nss ++ ns1)+ PXPatTag p -> rename1pat p PXPatTag renameIrrP+ -- End Hsx++ _ -> return (p, [])++ where renameIrrPf :: PatField -> RN (PatField, [NameBind])+ renameIrrPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameIrrP+ renameIrrPf pf = return (pf, [])++ renameIrrAttr :: PXAttr -> RN (PXAttr, [NameBind])+ renameIrrAttr (PXAttr s p) = rename1pat p (PXAttr s) renameIrrP+-----------------------------------------------------------------------------------+-- Transforming Patterns: the real stuff++-- | Transform several patterns in the same context, thereby+-- generating any code for matching regular patterns.+transformPatterns :: SrcLoc -> [Pat] -> HsxM ([Pat], [Guard], [Guard], [Decl])+transformPatterns s ps = runTr (trPatterns s ps)++---------------------------------------------------+-- The transformation monad++type State = (Int, Int, Int, [Guard], [Guard], [Decl])++newtype Tr a = Tr (State -> HsxM (a, State))++instance Monad Tr where+ return a = Tr $ \s -> return (a, s)+ (Tr f) >>= k = Tr $ \s ->+ do (a, s') <- f s+ let (Tr f') = k a+ f' s'++instance Functor Tr where+ fmap f tra = tra >>= (return . f)++liftTr :: HsxM a -> Tr a+liftTr hma = Tr $ \s -> do a <- hma+ return (a, s)++initState = initStateFrom 0 0++initStateFrom k l = (0, k, l, [], [], [])++runTr :: Tr a -> HsxM (a, [Guard], [Guard], [Decl])+runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState+ return (a, reverse gs1, reverse gs2, reverse ds)+++runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard], [Guard], [Decl], Int, Int)+runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l+ return (a, reverse gs1, reverse gs2, reverse ds, k', l')+++-- manipulating the state+getState :: Tr State+getState = Tr $ \s -> return (s,s)++setState :: State -> Tr ()+setState s = Tr $ \_ -> return ((),s)++updateState :: (State -> (a,State)) -> Tr a+updateState f = do s <- getState+ let (a,s') = f s+ setState s'+ return a++-- specific state manipulating functions+pushGuard :: SrcLoc -> Pat -> Exp -> Tr ()+pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))++pushDecl :: Decl -> Tr ()+pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))++pushAttrGuard :: SrcLoc -> Pat -> Exp -> Tr ()+pushAttrGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(s,p,e):gs1,gs2,ds))++genMatchName :: Tr Name+genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))+ return $ Ident $ "harp_match" ++ show k++genPatName :: Tr Name+genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))+ return $ Ident $ "harp_pat" ++ show k++genAttrName :: Tr Name+genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))+ return $ Ident $ "hsx_attrs" ++ show k+++setHarpTransformedT, setXmlTransformedT :: Tr ()+setHarpTransformedT = liftTr setHarpTransformed+setXmlTransformedT = liftTr setXmlTransformed+++-------------------------------------------------------------------+-- Some generic functions for computations in the Tr monad. Could+-- be made even more general, but there's really no point right now...++tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c+tr1pat p f tr = do q <- tr p+ return $ f q++tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c+tr2pat p1 p2 f tr = do q1 <- tr p1+ q2 <- tr p2+ return $ f q1 q2++trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c+trNpat ps f tr = do qs <- mapM tr ps+ return $ f qs++-----------------------------------------------------------------------------+-- The *real* transformations+-- Transforming patterns++-- | Transform several patterns in the same context+trPatterns :: SrcLoc -> [Pat] -> Tr [Pat]+trPatterns s = mapM (trPattern s)++-- | Transform a pattern by traversing the syntax tree.+-- A regular pattern is translated, other patterns are+-- simply left as is.+trPattern :: SrcLoc -> Pat -> Tr Pat+trPattern s p = case p of+ -- This is where the fun starts. =)+ -- Regular patterns must be transformed of course.+ PRPat rps -> do+ -- First we need a name for the placeholder pattern.+ n <- genPatName+ -- A top-level regular pattern is a sequence in linear+ -- context, so we can simply translate it as if it was one.+ (mname, vars, _) <- trRPat s True (RPSeq rps)+ -- Generate a top level declaration.+ topmname <- mkTopDecl s mname vars+ -- Generate a pattern guard for this regular pattern,+ -- that will match the generated declaration to the+ -- value of the placeholder, and bind all variables.+ mkGuard s vars topmname n+ -- And indeed, we have made a transformation!+ setHarpTransformedT+ -- Return the placeholder pattern.+ return $ pvar n+ -- Tag patterns should be transformed+ PXTag s name attrs mattr cpats -> do+ -- We need a name for the attribute list, if there are lookups+ an <- case (mattr, attrs) of+ -- ... if there is one already, and there are no lookups+ -- we can just return that+ (Just ap, []) -> return $ ap+ -- ... if there are none, we dont' care+ (_, []) -> return wildcard+ (_, _) -> do -- ... but if there are, we want a name for that list+ n <- genAttrName+ -- ... we must turn attribute lookups into guards+ mkAttrGuards s n attrs mattr+ -- ... and we return the pattern+ return $ pvar n+ -- ... the pattern representing children should be transformed+ cpat' <- case cpats of+ -- ... it's a regular pattern, so we can just go ahead and transform it+ (p@(PXRPats _)):[] -> trPattern s p+ -- ... it's an ordinary list, so we first wrap it up as such+ _ -> trPattern s (PList cpats)+ -- ... we have made a transformation and should report that+ setHarpTransformedT+ -- ... and we return a Tag pattern.+ let (dom, n) = xNameParts name+ return $ metaTag dom n an cpat'+ -- ... as should empty Tag patterns+ PXETag s name attrs mattr -> do+ -- We need a name for the attribute list, if there are lookups+ an <- case (mattr, attrs) of+ -- ... if there is a pattern already, and there are no lookups+ -- we can just return that+ (Just ap, []) -> return $ ap+ -- ... if there are none, we dont' care+ (_, []) -> return wildcard+ (_, _) -> do -- ... but if there are, we want a name for that list+ n <- genAttrName+ -- ... we must turn attribute lookups into guards+ mkAttrGuards s n attrs mattr+ -- ... and we return the pattern+ return $ pvar n+ -- ... we have made a transformation and should report that+ setHarpTransformedT+ -- ... and we return an ETag pattern.+ let (dom, n) = xNameParts name+ return $ metaTag dom n an peList+ -- PCDATA patterns are strings in the xml datatype.+ PXPcdata st -> setHarpTransformedT >> (return $ metaPcdata st)+ -- XML comments are likewise just treated as strings.+ PXPatTag p -> setHarpTransformedT >> trPattern s p+ -- Regular expression patterns over children should be translated+ -- just like PRPat.+ PXRPats rps -> trPattern s $ PRPat rps++ -- Transforming any other patterns simply means transforming+ -- their subparts.+ PViewPat e p -> do+ e' <- liftTr $ transformExpM e+ tr1pat p (PViewPat e') (trPattern s)+ PVar _ -> return p+ PLit _ -> return p+ PNeg q -> tr1pat q PNeg (trPattern s)+ PInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp p1 op p2) (trPattern s)+ PApp n ps -> trNpat ps (PApp n) (trPattern s)+ PTuple ps -> trNpat ps PTuple (trPattern s)+ PList ps -> trNpat ps PList (trPattern s)+ PParen p -> tr1pat p PParen (trPattern s)+ PRec n pfs -> trNpat pfs (PRec n) (trPatternField s)+ PAsPat n p -> tr1pat p (PAsPat n) (trPattern s)+ PWildCard -> return p+ PIrrPat p -> tr1pat p PIrrPat (trPattern s)+ PatTypeSig s p t -> tr1pat p (\p -> PatTypeSig s p t) (trPattern s)+ PExplTypeArg _ _ -> return p+ PQuasiQuote _ _ -> return p+ PBangPat p -> tr1pat p PBangPat (trPattern s)+ PNPlusK _ _ -> return p++ where -- Transform a pattern field.+ trPatternField :: SrcLoc -> PatField -> Tr PatField+ trPatternField s (PFieldPat n p) =+ tr1pat p (PFieldPat n) (trPattern s)+ trPatternField _ p = return p++ -- Deconstruct an xml tag name into its parts.+ xNameParts :: XName -> (Maybe String, String)+ xNameParts n = case n of+ XName s -> (Nothing, s)+ XDomName d s -> (Just d, s)++ -- | Generate a guard for looking up xml attributes.+ mkAttrGuards :: SrcLoc -> Name -> [PXAttr] -> Maybe Pat -> Tr ()+ mkAttrGuards s attrs [PXAttr n q] mattr = do+ -- Apply lookupAttr to the attribute name and+ -- attribute set+ let rhs = metaExtract n attrs+ -- ... catch the result+ pat = metaPJust q+ -- ... catch the remainder list+ rml = case mattr of+ Nothing -> wildcard+ Just ap -> ap+ -- ... and add the generated guard to the store.+ pushAttrGuard s (pTuple [pat, rml]) rhs++ mkAttrGuards s attrs ((PXAttr a q):xs) mattr = do+ -- Apply lookupAttr to the attribute name and+ -- attribute set+ let rhs = metaExtract a attrs+ -- ... catch the result+ pat = metaPJust q+ -- ... catch the remainder list+ newAttrs <- genAttrName+ -- ... and add the generated guard to the store.+ pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs+ -- ... and finally recurse+ mkAttrGuards s newAttrs xs mattr++ -- | Generate a declaration at top level that will finalise all+ -- variable continuations, and then return all bound variables.+ mkTopDecl :: SrcLoc -> Name -> [Name] -> Tr Name+ mkTopDecl s mname vars =+ do -- Give the match function a name+ n <- genMatchName+ -- Create the declaration and add it to the store.+ pushDecl $ topDecl s n mname vars+ -- Return the name of the match function so that the+ -- guard that will be generated can call it.+ return n++ topDecl :: SrcLoc -> Name -> Name -> [Name] -> Decl+ topDecl s n mname vs =+ let pat = pTuple [wildcard, pvarTuple vs] -- (_, (foo, bar, ...))+ g = var mname -- harp_matchX+ a = genStmt s pat g -- (_, (foo, ...)) <- harp_matchX+ vars = map (\v -> app (var v) eList) vs -- (foo [], bar [], ...)+ b = qualStmt $ metaReturn $ tuple vars -- return (foo [], bar [], ...)+ e = doE [a,b] -- do (...) <- harp_matchX+ -- return (foo [], bar [], ...)+ in nameBind s n e -- harp_matchY = do ....++ -- | Generate a pattern guard that will apply the @runMatch@+ -- function on the top-level match function and the input list,+ -- thereby binding all variables.+ mkGuard :: SrcLoc -> [Name] -> Name -> Name -> Tr ()+ mkGuard s vars mname n = do+ let tvs = pvarTuple vars -- (foo, bar, ...)+ ge = appFun runMatchFun [var mname, var n] -- runMatch harp_matchX harp_patY+ pushGuard s (pApp just_name [tvs]) ge -- Just (foo, bar, ...) , runMatch ...+++--------------------------------------------------------------------------------+-- Transforming regular patterns++-- | A simple datatype to annotate return values from sub-patterns+data MType = S -- Single element+ | L MType -- List of ... , (/ /), *, ++ | E MType MType -- Either ... or ... , ( | )+ | M MType -- Maybe ... , ?+++-- When transforming a regular sub-pattern, we need to know the+-- name of the function generated to match it, the names of all+-- variables it binds, and the type of its returned value.+type MFunMetaInfo = (Name, [Name], MType)+++-- | Transform away a regular pattern, generating code+-- to replace it.+trRPat :: SrcLoc -> Bool -> RPat -> Tr MFunMetaInfo+trRPat s linear rp = case rp of+ -- For an ordinary Haskell pattern we need to generate a+ -- base match function for the pattern, and a declaration+ -- that lifts that function into the matcher monad.+ RPPat p -> mkBaseDecl s linear p++ where+ -- | Generate declarations for matching ordinary Haskell patterns+ mkBaseDecl :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo+ mkBaseDecl s linear p = case p of+ -- We can simplify a lot if the pattern is a wildcard or a variable+ PWildCard -> mkWCMatch s+ PVar v -> mkVarMatch s linear v+ -- ... and if it is an embedded pattern tag, we can just skip it+ PXPatTag q -> mkBaseDecl s linear q++ -- ... otherwise we'll have to take the long way...+ p -> do -- First do a case match on a single element+ (name, vars, _) <- mkBasePat s linear p+ -- ... apply baseMatch to the case matcher to+ -- lift it into the matcher monad.+ newname <- mkBaseMatch s name+ -- ... and return the meta-info gathered.+ return (newname, vars, S)++ -- | Generate a basic function that cases on a single element,+ -- returning Just (all bound variables) on a match, and+ -- Nothing on a mismatch.+ mkBasePat :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo+ mkBasePat s b p =+ do -- First we need a name...+ n <- genMatchName+ -- ... and then we need to know what variables that+ -- will be bound by this match.+ let vs = gatherPVars p+ -- ... and then we can create and store away a casing function.+ basePatDecl s b n vs p >>= pushDecl+ return (n, vs, S)++ -- | Generate a basic casing function for a given pattern.+ basePatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> Tr Decl+ basePatDecl s linear f vs p = do+ -- We can use the magic variable harp_a since nothing else needs to+ -- be in scope at this time (we could use just a, or foo, or whatever)+ let a = Ident $ "harp_a"+ -- ... and we should case on that variable on the right-hand side.+ rhs <- baseCaseE s linear p a vs -- case harp_a of ...+ -- The result is a simple function with one paramenter and+ -- the right-hand side we just generated.+ return $ simpleFun s f a rhs+ where baseCaseE :: SrcLoc -> Bool -> Pat -> Name -> [Name] -> Tr Exp+ baseCaseE s b p a vs = do+ -- First the alternative if we actually+ -- match the given pattern+ let alt1 = alt s p -- foo -> Just (mf foo)+ (app (con just_name) $+ tuple (map (retVar b) vs))+ -- .. and finally an alternative for not matching the pattern.+ 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+ return $ caseE (var a) [alt1', alt2]+ retVar :: Bool -> Name -> Exp+ retVar linear v+ -- if bound in linear context, apply const+ | linear = metaConst (var v)+ -- if bound in non-linear context, apply (:)+ | otherwise = app consFun (var v)++ -- For guarded base patterns, we want to do the same as for unguarded base patterns,+ -- only with guards (doh).+ RPGuard p gs -> mkGuardDecl s linear p gs++ where mkGuardDecl :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo+ mkGuardDecl s linear p gs = case p of+ -- If it is an embedded pattern tag, we want to skip it+ PXPatTag q -> mkGuardDecl s linear q gs++ -- ... otherwise we'll want to make a base pattern+ p -> do -- First do a case match on a single element+ (name, vars, _) <- mkGuardPat s linear p gs+ -- ... apply baseMatch to the case matcher to+ -- lift it into the matcher monad.+ newname <- mkBaseMatch s name+ -- ... and return the meta-info gathered.+ return (newname, vars, S)++ -- | Generate a basic function that cases on a single element,+ -- returning Just (all bound variables) on a match, and+ -- Nothing on a mismatch.+ mkGuardPat :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo+ mkGuardPat s b p gs =+ do -- First we need a name...+ n <- genMatchName+ -- ... and then we need to know what variables that+ -- will be bound by this match.+ let vs = gatherPVars p ++ concatMap gatherStmtVars gs+ -- ... and then we can create and store away a casing function.+ guardPatDecl s b n vs p gs >>= pushDecl+ return (n, vs, S)++ -- | Generate a basic casing function for a given pattern.+ guardPatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> [Stmt] -> Tr Decl+ guardPatDecl s linear f vs p gs = do+ -- We can use the magic variable harp_a since nothing else needs to+ -- be in scope at this time (we could use just a, or foo, or whatever)+ let a = Ident $ "harp_a"+ -- ... and we should case on that variable on the right-hand side.+ rhs <- guardedCaseE s linear p gs a vs -- case harp_a of ...+ -- The result is a simple function with one parameter and+ -- the right-hand side we just generated.+ return $ simpleFun s f a rhs+ where guardedCaseE :: SrcLoc -> Bool -> Pat -> [Stmt] -> Name -> [Name] -> Tr Exp+ guardedCaseE s b p gs a vs = do+ -- First the alternative if we actually+ -- match the given pattern+ let alt1 = altGW s p gs -- foo -> Just (mf foo)+ (app (con just_name) $+ tuple (map (retVar b) vs)) noBinds+ -- .. and finally an alternative for not matching the pattern.+ 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+ return $ caseE (var a) [alt1', alt2]+ retVar :: Bool -> Name -> Exp+ retVar linear v+ -- if bound in linear context, apply const+ | linear = metaConst (var v)+ -- if bound in non-linear context, apply (:)+ | otherwise = app consFun (var v)++++ -- For a sequence of regular patterns, we should transform all+ -- sub-patterns and then generate a function for sequencing them.+ RPSeq rps -> do+ nvts <- mapM (trRPat s linear) rps+ mkSeqDecl s nvts++ where+ -- | Generate a match function for a sequence of regular patterns,+ -- flattening any special sub-patterns into normal elements of the list+ mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo+ mkSeqDecl s nvts = do+ -- First, as always, we need a name...+ name <- genMatchName+ let -- We need a generating statement for each sub-pattern.+ (gs, vals) = unzip $ mkGenExps s 0 nvts -- (harp_valX, (foo, ...)) <- harp_matchY+ -- Gather up all variables from all sub-patterns.+ vars = concatMap (\(_,vars,_) -> vars) nvts+ -- ... flatten all values to simple lists, and concatenate+ -- the lists to a new return value+ fldecls = flattenVals s vals -- harp_valXf = $flatten harp_valX+ -- harp_ret = foldComp [harp_val1f, ...]+ -- ... return the value along with all variables+ ret = qualStmt $ metaReturn $ -- return (harp_ret, (foo, .....))+ tuple [var retname, varTuple vars]+ -- ... do all these steps in a do expression+ rhs = doE $ gs ++ -- do (harp_valX, (foo, ...)) <- harpMatchY+ [letStmt fldecls, ret] -- let harp_valXf = $flatten harp_valX+ -- return (harp_ret, (foo, .....))+ -- ... bind it to its name, and add the declaration+ -- to the store.+ pushDecl $ nameBind s name rhs -- harp_matchZ = do ....+ -- The return value of a sequence is always a list of elements.+ return (name, vars, L S)++ -- | Flatten values of all sub-patterns into normal elements of the list+ flattenVals :: SrcLoc -> [(Name, MType)] -> [Decl]+ flattenVals s nts =+ let -- Flatten the values of all sub-patterns to+ -- lists of elements+ (nns, ds) = unzip $ map (flVal s) nts+ -- ... and concatenate their results.+ ret = nameBind s retname $ app+ (paren $ app foldCompFun+ (listE $ map var nns)) $ eList+ in ds ++ [ret]+++ flVal :: SrcLoc -> (Name, MType) -> (Name, Decl)+ flVal s (name, mt) =+ let -- We reuse the old names, we just extend them a bit.+ newname = extendVar name "f" -- harp_valXf+ -- Create the appropriate flattening function depending+ -- on the type of the value+ f = flatten mt+ -- ... apply it to the value and bind it to its new name.+ in (newname, nameBind s newname $ -- harp_valXf = $flatten harp_valX+ app f (var name))++ -- | Generate a flattening function for a given type structure.+ flatten :: MType -> Exp+ flatten S = consFun -- (:)+ flatten (L mt) =+ let f = flatten mt+ r = paren $ metaMap [f]+ in paren $ foldCompFun `metaComp` r -- (foldComp . (map $flatten))+ flatten (E mt1 mt2) =+ let f1 = flatten mt1+ f2 = flatten mt2+ in paren $ metaEither f1 f2 -- (either $flatten $flatten)+ flatten (M mt) =+ let f = flatten mt+ in paren $ metaMaybe idFun f -- (maybe id $flatten)++ -- For accumulating as-patterns we should transform the subpattern, and then generate+ -- a declaration that supplies the value to be bound to the variable in question.+ -- The variable should be bound non-linearly.+ RPCAs v rp -> do+ -- Transform the subpattern+ nvt@(name, vs, mt) <- trRPat s linear rp+ -- ... and create a declaration to bind its value.+ n <- mkCAsDecl s nvt+ -- The type of the value is unchanged.+ return (n, (v:vs), mt)++ where+ -- | Generate a declaration for a \@: binding.+ mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name+ mkCAsDecl = asDecl $ app consFun -- should become lists when applied to []+++ -- For ordinary as-patterns we should transform the subpattern, and then generate+ -- a declaration that supplies the value to be bound to the variable in question.+ -- The variable should be bound linearly.+ RPAs v rp+ | linear ->+ do -- Transform the subpattern+ nvt@(name, vs, mt) <- trRPat s linear rp+ -- ... and create a declaration to bind its value+ n <- mkAsDecl s nvt+ -- The type of the value is unchanged.+ return (n, (v:vs), mt)+ -- We may not use an @ bind in non-linear context+ | otherwise -> case v of+ Ident n -> fail $ "Attempting to bind variable "++n+++ " inside the context of a numerable regular pattern"+ _ -> fail $ "This should never ever ever happen... how the #% did you do it??!?"++ where+ -- | Generate a declaration for a \@ binding.+ mkAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name+ mkAsDecl = asDecl metaConst -- should be constant when applied to []+++ -- For regular patterns, parentheses have no real meaning+ -- so at this point we can just skip them.+ RPParen rp -> trRPat s linear rp++ -- For (possibly non-greedy) optional regular patterns we need to+ -- transform the subpattern, and the generate a function that can+ -- choose to match or not to match, that is the question...+ RPOp rp RPOpt->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can optionally match it.+ mkOptDecl s False nvt+ -- ... similarly for the non-greedy version.+ RPOp rp RPOptG ->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can optionally match it.+ mkOptDecl s True nvt+++ -- For union patterns, we should transform both subexpressions,+ -- and generate a function that chooses between them.+ RPEither rp1 rp2 ->+ do -- Transform the subpatterns+ nvt1 <- trRPat s False rp1+ nvt2 <- trRPat s False rp2+ -- ... and create a declaration that can choose between them.+ mkEitherDecl s nvt1 nvt2+ -- Generate declarations for either patterns, i.e. ( | )+ where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo+ mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do+ -- Eine namen, bitte!+ n <- genMatchName+ let -- Generate generators for the subpatterns+ (g1, v1) = mkGenExp s nvt1+ (g2, v2) = mkGenExp s nvt2 -- (harp_valX, (foo, bar, ...)) <- harp_matchY+ -- ... gather all variables from both sides+ allvs = vs1 `union` vs2+ -- ... some may be bound on both sides, so we+ -- need to check which ones are bound on each,+ -- supplying empty value for those that are not+ vals1 = map (varOrId vs1) allvs+ vals2 = map (varOrId vs2) allvs+ -- ... apply either Left or Right to the returned value+ ret1 = metaReturn $ tuple -- return (Left harp_val1, (foo, id, ...))+ [app (con left_name)+ (var v1), tuple vals1]+ ret2 = metaReturn $ tuple -- return (Right harp_val2, (id, bar, ...))+ [app (con right_name)+ (var v2), tuple vals2]+ -- ... and do all these things in do-expressions+ exp1 = doE [g1, qualStmt ret1]+ exp2 = doE [g2, qualStmt ret2]+ -- ... and choose between them using the choice (+++) operator.+ rhs = (paren exp1) `metaChoice` -- (do ...) ++++ (paren exp2) -- (do ...)+ -- Finally we create a declaration for this function and+ -- add it to the store.+ pushDecl $ nameBind s n rhs -- harp_matchZ = (do ...) ...+ -- The type of the returned value is Either the type of the first+ -- or the second subpattern.+ return (n, allvs, E t1 t2)++ varOrId :: [Name] -> Name -> Exp+ varOrId vs v = if v `elem` vs -- the variable is indeed bound in this branch+ then var v -- ... so it should be added to the result+ else idFun -- ... else it should be empty.++ -- For (possibly non-greedy) repeating regular patterns we need to transform the subpattern,+ -- and then generate a function to handle many matches of it.+ RPOp rp RPStar ->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can match it many times.+ mkStarDecl s False nvt+ -- ... and similarly for the non-greedy version.+ RPOp rp RPStarG->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can match it many times.+ mkStarDecl s True nvt++ -- For (possibly non-greedy) non-empty repeating patterns we need to transform the subpattern,+ -- and then generate a function to handle one or more matches of it.+ RPOp rp RPPlus ->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can match it one or more times.+ mkPlusDecl s False nvt+ -- ... and similarly for the non-greedy version.+ RPOp rp RPPlusG ->+ do -- Transform the subpattern+ nvt <- trRPat s False rp+ -- ... and create a declaration that can match it one or more times.+ mkPlusDecl s True nvt+++ where -- These are the functions that must be in scope for more than one case alternative above.++ -- | Generate a declaration for matching a variable.+ mkVarMatch :: SrcLoc -> Bool -> Name -> Tr MFunMetaInfo+ mkVarMatch s linear v = do+ -- First we need a name for the new match function.+ n <- genMatchName+ -- 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 (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.+ pushDecl $ nameBind s n $+ app baseMatchFun e -- harp_matchX = baseMatch (\v -> Just (mf v))+ return (n, [v], S) -- always binds v and only v++ where retVar :: Bool -> Name -> Exp+ retVar linear v+ -- if bound in linear context, apply const+ | linear = metaConst (var v)+ -- if bound in non-linear context, apply (:)+ | otherwise = app consFun (var v)++ -- | Generate a declaration for matching a wildcard+ mkWCMatch :: SrcLoc -> Tr MFunMetaInfo+ mkWCMatch s = do+ -- First we need a name...+ n <- genMatchName+ -- ... and then a function that always matches, discarding the result+ let e = paren $ lamE s [wildcard] $ -- (\_ -> Just ())+ 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+ return (n, [], S) -- no variables bound, hence []++ -- | Gather up the names of all variables in a pattern,+ -- using a simple fold over the syntax structure.+ gatherPVars :: Pat -> [Name]+ gatherPVars p = case p of+ PVar v -> [v]+ PNeg q -> gatherPVars q+ PInfixApp p1 _ p2 -> gatherPVars p1 +++ gatherPVars p2+ PApp _ ps -> concatMap gatherPVars ps+ PTuple ps -> concatMap gatherPVars ps+ PList ps -> concatMap gatherPVars ps+ PParen p -> gatherPVars p+ PRec _ pfs -> concatMap help pfs+ where help (PFieldPat _ p) = gatherPVars p+ help _ = []+ PAsPat n p -> n : gatherPVars p+ PWildCard -> []+ PIrrPat p -> gatherPVars p+ PatTypeSig _ p _ -> gatherPVars p+ PRPat rps -> concatMap gatherRPVars rps+ PXTag _ _ attrs mattr cps ->+ concatMap gatherAttrVars attrs ++ concatMap gatherPVars cps +++ case mattr of+ Nothing -> []+ Just ap -> gatherPVars ap+ PXETag _ _ attrs mattr ->+ concatMap gatherAttrVars attrs +++ case mattr of+ Nothing -> []+ Just ap -> gatherPVars ap+ PXPatTag p -> gatherPVars p+ _ -> []++ gatherRPVars :: RPat -> [Name]+ gatherRPVars rp = case rp of+ RPOp rq _ -> gatherRPVars rq+ RPEither rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2+ RPSeq rqs -> concatMap gatherRPVars rqs+ RPCAs n rq -> n : gatherRPVars rq+ RPAs n rq -> n : gatherRPVars rq+ RPParen rq -> gatherRPVars rq+ RPGuard q gs -> gatherPVars q ++ concatMap gatherStmtVars gs+ RPPat q -> gatherPVars q++ gatherAttrVars :: PXAttr -> [Name]+ gatherAttrVars (PXAttr _ p) = gatherPVars p++ gatherStmtVars :: Stmt -> [Name]+ gatherStmtVars gs = case gs of+ Generator _ p _ -> gatherPVars p+ _ -> []++ -- | Generate a match function that lift the result of the+ -- basic casing function into the matcher monad.+ mkBaseMatch :: SrcLoc -> Name -> Tr Name+ mkBaseMatch s name =+ do -- First we need a name...+ n <- genMatchName+ -- ... to which we bind the lifting function+ pushDecl $ baseMatchDecl s n name+ -- and then return for others to use.+ return n++ -- | Generate a declaration for the function that lifts a simple+ -- casing function into the matcher monad.+ baseMatchDecl :: SrcLoc -> Name -> Name -> Decl+ baseMatchDecl s newname oldname =+ -- Apply the lifting function "baseMatch" to the casing function+ let e = app baseMatchFun (var oldname)+ -- ... and bind it to the new name.+ in nameBind s newname e -- harp_matchX = baseMatch harp_matchY+++ -- | Generate the generators that call sub-matching functions, and+ -- annotate names with types for future flattening of values.+ -- Iterate to enable gensym-like behavior.+ mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(Stmt, (Name, MType))]+ mkGenExps _ _ [] = []+ mkGenExps s k ((name, vars, t):nvs) =+ let valname = mkValName k -- harp_valX+ pat = pTuple [pvar valname, pvarTuple vars] -- (harp_valX, (foo, bar, ...))+ g = var name+ in (genStmt s pat g, (valname, t)) : -- (harp_valX, (foo, ...)) <- harp_matchY+ mkGenExps s (k+1) nvs++ -- | Create a single generator.+ mkGenExp :: SrcLoc -> MFunMetaInfo -> (Stmt, Name)+ mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]+ in (g, name)++ -- | Generate a single generator with a call to (ng)manyMatch,+ -- and an extra variable name to use after unzipping.+ mkManyGen :: SrcLoc -> Bool -> Name -> Stmt+ mkManyGen s greedy mname =+ -- Choose which repeater function to use, determined by greed+ let mf = if greedy then gManyMatchFun else manyMatchFun+ -- ... and create a generator that applies it to the+ -- matching function in question.+ in genStmt s (pvar valsvarsname) $+ app mf (var mname)++ -- | Generate declarations for @: and @ bindings.+ asDecl :: (Exp -> Exp) -> SrcLoc -> MFunMetaInfo -> Tr Name+ asDecl mf s nvt@(_, vs, _) = do+ -- A name, if you would+ n <- genMatchName -- harp_matchX+ let -- Generate a generator for matching the subpattern+ (g, val) = mkGenExp s nvt -- (harp_valY, (foo, ...)) <- harp_matchZ+ -- ... fix the old variables+ vars = map var vs -- (apa, bepa, ...)+ -- ... and return the generated value, along with the+ -- new set of variables which is the old set prepended+ -- by the variable currently being bound.+ ret = qualStmt $ metaReturn $ tuple -- return (harp_valY, ($mf harp_valY, apa, ...))+ [var val, tuple $ mf (var val) : vars] -- mf in the line above is what separates+ -- @: ((:)) from @ (const)+ -- Finally we create a declaration for this function and+ -- add it to the store.+ pushDecl $ nameBind s n $ doE [g, ret] -- harp_matchX = do ...+ return n++ -- | Generate declarations for optional patterns, ? and #?.+ -- (Unfortunally we must place this function here since both variations+ -- of transformations of optional patterns should be able to call it...)+ mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+ mkOptDecl s greedy nvt@(_, vs, t) = do+ -- Un nome, s'il vouz plaît.+ n <- genMatchName+ let -- Generate a generator for matching the subpattern+ (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 (con just_name)+ (var val), varTuple vs]+ -- ... and do those two steps in a do-expression+ exp1 = doE [g, qualStmt ret1] -- do ....+ -- For the non-matching branch, all the variables should be empty+ ids = map (const idFun) vs -- (id, id, ...)+ -- ... and the value should be Nothing.+ ret2 = metaReturn $ tuple -- return (Nothing, (id, id, ...))+ [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+ then metaChoice -- standard order+ else (flip metaChoice) -- reversed order+ -- ... and then apply it to the branches.+ rhs = (paren exp1) `mc` -- (do ....) ++++ (paren ret2) -- (return (Nothing, .....))+ -- Finally we create a declaration for this function and+ -- add it to the store.+ pushDecl $ nameBind s n rhs -- harp_matchZ = (do ....) +++ (return ....)+ -- The type of the returned value will be Maybe the type+ -- of the value of the subpattern.+ return (n, vs, M t)++ -- | Generate declarations for star patterns, * and #*+ -- (Unfortunally we must place this function here since both variations+ -- of transformations of repeating patterns should be able to call it...)+ mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+ mkStarDecl s greedy (mname, vs, t) = do+ -- Ett namn, tack!+ n <- genMatchName+ let -- Create a generator that matches the subpattern+ -- many times, either greedily or non-greedily+ g = mkManyGen s greedy mname+ -- ... and unzip the result, choosing the proper unzip+ -- function depending on the number of variables returned.+ metaUnzipK = mkMetaUnzip s (length vs)+ -- ... first unzip values from variables+ dec1 = patBind s (pvarTuple [valname, varsname])+ (metaUnzip $ var valsvarsname)+ -- ... and then unzip the variables+ dec2 = patBind s (pvarTuple vs)+ (metaUnzipK $ var varsname)+ -- ... fold all the values for variables+ retExps = map ((app foldCompFun) . var) vs+ -- ... and return value and variables+ ret = metaReturn $ tuple $+ [var valname, tuple retExps]+ -- Finally we need to generate a function that does all this,+ -- using a let-statement for the non-monadic stuff and a+ -- do-expression to wrap it all in.+ pushDecl $ nameBind s n $+ doE [g, letStmt [dec1, dec2], qualStmt ret]+ -- The type of the returned value is a list ([]) of the+ -- type of the subpattern.+ return (n, vs, L t)++ -- | Generate declarations for plus patterns, + and #++ -- (Unfortunally we must place this function here since both variations+ -- of transformations of non-empty repeating patterns should be able to call it...)+ mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+ mkPlusDecl s greedy nvt@(mname, vs, t) = do+ -- and now I've run out of languages...+ n <- genMatchName+ let k = length vs+ -- First we want a generator to match the+ -- subpattern exactly one time+ (g1, val1) = mkGenExp s nvt -- (harp_valX, (foo, ...)) <- harpMatchY+ -- ... and then one that matches it many times.+ g2 = mkManyGen s greedy mname -- harp_vvs <- manyMatch harpMatchY+ -- ... we want to unzip the result, using+ -- the proper unzip function+ metaUnzipK = mkMetaUnzip s k+ -- ... first unzip values from variables+ dec1 = patBind s -- (harp_vals, harp_vars) = unzip harp_vvs+ (pvarTuple [valsname, varsname])+ (metaUnzip $ var valsvarsname)+ -- .. now we need new fresh names for variables+ -- since the ordinary ones are already taken.+ vlvars = genNames "harp_vl" k+ -- ... and then we can unzip the variables+ dec2 = patBind s (pvarTuple vlvars) -- (harp_vl1, ...) = unzipK harp_vars+ (metaUnzipK $ var varsname)+ -- .. and do the unzipping in a let-statement+ letSt = letStmt [dec1, dec2]+ -- ... fold variables from the many-match,+ -- prepending the variables from the single match+ retExps = map mkRetFormat $ zip vs vlvars -- foo . (foldComp harp_vl1), ...+ -- ... prepend values from the single match to+ -- those of the many-match.+ retVal = (var val1) `metaCons`+ (var valsname) -- harp_valX : harp_vals+ -- ... return all values and variables+ ret = metaReturn $ tuple $ -- return (harp_valX:harpVals,+ [retVal, tuple retExps] -- (foo . (...), ...))+ -- ... and wrap all of it in a do-expression.+ rhs = doE [g1, g2, letSt, qualStmt ret]+ -- Finally we create a declaration for this function and+ -- add it to the store.+ pushDecl $ nameBind s n rhs+ -- The type of the returned value is a list ([]) of the+ -- type of the subpattern.+ return (n, vs, L t)++ where mkRetFormat :: (Name, Name) -> Exp+ mkRetFormat (v, vl) =+ -- Prepend variables using function composition.+ (var v) `metaComp`+ (paren $ (app foldCompFun) $ var vl)+++--------------------------------------------------------------------------+-- HaRP-specific functions and ids++-- | Functions and ids from the @Match@ module,+-- used in the generated matching functions+runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: Exp+runMatchFun = match_qual runMatch_name+baseMatchFun = match_qual baseMatch_name+manyMatchFun = match_qual manyMatch_name+gManyMatchFun = match_qual gManyMatch_name++runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: Name+runMatch_name = Ident "runMatch"+baseMatch_name = Ident "baseMatch"+manyMatch_name = Ident "manyMatch"+gManyMatch_name = Ident "gManyMatch"++match_mod, match_qual_mod :: ModuleName+match_mod = ModuleName "Harp.Match"+match_qual_mod = ModuleName "HaRPMatch"++match_qual :: Name -> Exp+match_qual = qvar match_qual_mod++choiceOp :: QOp+choiceOp = QVarOp $ Qual match_qual_mod choice++appendOp :: QOp+appendOp = QVarOp $ UnQual append++-- foldComp = foldl (.) id, i.e. fold by composing+foldCompFun :: Exp+foldCompFun = match_qual $ Ident "foldComp"++mkMetaUnzip :: SrcLoc -> Int -> Exp -> Exp+mkMetaUnzip s k | k <= 7 = let n = "unzip" ++ show k+ in (\e -> matchFunction n [e])+ | otherwise =+ let vs = genNames "x" k+ lvs = genNames "xs" k+ uz = name $ "unzip" ++ show k+ ys = name "ys"+ xs = name "xs"+ alt1 = alt s peList $ tuple $ replicate k eList -- [] -> ([], [], ...)+ pat2 = (pvarTuple vs) `metaPCons` (pvar xs) -- (x1, x2, ...)+ ret2 = tuple $ map appCons $ zip vs lvs -- (x1:xs1, x2:xs2, ...)+ rhs2 = app (var uz) (var xs) -- unzipK xs+ dec2 = patBind s (pvarTuple lvs) rhs2 -- (xs1, xs2, ...) = unzipK xs+ exp2 = letE [dec2] ret2+ alt2 = alt s pat2 exp2+ topexp = lamE s [pvar ys] $ caseE (var ys) [alt1, alt2]+ topbind = nameBind s uz topexp+ in app (paren $ letE [topbind] (var uz))+ where appCons :: (Name, Name) -> Exp+ appCons (x, xs) = metaCons (var x) (var xs)++matchFunction :: String -> [Exp] -> Exp+matchFunction s es = mf s (reverse es)+ where mf s [] = match_qual $ Ident s+ mf s (e:es) = app (mf s es) e++-- | Some 'magic' gensym-like functions, and functions+-- with related functionality.+retname :: Name+retname = name "harp_ret"++varsname :: Name+varsname = name "harp_vars"++valname :: Name+valname = name "harp_val"++valsname :: Name+valsname = name "harp_vals"++valsvarsname :: Name+valsvarsname = name "harp_vvs"++mkValName :: Int -> Name+mkValName k = name $ "harp_val" ++ show k++extendVar :: Name -> String -> Name+extendVar (Ident n) s = Ident $ n ++ s+extendVar n _ = n++xNameParts :: XName -> (Maybe String, String)+xNameParts n = case n of+ XName s -> (Nothing, s)+ XDomName d s -> (Just d, s)++---------------------------------------------------------+-- meta-level functions, i.e. functions that represent functions,+-- and that take arguments representing arguments... whew!++metaReturn, metaConst, metaUnzip :: Exp -> Exp+metaReturn e = metaFunction "return" [e]+metaConst e = metaFunction "const" [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, metaMap :: [Exp] -> Exp+metaConcat es = metaFunction "concat" [listE es]+metaMap = metaFunction "map"++metaAppend :: Exp -> Exp -> Exp+metaAppend l1 l2 = infixApp l1 appendOp l2++-- the +++ choice operator+metaChoice :: Exp -> Exp -> Exp+metaChoice e1 e2 = infixApp e1 choiceOp e2++metaPCons :: Pat -> Pat -> Pat+metaPCons p1 p2 = PInfixApp p1 cons p2++metaCons, metaComp :: Exp -> Exp -> Exp+metaCons e1 e2 = infixApp e1 (QConOp cons) e2+metaComp e1 e2 = infixApp e1 (op fcomp) e2++metaPJust :: Pat -> Pat+metaPJust p = pApp just_name [p]++metaPNothing :: Pat+metaPNothing = pvar nothing_name++metaPMkMaybe :: Maybe Pat -> Pat+metaPMkMaybe mp = case mp of+ Nothing -> metaPNothing+ Just p -> pParen $ metaPJust p++metaJust :: Exp -> Exp+metaJust e = app (con just_name) e++metaNothing :: Exp+metaNothing = con nothing_name++metaMkMaybe :: Maybe Exp -> Exp+metaMkMaybe me = case me of+ Nothing -> metaNothing+ Just e -> paren $ metaJust e++---------------------------------------------------+-- some other useful functions at abstract level+consFun, idFun :: Exp+consFun = Con cons+idFun = function "id"++con :: Name -> Exp+con = Con . UnQual++cons :: QName+cons = Special Cons++fcomp, choice, append :: Name+fcomp = Symbol "."+choice = Symbol "+++"+append = Symbol "++"++just_name, nothing_name, left_name, right_name :: Name+just_name = Ident "Just"+nothing_name = Ident "Nothing"+left_name = Ident "Left"+right_name = Ident "Right"++------------------------------------------------------------------------+-- Help functions for meta programming xml++{- No longer used.+hsx_data_mod :: ModuleName+hsx_data_mod = ModuleName "HSP.Data"++-- Also no longer used, literal PCDATA should be considered a string.+-- | Create an xml PCDATA value+metaMkPcdata :: String -> Exp+metaMkPcdata s = metaFunction "pcdata" [strE s]+-}++-- | Create an xml tag, given its domain, name, attributes and+-- children.+metaGenElement :: XName -> [Exp] -> Maybe Exp -> [Exp] -> Exp+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 [argAsAttr, x])) mat+ attrs = m $ listE $ map metaAsAttr ats+ in metaFunction "genElement" [ne, attrs, listE cs]++-- | Create an empty xml tag, given its domain, name and attributes.+metaGenEElement :: XName -> [Exp] -> Maybe Exp -> Exp+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 [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@(Lit (String _)) = metaFunction "asAttr" [ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))]+metaAsAttr e = metaFunction "asAttr" [e]++argAsAttr :: Exp+argAsAttr = var $ name "asAttr"++-- | Create a property from an attribute and a value.+metaAssign :: Exp -> Exp -> Exp+metaAssign e1 e2 = infixApp e1 assignOp e2+ where assignOp = QConOp $ UnQual $ Symbol ":="++-- | Make xml out of some expression by applying the overloaded function+-- @asChild@.+metaAsChild :: Exp -> Exp+metaAsChild e = metaFunction "asChild" [paren e]+++-- TODO: We need to fix the stuff below so pattern matching on XML could also be overloaded.+-- Right now it only works on HSP XML, or anything that is syntactically identical to it.++-- | Lookup an attribute in the set of attributes.+metaExtract :: XName -> Name -> Exp+metaExtract name attrs =+ let (d,n) = xNameParts name+ np = tuple [metaMkMaybe $ fmap strE d, strE n]+ in metaFunction "extract" [np, var attrs]++-- | Generate a pattern under the Tag data constructor.+metaTag :: (Maybe String) -> String -> Pat -> Pat -> Pat+metaTag dom name ats cpat =+ let d = metaPMkMaybe $ fmap strP dom+ n = pTuple [d, strP name]+ in metaConPat "Element" [n, ats, cpat]++-- | Generate a pattern under the PCDATA data constructor.+metaPcdata :: String -> Pat+metaPcdata s = metaConPat "CDATA" [strP s]++metaMkName :: XName -> Exp+metaMkName n = case n of+ XName s -> stringTypeSig (strE s)+ XDomName d s -> tuple [stringTypeSig $ strE d, stringTypeSig $ strE s]+ where+ stringTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))+
+ src/hsx2hs.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+module Main where++#ifdef BASE4+import Control.OldException (handle,ErrorCall(..))+#else+import Control.Exception (handle,ErrorCall(..))+#endif+import Data.List (isPrefixOf)+import Prelude hiding (readFile, writeFile)+import Language.Haskell.Exts hiding (parse)+import Language.Haskell.HSX.Transform (transform)+import System.Exit (exitFailure)+import System.Environment (getArgs)+import System.IO.UTF8 (readFile, writeFile,hPutStrLn)+import System.IO (stderr)++showSrcLoc :: SrcLoc -> String+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 $ showSrcLoc loc ++ ": " ++ s++transformFile :: String -> String -> String -> IO ()+transformFile origfile infile outfile = do+ f <- readFile infile+ let fm = process origfile f+ writeFile outfile fm++testFile :: String -> IO ()+testFile file = do+ f <- readFile file+ putStrLn $ process file f++testTransform :: String -> IO ()+testTransform file = do+ f <- readFile file+ putStrLn $ show $ transform $ checkParse $ parse file f++testPretty :: String -> IO ()+testPretty file = do+ f <- readFile file+ putStrLn $ prettyPrint $ checkParse $ parse file f++testParse :: String -> IO ()+testParse file = do+ f <- readFile file+ putStrLn $ show $ parse file f++main :: IO ()+main = do args <- getArgs+ 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}) $+ transform $ checkParse $ parse fp fc++parse :: String -> String -> ParseResult Module+parse fn fc = parseModuleWithMode (ParseMode fn allExtensions False True (Just baseFixities)) fcuc+ where fcuc= unlines $ filter (not . isPrefixOf "#") $ lines fc++usageString :: String+usageString = "Usage: hsx2hs <infile> [<outfile>]"++allExtensions :: [Extension]+allExtensions = [RecursiveDo,ParallelListComp,MultiParamTypeClasses,FunctionalDependencies,RankNTypes,ExistentialQuantification,+ ScopedTypeVariables,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls,KindSignatures,+ BangPatterns,TemplateHaskell,ForeignFunctionInterface,Arrows,Generics,NamedFieldPuns,PatternGuards,+ MagicHash,TypeFamilies,StandaloneDeriving,TypeOperators,RecordWildCards,GADTs,UnboxedTuples,+ PackageImports,QuasiQuotes,TransformListComp,ViewPatterns,XmlSyntax,RegularPatterns]