diff --git a/hsx.cabal b/hsx.cabal --- a/hsx.cabal +++ b/hsx.cabal @@ -1,5 +1,5 @@ Name: hsx -Version: 0.5.6 +Version: 0.6.0 License: BSD3 License-File: LICENSE Author: Niklas Broberg, Joel Björnson @@ -29,10 +29,10 @@ Homepage: http://code.google.com/hsp -Build-Depends: base>3 && <5, mtl, haskell-src-exts >= 1.0 && < 1.1, utf8-string +Build-Depends: base>3 && <5, mtl, haskell-src-exts == 1.4.*, utf8-string Build-Type: Simple Tested-With: GHC==6.8.3, GHC==6.10.1 -Cabal-Version: >= 1.2.3 +Cabal-Version: >= 1.6 Hs-Source-Dirs: src Exposed-Modules: HSX.XMLGenerator, HSX.Transform diff --git a/src/HSX/Transform.hs b/src/HSX/Transform.hs --- a/src/HSX/Transform.hs +++ b/src/HSX/Transform.hs @@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : HSX.Tranform --- Copyright : (c) Niklas Broberg 2004, +-- Copyright : (c) Niklas Broberg 2004-2009 -- License : BSD-style (see the file LICENSE.txt) -- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se +-- Maintainer : Niklas Broberg, niklas.broberg@chalmers.se -- Stability : experimental -- Portability : portable -- @@ -124,8 +124,13 @@ -- declarations of automatically instantiated functions ClassDecl s c n ns ds cdecls -> fmap (ClassDecl s c n ns ds) $ mapM transformClassDecl cdecls - -- Type signatures, type, newtype or data declarations, infix declarations - -- and default declarations; none can contain regular patterns + -- TH splices are expressions and can contain regular patterns + SpliceDecl srcloc e -> + fmap (SpliceDecl srcloc) $ transformExp 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 @@ -310,25 +315,19 @@ e' <- transformExp e stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss return $ ParComp e' stmtss' -{- Proc p e -> 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' -} - -- All other expressions simply transform their immediate subterms. + Proc s pat rhs -> do + let -- First rename regular patterns + (ps, rnpss) = unzip $ renameRPats [pat] + -- ... 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' <- transformExp e + return $ Lambda s ps rhs' + -- All other expressions simply transform their immediate subterms. InfixApp e1 op e2 -> transform2exp e1 e2 (\e1 e2 -> InfixApp e1 op e2) App e1 e2 -> transform2exp e1 e2 App @@ -355,18 +354,22 @@ RightArrApp e1 e2 -> transform2exp e1 e2 RightArrApp LeftArrHighApp e1 e2 -> transform2exp e1 e2 LeftArrHighApp RightArrHighApp e1 e2 -> transform2exp e1 e2 RightArrHighApp - _ -> return e -- Warning - will not work inside TH pattern splices! + CorePragma s e -> fmap (CorePragma s) $ transformExp e + SCCPragma s e -> fmap (SCCPragma s) $ transformExp e + GenPragma s a b e -> fmap (GenPragma s a b) $ transformExp e + _ -> return e -- Warning - will not work inside TH brackets! + transformFieldUpdate :: FieldUpdate -> HsxM FieldUpdate transformFieldUpdate (FieldUpdate n e) = fmap (FieldUpdate n) $ transformExp e +transformFieldUpdate fup = return fup transformSplice :: Splice -> HsxM Splice transformSplice s = case s of ParenSplice e -> fmap ParenSplice $ transformExp e _ -> return s - transform2exp :: Exp -> Exp -> (Exp -> Exp -> a) -> HsxM a transform2exp e1 e2 f = do e1' <- transformExp e1 e2' <- transformExp e2 @@ -504,6 +507,8 @@ -- 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] @@ -672,6 +677,7 @@ 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 @@ -751,6 +757,7 @@ 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 @@ -942,6 +949,9 @@ -- Transforming any other patterns simply means transforming -- their subparts. + PViewPat e p -> do + e' <- liftTr $ transformExp e + tr1pat p (PViewPat e') (trPattern s) PVar _ -> return p PLit _ -> return p PNeg q -> tr1pat q PNeg (trPattern s) @@ -958,11 +968,13 @@ 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) @@ -1447,6 +1459,7 @@ 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 diff --git a/src/HSX/XMLGenerator.hs b/src/HSX/XMLGenerator.hs --- a/src/HSX/XMLGenerator.hs +++ b/src/HSX/XMLGenerator.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, + FlexibleContexts, FlexibleInstances, UndecidableInstances, + TypeSynonymInstances, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : HSX.XMLGenerator -- Copyright : (c) Niklas Broberg 2008 -- License : BSD-style (see the file LICENSE.txt) -- --- Maintainer : Niklas Broberg, nibro@cs.chalmers.se +-- Maintainer : Niklas Broberg, niklas.broberg@chalmers.se -- Stability : experimental -- Portability : requires newtype deriving and MPTCs with fundeps --