diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsx2hs.cabal b/hsx2hs.cabal new file mode 100644 --- /dev/null +++ b/hsx2hs.cabal @@ -0,0 +1,73 @@ +Name: hsx2hs +Version: 0.11.0 +License: BSD3 +License-File: LICENSE +Author: Niklas Broberg, Joel Bjornson +Maintainer: Niklas Broberg + +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 diff --git a/src/Language/Haskell/HSX/QQ.hs b/src/Language/Haskell/HSX/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/HSX/QQ.hs @@ -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|

<% map toUpper "hello, world!" %>

|] + +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] diff --git a/src/Language/Haskell/HSX/Transform.hs b/src/Language/Haskell/HSX/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/HSX/Transform.hs @@ -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"))) + diff --git a/src/hsx2hs.hs b/src/hsx2hs.hs new file mode 100644 --- /dev/null +++ b/src/hsx2hs.hs @@ -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 []" + +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]