-----------------------------------------------------------------------------
-- |
-- 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.
-----------------------------------------------------------------------------

{-# LANGUAGE CPP #-}

module Language.Haskell.HSX.Transform (
      transform       -- :: HsModule -> HsModule
    , transformExp
    ) where

import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Build
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad       (ap)
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
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 Applicative HsxM where
  pure :: a -> HsxM a
pure  = a -> HsxM a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: HsxM (a -> b) -> HsxM a -> HsxM b
(<*>) = HsxM (a -> b) -> HsxM a -> HsxM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad HsxM where
 return :: a -> HsxM a
return a
x = (HsxState -> (a, HsxState)) -> HsxM a
forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
s -> (a
x,HsxState
s))
 (MkHsxM HsxState -> (a, HsxState)
f) >>= :: HsxM a -> (a -> HsxM b) -> HsxM b
>>= a -> HsxM b
k = (HsxState -> (b, HsxState)) -> HsxM b
forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
s -> let (a
a, HsxState
s') = HsxState -> (a, HsxState)
f HsxState
s
                                      (MkHsxM HsxState -> (b, HsxState)
f') = a -> HsxM b
k a
a
                                   in HsxState -> (b, HsxState)
f' HsxState
s')

#if MIN_VERSION_base(4,9,0)
-- this is probably wrong, but should never be called anyway.
instance Fail.MonadFail HsxM where
    fail :: String -> HsxM a
fail String
str = String -> HsxM a
forall a. HasCallStack => String -> a
error String
str
    {-# INLINE fail #-}
#endif

getHsxState :: HsxM HsxState
getHsxState :: HsxM HsxState
getHsxState = (HsxState -> (HsxState, HsxState)) -> HsxM HsxState
forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
s -> (HsxState
s, HsxState
s))

setHsxState :: HsxState -> HsxM ()
setHsxState :: HsxState -> HsxM ()
setHsxState HsxState
s = (HsxState -> ((), HsxState)) -> HsxM ()
forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
_ -> ((),HsxState
s))

instance Functor HsxM where
 fmap :: (a -> b) -> HsxM a -> HsxM b
fmap a -> b
f HsxM a
hma = do a
a <- HsxM a
hma
                 b -> HsxM b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> HsxM b) -> b -> HsxM b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a

-----

type HsxState = (Bool, Bool)

initHsxState :: HsxState
initHsxState :: HsxState
initHsxState = (Bool
False, Bool
False)

setHarpTransformed :: HsxM ()
setHarpTransformed :: HsxM ()
setHarpTransformed =
    do (Bool
_,Bool
x) <- HsxM HsxState
getHsxState
       HsxState -> HsxM ()
setHsxState (Bool
True,Bool
x)

setXmlTransformed :: HsxM ()
setXmlTransformed :: HsxM ()
setXmlTransformed =
    do (Bool
h,Bool
_) <- HsxM HsxState
getHsxState
       HsxState -> HsxM ()
setHsxState (Bool
h,Bool
True)

runHsxM :: HsxM a -> (a, (Bool, Bool))
runHsxM :: HsxM a -> (a, HsxState)
runHsxM (MkHsxM HsxState -> (a, HsxState)
f) = HsxState -> (a, HsxState)
f HsxState
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 () -> Module ()
transform (Module ()
l Maybe (ModuleHead ())
m [ModulePragma ()]
pragmas [ImportDecl ()]
is [Decl ()]
decls) =
    let ([Decl ()]
decls', (Bool
harp, Bool
hsx)) = HsxM [Decl ()] -> ([Decl ()], HsxState)
forall a. HsxM a -> (a, HsxState)
runHsxM (HsxM [Decl ()] -> ([Decl ()], HsxState))
-> HsxM [Decl ()] -> ([Decl ()], HsxState)
forall a b. (a -> b) -> a -> b
$ (Decl () -> HsxM (Decl ())) -> [Decl ()] -> HsxM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> HsxM (Decl ())
transformDecl [Decl ()]
decls
        -- We may need to add an import for Match.hs that defines the matcher monad
        imps1 :: [ImportDecl ()] -> [ImportDecl ()]
imps1 = if Bool
harp
             then (:) (ImportDecl () -> [ImportDecl ()] -> [ImportDecl ()])
-> ImportDecl () -> [ImportDecl ()] -> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ ()
-> ModuleName ()
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName ())
-> Maybe (ImportSpecList ())
-> ImportDecl ()
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
ImportDecl () ModuleName ()
match_mod Bool
True Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing
                            (ModuleName () -> Maybe (ModuleName ())
forall a. a -> Maybe a
Just ModuleName ()
match_qual_mod)
                            Maybe (ImportSpecList ())
forall a. Maybe a
Nothing
             else [ImportDecl ()] -> [ImportDecl ()]
forall a. a -> a
id
        imps2 :: a -> a
imps2 = {- if hsx
                 then (:) $ ImportDecl s hsx_data_mod False
                         Nothing
                         Nothing
                 else -} a -> a
forall a. a -> a
id     -- we no longer want to import HSP.Data
     in ()
-> Maybe (ModuleHead ())
-> [ModulePragma ()]
-> [ImportDecl ()]
-> [Decl ()]
-> Module ()
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module ()
l Maybe (ModuleHead ())
m [ModulePragma ()]
pragmas ([ImportDecl ()] -> [ImportDecl ()]
imps1 ([ImportDecl ()] -> [ImportDecl ()])
-> [ImportDecl ()] -> [ImportDecl ()]
forall a b. (a -> b) -> a -> b
$ [ImportDecl ()] -> [ImportDecl ()]
forall a. a -> a
imps2 [ImportDecl ()]
is) [Decl ()]
decls'

-----------------------------------------------------------------------------
-- Declarations

-- | Transform a declaration by transforming subterms that could
-- contain regular patterns.
transformDecl :: Decl () -> HsxM (Decl ())
transformDecl :: Decl () -> HsxM (Decl ())
transformDecl Decl ()
d = case Decl ()
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 ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls -> do
        -- Preserve semantics of irrefutable regular patterns by postponing
        -- their evaluation to a let-expression on the right-hand side
        let ([Pat ()
pat'], [[NameBind ()]]
rnpss) = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()
pat]
        -- Transform the pattern itself
        ([Pat ()
pat''], [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
pat']
        -- Transform the right-hand side, and add any generated guards
        -- and let expressions to it
        Rhs ()
rhs' <- [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs ([Guard ()]
attrGuards [Guard ()] -> [Guard ()] -> [Guard ()]
forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
        -- Transform declarations in the where clause, adding any generated
        -- declarations to it
        Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
               Maybe (Binds ())
Nothing -> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Binds ())
forall a. Maybe a
Nothing
               Just (BDecls ()
l [Decl ()]
ds)
                         -> do [Decl ()]
ds' <- [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
                               Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Binds ()) -> HsxM (Maybe (Binds ())))
-> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall a b. (a -> b) -> a -> b
$ Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just (Binds () -> Maybe (Binds ())) -> Binds () -> Maybe (Binds ())
forall a b. (a -> b) -> a -> b
$ () -> [Decl ()] -> Binds ()
forall l. l -> [Decl l] -> Binds l
BDecls ()
l ([Decl ()] -> Binds ()) -> [Decl ()] -> Binds ()
forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds'
               Maybe (Binds ())
_           -> String -> HsxM (Maybe (Binds ()))
forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
                        \ \'where\' clause of a function using regular patterns."
        Decl () -> HsxM (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl () -> HsxM (Decl ())) -> Decl () -> HsxM (Decl ())
forall a b. (a -> b) -> a -> b
$ () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Decl ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind ()
l Pat ()
pat'' Rhs ()
rhs' Maybe (Binds ())
decls'

    -- Function binds can contain regular patterns in their matches
    FunBind ()
l [Match ()]
ms -> ([Match ()] -> Decl ()) -> HsxM [Match ()] -> HsxM (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> [Match ()] -> Decl ()
forall l. l -> [Match l] -> Decl l
FunBind ()
l) (HsxM [Match ()] -> HsxM (Decl ()))
-> HsxM [Match ()] -> HsxM (Decl ())
forall a b. (a -> b) -> a -> b
$ (Match () -> HsxM (Match ())) -> [Match ()] -> HsxM [Match ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Match () -> HsxM (Match ())
transformMatch [Match ()]
ms
    -- Instance declarations can contain regular patterns in the
    -- declarations of functions inside it
    InstDecl ()
l Maybe (Overlap ())
mo InstRule ()
irule Maybe [InstDecl ()]
Nothing -> Decl () -> HsxM (Decl ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl ()
d
    InstDecl ()
l Maybe (Overlap ())
mo InstRule ()
irule (Just [InstDecl ()]
idecls) ->
      ([InstDecl ()] -> Decl ()) -> HsxM [InstDecl ()] -> HsxM (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (()
-> Maybe (Overlap ())
-> InstRule ()
-> Maybe [InstDecl ()]
-> Decl ()
forall l.
l
-> Maybe (Overlap l) -> InstRule l -> Maybe [InstDecl l] -> Decl l
InstDecl ()
l Maybe (Overlap ())
mo InstRule ()
irule (Maybe [InstDecl ()] -> Decl ())
-> ([InstDecl ()] -> Maybe [InstDecl ()])
-> [InstDecl ()]
-> Decl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstDecl ()] -> Maybe [InstDecl ()]
forall a. a -> Maybe a
Just) (HsxM [InstDecl ()] -> HsxM (Decl ()))
-> HsxM [InstDecl ()] -> HsxM (Decl ())
forall a b. (a -> b) -> a -> b
$ (InstDecl () -> HsxM (InstDecl ()))
-> [InstDecl ()] -> HsxM [InstDecl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InstDecl () -> HsxM (InstDecl ())
transformInstDecl [InstDecl ()]
idecls
    -- Class declarations can contain regular patterns in the
    -- declarations of automatically instantiated functions
    ClassDecl ()
l Maybe (Context ())
c DeclHead ()
dh [FunDep ()]
fd Maybe [ClassDecl ()]
Nothing -> Decl () -> HsxM (Decl ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl ()
d
    ClassDecl ()
l Maybe (Context ())
c DeclHead ()
dh [FunDep ()]
fd (Just [ClassDecl ()]
cdecls) ->
        ([ClassDecl ()] -> Decl ())
-> HsxM [ClassDecl ()] -> HsxM (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (()
-> Maybe (Context ())
-> DeclHead ()
-> [FunDep ()]
-> Maybe [ClassDecl ()]
-> Decl ()
forall l.
l
-> Maybe (Context l)
-> DeclHead l
-> [FunDep l]
-> Maybe [ClassDecl l]
-> Decl l
ClassDecl ()
l Maybe (Context ())
c DeclHead ()
dh [FunDep ()]
fd (Maybe [ClassDecl ()] -> Decl ())
-> ([ClassDecl ()] -> Maybe [ClassDecl ()])
-> [ClassDecl ()]
-> Decl ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ClassDecl ()] -> Maybe [ClassDecl ()]
forall a. a -> Maybe a
Just) (HsxM [ClassDecl ()] -> HsxM (Decl ()))
-> HsxM [ClassDecl ()] -> HsxM (Decl ())
forall a b. (a -> b) -> a -> b
$ (ClassDecl () -> HsxM (ClassDecl ()))
-> [ClassDecl ()] -> HsxM [ClassDecl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ClassDecl () -> HsxM (ClassDecl ())
transformClassDecl [ClassDecl ()]
cdecls
    -- TH splices are expressions and can contain regular patterns
    SpliceDecl ()
l Exp ()
e ->
        (Exp () -> Decl ()) -> HsxM (Exp ()) -> HsxM (Decl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Exp () -> Decl ()
forall l. l -> Exp l -> Decl l
SpliceDecl ()
l) (HsxM (Exp ()) -> HsxM (Decl ()))
-> HsxM (Exp ()) -> HsxM (Decl ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
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!
    Decl ()
_ -> Decl () -> HsxM (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return Decl ()
d

transformInstDecl :: InstDecl () -> HsxM (InstDecl ())
transformInstDecl :: InstDecl () -> HsxM (InstDecl ())
transformInstDecl InstDecl ()
d = case InstDecl ()
d of
    InsDecl ()
l Decl ()
decl -> (Decl () -> InstDecl ()) -> HsxM (Decl ()) -> HsxM (InstDecl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Decl () -> InstDecl ()
forall l. l -> Decl l -> InstDecl l
InsDecl ()
l) (HsxM (Decl ()) -> HsxM (InstDecl ()))
-> HsxM (Decl ()) -> HsxM (InstDecl ())
forall a b. (a -> b) -> a -> b
$ Decl () -> HsxM (Decl ())
transformDecl Decl ()
decl
    InstDecl ()
_ -> InstDecl () -> HsxM (InstDecl ())
forall (m :: * -> *) a. Monad m => a -> m a
return InstDecl ()
d


transformClassDecl :: ClassDecl () -> HsxM (ClassDecl ())
transformClassDecl :: ClassDecl () -> HsxM (ClassDecl ())
transformClassDecl ClassDecl ()
d = case ClassDecl ()
d of
    ClsDecl ()
l Decl ()
decl -> (Decl () -> ClassDecl ()) -> HsxM (Decl ()) -> HsxM (ClassDecl ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Decl () -> ClassDecl ()
forall l. l -> Decl l -> ClassDecl l
ClsDecl ()
l) (HsxM (Decl ()) -> HsxM (ClassDecl ()))
-> HsxM (Decl ()) -> HsxM (ClassDecl ())
forall a b. (a -> b) -> a -> b
$ Decl () -> HsxM (Decl ())
transformDecl Decl ()
decl
    ClassDecl ()
_ -> ClassDecl () -> HsxM (ClassDecl ())
forall (m :: * -> *) a. Monad m => a -> m a
return ClassDecl ()
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 () -> HsxM (Match ())
transformMatch (Match ()
l Name ()
name [Pat ()]
pats Rhs ()
rhs Maybe (Binds ())
decls) = do
    -- Preserve semantics of irrefutable regular patterns by postponing
    -- their evaluation to a let-expression on the right-hand side
    let ([Pat ()]
pats', [[NameBind ()]]
rnpss) = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()]
pats
    -- Transform the patterns that stand as arguments to the function
    ([Pat ()]
pats'', [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()]
pats'
    -- Transform the right-hand side, and add any generated guards
    -- and let expressions to it
    Rhs ()
rhs' <- [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs ([Guard ()]
attrGuards [Guard ()] -> [Guard ()] -> [Guard ()]
forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
    -- Transform declarations in the where clause, adding any generated
    -- declarations to it
    Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
           Maybe (Binds ())
Nothing -> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Binds ())
forall a. Maybe a
Nothing
           Just (BDecls ()
l [Decl ()]
ds)
                     -> do [Decl ()]
ds' <- [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
                           Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Binds ()) -> HsxM (Maybe (Binds ())))
-> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall a b. (a -> b) -> a -> b
$ Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just (Binds () -> Maybe (Binds ())) -> Binds () -> Maybe (Binds ())
forall a b. (a -> b) -> a -> b
$ () -> [Decl ()] -> Binds ()
forall l. l -> [Decl l] -> Binds l
BDecls ()
l ([Decl ()] -> Binds ()) -> [Decl ()] -> Binds ()
forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds'
           Maybe (Binds ())
_           -> String -> HsxM (Maybe (Binds ()))
forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
                     \ \'where\' clause of a function using regular patterns."

    Match () -> HsxM (Match ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Match () -> HsxM (Match ())) -> Match () -> HsxM (Match ())
forall a b. (a -> b) -> a -> b
$ () -> Name () -> [Pat ()] -> Rhs () -> Maybe (Binds ()) -> Match ()
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match ()
l Name ()
name [Pat ()]
pats'' Rhs ()
rhs' Maybe (Binds ())
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 :: [Guard ()] -> [(Name (), Pat ())] -> Rhs () -> HsxM (Rhs ())
mkRhs :: [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs [Guard ()]
guards [NameBind ()]
rnps (UnGuardedRhs ()
l Exp ()
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.
    Exp ()
rhs' <- Exp () -> HsxM (Exp ())
transformExpM (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls [NameBind ()]
rnps Exp ()
rhs
    case [Guard ()]
guards of
     -- There were no guards before, and none should be added,
     -- so we still have an unguarded right-hand side
     [] -> Rhs () -> HsxM (Rhs ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Rhs () -> HsxM (Rhs ())) -> Rhs () -> HsxM (Rhs ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
UnGuardedRhs ()
l Exp ()
rhs'
     -- There are guards to add. These should be added as pattern
     -- guards, i.e. as statements.
     [Guard ()]
_  -> Rhs () -> HsxM (Rhs ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Rhs () -> HsxM (Rhs ())) -> Rhs () -> HsxM (Rhs ())
forall a b. (a -> b) -> a -> b
$ () -> [GuardedRhs ()] -> Rhs ()
forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss ()
l [() -> [Stmt ()] -> Exp () -> GuardedRhs ()
forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs ()
l ((Guard () -> Stmt ()) -> [Guard ()] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
mkStmtGuard [Guard ()]
guards) Exp ()
rhs']
mkRhs [Guard ()]
guards [NameBind ()]
rnps (GuardedRhss ()
l [GuardedRhs ()]
gdrhss) = ([GuardedRhs ()] -> Rhs ())
-> HsxM [GuardedRhs ()] -> HsxM (Rhs ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> [GuardedRhs ()] -> Rhs ()
forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss ()
l) (HsxM [GuardedRhs ()] -> HsxM (Rhs ()))
-> HsxM [GuardedRhs ()] -> HsxM (Rhs ())
forall a b. (a -> b) -> a -> b
$ (GuardedRhs () -> HsxM (GuardedRhs ()))
-> [GuardedRhs ()] -> HsxM [GuardedRhs ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Guard ()]
-> [NameBind ()] -> GuardedRhs () -> HsxM (GuardedRhs ())
mkGRhs [Guard ()]
guards [NameBind ()]
rnps) [GuardedRhs ()]
gdrhss
  where mkGRhs :: [Guard ()] -> [(Name (), Pat ())] -> GuardedRhs () -> HsxM (GuardedRhs ())
        mkGRhs :: [Guard ()]
-> [NameBind ()] -> GuardedRhs () -> HsxM (GuardedRhs ())
mkGRhs [Guard ()]
gs [NameBind ()]
rnps (GuardedRhs ()
l [Stmt ()]
oldgs Exp ()
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.
            Exp ()
rhs' <- Exp () -> HsxM (Exp ())
transformExpM (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls [NameBind ()]
rnps Exp ()
rhs
            -- Now there are guards, so first we need to transform those
            [Stmt ()]
oldgs' <- ([[Stmt ()]] -> [Stmt ()]) -> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Stmt ()]] -> [Stmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HsxM [[Stmt ()]] -> HsxM [Stmt ()])
-> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ (Stmt () -> HsxM [Stmt ()]) -> [Stmt ()] -> HsxM [[Stmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
GuardStmt) [Stmt ()]
oldgs
            -- ... and then prepend the newly generated ones, as statements
            GuardedRhs () -> HsxM (GuardedRhs ())
forall (m :: * -> *) a. Monad m => a -> m a
return (GuardedRhs () -> HsxM (GuardedRhs ()))
-> GuardedRhs () -> HsxM (GuardedRhs ())
forall a b. (a -> b) -> a -> b
$ () -> [Stmt ()] -> Exp () -> GuardedRhs ()
forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs ()
l (((Guard () -> Stmt ()) -> [Guard ()] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
mkStmtGuard [Guard ()]
gs) [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. [a] -> [a] -> [a]
++ [Stmt ()]
oldgs') Exp ()
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 :: [(Name (), Pat ())] -> Exp () -> Exp ()
addLetDecls :: [NameBind ()] -> Exp () -> Exp ()
addLetDecls []   Exp ()
e = Exp ()
e    -- no declarations to add
addLetDecls [NameBind ()]
rnps Exp ()
e =
    -- Place all postponed patterns in the same let-expression
    [Decl ()] -> Exp () -> Exp ()
letE ((NameBind () -> Decl ()) -> [NameBind ()] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map NameBind () -> Decl ()
mkDecl [NameBind ()]
rnps) Exp ()
e

-- | Make pattern binds from postponed regular patterns
mkDecl :: (Name (), Pat ()) -> Decl ()
mkDecl :: NameBind () -> Decl ()
mkDecl (Name ()
n,Pat ()
p) = Pat () -> Exp () -> Decl ()
patBind Pat ()
p (Name () -> Exp ()
var Name ()
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 :: Exp () -> Exp ()
transformExp Exp ()
e =
    let (Exp ()
e', HsxState
_) = HsxM (Exp ()) -> (Exp (), HsxState)
forall a. HsxM a -> (a, HsxState)
runHsxM (HsxM (Exp ()) -> (Exp (), HsxState))
-> HsxM (Exp ()) -> (Exp (), HsxState)
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    in Exp ()
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 :: Exp () -> HsxM (Exp ())
transformExpM Exp ()
e = case Exp ()
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 ()
_ XName ()
name [XAttr ()]
attrs Maybe (Exp ())
mattr [Exp ()]
cs -> do
        -- Hey Pluto, look, we have XML in our syntax tree!
        HsxM ()
setXmlTransformed
        let -- ... make tuples of the attributes
            as :: [Exp ()]
as = (XAttr () -> Exp ()) -> [XAttr ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
        -- ... transform the children
        [Exp ()]
cs' <- (Exp () -> HsxM (Exp ())) -> [Exp ()] -> HsxM [Exp ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformChild [Exp ()]
cs
        -- ... and lift the values into the XML datatype.
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ XName () -> [Exp ()] -> Maybe (Exp ()) -> [Exp ()] -> Exp ()
metaGenElement XName ()
name [Exp ()]
as Maybe (Exp ())
mattr [Exp ()]
cs'

    -- An empty xml tag should be transformed just as a standard tag,
    -- only that there are no children,
    XETag ()
_ XName ()
name [XAttr ()]
attrs Maybe (Exp ())
mattr -> do
        -- ... 'tis the season to be jolly, falalalalaaaa....
        HsxM ()
setXmlTransformed
        let -- ... make tuples of the attributes
            as :: [Exp ()]
as = (XAttr () -> Exp ()) -> [XAttr ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
            -- ... and lift the values into the XML datatype.
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ XName () -> [Exp ()] -> Maybe (Exp ()) -> Exp ()
metaGenEElement XName ()
name [Exp ()]
as Maybe (Exp ())
mattr

    -- A child tag should be transformed into an application
    -- of asChild to a list of children.
    XChildTag ()
_ [Exp ()]
cs  -> do
        -- After all, it IS christmas!
        HsxM ()
setXmlTransformed
        -- ... transform the children
        [Exp ()]
cs' <- (Exp () -> HsxM (Exp ())) -> [Exp ()] -> HsxM [Exp ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformChild [Exp ()]
cs
        -- ... and make them into a list
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaAsChild (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE [Exp ()]
cs'

    -- PCDATA should be lifted as a string into the XML datatype.
    XPcdata ()
_ String
pcdata    -> do HsxM ()
setXmlTransformed
                              Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
pcdata
--                            return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "Text")))
    -- Escaped expressions should be treated as just expressions.
    XExpTag ()
_ Exp ()
e     -> do HsxM ()
setXmlTransformed
                          Exp ()
e' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
                          Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaAsChild Exp ()
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 ()
l [Pat ()]
pats Exp ()
rhs -> do
        let -- First rename regular patterns
            ([Pat ()]
ps, [[NameBind ()]]
rnpss)  = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()]
pats
            -- ... group them up to one big tuple
            ([Name ()]
rns, [Pat ()]
rps) = [NameBind ()] -> ([Name ()], [Pat ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss)
            alt1 :: Alt ()
alt1 = Pat () -> Exp () -> Alt ()
alt ([Pat ()] -> Pat ()
pTuple [Pat ()]
rps) Exp ()
rhs
            texp :: Exp ()
texp = [Name ()] -> Exp ()
varTuple [Name ()]
rns
            -- ... and put it all in a case expression, which
            -- can then be transformed in the normal way.
            e :: Exp ()
e = if [Name ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name ()]
rns then Exp ()
rhs else Exp () -> [Alt ()] -> Exp ()
caseE Exp ()
texp [Alt ()
alt1]
        Exp ()
rhs' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> [Pat ()] -> Exp () -> Exp ()
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda ()
l [Pat ()]
ps Exp ()
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 ()
_ [Decl ()]
ds) Exp ()
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.
        [Decl ()]
ds' <- [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
        Exp ()
e'  <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> Exp () -> Exp ()
letE [Decl ()]
ds' Exp ()
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 ()
l (IPBinds ()
l' [IPBind ()]
is) Exp ()
e -> do
        [IPBind ()]
is' <- (IPBind () -> HsxM (IPBind ())) -> [IPBind ()] -> HsxM [IPBind ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IPBind () -> HsxM (IPBind ())
transformIPBind [IPBind ()]
is
        Exp ()
e'  <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Binds () -> Exp () -> Exp ()
forall l. l -> Binds l -> Exp l -> Exp l
Let ()
l (() -> [IPBind ()] -> Binds ()
forall l. l -> [IPBind l] -> Binds l
IPBinds ()
l' [IPBind ()]
is') Exp ()
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 ()
l Exp ()
e [Alt ()]
alts -> do
        Exp ()
e'    <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        [Alt ()]
alts' <- (Alt () -> HsxM (Alt ())) -> [Alt ()] -> HsxM [Alt ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt () -> HsxM (Alt ())
transformAlt [Alt ()]
alts
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> [Alt ()] -> Exp ()
forall l. l -> Exp l -> [Alt l] -> Exp l
Case ()
l Exp ()
e' [Alt ()]
alts'
    -- A do expression can contain regular patterns in its statements.
    Do ()
l [Stmt ()]
stmts -> do
        [Stmt ()]
stmts' <- ([[Stmt ()]] -> [Stmt ()]) -> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Stmt ()]] -> [Stmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HsxM [[Stmt ()]] -> HsxM [Stmt ()])
-> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ (Stmt () -> HsxM [Stmt ()]) -> [Stmt ()] -> HsxM [[Stmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
DoStmt) [Stmt ()]
stmts
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> [Stmt ()] -> Exp ()
forall l. l -> [Stmt l] -> Exp l
Do ()
l [Stmt ()]
stmts'
    MDo ()
l [Stmt ()]
stmts -> do
        [Stmt ()]
stmts' <- ([[Stmt ()]] -> [Stmt ()]) -> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Stmt ()]] -> [Stmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HsxM [[Stmt ()]] -> HsxM [Stmt ()])
-> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ (Stmt () -> HsxM [Stmt ()]) -> [Stmt ()] -> HsxM [[Stmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
DoStmt) [Stmt ()]
stmts
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> [Stmt ()] -> Exp ()
forall l. l -> [Stmt l] -> Exp l
MDo ()
l [Stmt ()]
stmts'
    -- A list comprehension can contain regular patterns in the result
    -- expression, or in any of its statements.
    ListComp ()
l Exp ()
e [QualStmt ()]
stmts  -> do
        Exp ()
e'     <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        [QualStmt ()]
stmts' <- ([[QualStmt ()]] -> [QualStmt ()])
-> HsxM [[QualStmt ()]] -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[QualStmt ()]] -> [QualStmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HsxM [[QualStmt ()]] -> HsxM [QualStmt ()])
-> HsxM [[QualStmt ()]] -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ (QualStmt () -> HsxM [QualStmt ()])
-> [QualStmt ()] -> HsxM [[QualStmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualStmt () -> HsxM [QualStmt ()]
transformQualStmt [QualStmt ()]
stmts
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> [QualStmt ()] -> Exp ()
forall l. l -> Exp l -> [QualStmt l] -> Exp l
ListComp ()
l Exp ()
e' [QualStmt ()]
stmts'
    ParComp ()
l Exp ()
e [[QualStmt ()]]
stmtss  -> do
        Exp ()
e'      <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        [[QualStmt ()]]
stmtss' <- ([[[QualStmt ()]]] -> [[QualStmt ()]])
-> HsxM [[[QualStmt ()]]] -> HsxM [[QualStmt ()]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[QualStmt ()]] -> [QualStmt ()])
-> [[[QualStmt ()]]] -> [[QualStmt ()]]
forall a b. (a -> b) -> [a] -> [b]
map [[QualStmt ()]] -> [QualStmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (HsxM [[[QualStmt ()]]] -> HsxM [[QualStmt ()]])
-> HsxM [[[QualStmt ()]]] -> HsxM [[QualStmt ()]]
forall a b. (a -> b) -> a -> b
$ ([QualStmt ()] -> HsxM [[QualStmt ()]])
-> [[QualStmt ()]] -> HsxM [[[QualStmt ()]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((QualStmt () -> HsxM [QualStmt ()])
-> [QualStmt ()] -> HsxM [[QualStmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualStmt () -> HsxM [QualStmt ()]
transformQualStmt) [[QualStmt ()]]
stmtss
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> [[QualStmt ()]] -> Exp ()
forall l. l -> Exp l -> [[QualStmt l]] -> Exp l
ParComp ()
l Exp ()
e' [[QualStmt ()]]
stmtss'
    Proc ()
l Pat ()
pat Exp ()
rhs          -> do
        let -- First rename regular patterns
            ([Pat ()
p], [[NameBind ()]
rnps])  = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()
pat]
            -- ... group them up to one big tuple
            ([Name ()]
rns, [Pat ()]
rps) = [NameBind ()] -> ([Name ()], [Pat ()])
forall a b. [(a, b)] -> ([a], [b])
unzip [NameBind ()]
rnps
            alt1 :: Alt ()
alt1 = Pat () -> Exp () -> Alt ()
alt ([Pat ()] -> Pat ()
pTuple [Pat ()]
rps) Exp ()
rhs
            texp :: Exp ()
texp = [Name ()] -> Exp ()
varTuple [Name ()]
rns
            -- ... and put it all in a case expression, which
            -- can then be transformed in the normal way.
            e :: Exp ()
e = if [Name ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name ()]
rns then Exp ()
rhs else Exp () -> [Alt ()] -> Exp ()
caseE Exp ()
texp [Alt ()
alt1]
        Exp ()
rhs' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Pat () -> Exp () -> Exp ()
forall l. l -> Pat l -> Exp l -> Exp l
Proc ()
l Pat ()
p Exp ()
rhs'

    -- All other expressions simply transform their immediate subterms.
    InfixApp ()
l Exp ()
e1 QOp ()
op Exp ()
e2 -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2
                                (\Exp ()
e1 Exp ()
e2 -> () -> Exp () -> QOp () -> Exp () -> Exp ()
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp ()
l Exp ()
e1 QOp ()
op Exp ()
e2)
    App ()
l Exp ()
e1 Exp ()
e2         -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
App ()
l)
    NegApp ()
l Exp ()
e          -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l
NegApp ()
l) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    If ()
l Exp ()
e1 Exp ()
e2 Exp ()
e3       -> Exp ()
-> Exp ()
-> Exp ()
-> (Exp () -> Exp () -> Exp () -> Exp ())
-> HsxM (Exp ())
forall a.
Exp ()
-> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp Exp ()
e1 Exp ()
e2 Exp ()
e3 (() -> Exp () -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
If ()
l)
    Tuple ()
l Boxed
bx [Exp ()]
es       -> ([Exp ()] -> Exp ()) -> HsxM [Exp ()] -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Boxed -> [Exp ()] -> Exp ()
forall l. l -> Boxed -> [Exp l] -> Exp l
Tuple ()
l Boxed
bx) (HsxM [Exp ()] -> HsxM (Exp ())) -> HsxM [Exp ()] -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ (Exp () -> HsxM (Exp ())) -> [Exp ()] -> HsxM [Exp ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformExpM [Exp ()]
es
    List ()
l [Exp ()]
es           -> ([Exp ()] -> Exp ()) -> HsxM [Exp ()] -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> [Exp ()] -> Exp ()
forall l. l -> [Exp l] -> Exp l
List ()
l) (HsxM [Exp ()] -> HsxM (Exp ())) -> HsxM [Exp ()] -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ (Exp () -> HsxM (Exp ())) -> [Exp ()] -> HsxM [Exp ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformExpM [Exp ()]
es
    Paren ()
l Exp ()
e           -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l
Paren ()
l) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    LeftSection ()
l Exp ()
e QOp ()
op  -> do Exp ()
e' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
                              Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> QOp () -> Exp ()
forall l. l -> Exp l -> QOp l -> Exp l
LeftSection ()
l Exp ()
e' QOp ()
op
    RightSection ()
l QOp ()
op Exp ()
e -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> QOp () -> Exp () -> Exp ()
forall l. l -> QOp l -> Exp l -> Exp l
RightSection ()
l QOp ()
op) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    RecConstr ()
l QName ()
n [FieldUpdate ()]
fus   -> ([FieldUpdate ()] -> Exp ())
-> HsxM [FieldUpdate ()] -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> QName () -> [FieldUpdate ()] -> Exp ()
forall l. l -> QName l -> [FieldUpdate l] -> Exp l
RecConstr ()
l QName ()
n) (HsxM [FieldUpdate ()] -> HsxM (Exp ()))
-> HsxM [FieldUpdate ()] -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ (FieldUpdate () -> HsxM (FieldUpdate ()))
-> [FieldUpdate ()] -> HsxM [FieldUpdate ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate [FieldUpdate ()]
fus
    RecUpdate ()
l Exp ()
e [FieldUpdate ()]
fus   -> do Exp ()
e'   <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
                              [FieldUpdate ()]
fus' <- (FieldUpdate () -> HsxM (FieldUpdate ()))
-> [FieldUpdate ()] -> HsxM [FieldUpdate ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate [FieldUpdate ()]
fus
                              Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> [FieldUpdate ()] -> Exp ()
forall l. l -> Exp l -> [FieldUpdate l] -> Exp l
RecUpdate ()
l Exp ()
e' [FieldUpdate ()]
fus'
    EnumFrom ()
l Exp ()
e        -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l
EnumFrom ()
l) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    EnumFromTo ()
l Exp ()
e1 Exp ()
e2  -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
EnumFromTo ()
l)
    EnumFromThen ()
l Exp ()
e1 Exp ()
e2      -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
EnumFromThen ()
l)
    EnumFromThenTo ()
l Exp ()
e1 Exp ()
e2 Exp ()
e3 -> Exp ()
-> Exp ()
-> Exp ()
-> (Exp () -> Exp () -> Exp () -> Exp ())
-> HsxM (Exp ())
forall a.
Exp ()
-> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp Exp ()
e1 Exp ()
e2 Exp ()
e3 (() -> Exp () -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
EnumFromThenTo ()
l)
    ExpTypeSig ()
l Exp ()
e Type ()
t  -> do Exp ()
e' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
                            Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ () -> Exp () -> Type () -> Exp ()
forall l. l -> Exp l -> Type l -> Exp l
ExpTypeSig ()
l Exp ()
e' Type ()
t
    SpliceExp ()
l Splice ()
s       -> (Splice () -> Exp ()) -> HsxM (Splice ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Splice () -> Exp ()
forall l. l -> Splice l -> Exp l
SpliceExp ()
l) (HsxM (Splice ()) -> HsxM (Exp ()))
-> HsxM (Splice ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Splice () -> HsxM (Splice ())
transformSplice Splice ()
s
    LeftArrApp ()
l Exp ()
e1 Exp ()
e2        -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
LeftArrApp ()
l)
    RightArrApp ()
l Exp ()
e1 Exp ()
e2       -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
RightArrApp ()
l)
    LeftArrHighApp ()
l Exp ()
e1 Exp ()
e2    -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
LeftArrHighApp ()
l)
    RightArrHighApp ()
l Exp ()
e1 Exp ()
e2   -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp ()) -> HsxM (Exp ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (() -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
RightArrHighApp ()
l)
    CorePragma ()
l String
s Exp ()
e      -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> String -> Exp () -> Exp ()
forall l. l -> String -> Exp l -> Exp l
CorePragma ()
l String
s) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    SCCPragma  ()
l String
s Exp ()
e      -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> String -> Exp () -> Exp ()
forall l. l -> String -> Exp l -> Exp l
SCCPragma  ()
l String
s) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    GenPragma  ()
l String
s (Int, Int)
a (Int, Int)
b Exp ()
e  -> (Exp () -> Exp ()) -> HsxM (Exp ()) -> HsxM (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> String -> (Int, Int) -> (Int, Int) -> Exp () -> Exp ()
forall l. l -> String -> (Int, Int) -> (Int, Int) -> Exp l -> Exp l
GenPragma  ()
l String
s (Int, Int)
a (Int, Int)
b) (HsxM (Exp ()) -> HsxM (Exp ())) -> HsxM (Exp ()) -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    Exp ()
_           -> Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return Exp ()
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 :: Exp () -> HsxM (Exp ())
transformChild Exp ()
e = do
        -- Transform the expression
        Exp ()
te <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        -- ... and apply the overloaded toXMLs to it
        Exp () -> HsxM (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaAsChild Exp ()
te

transformFieldUpdate :: FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate :: FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate (FieldUpdate ()
l QName ()
n Exp ()
e) =
        (Exp () -> FieldUpdate ())
-> HsxM (Exp ()) -> HsxM (FieldUpdate ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> QName () -> Exp () -> FieldUpdate ()
forall l. l -> QName l -> Exp l -> FieldUpdate l
FieldUpdate ()
l QName ()
n) (HsxM (Exp ()) -> HsxM (FieldUpdate ()))
-> HsxM (Exp ()) -> HsxM (FieldUpdate ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
transformFieldUpdate FieldUpdate ()
fup = FieldUpdate () -> HsxM (FieldUpdate ())
forall (m :: * -> *) a. Monad m => a -> m a
return FieldUpdate ()
fup

transformSplice :: Splice () -> HsxM (Splice ())
transformSplice :: Splice () -> HsxM (Splice ())
transformSplice Splice ()
s = case Splice ()
s of
    ParenSplice ()
l Exp ()
e     -> (Exp () -> Splice ()) -> HsxM (Exp ()) -> HsxM (Splice ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Exp () -> Splice ()
forall l. l -> Exp l -> Splice l
ParenSplice ()
l) (HsxM (Exp ()) -> HsxM (Splice ()))
-> HsxM (Exp ()) -> HsxM (Splice ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    Splice ()
_                   -> Splice () -> HsxM (Splice ())
forall (m :: * -> *) a. Monad m => a -> m a
return Splice ()
s

transform2exp :: Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp :: Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 Exp () -> Exp () -> a
f = do Exp ()
e1' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e1
                           Exp ()
e2' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e2
                           a -> HsxM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> HsxM a) -> a -> HsxM a
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> a
f Exp ()
e1' Exp ()
e2'

transform3exp :: Exp () -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp :: Exp ()
-> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp Exp ()
e1 Exp ()
e2 Exp ()
e3 Exp () -> Exp () -> Exp () -> a
f = do Exp ()
e1' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e1
                              Exp ()
e2' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e2
                              Exp ()
e3' <- Exp () -> HsxM (Exp ())
transformExpM Exp ()
e3
                              a -> HsxM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> HsxM a) -> a -> HsxM a
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp () -> a
f Exp ()
e1' Exp ()
e2' Exp ()
e3'

mkAttr :: XAttr () -> Exp ()
mkAttr :: XAttr () -> Exp ()
mkAttr (XAttr ()
_ XName ()
name Exp ()
e) =
    Exp () -> Exp ()
paren (XName () -> Exp ()
metaMkName XName ()
name Exp () -> Exp () -> Exp ()
`metaAssign` (Exp () -> Exp ()
textTypeSig Exp ()
e))
    where
      textTypeSig :: Exp () -> Exp ()
textTypeSig e :: Exp ()
e@(Lit ()
_ (String ()
_ String
_ String
_)) = Exp () -> Exp ()
metaFromStringLit Exp ()
e
--      textTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))
      textTypeSig Exp ()
e                  = Exp ()
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 :: [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
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' :: [Decl ()]
ds' = [Decl ()] -> [Decl ()]
renameLetDecls [Decl ()]
ds
    Int -> Int -> [Decl ()] -> HsxM [Decl ()]
transformLDs Int
0 Int
0 [Decl ()]
ds'
  where transformLDs :: Int -> Int -> [Decl ()] -> HsxM [Decl ()]
        transformLDs :: Int -> Int -> [Decl ()] -> HsxM [Decl ()]
transformLDs Int
k Int
l [Decl ()]
ds = case [Decl ()]
ds of
            []     -> [Decl ()] -> HsxM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            (Decl ()
d:[Decl ()]
ds) -> case Decl ()
d of
                PatBind ()
l'' Pat ()
pat Rhs ()
rhs Maybe (Binds ())
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 ()
pat'], [Guard ()]
ags, [Guard ()]
gs, [Decl ()]
ws, Int
k', Int
l') <- Int
-> Int
-> Tr [Pat ()]
-> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()], Int, Int)
forall a.
Int
-> Int
-> Tr a
-> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
runTrFromTo Int
k Int
l ([Pat ()] -> Tr [Pat ()]
trPatterns [Pat ()
pat])
                    Maybe (Binds ())
decls' <- case Maybe (Binds ())
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...
                        Maybe (Binds ())
Nothing -> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Binds ())
forall a. Maybe a
Nothing
                        Just (BDecls ()
l'' [Decl ()]
decls) -> ([Decl ()] -> Maybe (Binds ()))
-> HsxM [Decl ()] -> HsxM (Maybe (Binds ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just (Binds () -> Maybe (Binds ()))
-> ([Decl ()] -> Binds ()) -> [Decl ()] -> Maybe (Binds ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> [Decl ()] -> Binds ()
forall l. l -> [Decl l] -> Binds l
BDecls ()
l'') (HsxM [Decl ()] -> HsxM (Maybe (Binds ())))
-> HsxM [Decl ()] -> HsxM (Maybe (Binds ()))
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
decls
                        -- If they are implicit parameter bindings we simply transform
                        -- them as such.
                        Just (IPBinds ()
l'' [IPBind ()]
decls) -> ([IPBind ()] -> Maybe (Binds ()))
-> HsxM [IPBind ()] -> HsxM (Maybe (Binds ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just (Binds () -> Maybe (Binds ()))
-> ([IPBind ()] -> Binds ()) -> [IPBind ()] -> Maybe (Binds ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> [IPBind ()] -> Binds ()
forall l. l -> [IPBind l] -> Binds l
IPBinds ()
l'') (HsxM [IPBind ()] -> HsxM (Maybe (Binds ())))
-> HsxM [IPBind ()] -> HsxM (Maybe (Binds ()))
forall a b. (a -> b) -> a -> b
$ (IPBind () -> HsxM (IPBind ())) -> [IPBind ()] -> HsxM [IPBind ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IPBind () -> HsxM (IPBind ())
transformIPBind [IPBind ()]
decls
                    -- The generated guard, if any, should be a declaration, and the
                    -- generated declarations should be associated with it.
                    let gs' :: [Decl ()]
gs' = case [Guard ()]
gs of
                           []  -> []
                           [Guard ()
g] -> [Guard () -> [Decl ()] -> Decl ()
mkDeclGuard Guard ()
g [Decl ()]
ws]
                           [Guard ()]
_   -> String -> [Decl ()]
forall a. HasCallStack => String -> a
error String
"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' :: [Decl ()]
ags' = (Guard () -> Decl ()) -> [Guard ()] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Guard () -> [Decl ()] -> Decl ())
-> [Decl ()] -> Guard () -> Decl ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Guard () -> [Decl ()] -> Decl ()
mkDeclGuard ([Decl ()] -> Guard () -> Decl ())
-> [Decl ()] -> Guard () -> Decl ()
forall a b. (a -> b) -> a -> b
$ []) [Guard ()]
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 ()
rhs' <- [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs [] [] Rhs ()
rhs
                    -- ... and then we should recurse with the new gensym argument.
                    [Decl ()]
ds' <- Int -> Int -> [Decl ()] -> HsxM [Decl ()]
transformLDs Int
k' Int
l' [Decl ()]
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.
                    [Decl ()] -> HsxM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl ()] -> HsxM [Decl ()]) -> [Decl ()] -> HsxM [Decl ()]
forall a b. (a -> b) -> a -> b
$ (() -> Pat () -> Rhs () -> Maybe (Binds ()) -> Decl ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind ()
l'' Pat ()
pat' Rhs ()
rhs' Maybe (Binds ())
decls') Decl () -> [Decl ()] -> [Decl ()]
forall a. a -> [a] -> [a]
: [Decl ()]
ags' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
gs' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds'

                    -- We only need to treat pattern binds separately, other declarations
                    -- can be transformed normally.
                Decl ()
d -> do Decl ()
d'  <- Decl () -> HsxM (Decl ())
transformDecl Decl ()
d
                        [Decl ()]
ds' <- Int -> Int -> [Decl ()] -> HsxM [Decl ()]
transformLDs Int
k Int
l [Decl ()]
ds
                        [Decl ()] -> HsxM [Decl ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl ()] -> HsxM [Decl ()]) -> [Decl ()] -> HsxM [Decl ()]
forall a b. (a -> b) -> a -> b
$ Decl ()
d'Decl () -> [Decl ()] -> [Decl ()]
forall a. a -> [a] -> [a]
:[Decl ()]
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 () -> HsxM (IPBind ())
transformIPBind (IPBind ()
l IPName ()
n Exp ()
e) =
    (Exp () -> IPBind ()) -> HsxM (Exp ()) -> HsxM (IPBind ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> IPName () -> Exp () -> IPBind ()
forall l. l -> IPName l -> Exp l -> IPBind l
IPBind ()
l IPName ()
n) (HsxM (Exp ()) -> HsxM (IPBind ()))
-> HsxM (Exp ()) -> HsxM (IPBind ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
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 :: StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
t Stmt ()
s = case Stmt ()
s of
    -- Generators can have regular patterns in the result pattern on the
    -- left-hand side and in the generating expression.
    Generator ()
s Pat ()
p Exp ()
e -> do
        let -- We need to treat generated guards differently depending
            -- on the context of the statement.
            guardFun :: Guard () -> Stmt ()
guardFun = case StmtType
t of
                StmtType
DoStmt       -> Guard () -> Stmt ()
monadify
                StmtType
ListCompStmt -> Guard () -> Stmt ()
monadify
                StmtType
GuardStmt    -> Guard () -> Stmt ()
mkStmtGuard
            -- Preserve semantics of irrefutable regular patterns by postponing
            -- their evaluation to a let-expression on the right-hand side
            ([Pat ()
p'], [[NameBind ()]]
rnpss) = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()
p]
        -- Transform the pattern itself
        ([Pat ()
p''], [Guard ()]
ags, [Guard ()]
gs, [Decl ()]
ds) <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
p']
        -- Put the generated declarations in a let-statement
        let lt :: [Stmt ()]
lt  = case [Decl ()]
ds of
               [] -> []
               [Decl ()]
_  -> [[Decl ()] -> Stmt ()
letStmt [Decl ()]
ds]
            -- Perform the designated trick on the generated guards.
            gs' :: [Stmt ()]
gs' = (Guard () -> Stmt ()) -> [Guard ()] -> [Stmt ()]
forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
guardFun ([Guard ()]
ags [Guard ()] -> [Guard ()] -> [Guard ()]
forall a. [a] -> [a] -> [a]
++ [Guard ()]
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.
        Exp ()
e' <- Exp () -> HsxM (Exp ())
transformExpM (Exp () -> HsxM (Exp ())) -> Exp () -> HsxM (Exp ())
forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Exp ()
e
        [Stmt ()] -> HsxM [Stmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt ()] -> HsxM [Stmt ()]) -> [Stmt ()] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ () -> Pat () -> Exp () -> Stmt ()
forall l. l -> Pat l -> Exp l -> Stmt l
Generator ()
s Pat ()
p'' Exp ()
e'Stmt () -> [Stmt ()] -> [Stmt ()]
forall a. a -> [a] -> [a]
:[Stmt ()]
lt [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. [a] -> [a] -> [a]
++ [Stmt ()]
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 :: Guard () -> Stmt ()
monadify (Pat ()
p,Exp ()
e) = Pat () -> Exp () -> Stmt ()
genStmt Pat ()
p (Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren Exp ()
e)
    -- Qualifiers are simply wrapped expressions and are treated as such.
    Qualifier ()
l Exp ()
e -> (Exp () -> [Stmt ()]) -> HsxM (Exp ()) -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Exp ()
e -> [() -> Exp () -> Stmt ()
forall l. l -> Exp l -> Stmt l
Qualifier ()
l (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$ Exp ()
e]) (HsxM (Exp ()) -> HsxM [Stmt ()])
-> HsxM (Exp ()) -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    -- Let statements suffer from the same problem as let expressions, so
    -- the declarations should be treated in the same special way.
    LetStmt ()
_ (BDecls ()
_ [Decl ()]
ds)  ->
        ([Decl ()] -> [Stmt ()]) -> HsxM [Decl ()] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Decl ()]
ds -> [[Decl ()] -> Stmt ()
letStmt [Decl ()]
ds]) (HsxM [Decl ()] -> HsxM [Stmt ()])
-> HsxM [Decl ()] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
    -- If the bindings are of implicit parameters we simply transform them as such.
    LetStmt ()
l (IPBinds ()
l' [IPBind ()]
is) ->
        ([IPBind ()] -> [Stmt ()]) -> HsxM [IPBind ()] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[IPBind ()]
is -> [() -> Binds () -> Stmt ()
forall l. l -> Binds l -> Stmt l
LetStmt ()
l (() -> [IPBind ()] -> Binds ()
forall l. l -> [IPBind l] -> Binds l
IPBinds ()
l' [IPBind ()]
is)]) (HsxM [IPBind ()] -> HsxM [Stmt ()])
-> HsxM [IPBind ()] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ (IPBind () -> HsxM (IPBind ())) -> [IPBind ()] -> HsxM [IPBind ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IPBind () -> HsxM (IPBind ())
transformIPBind [IPBind ()]
is
    RecStmt ()
l [Stmt ()]
stmts   ->
        ([[Stmt ()]] -> [Stmt ()]) -> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Stmt () -> [Stmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt () -> [Stmt ()])
-> ([[Stmt ()]] -> Stmt ()) -> [[Stmt ()]] -> [Stmt ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> [Stmt ()] -> Stmt ()
forall l. l -> [Stmt l] -> Stmt l
RecStmt ()
l ([Stmt ()] -> Stmt ())
-> ([[Stmt ()]] -> [Stmt ()]) -> [[Stmt ()]] -> Stmt ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Stmt ()]] -> [Stmt ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (HsxM [[Stmt ()]] -> HsxM [Stmt ()])
-> HsxM [[Stmt ()]] -> HsxM [Stmt ()]
forall a b. (a -> b) -> a -> b
$ (Stmt () -> HsxM [Stmt ()]) -> [Stmt ()] -> HsxM [[Stmt ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
t) [Stmt ()]
stmts

transformQualStmt :: QualStmt () -> HsxM [QualStmt ()]
transformQualStmt :: QualStmt () -> HsxM [QualStmt ()]
transformQualStmt QualStmt ()
qs = case QualStmt ()
qs of
    -- For qual statments in list comprehensions we just pass on the baton
    QualStmt     ()
l Stmt ()
s      -> ([Stmt ()] -> [QualStmt ()])
-> HsxM [Stmt ()] -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stmt () -> QualStmt ()) -> [Stmt ()] -> [QualStmt ()]
forall a b. (a -> b) -> [a] -> [b]
map (() -> Stmt () -> QualStmt ()
forall l. l -> Stmt l -> QualStmt l
QualStmt ()
l)) (HsxM [Stmt ()] -> HsxM [QualStmt ()])
-> HsxM [Stmt ()] -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
ListCompStmt Stmt ()
s
    ThenTrans    ()
l Exp ()
e      -> (Exp () -> [QualStmt ()]) -> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QualStmt () -> [QualStmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (QualStmt () -> [QualStmt ()])
-> (Exp () -> QualStmt ()) -> Exp () -> [QualStmt ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Exp () -> QualStmt ()
forall l. l -> Exp l -> QualStmt l
ThenTrans ()
l) (HsxM (Exp ()) -> HsxM [QualStmt ()])
-> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    ThenBy       ()
l Exp ()
e Exp ()
f    -> (QualStmt () -> [QualStmt ()])
-> HsxM (QualStmt ()) -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualStmt () -> [QualStmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (HsxM (QualStmt ()) -> HsxM [QualStmt ()])
-> HsxM (QualStmt ()) -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ Exp ()
-> Exp ()
-> (Exp () -> Exp () -> QualStmt ())
-> HsxM (QualStmt ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e Exp ()
f (() -> Exp () -> Exp () -> QualStmt ()
forall l. l -> Exp l -> Exp l -> QualStmt l
ThenBy ()
l)
    GroupBy      ()
l Exp ()
e      -> (Exp () -> [QualStmt ()]) -> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QualStmt () -> [QualStmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (QualStmt () -> [QualStmt ()])
-> (Exp () -> QualStmt ()) -> Exp () -> [QualStmt ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Exp () -> QualStmt ()
forall l. l -> Exp l -> QualStmt l
GroupBy ()
l) (HsxM (Exp ()) -> HsxM [QualStmt ()])
-> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
    GroupUsing   ()
l Exp ()
f      -> (Exp () -> [QualStmt ()]) -> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QualStmt () -> [QualStmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (QualStmt () -> [QualStmt ()])
-> (Exp () -> QualStmt ()) -> Exp () -> [QualStmt ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Exp () -> QualStmt ()
forall l. l -> Exp l -> QualStmt l
GroupUsing ()
l) (HsxM (Exp ()) -> HsxM [QualStmt ()])
-> HsxM (Exp ()) -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
f
    GroupByUsing ()
l Exp ()
e Exp ()
f    -> (QualStmt () -> [QualStmt ()])
-> HsxM (QualStmt ()) -> HsxM [QualStmt ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualStmt () -> [QualStmt ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (HsxM (QualStmt ()) -> HsxM [QualStmt ()])
-> HsxM (QualStmt ()) -> HsxM [QualStmt ()]
forall a b. (a -> b) -> a -> b
$ Exp ()
-> Exp ()
-> (Exp () -> Exp () -> QualStmt ())
-> HsxM (QualStmt ())
forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e Exp ()
f (() -> Exp () -> Exp () -> QualStmt ()
forall l. l -> Exp l -> Exp l -> QualStmt l
GroupByUsing ()
l)

------------------------------------------------------------------------------------------
-- Case alternatives

-- | Transform alternatives in a @case@-expression. Patterns are
-- transformed, while other subterms are traversed further.
transformAlt :: Alt () -> HsxM (Alt ())
transformAlt :: Alt () -> HsxM (Alt ())
transformAlt (Alt ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls) = do
    -- Preserve semantics of irrefutable regular patterns by postponing
    -- their evaluation to a let-expression on the right-hand side
    let ([Pat ()
pat'], [[NameBind ()]]
rnpss) = [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]]))
-> [(Pat (), [NameBind ()])] -> ([Pat ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()
pat]
    -- Transform the pattern itself
    ([Pat ()
pat''], [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
pat']
    -- Transform the right-hand side, and add any generated guards
    -- and let expressions to it.
    Rhs ()
rhs' <- [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs ([Guard ()]
attrGuards [Guard ()] -> [Guard ()] -> [Guard ()]
forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
    -- Transform declarations in the where clause, adding any generated
    -- declarations to it.
    Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
           Maybe (Binds ())
Nothing -> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Binds ())
forall a. Maybe a
Nothing
           Just (BDecls ()
l' [Decl ()]
ds) -> do [Decl ()]
ds' <- (Decl () -> HsxM (Decl ())) -> [Decl ()] -> HsxM [Decl ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> HsxM (Decl ())
transformDecl [Decl ()]
ds
                                     Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Binds ()) -> HsxM (Maybe (Binds ())))
-> Maybe (Binds ()) -> HsxM (Maybe (Binds ()))
forall a b. (a -> b) -> a -> b
$ Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just (Binds () -> Maybe (Binds ())) -> Binds () -> Maybe (Binds ())
forall a b. (a -> b) -> a -> b
$ () -> [Decl ()] -> Binds ()
forall l. l -> [Decl l] -> Binds l
BDecls ()
l' ([Decl ()] -> Binds ()) -> [Decl ()] -> Binds ()
forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds
           Maybe (Binds ())
_           -> String -> HsxM (Maybe (Binds ()))
forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
                     \ \'where\' clause of a function using regular patterns."

    Alt () -> HsxM (Alt ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt () -> HsxM (Alt ())) -> Alt () -> HsxM (Alt ())
forall a b. (a -> b) -> a -> b
$ () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Alt ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt ()
l Pat ()
pat'' Rhs ()
rhs' Maybe (Binds ())
decls'

----------------------------------------------------------------------------------
-- 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 l = (Pat l, Exp l)

mkStmtGuard :: Guard () -> Stmt ()
mkStmtGuard :: Guard () -> Stmt ()
mkStmtGuard (Pat ()
p, Exp ()
e) = Pat () -> Exp () -> Stmt ()
genStmt Pat ()
p Exp ()
e

mkDeclGuard :: Guard () -> [Decl ()] -> Decl ()
mkDeclGuard :: Guard () -> [Decl ()] -> Decl ()
mkDeclGuard (Pat ()
p, Exp ()
e) [Decl ()]
ds = Pat () -> Exp () -> [Decl ()] -> Decl ()
patBindWhere Pat ()
p Exp ()
e [Decl ()]
ds

----------------------------------------------------------------------------------
-- Rewriting expressions before transformation.
-- Done in a monad for gensym capability.

newtype RN a = RN (RNState -> (a, RNState))

type RNState = Int

initRNState :: Int
initRNState = Int
0

instance Applicative RN where
  pure :: a -> RN a
pure  = a -> RN a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: RN (a -> b) -> RN a -> RN b
(<*>) = RN (a -> b) -> RN a -> RN b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad RN where
 return :: a -> RN a
return a
a = (Int -> (a, Int)) -> RN a
forall a. (Int -> (a, Int)) -> RN a
RN ((Int -> (a, Int)) -> RN a) -> (Int -> (a, Int)) -> RN a
forall a b. (a -> b) -> a -> b
$ \Int
s -> (a
a,Int
s)
 (RN Int -> (a, Int)
f) >>= :: RN a -> (a -> RN b) -> RN b
>>= a -> RN b
k = (Int -> (b, Int)) -> RN b
forall a. (Int -> (a, Int)) -> RN a
RN ((Int -> (b, Int)) -> RN b) -> (Int -> (b, Int)) -> RN b
forall a b. (a -> b) -> a -> b
$ \Int
s -> let (a
a,Int
s') = Int -> (a, Int)
f Int
s
                               (RN Int -> (b, Int)
g) = a -> RN b
k a
a
                            in Int -> (b, Int)
g Int
s'

instance Functor RN where
 fmap :: (a -> b) -> RN a -> RN b
fmap a -> b
f RN a
rna = do a
a <- RN a
rna
                 b -> RN b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> RN b) -> b -> RN b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a


runRename :: RN a -> a
runRename :: RN a -> a
runRename (RN Int -> (a, Int)
f) = let (a
a,Int
_) = Int -> (a, Int)
f Int
initRNState
                    in a
a

getRNState :: RN RNState
getRNState :: RN Int
getRNState = (Int -> (Int, Int)) -> RN Int
forall a. (Int -> (a, Int)) -> RN a
RN ((Int -> (Int, Int)) -> RN Int) -> (Int -> (Int, Int)) -> RN Int
forall a b. (a -> b) -> a -> b
$ \Int
s -> (Int
s,Int
s)

setRNState :: RNState -> RN ()
setRNState :: Int -> RN ()
setRNState Int
s = (Int -> ((), Int)) -> RN ()
forall a. (Int -> (a, Int)) -> RN a
RN ((Int -> ((), Int)) -> RN ()) -> (Int -> ((), Int)) -> RN ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> ((), Int
s)

genVarName :: RN (Name ())
genVarName :: RN (Name ())
genVarName = do
    Int
k <- RN Int
getRNState
    Int -> RN ()
setRNState (Int -> RN ()) -> Int -> RN ()
forall a b. (a -> b) -> a -> b
$ Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
    Name () -> RN (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> RN (Name ())) -> Name () -> RN (Name ())
forall a b. (a -> b) -> a -> b
$ String -> Name ()
name (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_rnvar" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k


type NameBind l = (Name l, Pat l)

-- Some generic functions on monads for traversing subterms

rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat a
p b -> c
f a -> RN (b, [d])
rn = do (b
q, [d]
ms) <- a -> RN (b, [d])
rn a
p
                       (c, [d]) -> RN (c, [d])
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> c
f b
q, [d]
ms)

rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename2pat a
p1 a
p2 b -> b -> c
f a -> RN (b, [d])
rn = do (b
q1, [d]
ms1) <- a -> RN (b, [d])
rn a
p1
                           (b
q2, [d]
ms2) <- a -> RN (b, [d])
rn a
p2
                           (c, [d]) -> RN (c, [d])
forall (m :: * -> *) a. Monad m => a -> m a
return ((c, [d]) -> RN (c, [d])) -> (c, [d]) -> RN (c, [d])
forall a b. (a -> b) -> a -> b
$ (b -> b -> c
f b
q1 b
q2, [d]
ms1 [d] -> [d] -> [d]
forall a. [a] -> [a] -> [a]
++ [d]
ms2)

renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [a]
ps [b] -> c
f a -> RN (b, [d])
rn = do ([b]
qs, [[d]]
mss) <- ([(b, [d])] -> ([b], [[d]])) -> RN [(b, [d])] -> RN ([b], [[d]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(b, [d])] -> ([b], [[d]])
forall a b. [(a, b)] -> ([a], [b])
unzip (RN [(b, [d])] -> RN ([b], [[d]]))
-> RN [(b, [d])] -> RN ([b], [[d]])
forall a b. (a -> b) -> a -> b
$ (a -> RN (b, [d])) -> [a] -> RN [(b, [d])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> RN (b, [d])
rn [a]
ps
                        (c, [d]) -> RN (c, [d])
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> c
f [b]
qs, [[d]] -> [d]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[d]]
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 :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()]
ps = RN [(Pat (), [NameBind ()])] -> [(Pat (), [NameBind ()])]
forall a. RN a -> a
runRename (RN [(Pat (), [NameBind ()])] -> [(Pat (), [NameBind ()])])
-> RN [(Pat (), [NameBind ()])] -> [(Pat (), [NameBind ()])]
forall a b. (a -> b) -> a -> b
$ (Pat () -> RN (Pat (), [NameBind ()]))
-> [Pat ()] -> RN [(Pat (), [NameBind ()])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat () -> RN (Pat (), [NameBind ()])
renameRP [Pat ()]
ps

renameRP :: Pat () -> RN (Pat (), [NameBind ()])
renameRP :: Pat () -> RN (Pat (), [NameBind ()])
renameRP Pat ()
p = case Pat ()
p of
    -- We must rename regular patterns and Tag expressions
    PRPat ()
_ [RPat ()]
_           -> Pat () -> RN (Pat (), [NameBind ()])
rename Pat ()
p
    PXTag ()
_ XName ()
_ [PXAttr ()]
_ Maybe (Pat ())
_ [Pat ()]
_   -> Pat () -> RN (Pat (), [NameBind ()])
rename Pat ()
p
    PXETag ()
_ XName ()
_ [PXAttr ()]
_ Maybe (Pat ())
_    -> Pat () -> RN (Pat (), [NameBind ()])
rename Pat ()
p
    -- The rest of the rules simply try to rename regular patterns in
    -- their immediate subpatterns.
    PInfixApp ()
l Pat ()
p1 QName ()
n Pat ()
p2 -> Pat ()
-> Pat ()
-> (Pat () -> Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename2pat Pat ()
p1 Pat ()
p2
                                (\Pat ()
p1 Pat ()
p2 -> () -> Pat () -> QName () -> Pat () -> Pat ()
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp ()
l Pat ()
p1 QName ()
n Pat ()
p2)
                                Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PApp ()
l QName ()
n [Pat ()]
ps         -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> QName () -> [Pat ()] -> Pat ()
forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PTuple ()
l Boxed
bx [Pat ()]
ps      -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> Boxed -> [Pat ()] -> Pat ()
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PList ()
l [Pat ()]
ps          -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PParen ()
l Pat ()
p          -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PRec ()
l QName ()
n [PatField ()]
pfs        -> [PatField ()]
-> ([PatField ()] -> Pat ())
-> (PatField () -> RN (PatField (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [PatField ()]
pfs (() -> QName () -> [PatField ()] -> Pat ()
forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> RN (PatField (), [NameBind ()])
renameRPf
    PAsPat ()
l Name ()
n Pat ()
p        -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Name () -> Pat () -> Pat ()
forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PIrrPat ()
l Pat ()
p         -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PIrrPat ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PXPatTag ()
l Pat ()
p        -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PXPatTag ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    PatTypeSig ()
l Pat ()
p Type ()
t  -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (\Pat ()
p -> () -> Pat () -> Type () -> Pat ()
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig ()
l Pat ()
p Type ()
t) Pat () -> RN (Pat (), [NameBind ()])
renameRP
    Pat ()
_                   -> (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat ()
p, [])
  where renameRPf :: PatField () -> RN (PatField (), [NameBind ()])
        renameRPf :: PatField () -> RN (PatField (), [NameBind ()])
renameRPf (PFieldPat ()
l QName ()
n Pat ()
p) = Pat ()
-> (Pat () -> PatField ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (PatField (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> QName () -> Pat () -> PatField ()
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
        renameRPf PatField ()
pf              = (PatField (), [NameBind ()]) -> RN (PatField (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (PatField ()
pf, [])

        renameAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
        renameAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
renameAttr (PXAttr ()
l XName ()
s Pat ()
p) = Pat ()
-> (Pat () -> PXAttr ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (PXAttr (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> XName () -> Pat () -> PXAttr ()
forall l. l -> XName l -> Pat l -> PXAttr l
PXAttr ()
l XName ()
s) Pat () -> RN (Pat (), [NameBind ()])
renameRP

        rename :: Pat () -> RN (Pat (), [NameBind ()])
        rename :: Pat () -> RN (Pat (), [NameBind ()])
rename Pat ()
p = do -- Generate a fresh variable
              Name ()
n <- RN (Name ())
genVarName
              -- ... and return that, along with the association of
              -- the variable with the old pattern
              (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> Pat ()
pvar Name ()
n, [(Name ()
n,Pat ()
p)])

-- | Rename declarations appearing in @let@s or @where@ clauses.
renameLetDecls :: [Decl ()] -> [Decl ()]
renameLetDecls :: [Decl ()] -> [Decl ()]
renameLetDecls [Decl ()]
ds =
    let -- Rename all regular patterns bound in pattern bindings.
        ([Decl ()]
ds', [[NameBind ()]]
smss) = [(Decl (), [NameBind ()])] -> ([Decl ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Decl (), [NameBind ()])] -> ([Decl ()], [[NameBind ()]]))
-> [(Decl (), [NameBind ()])] -> ([Decl ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ RN [(Decl (), [NameBind ()])] -> [(Decl (), [NameBind ()])]
forall a. RN a -> a
runRename (RN [(Decl (), [NameBind ()])] -> [(Decl (), [NameBind ()])])
-> RN [(Decl (), [NameBind ()])] -> [(Decl (), [NameBind ()])]
forall a b. (a -> b) -> a -> b
$ (Decl () -> RN (Decl (), [NameBind ()]))
-> [Decl ()] -> RN [(Decl (), [NameBind ()])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> RN (Decl (), [NameBind ()])
renameLetDecl [Decl ()]
ds
        -- ... and then generate declarations for the associations
        gs :: [Decl ()]
gs = (NameBind () -> Decl ()) -> [NameBind ()] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name ()
n,Pat ()
p) -> NameBind () -> Decl ()
mkDecl (Name ()
n,Pat ()
p)) ([[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
smss)
        -- ... which should be added to the original list of declarations.
     in [Decl ()]
ds' [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()]
gs

  where renameLetDecl :: Decl () -> RN (Decl (), [(Name (), Pat ())])
        renameLetDecl :: Decl () -> RN (Decl (), [NameBind ()])
renameLetDecl Decl ()
d = case Decl ()
d of
            -- We need only bother about pattern bindings.
            PatBind ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls -> do
                -- Rename any regular patterns that appear in the
                -- pattern being bound.
                (Pat ()
p, [NameBind ()]
ms) <- Pat () -> RN (Pat (), [NameBind ()])
renameRP Pat ()
pat
                let sms :: [NameBind ()]
sms = (NameBind () -> NameBind ()) -> [NameBind ()] -> [NameBind ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name ()
n,Pat ()
p) -> (Name ()
n, Pat ()
p)) [NameBind ()]
ms
                (Decl (), [NameBind ()]) -> RN (Decl (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Decl (), [NameBind ()]) -> RN (Decl (), [NameBind ()]))
-> (Decl (), [NameBind ()]) -> RN (Decl (), [NameBind ()])
forall a b. (a -> b) -> a -> b
$ (() -> Pat () -> Rhs () -> Maybe (Binds ()) -> Decl ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind ()
l Pat ()
p Rhs ()
rhs Maybe (Binds ())
decls, [NameBind ()]
sms)
            Decl ()
_ -> (Decl (), [NameBind ()]) -> RN (Decl (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl ()
d, [])

-- | Move irrefutable regular patterns into a @let@-expression instead,
-- to make sure that the semantics of @~@ are preserved.
renameIrrPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()]
ps = RN [(Pat (), [NameBind ()])] -> [(Pat (), [NameBind ()])]
forall a. RN a -> a
runRename ((Pat () -> RN (Pat (), [NameBind ()]))
-> [Pat ()] -> RN [(Pat (), [NameBind ()])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat () -> RN (Pat (), [NameBind ()])
renameIrrP [Pat ()]
ps)

renameIrrP :: Pat () -> RN (Pat (), [(Name (), Pat ())])
renameIrrP :: Pat () -> RN (Pat (), [NameBind ()])
renameIrrP Pat ()
p = case Pat ()
p of
    -- We should rename any regular pattern appearing
    -- inside an irrefutable pattern.
    PIrrPat ()
l Pat ()
p     -> do (Pat ()
q, [NameBind ()]
ms) <- Pat () -> RN (Pat (), [NameBind ()])
renameRP Pat ()
p
                          (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()]))
-> (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall a b. (a -> b) -> a -> b
$ (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PIrrPat ()
l Pat ()
q, [NameBind ()]
ms)
    -- The rest of the rules simply try to rename regular patterns in
    -- irrefutable patterns in their immediate subpatterns.
    PInfixApp ()
l Pat ()
p1 QName ()
n Pat ()
p2 -> Pat ()
-> Pat ()
-> (Pat () -> Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename2pat Pat ()
p1 Pat ()
p2
                                (\Pat ()
p1 Pat ()
p2 -> () -> Pat () -> QName () -> Pat () -> Pat ()
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp ()
l Pat ()
p1 QName ()
n Pat ()
p2)
                                Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PApp ()
l QName ()
n [Pat ()]
ps         -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> QName () -> [Pat ()] -> Pat ()
forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PTuple ()
l Boxed
bx [Pat ()]
ps      -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> Boxed -> [Pat ()] -> Pat ()
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PList ()
l [Pat ()]
ps          -> [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (() -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PParen ()
l Pat ()
p          -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PRec ()
l QName ()
n [PatField ()]
pfs        -> [PatField ()]
-> ([PatField ()] -> Pat ())
-> (PatField () -> RN (PatField (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [PatField ()]
pfs (() -> QName () -> [PatField ()] -> Pat ()
forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> RN (PatField (), [NameBind ()])
renameIrrPf
    PAsPat ()
l Name ()
n Pat ()
p        -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Name () -> Pat () -> Pat ()
forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    PatTypeSig ()
l Pat ()
p Type ()
t  -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (\Pat ()
p -> () -> Pat () -> Type () -> Pat ()
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig ()
l Pat ()
p Type ()
t) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    -- Hsx
    PXTag ()
l XName ()
n [PXAttr ()]
attrs Maybe (Pat ())
mat [Pat ()]
ps -> do ([PXAttr ()]
attrs', [[NameBind ()]]
nss) <- ([(PXAttr (), [NameBind ()])] -> ([PXAttr ()], [[NameBind ()]]))
-> RN [(PXAttr (), [NameBind ()])]
-> RN ([PXAttr ()], [[NameBind ()]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PXAttr (), [NameBind ()])] -> ([PXAttr ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip (RN [(PXAttr (), [NameBind ()])]
 -> RN ([PXAttr ()], [[NameBind ()]]))
-> RN [(PXAttr (), [NameBind ()])]
-> RN ([PXAttr ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ (PXAttr () -> RN (PXAttr (), [NameBind ()]))
-> [PXAttr ()] -> RN [(PXAttr (), [NameBind ()])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PXAttr () -> RN (PXAttr (), [NameBind ()])
renameIrrAttr [PXAttr ()]
attrs
                                 (Maybe (Pat ())
mat', [NameBind ()]
ns1) <- case Maybe (Pat ())
mat of
                                                   Maybe (Pat ())
Nothing -> (Maybe (Pat ()), [NameBind ()])
-> RN (Maybe (Pat ()), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Pat ())
forall a. Maybe a
Nothing, [])
                                                   Just Pat ()
at -> do (Pat ()
at', [NameBind ()]
ns) <- Pat () -> RN (Pat (), [NameBind ()])
renameIrrP Pat ()
at
                                                                 (Maybe (Pat ()), [NameBind ()])
-> RN (Maybe (Pat ()), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Maybe (Pat ())
forall a. a -> Maybe a
Just Pat ()
at', [NameBind ()]
ns)
                                 (Pat ()
q, [NameBind ()]
ns) <- [Pat ()]
-> ([Pat ()] -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (()
-> XName () -> [PXAttr ()] -> Maybe (Pat ()) -> [Pat ()] -> Pat ()
forall l.
l -> XName l -> [PXAttr l] -> Maybe (Pat l) -> [Pat l] -> Pat l
PXTag ()
l XName ()
n [PXAttr ()]
attrs' Maybe (Pat ())
mat') Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
                                 (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat ()
q, [[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
nss [NameBind ()] -> [NameBind ()] -> [NameBind ()]
forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns1 [NameBind ()] -> [NameBind ()] -> [NameBind ()]
forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns)
    PXETag ()
l XName ()
n [PXAttr ()]
attrs Maybe (Pat ())
mat  -> do ([PXAttr ()]
as, [[NameBind ()]]
nss) <- ([(PXAttr (), [NameBind ()])] -> ([PXAttr ()], [[NameBind ()]]))
-> RN [(PXAttr (), [NameBind ()])]
-> RN ([PXAttr ()], [[NameBind ()]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PXAttr (), [NameBind ()])] -> ([PXAttr ()], [[NameBind ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip (RN [(PXAttr (), [NameBind ()])]
 -> RN ([PXAttr ()], [[NameBind ()]]))
-> RN [(PXAttr (), [NameBind ()])]
-> RN ([PXAttr ()], [[NameBind ()]])
forall a b. (a -> b) -> a -> b
$ (PXAttr () -> RN (PXAttr (), [NameBind ()]))
-> [PXAttr ()] -> RN [(PXAttr (), [NameBind ()])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PXAttr () -> RN (PXAttr (), [NameBind ()])
renameIrrAttr [PXAttr ()]
attrs
                                (Maybe (Pat ())
mat', [NameBind ()]
ns1) <- case Maybe (Pat ())
mat of
                                                  Maybe (Pat ())
Nothing -> (Maybe (Pat ()), [NameBind ()])
-> RN (Maybe (Pat ()), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Pat ())
forall a. Maybe a
Nothing, [])
                                                  Just Pat ()
at -> do (Pat ()
at', [NameBind ()]
ns) <- Pat () -> RN (Pat (), [NameBind ()])
renameIrrP Pat ()
at
                                                                (Maybe (Pat ()), [NameBind ()])
-> RN (Maybe (Pat ()), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Maybe (Pat ())
forall a. a -> Maybe a
Just Pat ()
at', [NameBind ()]
ns)
                                (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()]))
-> (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall a b. (a -> b) -> a -> b
$ (() -> XName () -> [PXAttr ()] -> Maybe (Pat ()) -> Pat ()
forall l. l -> XName l -> [PXAttr l] -> Maybe (Pat l) -> Pat l
PXETag ()
l XName ()
n [PXAttr ()]
as Maybe (Pat ())
mat', [[NameBind ()]] -> [NameBind ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
nss [NameBind ()] -> [NameBind ()] -> [NameBind ()]
forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns1)
    PXPatTag ()
l Pat ()
p            -> Pat ()
-> (Pat () -> Pat ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (Pat (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PXPatTag ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
    -- End Hsx

    Pat ()
_                       -> (Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat ()
p, [])

  where renameIrrPf :: PatField () -> RN (PatField (), [NameBind ()])
        renameIrrPf :: PatField () -> RN (PatField (), [NameBind ()])
renameIrrPf (PFieldPat ()
l QName ()
n Pat ()
p) = Pat ()
-> (Pat () -> PatField ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (PatField (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> QName () -> Pat () -> PatField ()
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
        renameIrrPf PatField ()
pf = (PatField (), [NameBind ()]) -> RN (PatField (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (PatField ()
pf, [])

        renameIrrAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
        renameIrrAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
renameIrrAttr (PXAttr ()
l XName ()
s Pat ()
p) = Pat ()
-> (Pat () -> PXAttr ())
-> (Pat () -> RN (Pat (), [NameBind ()]))
-> RN (PXAttr (), [NameBind ()])
forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (() -> XName () -> Pat () -> PXAttr ()
forall l. l -> XName l -> Pat l -> PXAttr l
PXAttr ()
l XName ()
s) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP

-----------------------------------------------------------------------------------
-- Transforming Patterns: the real stuff

-- | Transform several patterns in the same context, thereby
-- generating any code for matching regular patterns.
transformPatterns :: [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns :: [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()]
ps = Tr [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
forall a. Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()])
runTr ([Pat ()] -> Tr [Pat ()]
trPatterns [Pat ()]
ps)

---------------------------------------------------
-- The transformation monad

type State = (Int, Int, Int, [Guard ()], [Guard ()], [Decl ()])

newtype Tr a = Tr (State -> HsxM (a, State))

instance Applicative Tr where
  pure :: a -> Tr a
pure  = a -> Tr a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: Tr (a -> b) -> Tr a -> Tr b
(<*>) = Tr (a -> b) -> Tr a -> Tr b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Tr where
 return :: a -> Tr a
return a
a = (State -> HsxM (a, State)) -> Tr a
forall a. (State -> HsxM (a, State)) -> Tr a
Tr ((State -> HsxM (a, State)) -> Tr a)
-> (State -> HsxM (a, State)) -> Tr a
forall a b. (a -> b) -> a -> b
$ \State
s -> (a, State) -> HsxM (a, State)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, State
s)
 (Tr State -> HsxM (a, State)
f) >>= :: Tr a -> (a -> Tr b) -> Tr b
>>= a -> Tr b
k = (State -> HsxM (b, State)) -> Tr b
forall a. (State -> HsxM (a, State)) -> Tr a
Tr ((State -> HsxM (b, State)) -> Tr b)
-> (State -> HsxM (b, State)) -> Tr b
forall a b. (a -> b) -> a -> b
$ \State
s ->
          do (a
a, State
s') <- State -> HsxM (a, State)
f State
s
             let (Tr State -> HsxM (b, State)
f') = a -> Tr b
k a
a
             State -> HsxM (b, State)
f' State
s'

instance Functor Tr where
 fmap :: (a -> b) -> Tr a -> Tr b
fmap a -> b
f Tr a
tra = Tr a
tra Tr a -> (a -> Tr b) -> Tr b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> Tr b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Tr b) -> (a -> b) -> a -> Tr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

liftTr :: HsxM a -> Tr a
liftTr :: HsxM a -> Tr a
liftTr HsxM a
hma = (State -> HsxM (a, State)) -> Tr a
forall a. (State -> HsxM (a, State)) -> Tr a
Tr ((State -> HsxM (a, State)) -> Tr a)
-> (State -> HsxM (a, State)) -> Tr a
forall a b. (a -> b) -> a -> b
$ \State
s -> do a
a <- HsxM a
hma
                           (a, State) -> HsxM (a, State)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, State
s)

initState :: (Int, Int, Int, [a], [a], [a])
initState = Int -> Int -> (Int, Int, Int, [a], [a], [a])
forall a b c a a a. Num a => b -> c -> (a, b, c, [a], [a], [a])
initStateFrom Int
0 Int
0

initStateFrom :: b -> c -> (a, b, c, [a], [a], [a])
initStateFrom b
k c
l = (a
0, b
k, c
l, [], [], [])

runTr :: Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()])
runTr :: Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()])
runTr (Tr State -> HsxM (a, State)
f) = do (a
a, (Int
_,Int
_,Int
_,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds)) <- State -> HsxM (a, State)
f State
forall a a a. (Int, Int, Int, [a], [a], [a])
initState
                  (a, [Guard ()], [Guard ()], [Decl ()])
-> HsxM (a, [Guard ()], [Guard ()], [Decl ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, [Guard ()] -> [Guard ()]
forall a. [a] -> [a]
reverse [Guard ()]
gs1, [Guard ()] -> [Guard ()]
forall a. [a] -> [a]
reverse [Guard ()]
gs2, [Decl ()] -> [Decl ()]
forall a. [a] -> [a]
reverse [Decl ()]
ds)


runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
runTrFromTo :: Int
-> Int
-> Tr a
-> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
runTrFromTo Int
k Int
l (Tr State -> HsxM (a, State)
f) = do (a
a, (Int
_,Int
k',Int
l',[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds)) <- State -> HsxM (a, State)
f (State -> HsxM (a, State)) -> State -> HsxM (a, State)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> State
forall a b c a a a. Num a => b -> c -> (a, b, c, [a], [a], [a])
initStateFrom Int
k Int
l
                            (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
-> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, [Guard ()] -> [Guard ()]
forall a. [a] -> [a]
reverse [Guard ()]
gs1, [Guard ()] -> [Guard ()]
forall a. [a] -> [a]
reverse [Guard ()]
gs2, [Decl ()] -> [Decl ()]
forall a. [a] -> [a]
reverse [Decl ()]
ds, Int
k', Int
l')


-- manipulating the state
getState :: Tr State
getState :: Tr State
getState = (State -> HsxM (State, State)) -> Tr State
forall a. (State -> HsxM (a, State)) -> Tr a
Tr ((State -> HsxM (State, State)) -> Tr State)
-> (State -> HsxM (State, State)) -> Tr State
forall a b. (a -> b) -> a -> b
$ \State
s -> (State, State) -> HsxM (State, State)
forall (m :: * -> *) a. Monad m => a -> m a
return (State
s,State
s)

setState :: State -> Tr ()
setState :: State -> Tr ()
setState State
s = (State -> HsxM ((), State)) -> Tr ()
forall a. (State -> HsxM (a, State)) -> Tr a
Tr ((State -> HsxM ((), State)) -> Tr ())
-> (State -> HsxM ((), State)) -> Tr ()
forall a b. (a -> b) -> a -> b
$ \State
_ -> ((), State) -> HsxM ((), State)
forall (m :: * -> *) a. Monad m => a -> m a
return ((),State
s)

updateState :: (State -> (a,State)) -> Tr a
updateState :: (State -> (a, State)) -> Tr a
updateState State -> (a, State)
f = do State
s <- Tr State
getState
                   let (a
a,State
s') = State -> (a, State)
f State
s
                   State -> Tr ()
setState State
s'
                   a -> Tr a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- specific state manipulating functions
pushGuard :: Pat () -> Exp () -> Tr ()
pushGuard :: Pat () -> Exp () -> Tr ()
pushGuard Pat ()
p Exp ()
e = (State -> ((), State)) -> Tr ()
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> ((), State)) -> Tr ())
-> (State -> ((), State)) -> Tr ()
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> ((),(Int
n,Int
m,Int
a,[Guard ()]
gs1,(Pat ()
p,Exp ()
e)Guard () -> [Guard ()] -> [Guard ()]
forall a. a -> [a] -> [a]
:[Guard ()]
gs2,[Decl ()]
ds))

pushDecl :: Decl () -> Tr ()
pushDecl :: Decl () -> Tr ()
pushDecl Decl ()
d = (State -> ((), State)) -> Tr ()
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> ((), State)) -> Tr ())
-> (State -> ((), State)) -> Tr ()
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> ((),(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,Decl ()
dDecl () -> [Decl ()] -> [Decl ()]
forall a. a -> [a] -> [a]
:[Decl ()]
ds))

pushAttrGuard :: Pat () -> Exp () -> Tr ()
pushAttrGuard :: Pat () -> Exp () -> Tr ()
pushAttrGuard Pat ()
p Exp ()
e = (State -> ((), State)) -> Tr ()
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> ((), State)) -> Tr ())
-> (State -> ((), State)) -> Tr ()
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> ((),(Int
n,Int
m,Int
a,(Pat ()
p,Exp ()
e)Guard () -> [Guard ()] -> [Guard ()]
forall a. a -> [a] -> [a]
:[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))

genMatchName :: Tr (Name ())
genMatchName :: Tr (Name ())
genMatchName = do Int
k <- (State -> (Int, State)) -> Tr Int
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> (Int, State)) -> Tr Int)
-> (State -> (Int, State)) -> Tr Int
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> (Int
n,(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
                  Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> Tr (Name ())) -> Name () -> Tr (Name ())
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_match" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k

genPatName :: Tr (Name ())
genPatName :: Tr (Name ())
genPatName = do Int
k <- (State -> (Int, State)) -> Tr Int
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> (Int, State)) -> Tr Int)
-> (State -> (Int, State)) -> Tr Int
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> (Int
m,(Int
n,Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
                Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> Tr (Name ())) -> Name () -> Tr (Name ())
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_pat" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k

genAttrName :: Tr (Name ())
genAttrName :: Tr (Name ())
genAttrName = do Int
k <- (State -> (Int, State)) -> Tr Int
forall a. (State -> (a, State)) -> Tr a
updateState ((State -> (Int, State)) -> Tr Int)
-> (State -> (Int, State)) -> Tr Int
forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> (Int
m,(Int
n,Int
m,Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
                 Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> Tr (Name ())) -> Name () -> Tr (Name ())
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Ident ()  (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"hsx_attrs" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k


setHarpTransformedT, setXmlTransformedT :: Tr ()
setHarpTransformedT :: Tr ()
setHarpTransformedT = HsxM () -> Tr ()
forall a. HsxM a -> Tr a
liftTr HsxM ()
setHarpTransformed
setXmlTransformedT :: Tr ()
setXmlTransformedT  = HsxM () -> Tr ()
forall a. HsxM a -> Tr a
liftTr HsxM ()
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 :: a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat a
p b -> c
f a -> Tr b
tr = do b
q <- a -> Tr b
tr a
p
                   c -> Tr c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> Tr c) -> c -> Tr c
forall a b. (a -> b) -> a -> b
$ b -> c
f b
q

tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat a
p1 a
p2 b -> b -> c
f a -> Tr b
tr = do b
q1 <- a -> Tr b
tr a
p1
                       b
q2 <- a -> Tr b
tr a
p2
                       c -> Tr c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> Tr c) -> c -> Tr c
forall a b. (a -> b) -> a -> b
$ b -> b -> c
f b
q1 b
q2

trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [a]
ps [b] -> c
f a -> Tr b
tr = do [b]
qs <- (a -> Tr b) -> [a] -> Tr [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> Tr b
tr [a]
ps
                    c -> Tr c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> Tr c) -> c -> Tr c
forall a b. (a -> b) -> a -> b
$ [b] -> c
f [b]
qs

-----------------------------------------------------------------------------
-- The *real* transformations
-- Transforming patterns

-- | Transform several patterns in the same context
trPatterns :: [Pat ()] -> Tr [Pat ()]
trPatterns :: [Pat ()] -> Tr [Pat ()]
trPatterns = (Pat () -> Tr (Pat ())) -> [Pat ()] -> Tr [Pat ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat () -> Tr (Pat ())
trPattern

-- | Transform a pattern by traversing the syntax tree.
-- A regular pattern is translated, other patterns are
-- simply left as is.
trPattern :: Pat () -> Tr (Pat ())
trPattern :: Pat () -> Tr (Pat ())
trPattern Pat ()
p = case Pat ()
p of
    -- This is where the fun starts. =)
    -- Regular patterns must be transformed of course.
    PRPat ()
_ [RPat ()]
rps -> do
        -- First we need a name for the placeholder pattern.
        Name ()
n <- Tr (Name ())
genPatName
        -- A top-level regular pattern is a sequence in linear
        -- context, so we can simply translate it as if it was one.
        (Name ()
mname, [Name ()]
vars, MType
_) <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
True (() -> [RPat ()] -> RPat ()
forall l. l -> [RPat l] -> RPat l
RPSeq () [RPat ()]
rps)
        -- Generate a top level declaration.
        Name ()
topmname <- Name () -> [Name ()] -> Tr (Name ())
mkTopDecl Name ()
mname [Name ()]
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.
        [Name ()] -> Name () -> Name () -> Tr ()
mkGuard [Name ()]
vars Name ()
topmname Name ()
n
        -- And indeed, we have made a transformation!
        Tr ()
setHarpTransformedT
        -- Return the placeholder pattern.
        Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Name () -> Pat ()
pvar Name ()
n
    -- Tag patterns should be transformed
    PXTag ()
_ XName ()
name [PXAttr ()]
attrs Maybe (Pat ())
mattr [Pat ()]
cpats -> do
        -- We need a name for the attribute list, if there are lookups
        Pat ()
an <- case (Maybe (Pat ())
mattr, [PXAttr ()]
attrs) of
                -- ... if there is one already, and there are no lookups
                -- we can just return that
                (Just Pat ()
ap, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Pat ()
ap
                      -- ... if there are none, we dont' care
                (Maybe (Pat ())
_, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
wildcard
                (Maybe (Pat ())
_, [PXAttr ()]
_)  -> do -- ... but if there are, we want a name for that list
                              Name ()
n <- Tr (Name ())
genAttrName
                              -- ... we must turn attribute lookups into guards
                              Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
n [PXAttr ()]
attrs Maybe (Pat ())
mattr
                              -- ... and we return the pattern
                              Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Name () -> Pat ()
pvar Name ()
n
        -- ... the pattern representing children should be transformed
        Pat ()
cpat' <- case [Pat ()]
cpats of
                  -- ... it's a regular pattern, so we can just go ahead and transform it
                  (p :: Pat ()
p@(PXRPats ()
_ [RPat ()]
_)):[] -> Pat () -> Tr (Pat ())
trPattern Pat ()
p
                  -- ... it's an ordinary list, so we first wrap it up as such
                  [Pat ()]
_                    -> Pat () -> Tr (Pat ())
trPattern (() -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList () [Pat ()]
cpats)
        -- ...  we have made a transformation and should report that
        Tr ()
setHarpTransformedT
        -- ... and we return a Tag pattern.
        let (Maybe String
dom, String
n) = XName () -> (Maybe String, String)
xNameParts XName ()
name
        Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> Pat () -> Pat () -> Pat ()
metaTag Maybe String
dom String
n Pat ()
an Pat ()
cpat'
    -- ... as should empty Tag patterns
    PXETag ()
_ XName ()
name [PXAttr ()]
attrs Maybe (Pat ())
mattr -> do
        -- We need a name for the attribute list, if there are lookups
        Pat ()
an <- case (Maybe (Pat ())
mattr, [PXAttr ()]
attrs) of
                -- ... if there is a pattern already, and there are no lookups
                -- we can just return that
                (Just Pat ()
ap, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Pat ()
ap
                      -- ... if there are none, we dont' care
                (Maybe (Pat ())
_, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
wildcard
                (Maybe (Pat ())
_, [PXAttr ()]
_)  -> do -- ... but if there are, we want a name for that list
                              Name ()
n <- Tr (Name ())
genAttrName
                              -- ... we must turn attribute lookups into guards
                              Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
n [PXAttr ()]
attrs Maybe (Pat ())
mattr
                              -- ... and we return the pattern
                              Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Name () -> Pat ()
pvar Name ()
n
        -- ...  we have made a transformation and should report that
        Tr ()
setHarpTransformedT
        -- ... and we return an ETag pattern.
        let (Maybe String
dom, String
n) = XName () -> (Maybe String, String)
xNameParts XName ()
name
        Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> Pat () -> Pat () -> Pat ()
metaTag Maybe String
dom String
n Pat ()
an Pat ()
peList
    -- PCDATA patterns are strings in the xml datatype.
    PXPcdata ()
_ String
st -> Tr ()
setHarpTransformedT Tr () -> Tr (Pat ()) -> Tr (Pat ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ String -> Pat ()
metaPcdata String
st)
    -- XML comments are likewise just treated as strings.
    PXPatTag ()
_ Pat ()
p -> Tr ()
setHarpTransformedT Tr () -> Tr (Pat ()) -> Tr (Pat ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pat () -> Tr (Pat ())
trPattern Pat ()
p
    -- Regular expression patterns over children should be translated
    -- just like PRPat.

    PXRPats ()
l [RPat ()]
rps -> Pat () -> Tr (Pat ())
trPattern (Pat () -> Tr (Pat ())) -> Pat () -> Tr (Pat ())
forall a b. (a -> b) -> a -> b
$ () -> [RPat ()] -> Pat ()
forall l. l -> [RPat l] -> Pat l
PRPat ()
l [RPat ()]
rps
    -- Transforming any other patterns simply means transforming
    -- their subparts.
    PViewPat ()
l Exp ()
e Pat ()
p       -> do
        Exp ()
e' <- HsxM (Exp ()) -> Tr (Exp ())
forall a. HsxM a -> Tr a
liftTr (HsxM (Exp ()) -> Tr (Exp ())) -> HsxM (Exp ()) -> Tr (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
        Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> Exp () -> Pat () -> Pat ()
forall l. l -> Exp l -> Pat l -> Pat l
PViewPat ()
l Exp ()
e') Pat () -> Tr (Pat ())
trPattern
    PVar ()
_ Name ()
_             -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
    PLit ()
_ Sign ()
_ Literal ()
_           -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
    PInfixApp ()
l Pat ()
p1 QName ()
op Pat ()
p2 -> Pat ()
-> Pat ()
-> (Pat () -> Pat () -> Pat ())
-> (Pat () -> Tr (Pat ()))
-> Tr (Pat ())
forall a b c. a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat Pat ()
p1 Pat ()
p2 (\Pat ()
p1 Pat ()
p2 -> () -> Pat () -> QName () -> Pat () -> Pat ()
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp ()
l Pat ()
p1 QName ()
op Pat ()
p2) Pat () -> Tr (Pat ())
trPattern
    PApp ()
l QName ()
n [Pat ()]
ps          -> [Pat ()]
-> ([Pat ()] -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (() -> QName () -> [Pat ()] -> Pat ()
forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> Tr (Pat ())
trPattern
    PTuple ()
l Boxed
bx [Pat ()]
ps       -> [Pat ()]
-> ([Pat ()] -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (() -> Boxed -> [Pat ()] -> Pat ()
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> Tr (Pat ())
trPattern
    PList ()
l [Pat ()]
ps           -> [Pat ()]
-> ([Pat ()] -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (() -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> Tr (Pat ())
trPattern
    PParen ()
l Pat ()
p           -> Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> Tr (Pat ())
trPattern
    PRec ()
l QName ()
n [PatField ()]
pfs         -> [PatField ()]
-> ([PatField ()] -> Pat ())
-> (PatField () -> Tr (PatField ()))
-> Tr (Pat ())
forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [PatField ()]
pfs (() -> QName () -> [PatField ()] -> Pat ()
forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> Tr (PatField ())
trPatternField
    PAsPat ()
l Name ()
n Pat ()
p         -> Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> Name () -> Pat () -> Pat ()
forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> Tr (Pat ())
trPattern
    PWildCard ()
l          -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
    PIrrPat ()
l Pat ()
p          -> Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PIrrPat ()
l) Pat () -> Tr (Pat ())
trPattern
    PatTypeSig ()
l Pat ()
p Type ()
t   -> Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (\Pat ()
p -> () -> Pat () -> Type () -> Pat ()
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig ()
l Pat ()
p Type ()
t) Pat () -> Tr (Pat ())
trPattern
    PQuasiQuote ()
_ String
_ String
_    -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
    PBangPat ()
l Pat ()
p         -> Pat ()
-> (Pat () -> Pat ()) -> (Pat () -> Tr (Pat ())) -> Tr (Pat ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PBangPat ()
l) Pat () -> Tr (Pat ())
trPattern
    PNPlusK ()
_ Name ()
_ Integer
_        -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p

  where -- Transform a pattern field.
    trPatternField :: PatField () -> Tr (PatField ())
    trPatternField :: PatField () -> Tr (PatField ())
trPatternField (PFieldPat ()
l QName ()
n Pat ()
p) =
        Pat ()
-> (Pat () -> PatField ())
-> (Pat () -> Tr (Pat ()))
-> Tr (PatField ())
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (() -> QName () -> Pat () -> PatField ()
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> Tr (Pat ())
trPattern
    trPatternField PatField ()
p = PatField () -> Tr (PatField ())
forall (m :: * -> *) a. Monad m => a -> m a
return PatField ()
p

    -- | Generate a guard for looking up xml attributes.
    mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
    mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
attrs [PXAttr ()
_ XName ()
n Pat ()
q] Maybe (Pat ())
mattr = do
        -- Apply lookupAttr to the attribute name and
        -- attribute set
        let rhs :: Exp ()
rhs = XName () -> Name () -> Exp ()
metaExtract XName ()
n Name ()
attrs
            -- ... catch the result
            pat :: Pat ()
pat = Pat () -> Pat ()
metaPJust Pat ()
q
            -- ... catch the remainder list
            rml :: Pat ()
rml = case Maybe (Pat ())
mattr of
                   Maybe (Pat ())
Nothing -> Pat ()
wildcard
                   Just Pat ()
ap -> Pat ()
ap
        -- ... and add the generated guard to the store.
        Pat () -> Exp () -> Tr ()
pushAttrGuard ([Pat ()] -> Pat ()
pTuple [Pat ()
pat, Pat ()
rml]) Exp ()
rhs

    mkAttrGuards Name ()
attrs ((PXAttr ()
_ XName ()
a Pat ()
q):[PXAttr ()]
xs) Maybe (Pat ())
mattr = do
        -- Apply lookupAttr to the attribute name and
        -- attribute set
        let rhs :: Exp ()
rhs = XName () -> Name () -> Exp ()
metaExtract XName ()
a Name ()
attrs
            -- ... catch the result
            pat :: Pat ()
pat = Pat () -> Pat ()
metaPJust Pat ()
q
        -- ... catch the remainder list
        Name ()
newAttrs <- Tr (Name ())
genAttrName
        -- ... and add the generated guard to the store.
        Pat () -> Exp () -> Tr ()
pushAttrGuard ([Pat ()] -> Pat ()
pTuple [Pat ()
pat, Name () -> Pat ()
pvar Name ()
newAttrs]) Exp ()
rhs
        -- ... and finally recurse
        Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
newAttrs [PXAttr ()]
xs Maybe (Pat ())
mattr

    -- | Generate a declaration at top level that will finalise all
    -- variable continuations, and then return all bound variables.
    mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())
    mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())
mkTopDecl Name ()
mname [Name ()]
vars =
        do -- Give the match function a name
           Name ()
n <- Tr (Name ())
genMatchName
           -- Create the declaration and add it to the store.
           Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> [Name ()] -> Decl ()
topDecl Name ()
n Name ()
mname [Name ()]
vars
           -- Return the name of the match function so that the
           -- guard that will be generated can call it.
           Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return Name ()
n

    topDecl :: Name () -> Name () -> [Name ()] -> Decl ()
    topDecl :: Name () -> Name () -> [Name ()] -> Decl ()
topDecl Name ()
n Name ()
mname [Name ()]
vs =
        let pat :: Pat ()
pat  = [Pat ()] -> Pat ()
pTuple [Pat ()
wildcard, [Name ()] -> Pat ()
pvarTuple [Name ()]
vs]      -- (_, (foo, bar, ...))
            g :: Exp ()
g    = Name () -> Exp ()
var Name ()
mname                            -- harp_matchX
            a :: Stmt ()
a    = Pat () -> Exp () -> Stmt ()
genStmt Pat ()
pat Exp ()
g                        -- (_, (foo, ...)) <- harp_matchX
            vars :: [Exp ()]
vars = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (\Name ()
v -> Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
var Name ()
v) Exp ()
eList) [Name ()]
vs     -- (foo [], bar [], ...)
            b :: Stmt ()
b    = Exp () -> Stmt ()
qualStmt (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple [Exp ()]
vars   -- return (foo [], bar [], ...)
            e :: Exp ()
e    = [Stmt ()] -> Exp ()
doE [Stmt ()
a,Stmt ()
b]                            -- do (...) <- harp_matchX
                                                        --    return (foo [], bar [], ...)
         in Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
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 :: [Name ()] -> Name () -> Name () -> Tr ()
    mkGuard :: [Name ()] -> Name () -> Name () -> Tr ()
mkGuard [Name ()]
vars Name ()
mname Name ()
n = do
        let tvs :: Pat ()
tvs = [Name ()] -> Pat ()
pvarTuple [Name ()]
vars                        -- (foo, bar, ...)
            ge :: Exp ()
ge  = Exp () -> [Exp ()] -> Exp ()
appFun Exp ()
runMatchFun [Name () -> Exp ()
var Name ()
mname, Name () -> Exp ()
var Name ()
n] -- runMatch harp_matchX harp_patY
        Pat () -> Exp () -> Tr ()
pushGuard (Name () -> [Pat ()] -> Pat ()
pApp Name ()
just_name [Pat ()
tvs]) Exp ()
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 l = (Name l, [Name l], MType)


-- | Transform away a regular pattern, generating code
-- to replace it.
trRPat :: Bool -> RPat () -> Tr (MFunMetaInfo ())
trRPat :: Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp = case RPat ()
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 ()
_ Pat ()
p -> Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
p

      where
        -- | Generate declarations for matching ordinary Haskell patterns
        mkBaseDecl :: Bool -> Pat () -> Tr (MFunMetaInfo ())
        mkBaseDecl :: Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
p = case Pat ()
p of
            -- We can simplify a lot if the pattern is a wildcard or a variable
            PWildCard ()
_ -> Tr (Name (), [Name ()], MType)
mkWCMatch
            PVar ()
_ Name ()
v    -> Bool -> Name () -> Tr (Name (), [Name ()], MType)
mkVarMatch Bool
linear Name ()
v
            -- ... and if it is an embedded pattern tag, we can just skip it
            PXPatTag ()
_ Pat ()
q -> Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
q

            -- ... otherwise we'll have to take the long way...
            Pat ()
p           -> do -- First do a case match on a single element
                              (Name ()
name, [Name ()]
vars, MType
_) <- Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBasePat Bool
linear Pat ()
p
                              -- ... apply baseMatch to the case matcher to
                              -- lift it into the matcher monad.
                              Name ()
newname <- Name () -> Tr (Name ())
mkBaseMatch Name ()
name
                              -- ... and return the meta-info gathered.
                              (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
newname, [Name ()]
vars, MType
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 :: Bool -> Pat () -> Tr (MFunMetaInfo ())
        mkBasePat :: Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBasePat Bool
b Pat ()
p =
         do -- First we need a name...
           Name ()
n <- Tr (Name ())
genMatchName
           -- ... and then we need to know what variables that
           -- will be bound by this match.
           let vs :: [Name ()]
vs = Pat () -> [Name ()]
gatherPVars Pat ()
p
           -- ... and then we can create and store away a casing function.
           Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
basePatDecl Bool
b Name ()
n [Name ()]
vs Pat ()
p Tr (Decl ()) -> (Decl () -> Tr ()) -> Tr ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decl () -> Tr ()
pushDecl
           (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
vs, MType
S)

        -- | Generate a basic casing function for a given pattern.
        basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
        basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
basePatDecl Bool
linear Name ()
f [Name ()]
vs Pat ()
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 :: Name ()
a = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_a"
         -- ... and we should case on that variable on the right-hand side.
         Exp ()
rhs <- Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())
baseCaseE Bool
linear Pat ()
p Name ()
a [Name ()]
vs    -- case harp_a of ...
         -- The result is a simple function with one paramenter and
         -- the right-hand side we just generated.
         Decl () -> Tr (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl () -> Tr (Decl ())) -> Decl () -> Tr (Decl ())
forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> Exp () -> Decl ()
simpleFun Name ()
f Name ()
a Exp ()
rhs
           where baseCaseE :: Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())
                 baseCaseE :: Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())
baseCaseE Bool
b Pat ()
p Name ()
a [Name ()]
vs = do
                    -- First the alternative if we actually
                    -- match the given pattern
                    let alt1 :: Alt ()
alt1 = Pat () -> Exp () -> Alt ()
alt Pat ()
p                  -- foo -> Just (mf foo)
                                (Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
                                 [Exp ()] -> Exp ()
tuple ((Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Name () -> Exp ()
retVar Bool
b) [Name ()]
vs))
                        -- .. and finally an alternative for not matching the pattern.
                        alt2 :: Alt ()
alt2 = Pat () -> Exp () -> Alt ()
alt Pat ()
wildcard (Name () -> Exp ()
con Name ()
nothing_name)        -- _ -> Nothing
                        -- ... and that pattern could itself contain regular patterns
                        -- so we must transform away these.
                    Alt ()
alt1' <- HsxM (Alt ()) -> Tr (Alt ())
forall a. HsxM a -> Tr a
liftTr (HsxM (Alt ()) -> Tr (Alt ())) -> HsxM (Alt ()) -> Tr (Alt ())
forall a b. (a -> b) -> a -> b
$ Alt () -> HsxM (Alt ())
transformAlt Alt ()
alt1
                    Exp () -> Tr (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> Tr (Exp ())) -> Exp () -> Tr (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> [Alt ()] -> Exp ()
caseE (Name () -> Exp ()
var Name ()
a) [Alt ()
alt1', Alt ()
alt2]
                 retVar :: Bool -> Name () -> Exp ()
                 retVar :: Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v
                    -- if bound in linear context, apply const
                    | Bool
linear    = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
                    -- if bound in non-linear context, apply (:)
                    | Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)

    -- For guarded base patterns, we want to do the same as for unguarded base patterns,
    -- only with guards (doh).
    RPGuard ()
_ Pat ()
p [Stmt ()]
gs -> Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardDecl Bool
linear Pat ()
p [Stmt ()]
gs

     where mkGuardDecl :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())
           mkGuardDecl :: Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardDecl Bool
linear Pat ()
p [Stmt ()]
gs = case Pat ()
p of
                -- If it is an embedded pattern tag, we want to skip it
                PXPatTag ()
_ Pat ()
q -> Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardDecl Bool
linear Pat ()
q [Stmt ()]
gs

                -- ... otherwise we'll want to make a base pattern
                Pat ()
p           -> do -- First do a case match on a single element
                      (Name ()
name, [Name ()]
vars, MType
_) <- Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardPat Bool
linear Pat ()
p [Stmt ()]
gs
                      -- ... apply baseMatch to the case matcher to
                      -- lift it into the matcher monad.
                      Name ()
newname <- Name () -> Tr (Name ())
mkBaseMatch Name ()
name
                      -- ... and return the meta-info gathered.
                      (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
newname, [Name ()]
vars, MType
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 :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())
           mkGuardPat :: Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardPat Bool
b Pat ()
p [Stmt ()]
gs =
                do -- First we need a name...
                   Name ()
n <- Tr (Name ())
genMatchName
                   -- ... and then we need to know what variables that
                   -- will be bound by this match.
                   let vs :: [Name ()]
vs = Pat () -> [Name ()]
gatherPVars Pat ()
p [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++ (Stmt () -> [Name ()]) -> [Stmt ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Stmt () -> [Name ()]
gatherStmtVars [Stmt ()]
gs
                   -- ... and then we can create and store away a casing function.
                   Bool -> Name () -> [Name ()] -> Pat () -> [Stmt ()] -> Tr (Decl ())
guardPatDecl Bool
b Name ()
n [Name ()]
vs Pat ()
p [Stmt ()]
gs Tr (Decl ()) -> (Decl () -> Tr ()) -> Tr ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decl () -> Tr ()
pushDecl
                   (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
vs, MType
S)

           -- | Generate a basic casing function for a given pattern.
           guardPatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> [Stmt ()] -> Tr (Decl ())
           guardPatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> [Stmt ()] -> Tr (Decl ())
guardPatDecl Bool
linear Name ()
f [Name ()]
vs Pat ()
p [Stmt ()]
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 :: Name ()
a = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_a"
                -- ... and we should case on that variable on the right-hand side.
                Exp ()
rhs <- Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())
guardedCaseE Bool
linear Pat ()
p [Stmt ()]
gs Name ()
a [Name ()]
vs  -- case harp_a of ...
                -- The result is a simple function with one parameter and
                -- the right-hand side we just generated.
                Decl () -> Tr (Decl ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl () -> Tr (Decl ())) -> Decl () -> Tr (Decl ())
forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> Exp () -> Decl ()
simpleFun Name ()
f Name ()
a Exp ()
rhs
              where guardedCaseE :: Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())
                    guardedCaseE :: Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())
guardedCaseE Bool
b Pat ()
p [Stmt ()]
gs Name ()
a [Name ()]
vs = do
                        -- First the alternative if we actually
                        -- match the given pattern
                        let alt1 :: Alt ()
alt1 = Pat () -> [Stmt ()] -> Exp () -> Binds () -> Alt ()
altGW Pat ()
p [Stmt ()]
gs                 -- foo -> Just (mf foo)
                                    (Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$
                                    [Exp ()] -> Exp ()
tuple ((Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Name () -> Exp ()
retVar Bool
b) [Name ()]
vs)) ([Decl ()] -> Binds ()
binds [])
                            -- .. and finally an alternative for not matching the pattern.
                            alt2 :: Alt ()
alt2 = Pat () -> Exp () -> Alt ()
alt Pat ()
wildcard (Name () -> Exp ()
con Name ()
nothing_name)        -- _ -> Nothing
                            -- ... and that pattern could itself contain regular patterns
                            -- so we must transform away these.
                        Alt ()
alt1' <- HsxM (Alt ()) -> Tr (Alt ())
forall a. HsxM a -> Tr a
liftTr (HsxM (Alt ()) -> Tr (Alt ())) -> HsxM (Alt ()) -> Tr (Alt ())
forall a b. (a -> b) -> a -> b
$ Alt () -> HsxM (Alt ())
transformAlt Alt ()
alt1
                        Exp () -> Tr (Exp ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp () -> Tr (Exp ())) -> Exp () -> Tr (Exp ())
forall a b. (a -> b) -> a -> b
$ Exp () -> [Alt ()] -> Exp ()
caseE (Name () -> Exp ()
var Name ()
a) [Alt ()
alt1', Alt ()
alt2]
                    retVar :: Bool -> Name () -> Exp ()
                    retVar :: Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v
                        -- if bound in linear context, apply const
                        | Bool
linear    = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
                        -- if bound in non-linear context, apply (:)
                        | Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)

    -- For a sequence of regular patterns, we should transform all
    -- sub-patterns and then generate a function for sequencing them.
    RPSeq ()
_ [RPat ()]
rps -> do
        [(Name (), [Name ()], MType)]
nvts <- (RPat () -> Tr (Name (), [Name ()], MType))
-> [RPat ()] -> Tr [(Name (), [Name ()], MType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear) [RPat ()]
rps
        [(Name (), [Name ()], MType)] -> Tr (Name (), [Name ()], MType)
mkSeqDecl [(Name (), [Name ()], MType)]
nvts

      where
        -- | Generate a match function for a sequence of regular patterns,
        -- flattening any special sub-patterns into normal elements of the list
        mkSeqDecl :: [MFunMetaInfo ()] -> Tr (MFunMetaInfo ())
        mkSeqDecl :: [(Name (), [Name ()], MType)] -> Tr (Name (), [Name ()], MType)
mkSeqDecl [(Name (), [Name ()], MType)]
nvts = do
            -- First, as always, we need a name...
            Name ()
name <- Tr (Name ())
genMatchName
            let -- We need a generating statement for each sub-pattern.
                ([Stmt ()]
gs, [(Name (), MType)]
vals) = [(Stmt (), (Name (), MType))] -> ([Stmt ()], [(Name (), MType)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Stmt (), (Name (), MType))] -> ([Stmt ()], [(Name (), MType)]))
-> [(Stmt (), (Name (), MType))] -> ([Stmt ()], [(Name (), MType)])
forall a b. (a -> b) -> a -> b
$ Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps Int
0 [(Name (), [Name ()], MType)]
nvts     -- (harp_valX, (foo, ...)) <- harp_matchY
                -- Gather up all variables from all sub-patterns.
                vars :: [Name ()]
vars    = ((Name (), [Name ()], MType) -> [Name ()])
-> [(Name (), [Name ()], MType)] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Name ()
_,[Name ()]
vars,MType
_) -> [Name ()]
vars) [(Name (), [Name ()], MType)]
nvts
                -- ... flatten all values to simple lists, and concatenate
                -- the lists to a new return value
                fldecls :: [Decl ()]
fldecls = [(Name (), MType)] -> [Decl ()]
flattenVals [(Name (), MType)]
vals                  -- harp_valXf = $flatten harp_valX
                                                            -- harp_ret = foldComp [harp_val1f, ...]
                -- ... return the value along with all variables
                ret :: Stmt ()
ret     = Exp () -> Stmt ()
qualStmt (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$           -- return (harp_ret, (foo, .....))
                            [Exp ()] -> Exp ()
tuple [Name () -> Exp ()
var Name ()
retname, [Name ()] -> Exp ()
varTuple [Name ()]
vars]
                -- ... do all these steps in a do expression
                rhs :: Exp ()
rhs     = [Stmt ()] -> Exp ()
doE ([Stmt ()] -> Exp ()) -> [Stmt ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Stmt ()]
gs [Stmt ()] -> [Stmt ()] -> [Stmt ()]
forall a. [a] -> [a] -> [a]
++                       -- do (harp_valX, (foo, ...)) <- harpMatchY
                            [[Decl ()] -> Stmt ()
letStmt [Decl ()]
fldecls, Stmt ()
ret]          --    let harp_valXf = $flatten harp_valX
                                                            --    return (harp_ret, (foo, .....))
            -- ... bind it to its name, and add the declaration
            -- to the store.
            Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
name Exp ()
rhs                    -- harp_matchZ = do ....
            -- The return value of a sequence is always a list of elements.
            (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
name, [Name ()]
vars, MType -> MType
L MType
S)

        -- | Flatten values of all sub-patterns into normal elements of the list
        flattenVals :: [(Name (), MType)] -> [Decl ()]
        flattenVals :: [(Name (), MType)] -> [Decl ()]
flattenVals [(Name (), MType)]
nts =
            let -- Flatten the values of all sub-patterns to
                -- lists of elements
                ([Name ()]
nns, [Decl ()]
ds) = [(Name (), Decl ())] -> ([Name ()], [Decl ()])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name (), Decl ())] -> ([Name ()], [Decl ()]))
-> [(Name (), Decl ())] -> ([Name ()], [Decl ()])
forall a b. (a -> b) -> a -> b
$ ((Name (), MType) -> (Name (), Decl ()))
-> [(Name (), MType)] -> [(Name (), Decl ())]
forall a b. (a -> b) -> [a] -> [b]
map (Name (), MType) -> (Name (), Decl ())
flVal [(Name (), MType)]
nts
                -- ... and concatenate their results.
                ret :: Decl ()
ret       = Name () -> Exp () -> Decl ()
nameBind Name ()
retname (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
app
                              (Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun
                                ([Exp ()] -> Exp ()
listE ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
nns)) (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp ()
eList
             in [Decl ()]
ds [Decl ()] -> [Decl ()] -> [Decl ()]
forall a. [a] -> [a] -> [a]
++ [Decl ()
ret]

        flVal :: (Name (), MType) -> (Name (), Decl ())
        flVal :: (Name (), MType) -> (Name (), Decl ())
flVal (Name ()
name, MType
mt) =
            let -- We reuse the old names, we just extend them a bit.
                newname :: Name ()
newname = Name () -> String -> Name ()
extendVar Name ()
name String
"f"    -- harp_valXf
                -- Create the appropriate flattening function depending
                -- on the type of the value
                f :: Exp ()
f       = MType -> Exp ()
flatten MType
mt
                -- ... apply it to the value and bind it to its new name.
             in (Name ()
newname, Name () -> Exp () -> Decl ()
nameBind Name ()
newname (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$  -- harp_valXf = $flatten harp_valX
                    Exp () -> Exp () -> Exp ()
app Exp ()
f (Name () -> Exp ()
var Name ()
name))

        -- | Generate a flattening function for a given type structure.
        flatten :: MType -> Exp ()
        flatten :: MType -> Exp ()
flatten MType
S = Exp ()
consFun                         -- (:)
        flatten (L MType
mt) =
            let f :: Exp ()
f = MType -> Exp ()
flatten MType
mt
                r :: Exp ()
r = Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
metaMap [Exp ()
f]
             in Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp ()
foldCompFun Exp () -> Exp () -> Exp ()
`metaComp` Exp ()
r    -- (foldComp . (map $flatten))
        flatten (E MType
mt1 MType
mt2) =
            let f1 :: Exp ()
f1 = MType -> Exp ()
flatten MType
mt1
                f2 :: Exp ()
f2 = MType -> Exp ()
flatten MType
mt2
             in Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
metaEither Exp ()
f1 Exp ()
f2            -- (either $flatten $flatten)
        flatten (M MType
mt) =
            let f :: Exp ()
f = MType -> Exp ()
flatten MType
mt
             in Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
metaMaybe Exp ()
idFun Exp ()
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 ()
_ Name ()
v RPat ()
rp -> do
        -- Transform the subpattern
        nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
name, [Name ()]
vs, MType
mt) <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp
        -- ... and create a declaration to bind its value.
        Name ()
n <- (Name (), [Name ()], MType) -> Tr (Name ())
mkCAsDecl (Name (), [Name ()], MType)
nvt
        -- The type of the value is unchanged.
        (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, (Name ()
vName () -> [Name ()] -> [Name ()]
forall a. a -> [a] -> [a]
:[Name ()]
vs), MType
mt)

      where
        -- | Generate a declaration for a \@: binding.
        mkCAsDecl :: MFunMetaInfo () -> Tr (Name ())
        mkCAsDecl :: (Name (), [Name ()], MType) -> Tr (Name ())
mkCAsDecl = (Exp () -> Exp ()) -> (Name (), [Name ()], MType) -> Tr (Name ())
asDecl ((Exp () -> Exp ()) -> (Name (), [Name ()], MType) -> Tr (Name ()))
-> (Exp () -> Exp ())
-> (Name (), [Name ()], MType)
-> Tr (Name ())
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
app Exp ()
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 ()
_ Name ()
v RPat ()
rp
        | Bool
linear ->
             do -- Transform the subpattern
                nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
name, [Name ()]
vs, MType
mt) <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp
                -- ... and create a declaration to bind its value
                Name ()
n <- (Name (), [Name ()], MType) -> Tr (Name ())
mkAsDecl (Name (), [Name ()], MType)
nvt
                -- The type of the value is unchanged.
                (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, (Name ()
vName () -> [Name ()] -> [Name ()]
forall a. a -> [a] -> [a]
:[Name ()]
vs), MType
mt)
        -- We may not use an @ bind in non-linear context
        | Bool
otherwise -> case Name ()
v of
                Ident () String
n -> String -> Tr (Name (), [Name ()], MType)
forall a. HasCallStack => String -> a
error (String -> Tr (Name (), [Name ()], MType))
-> String -> Tr (Name (), [Name ()], MType)
forall a b. (a -> b) -> a -> b
$ String
"Attempting to bind variable "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
" inside the context of a numerable regular pattern"
                Name ()
_         -> String -> Tr (Name (), [Name ()], MType)
forall a. HasCallStack => String -> a
error (String -> Tr (Name (), [Name ()], MType))
-> String -> Tr (Name (), [Name ()], MType)
forall a b. (a -> b) -> a -> b
$ String
"This should never ever ever happen... how the #% did you do it??!?"

      where
        -- | Generate a declaration for a \@ binding.
        mkAsDecl :: MFunMetaInfo () -> Tr (Name ())
        mkAsDecl :: (Name (), [Name ()], MType) -> Tr (Name ())
mkAsDecl = (Exp () -> Exp ()) -> (Name (), [Name ()], MType) -> Tr (Name ())
asDecl Exp () -> Exp ()
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 ()
_ RPat ()
rp -> Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
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 ()
_ RPat ()
rp (RPOpt ()
_)->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can optionally match it.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkOptDecl Bool
False (Name (), [Name ()], MType)
nvt
    -- ... similarly for the non-greedy version.
    RPOp ()
_ RPat ()
rp (RPOptG ()
_) ->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can optionally match it.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkOptDecl Bool
True (Name (), [Name ()], MType)
nvt

    -- For union patterns, we should transform both subexpressions,
    -- and generate a function that chooses between them.
    RPEither ()
_ RPat ()
rp1 RPat ()
rp2 ->
        do -- Transform the subpatterns
           (Name (), [Name ()], MType)
nvt1 <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp1
           (Name (), [Name ()], MType)
nvt2 <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp2
           -- ... and create a declaration that can choose between them.
           (Name (), [Name ()], MType)
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkEitherDecl (Name (), [Name ()], MType)
nvt1 (Name (), [Name ()], MType)
nvt2
        -- Generate declarations for either patterns, i.e. ( | )
      where mkEitherDecl :: MFunMetaInfo () -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
            mkEitherDecl :: (Name (), [Name ()], MType)
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkEitherDecl nvt1 :: (Name (), [Name ()], MType)
nvt1@(Name ()
_, [Name ()]
vs1, MType
t1) nvt2 :: (Name (), [Name ()], MType)
nvt2@(Name ()
_, [Name ()]
vs2, MType
t2) = do
                -- Eine namen, bitte!
                Name ()
n <- Tr (Name ())
genMatchName
                let -- Generate generators for the subpatterns
                    (Stmt ()
g1, Name ()
v1) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt1
                    (Stmt ()
g2, Name ()
v2) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt2          -- (harp_valX, (foo, bar, ...)) <- harp_matchY
                    -- ... gather all variables from both sides
                    allvs :: [Name ()]
allvs = [Name ()]
vs1 [Name ()] -> [Name ()] -> [Name ()]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name ()]
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 :: [Exp ()]
vals1 = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map ([Name ()] -> Name () -> Exp ()
varOrId [Name ()]
vs1) [Name ()]
allvs
                    vals2 :: [Exp ()]
vals2 = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map ([Name ()] -> Name () -> Exp ()
varOrId [Name ()]
vs2) [Name ()]
allvs
                    -- ... apply either Left or Right to the returned value
                    ret1 :: Exp ()
ret1  = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple          -- return (Left harp_val1, (foo, id, ...))
                                [Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
left_name)
                                 (Name () -> Exp ()
var Name ()
v1), [Exp ()] -> Exp ()
tuple [Exp ()]
vals1]
                    ret2 :: Exp ()
ret2  = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple          -- return (Right harp_val2, (id, bar, ...))
                                [Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
right_name)
                                 (Name () -> Exp ()
var Name ()
v2), [Exp ()] -> Exp ()
tuple [Exp ()]
vals2]
                    -- ... and do all these things in do-expressions
                    exp1 :: Exp ()
exp1  = [Stmt ()] -> Exp ()
doE [Stmt ()
g1, Exp () -> Stmt ()
qualStmt Exp ()
ret1]
                    exp2 :: Exp ()
exp2  = [Stmt ()] -> Exp ()
doE [Stmt ()
g2, Exp () -> Stmt ()
qualStmt Exp ()
ret2]
                    -- ... and choose between them using the choice (+++) operator.
                    rhs :: Exp ()
rhs   = (Exp () -> Exp ()
paren Exp ()
exp1) Exp () -> Exp () -> Exp ()
`metaChoice`       -- (do ...) +++
                            (Exp () -> Exp ()
paren Exp ()
exp2)            --  (do ...)
                -- Finally we create a declaration for this function and
                -- add it to the store.
                Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs         -- harp_matchZ = (do ...) ...
                -- The type of the returned value is Either the type of the first
                -- or the second subpattern.
                (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
allvs, MType -> MType -> MType
E MType
t1 MType
t2)

            varOrId :: [Name ()] -> Name () -> Exp ()
            varOrId :: [Name ()] -> Name () -> Exp ()
varOrId [Name ()]
vs Name ()
v = if Name ()
v Name () -> [Name ()] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name ()]
vs   -- the variable is indeed bound in this branch
                            then Name () -> Exp ()
var Name ()
v      -- ... so it should be added to the result
                            else Exp ()
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 ()
_ RPat ()
rp (RPStar ()
_) ->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can match it many times.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
False (Name (), [Name ()], MType)
nvt
    -- ... and similarly for the non-greedy version.

    RPOp ()
_ RPat ()
rp (RPStarG ()
_) ->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can match it many times.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
True (Name (), [Name ()], MType)
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 ()
_ RPat ()
rp (RPPlus ()
_) ->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can match it one or more times.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkPlusDecl Bool
False (Name (), [Name ()], MType)
nvt

    -- ... and similarly for the non-greedy version.
    RPOp ()
_ RPat ()
rp (RPPlusG ()
_) ->
        do -- Transform the subpattern
           (Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
           -- ... and create a declaration that can match it one or more times.
           Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkPlusDecl Bool
True (Name (), [Name ()], MType)
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 :: Bool -> Name () -> Tr (MFunMetaInfo ())
    mkVarMatch :: Bool -> Name () -> Tr (Name (), [Name ()], MType)
mkVarMatch Bool
linear Name ()
v = do
            -- First we need a name for the new match function.
            Name ()
n <- Tr (Name ())
genMatchName
            -- Then we need a basic matching function that always matches,
            -- and that binds the value matched to the variable in question.
            let e :: Exp ()
e = Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> Exp () -> Exp ()
lamE [Name () -> Pat ()
pvar Name ()
v] (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$       -- (\v -> Just (mf v))
                              Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name)
                              (Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v)
            -- Lift the function into the matcher monad, and bind it to its name,
            -- then add it the declaration to the store.
            Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$
                          Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun Exp ()
e    -- harp_matchX = baseMatch (\v -> Just (mf v))
            (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()
v], MType
S)          -- always binds v and only v

          where retVar :: Bool -> Name () -> Exp ()
                retVar :: Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v
                    -- if bound in linear context, apply const
                    | Bool
linear    = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
                    -- if bound in non-linear context, apply (:)
                    | Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)

    -- | Generate a declaration for matching a wildcard
    mkWCMatch :: Tr (MFunMetaInfo ())
    mkWCMatch :: Tr (Name (), [Name ()], MType)
mkWCMatch = do
            -- First we need a name...
            Name ()
n <- Tr (Name ())
genMatchName
            -- ... and then a function that always matches, discarding the result
            let e :: Exp ()
e = Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Pat ()] -> Exp () -> Exp ()
lamE [Pat ()
wildcard] (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$     -- (\_ -> Just ())
                                Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) (() -> Exp ()
forall l. l -> Exp l
unit_con ())
            -- ... which we lift, bind, and add to the store.
            Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$       -- harp_matchX = baseMatch (\_ -> Just ())
                         Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun Exp ()
e
            (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [], MType
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 :: Pat () -> [Name ()]
gatherPVars Pat ()
p = case Pat ()
p of
            PVar ()
_ Name ()
v             -> [Name ()
v]
            PInfixApp ()
_ Pat ()
p1 QName ()
_ Pat ()
p2  -> Pat () -> [Name ()]
gatherPVars Pat ()
p1 [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++
                                         Pat () -> [Name ()]
gatherPVars Pat ()
p2
            PApp ()
_ QName ()
_ [Pat ()]
ps          -> (Pat () -> [Name ()]) -> [Pat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
ps
            PTuple ()
_ Boxed
_ [Pat ()]
ps        -> (Pat () -> [Name ()]) -> [Pat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
ps
            PList ()
_ [Pat ()]
ps           -> (Pat () -> [Name ()]) -> [Pat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
ps
            PParen ()
_ Pat ()
p           -> Pat () -> [Name ()]
gatherPVars Pat ()
p
            PRec ()
_ QName ()
_ [PatField ()]
pfs         -> (PatField () -> [Name ()]) -> [PatField ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatField () -> [Name ()]
help [PatField ()]
pfs
                where help :: PatField () -> [Name ()]
help (PFieldPat ()
_ QName ()
_ Pat ()
p) = Pat () -> [Name ()]
gatherPVars Pat ()
p
                      help PatField ()
_                 = []
            PAsPat ()
_ Name ()
n Pat ()
p         -> Name ()
n Name () -> [Name ()] -> [Name ()]
forall a. a -> [a] -> [a]
: Pat () -> [Name ()]
gatherPVars Pat ()
p
            PWildCard ()
_          -> []
            PIrrPat ()
_ Pat ()
p          -> Pat () -> [Name ()]
gatherPVars Pat ()
p
            PatTypeSig ()
_ Pat ()
p Type ()
_     -> Pat () -> [Name ()]
gatherPVars Pat ()
p
            PRPat ()
_ [RPat ()]
rps          -> (RPat () -> [Name ()]) -> [RPat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RPat () -> [Name ()]
gatherRPVars [RPat ()]
rps
            PXTag ()
_ XName ()
_ [PXAttr ()]
attrs Maybe (Pat ())
mattr [Pat ()]
cps ->
                (PXAttr () -> [Name ()]) -> [PXAttr ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PXAttr () -> [Name ()]
gatherAttrVars [PXAttr ()]
attrs [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++ (Pat () -> [Name ()]) -> [Pat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
cps [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++
                    case Maybe (Pat ())
mattr of
                     Maybe (Pat ())
Nothing -> []
                     Just Pat ()
ap -> Pat () -> [Name ()]
gatherPVars Pat ()
ap
            PXETag ()
_ XName ()
_ [PXAttr ()]
attrs Maybe (Pat ())
mattr ->
                (PXAttr () -> [Name ()]) -> [PXAttr ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PXAttr () -> [Name ()]
gatherAttrVars [PXAttr ()]
attrs [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++
                    case Maybe (Pat ())
mattr of
                     Maybe (Pat ())
Nothing -> []
                     Just Pat ()
ap -> Pat () -> [Name ()]
gatherPVars Pat ()
ap
            PXPatTag ()
_ Pat ()
p         -> Pat () -> [Name ()]
gatherPVars Pat ()
p
            Pat ()
_                    -> []

    gatherRPVars :: RPat () -> [Name ()]
    gatherRPVars :: RPat () -> [Name ()]
gatherRPVars RPat ()
rp = case RPat ()
rp of
            RPOp ()
_ RPat ()
rq RPatOp ()
_        -> RPat () -> [Name ()]
gatherRPVars RPat ()
rq
            RPEither ()
_ RPat ()
rq1 RPat ()
rq2 -> RPat () -> [Name ()]
gatherRPVars RPat ()
rq1 [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++ RPat () -> [Name ()]
gatherRPVars RPat ()
rq2
            RPSeq ()
_ [RPat ()]
rqs        -> (RPat () -> [Name ()]) -> [RPat ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RPat () -> [Name ()]
gatherRPVars [RPat ()]
rqs
            RPCAs ()
_ Name ()
n RPat ()
rq       -> Name ()
n Name () -> [Name ()] -> [Name ()]
forall a. a -> [a] -> [a]
: RPat () -> [Name ()]
gatherRPVars RPat ()
rq
            RPAs ()
_ Name ()
n RPat ()
rq        -> Name ()
n Name () -> [Name ()] -> [Name ()]
forall a. a -> [a] -> [a]
: RPat () -> [Name ()]
gatherRPVars RPat ()
rq
            RPParen ()
_ RPat ()
rq       -> RPat () -> [Name ()]
gatherRPVars RPat ()
rq
            RPGuard ()
_ Pat ()
q [Stmt ()]
gs     -> Pat () -> [Name ()]
gatherPVars Pat ()
q [Name ()] -> [Name ()] -> [Name ()]
forall a. [a] -> [a] -> [a]
++ (Stmt () -> [Name ()]) -> [Stmt ()] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Stmt () -> [Name ()]
gatherStmtVars [Stmt ()]
gs
            RPPat ()
_ Pat ()
q          -> Pat () -> [Name ()]
gatherPVars Pat ()
q

    gatherAttrVars :: PXAttr () -> [Name ()]
    gatherAttrVars :: PXAttr () -> [Name ()]
gatherAttrVars (PXAttr ()
_ XName ()
_ Pat ()
p) = Pat () -> [Name ()]
gatherPVars Pat ()
p

    gatherStmtVars :: Stmt () -> [Name ()]
    gatherStmtVars :: Stmt () -> [Name ()]
gatherStmtVars Stmt ()
gs = case Stmt ()
gs of
            Generator ()
_ Pat ()
p Exp ()
_ -> Pat () -> [Name ()]
gatherPVars Pat ()
p
            Stmt ()
_               -> []

    -- | Generate a match function that lift the result of the
    -- basic casing function into the matcher monad.
    mkBaseMatch :: Name () -> Tr (Name ())
    mkBaseMatch :: Name () -> Tr (Name ())
mkBaseMatch Name ()
name =
            do -- First we need a name...
               Name ()
n <- Tr (Name ())
genMatchName
               -- ... to which we bind the lifting function
               Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> Decl ()
baseMatchDecl Name ()
n Name ()
name
               -- and then return for others to use.
               Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return Name ()
n

    -- | Generate a declaration for the function that lifts a simple
    -- casing function into the matcher monad.
    baseMatchDecl :: Name () -> Name () -> Decl ()
    baseMatchDecl :: Name () -> Name () -> Decl ()
baseMatchDecl Name ()
newname Name ()
oldname =
            -- Apply the lifting function "baseMatch" to the casing function
            let e :: Exp ()
e = Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun (Name () -> Exp ()
var Name ()
oldname)
                -- ... and bind it to the new name.
             in Name () -> Exp () -> Decl ()
nameBind Name ()
newname Exp ()
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 :: Int -> [MFunMetaInfo ()] -> [(Stmt (), (Name (), MType))]
    mkGenExps :: Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps Int
_ [] = []
    mkGenExps Int
k ((Name ()
name, [Name ()]
vars, MType
t):[(Name (), [Name ()], MType)]
nvs) =
        let valname :: Name ()
valname = Int -> Name ()
mkValName Int
k                           -- harp_valX
            pat :: Pat ()
pat     = [Pat ()] -> Pat ()
pTuple [Name () -> Pat ()
pvar Name ()
valname, [Name ()] -> Pat ()
pvarTuple [Name ()]
vars] -- (harp_valX, (foo, bar, ...))
            g :: Exp ()
g       = Name () -> Exp ()
var Name ()
name
         in (Pat () -> Exp () -> Stmt ()
genStmt Pat ()
pat Exp ()
g, (Name ()
valname, MType
t)) (Stmt (), (Name (), MType))
-> [(Stmt (), (Name (), MType))] -> [(Stmt (), (Name (), MType))]
forall a. a -> [a] -> [a]
:               -- (harp_valX, (foo, ...)) <- harp_matchY
                Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(Name (), [Name ()], MType)]
nvs

    -- | Create a single generator.
    mkGenExp :: MFunMetaInfo () -> (Stmt (), Name ())
    mkGenExp :: (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt = let [(Stmt ()
g, (Name ()
name, MType
_t))] = Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps Int
0 [(Name (), [Name ()], MType)
nvt]
                   in (Stmt ()
g, Name ()
name)

    -- | Generate a single generator with a call to (ng)manyMatch,
    -- and an extra variable name to use after unzipping.
    mkManyGen :: Bool -> Name () -> Stmt ()
    mkManyGen :: Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname =
        -- Choose which repeater function to use, determined by greed
        let mf :: Exp ()
mf  = if Bool
greedy then Exp ()
gManyMatchFun else Exp ()
manyMatchFun
         -- ... and create a generator that applies it to the
         -- matching function in question.
         in Pat () -> Exp () -> Stmt ()
genStmt (Name () -> Pat ()
pvar Name ()
valsvarsname) (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$
            Exp () -> Exp () -> Exp ()
app Exp ()
mf (Name () -> Exp ()
var Name ()
mname)

    -- | Generate declarations for @: and @ bindings.
    asDecl :: (Exp () -> Exp ()) -> MFunMetaInfo () -> Tr (Name ())
    asDecl :: (Exp () -> Exp ()) -> (Name (), [Name ()], MType) -> Tr (Name ())
asDecl Exp () -> Exp ()
mf nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
_, [Name ()]
vs, MType
_) = do
        -- A name, if you would
        Name ()
n <- Tr (Name ())
genMatchName                                -- harp_matchX
        let -- Generate a generator for matching the subpattern
            (Stmt ()
g, Name ()
val) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt                      -- (harp_valY, (foo, ...)) <- harp_matchZ
            -- ... fix the old variables
            vars :: [Exp ()]
vars     = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
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 :: Stmt ()
ret = Exp () -> Stmt ()
qualStmt (Exp () -> Stmt ()) -> Exp () -> Stmt ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple          -- return (harp_valY, ($mf harp_valY, apa, ...))
                [Name () -> Exp ()
var Name ()
val, [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
mf (Name () -> Exp ()
var Name ()
val) Exp () -> [Exp ()] -> [Exp ()]
forall a. a -> [a] -> [a]
: [Exp ()]
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.
        Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$ [Stmt ()] -> Exp ()
doE [Stmt ()
g, Stmt ()
ret]             -- harp_matchX = do ...
        Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return Name ()
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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
    mkOptDecl :: Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkOptDecl Bool
greedy nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
_, [Name ()]
vs, MType
t) = do
        -- Un nome, s'il vouz plaît.
        Name ()
n <- Tr (Name ())
genMatchName
        let -- Generate a generator for matching the subpattern
            (Stmt ()
g, Name ()
val) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt                 -- (harp_valX, (foo, bar, ...)) <- harp_matchY
            -- ... and apply a Just to its value
            ret1 :: Exp ()
ret1 = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple               -- return (Just harp_val1, (foo, bar, ...))
                    [Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name)
                     (Name () -> Exp ()
var Name ()
val), [Name ()] -> Exp ()
varTuple [Name ()]
vs]
            -- ... and do those two steps in a do-expression
            exp1 :: Exp ()
exp1 = [Stmt ()] -> Exp ()
doE [Stmt ()
g, Exp () -> Stmt ()
qualStmt Exp ()
ret1]           -- do ....
            -- For the non-matching branch, all the variables should be empty
            ids :: [Exp ()]
ids  = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (Exp () -> Name () -> Exp ()
forall a b. a -> b -> a
const Exp ()
idFun) [Name ()]
vs             -- (id, id, ...)
            -- ... and the value should be Nothing.
            ret2 :: Exp ()
ret2 = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple               -- return (Nothing, (id, id, ...))
                    [Name () -> Exp ()
con Name ()
nothing_name, [Exp ()] -> Exp ()
tuple [Exp ()]
ids]   -- i.e. no vars were bound
            -- The order of the arguments to the choice (+++) operator
            -- is determined by greed...
            mc :: Exp () -> Exp () -> Exp ()
mc   = if Bool
greedy
                    then Exp () -> Exp () -> Exp ()
metaChoice        -- standard order
                    else ((Exp () -> Exp () -> Exp ()) -> Exp () -> Exp () -> Exp ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp () -> Exp () -> Exp ()
metaChoice) -- reversed order
            -- ... and then apply it to the branches.
            rhs :: Exp ()
rhs  = (Exp () -> Exp ()
paren Exp ()
exp1) Exp () -> Exp () -> Exp ()
`mc`                -- (do ....) +++
                    (Exp () -> Exp ()
paren Exp ()
ret2)                    --  (return (Nothing, .....))
        -- Finally we create a declaration for this function and
        -- add it to the store.
        Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs                   -- harp_matchZ = (do ....) +++ (return ....)
        -- The type of the returned value will be Maybe the type
        -- of the value of the subpattern.
        (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
vs, MType -> MType
M MType
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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
    mkStarDecl :: Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
greedy (Name ()
mname, [Name ()]
vs, MType
t) = do
        -- Ett namn, tack!
        Name ()
n <- Tr (Name ())
genMatchName
        let -- Create a generator that matches the subpattern
            -- many times, either greedily or non-greedily
            g :: Stmt ()
g = Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname
            -- ... and unzip the result, choosing the proper unzip
            -- function depending on the number of variables returned.
            metaUnzipK :: Exp () -> Exp ()
metaUnzipK = Int -> Exp () -> Exp ()
mkMetaUnzip ([Name ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name ()]
vs)
            -- ... first unzip values from variables
            dec1 :: Decl ()
dec1    = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()
valname, Name ()
varsname])
                    (Exp () -> Exp ()
metaUnzip (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
valsvarsname)
            -- ... and then unzip the variables
            dec2 :: Decl ()
dec2    = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()]
vs)
                    (Exp () -> Exp ()
metaUnzipK (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
varsname)
            -- ... fold all the values for variables
            retExps :: [Exp ()]
retExps = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun) (Exp () -> Exp ()) -> (Name () -> Exp ()) -> Name () -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name () -> Exp ()
var) [Name ()]
vs
            -- ... and return value and variables
            ret :: Exp ()
ret     = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$
                    [Name () -> Exp ()
var Name ()
valname, [Exp ()] -> Exp ()
tuple [Exp ()]
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.
        Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$
            [Stmt ()] -> Exp ()
doE [Stmt ()
g, [Decl ()] -> Stmt ()
letStmt [Decl ()
dec1, Decl ()
dec2], Exp () -> Stmt ()
qualStmt Exp ()
ret]
        -- The type of the returned value is a list ([]) of the
        -- type of the subpattern.
        (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
vs, MType -> MType
L MType
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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
    mkPlusDecl :: Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkPlusDecl Bool
greedy nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
mname, [Name ()]
vs, MType
t) = do
        -- and now I've run out of languages...
        Name ()
n <- Tr (Name ())
genMatchName
        let k :: Int
k = [Name ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name ()]
vs
            -- First we want a generator to match the
            -- subpattern exactly one time
            (Stmt ()
g1, Name ()
val1) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt                       -- (harp_valX, (foo, ...)) <- harpMatchY
            -- ... and then one that matches it many times.
            g2 :: Stmt ()
g2         = Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname             -- harp_vvs <- manyMatch harpMatchY
            -- ... we want to unzip the result, using
            -- the proper unzip function
            metaUnzipK :: Exp () -> Exp ()
metaUnzipK = Int -> Exp () -> Exp ()
mkMetaUnzip Int
k
            -- ... first unzip values from variables
            dec1 :: Decl ()
dec1    = Pat () -> Exp () -> Decl ()
patBind                               -- (harp_vals, harp_vars) = unzip harp_vvs
                        ([Name ()] -> Pat ()
pvarTuple [Name ()
valsname, Name ()
varsname])
                        (Exp () -> Exp ()
metaUnzip (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
valsvarsname)
            -- .. now we need new fresh names for variables
            -- since the ordinary ones are already taken.
            vlvars :: [Name ()]
vlvars  = String -> Int -> [Name ()]
genNames String
"harp_vl" Int
k
            -- ... and then we can unzip the variables
            dec2 :: Decl ()
dec2    = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()]
vlvars)            -- (harp_vl1, ...) = unzipK harp_vars
                        (Exp () -> Exp ()
metaUnzipK (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
varsname)
            -- .. and do the unzipping in a let-statement
            letSt :: Stmt ()
letSt   = [Decl ()] -> Stmt ()
letStmt [Decl ()
dec1, Decl ()
dec2]
            -- ... fold variables from the many-match,
            -- prepending the variables from the single match
            retExps :: [Exp ()]
retExps = ((Name (), Name ()) -> Exp ()) -> [(Name (), Name ())] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (Name (), Name ()) -> Exp ()
mkRetFormat ([(Name (), Name ())] -> [Exp ()])
-> [(Name (), Name ())] -> [Exp ()]
forall a b. (a -> b) -> a -> b
$ [Name ()] -> [Name ()] -> [(Name (), Name ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name ()]
vs [Name ()]
vlvars       -- foo . (foldComp harp_vl1), ...
            -- ... prepend values from the single match to
            -- those of the many-match.
            retVal :: Exp ()
retVal  = (Name () -> Exp ()
var Name ()
val1) Exp () -> Exp () -> Exp ()
`metaCons`
                        (Name () -> Exp ()
var Name ()
valsname)                      -- harp_valX : harp_vals
            -- ... return all values and variables
            ret :: Exp ()
ret     = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$                  -- return (harp_valX:harpVals,
                        [Exp ()
retVal, [Exp ()] -> Exp ()
tuple [Exp ()]
retExps]             --   (foo . (...), ...))
            -- ... and wrap all of it in a do-expression.
            rhs :: Exp ()
rhs     = [Stmt ()] -> Exp ()
doE [Stmt ()
g1, Stmt ()
g2, Stmt ()
letSt, Exp () -> Stmt ()
qualStmt Exp ()
ret]
        -- Finally we create a declaration for this function and
        -- add it to the store.
        Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
        -- The type of the returned value is a list ([]) of the
        -- type of the subpattern.
        (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()]
vs, MType -> MType
L MType
t)

      where mkRetFormat :: (Name (), Name ()) -> Exp ()
            mkRetFormat :: (Name (), Name ()) -> Exp ()
mkRetFormat (Name ()
v, Name ()
vl) =
                -- Prepend variables using function composition.
                (Name () -> Exp ()
var Name ()
v) Exp () -> Exp () -> Exp ()
`metaComp`
                  (Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ (Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun) (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
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 :: Exp ()
runMatchFun = Name () -> Exp ()
match_qual Name ()
runMatch_name
baseMatchFun :: Exp ()
baseMatchFun = Name () -> Exp ()
match_qual Name ()
baseMatch_name
manyMatchFun :: Exp ()
manyMatchFun = Name () -> Exp ()
match_qual Name ()
manyMatch_name
gManyMatchFun :: Exp ()
gManyMatchFun = Name () -> Exp ()
match_qual Name ()
gManyMatch_name

runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: Name ()
runMatch_name :: Name ()
runMatch_name   = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"runMatch"
baseMatch_name :: Name ()
baseMatch_name  = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"baseMatch"
manyMatch_name :: Name ()
manyMatch_name  = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"manyMatch"
gManyMatch_name :: Name ()
gManyMatch_name = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"gManyMatch"

match_mod, match_qual_mod :: ModuleName ()
match_mod :: ModuleName ()
match_mod      = () -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
"Harp.Match"
match_qual_mod :: ModuleName ()
match_qual_mod = () -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
"HaRPMatch"

match_qual :: Name () -> Exp ()
match_qual :: Name () -> Exp ()
match_qual = ModuleName () -> Name () -> Exp ()
qvar ModuleName ()
match_qual_mod

choiceOp :: QOp ()
choiceOp :: QOp ()
choiceOp = () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (QName () -> QOp ()) -> QName () -> QOp ()
forall a b. (a -> b) -> a -> b
$ () -> ModuleName () -> Name () -> QName ()
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
match_qual_mod Name ()
choice

appendOp :: QOp ()
appendOp :: QOp ()
appendOp = () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (QName () -> QOp ()) -> QName () -> QOp ()
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name ()
append

-- foldComp = foldl (.) id, i.e. fold by composing
foldCompFun :: Exp ()
foldCompFun :: Exp ()
foldCompFun = Name () -> Exp ()
match_qual (Name () -> Exp ()) -> Name () -> Exp ()
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"foldComp"

mkMetaUnzip :: Int -> Exp () -> Exp ()
mkMetaUnzip :: Int -> Exp () -> Exp ()
mkMetaUnzip Int
k | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
7 = let n :: String
n = String
"unzip" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k
                          in (\Exp ()
e -> String -> [Exp ()] -> Exp ()
matchFunction String
n [Exp ()
e])
              | Bool
otherwise =
                   let vs :: [Name ()]
vs      = String -> Int -> [Name ()]
genNames String
"x" Int
k
                       lvs :: [Name ()]
lvs     = String -> Int -> [Name ()]
genNames String
"xs" Int
k
                       uz :: Name ()
uz      = String -> Name ()
name (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"unzip" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k
                       ys :: Name ()
ys      = String -> Name ()
name String
"ys"
                       xs :: Name ()
xs      = String -> Name ()
name String
"xs"
                       alt1 :: Alt ()
alt1    = Pat () -> Exp () -> Alt ()
alt Pat ()
peList (Exp () -> Alt ()) -> Exp () -> Alt ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ Int -> Exp () -> [Exp ()]
forall a. Int -> a -> [a]
replicate Int
k Exp ()
eList   -- [] -> ([], [], ...)
                       pat2 :: Pat ()
pat2    = ([Name ()] -> Pat ()
pvarTuple [Name ()]
vs) Pat () -> Pat () -> Pat ()
`metaPCons` (Name () -> Pat ()
pvar Name ()
xs)       -- (x1, x2, ...)
                       ret2 :: Exp ()
ret2    = [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ ((Name (), Name ()) -> Exp ()) -> [(Name (), Name ())] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map (Name (), Name ()) -> Exp ()
appCons ([(Name (), Name ())] -> [Exp ()])
-> [(Name (), Name ())] -> [Exp ()]
forall a b. (a -> b) -> a -> b
$ [Name ()] -> [Name ()] -> [(Name (), Name ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name ()]
vs [Name ()]
lvs           -- (x1:xs1, x2:xs2, ...)
                       rhs2 :: Exp ()
rhs2    = Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
var Name ()
uz) (Name () -> Exp ()
var Name ()
xs)                      -- unzipK xs
                       dec2 :: Decl ()
dec2    = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()]
lvs) Exp ()
rhs2             -- (xs1, xs2, ...) = unzipK xs
                       exp2 :: Exp ()
exp2    = [Decl ()] -> Exp () -> Exp ()
letE [Decl ()
dec2] Exp ()
ret2
                       alt2 :: Alt ()
alt2    = Pat () -> Exp () -> Alt ()
alt Pat ()
pat2 Exp ()
exp2
                       topexp :: Exp ()
topexp  = [Pat ()] -> Exp () -> Exp ()
lamE [Name () -> Pat ()
pvar Name ()
ys] (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> [Alt ()] -> Exp ()
caseE (Name () -> Exp ()
var Name ()
ys) [Alt ()
alt1, Alt ()
alt2]
                       topbind :: Decl ()
topbind = Name () -> Exp () -> Decl ()
nameBind Name ()
uz Exp ()
topexp
                    in Exp () -> Exp () -> Exp ()
app (Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> Exp () -> Exp ()
letE [Decl ()
topbind] (Name () -> Exp ()
var Name ()
uz))
  where appCons :: (Name (), Name ()) -> Exp ()
        appCons :: (Name (), Name ()) -> Exp ()
appCons (Name ()
x, Name ()
xs) = Exp () -> Exp () -> Exp ()
metaCons (Name () -> Exp ()
var Name ()
x) (Name () -> Exp ()
var Name ()
xs)

matchFunction :: String -> [Exp ()] -> Exp ()
matchFunction :: String -> [Exp ()] -> Exp ()
matchFunction String
s [Exp ()]
es = String -> [Exp ()] -> Exp ()
mf String
s ([Exp ()] -> [Exp ()]
forall a. [a] -> [a]
reverse [Exp ()]
es)
  where mf :: String -> [Exp ()] -> Exp ()
mf String
s []     = Name () -> Exp ()
match_qual (Name () -> Exp ()) -> Name () -> Exp ()
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
s
        mf String
s (Exp ()
e:[Exp ()]
es) = Exp () -> Exp () -> Exp ()
app (String -> [Exp ()] -> Exp ()
mf String
s [Exp ()]
es) Exp ()
e

-- | Some 'magic' gensym-like functions, and functions
-- with related functionality.
retname :: Name ()
retname :: Name ()
retname = String -> Name ()
name String
"harp_ret"

varsname :: Name ()
varsname :: Name ()
varsname = String -> Name ()
name String
"harp_vars"

valname :: Name ()
valname :: Name ()
valname = String -> Name ()
name String
"harp_val"

valsname :: Name ()
valsname :: Name ()
valsname = String -> Name ()
name String
"harp_vals"

valsvarsname :: Name ()
valsvarsname :: Name ()
valsvarsname = String -> Name ()
name String
"harp_vvs"

mkValName :: Int -> Name ()
mkValName :: Int -> Name ()
mkValName Int
k = String -> Name ()
name (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
"harp_val" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k

extendVar :: Name () -> String -> Name ()
extendVar :: Name () -> String -> Name ()
extendVar (Ident ()
l String
n) String
s = () -> String -> Name ()
forall l. l -> String -> Name l
Ident ()
l (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
extendVar Name ()
n String
_ = Name ()
n

xNameParts :: XName () -> (Maybe String, String)
xNameParts :: XName () -> (Maybe String, String)
xNameParts XName ()
n = case XName ()
n of
                XName ()
_ String
s      -> (Maybe String
forall a. Maybe a
Nothing, String
s)
                XDomName ()
_ String
d String
s -> (String -> Maybe String
forall a. a -> Maybe a
Just String
d, String
s)

---------------------------------------------------------
-- meta-level functions, i.e. functions that represent functions,
-- and that take arguments representing arguments... whew!

metaReturn, metaConst, metaUnzip :: Exp () -> Exp ()
metaReturn :: Exp () -> Exp ()
metaReturn Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"return" [Exp ()
e]
metaConst :: Exp () -> Exp ()
metaConst Exp ()
e  = String -> [Exp ()] -> Exp ()
metaFunction String
"const" [Exp ()
e]
metaUnzip :: Exp () -> Exp ()
metaUnzip Exp ()
e  = String -> [Exp ()] -> Exp ()
metaFunction String
"unzip" [Exp ()
e]

metaEither, metaMaybe :: Exp () -> Exp () -> Exp ()
metaEither :: Exp () -> Exp () -> Exp ()
metaEither Exp ()
e1 Exp ()
e2 = String -> [Exp ()] -> Exp ()
metaFunction String
"either" [Exp ()
e1,Exp ()
e2]
metaMaybe :: Exp () -> Exp () -> Exp ()
metaMaybe Exp ()
e1 Exp ()
e2 = String -> [Exp ()] -> Exp ()
metaFunction String
"maybe" [Exp ()
e1,Exp ()
e2]

metaConcat, metaMap :: [Exp ()] -> Exp ()
metaConcat :: [Exp ()] -> Exp ()
metaConcat [Exp ()]
es = String -> [Exp ()] -> Exp ()
metaFunction String
"concat" [[Exp ()] -> Exp ()
listE [Exp ()]
es]
metaMap :: [Exp ()] -> Exp ()
metaMap       = String -> [Exp ()] -> Exp ()
metaFunction String
"map"

metaAppend :: Exp () -> Exp () -> Exp ()
metaAppend :: Exp () -> Exp () -> Exp ()
metaAppend Exp ()
l1 Exp ()
l2 = Exp () -> QOp () -> Exp () -> Exp ()
infixApp Exp ()
l1 QOp ()
appendOp Exp ()
l2

-- the +++ choice operator
metaChoice :: Exp () -> Exp () -> Exp ()
metaChoice :: Exp () -> Exp () -> Exp ()
metaChoice Exp ()
e1 Exp ()
e2 = Exp () -> QOp () -> Exp () -> Exp ()
infixApp Exp ()
e1 QOp ()
choiceOp Exp ()
e2

metaPCons :: Pat () -> Pat () -> Pat ()
metaPCons :: Pat () -> Pat () -> Pat ()
metaPCons Pat ()
p1 Pat ()
p2 = () -> Pat () -> QName () -> Pat () -> Pat ()
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp () Pat ()
p1 QName ()
cons Pat ()
p2

metaCons, metaComp :: Exp () -> Exp () -> Exp ()
metaCons :: Exp () -> Exp () -> Exp ()
metaCons Exp ()
e1 Exp ()
e2 = Exp () -> QOp () -> Exp () -> Exp ()
infixApp Exp ()
e1 (() -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QConOp () QName ()
cons) Exp ()
e2
metaComp :: Exp () -> Exp () -> Exp ()
metaComp Exp ()
e1 Exp ()
e2 = Exp () -> QOp () -> Exp () -> Exp ()
infixApp Exp ()
e1 (Name () -> QOp ()
op Name ()
fcomp) Exp ()
e2

metaPJust :: Pat () -> Pat ()
metaPJust :: Pat () -> Pat ()
metaPJust Pat ()
p = Name () -> [Pat ()] -> Pat ()
pApp Name ()
just_name [Pat ()
p]

metaPNothing :: Pat ()
metaPNothing :: Pat ()
metaPNothing = Name () -> Pat ()
pvar Name ()
nothing_name

metaPMkMaybe :: Maybe (Pat ()) -> Pat ()
metaPMkMaybe :: Maybe (Pat ()) -> Pat ()
metaPMkMaybe Maybe (Pat ())
mp = case Maybe (Pat ())
mp of
    Maybe (Pat ())
Nothing -> Pat ()
metaPNothing
    Just Pat ()
p  -> Pat () -> Pat ()
pParen (Pat () -> Pat ()) -> Pat () -> Pat ()
forall a b. (a -> b) -> a -> b
$ Pat () -> Pat ()
metaPJust Pat ()
p

metaJust :: Exp () -> Exp ()
metaJust :: Exp () -> Exp ()
metaJust Exp ()
e = Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) Exp ()
e

metaNothing :: Exp ()
metaNothing :: Exp ()
metaNothing = Name () -> Exp ()
con Name ()
nothing_name

metaMkMaybe :: Maybe (Exp ()) -> Exp ()
metaMkMaybe :: Maybe (Exp ()) -> Exp ()
metaMkMaybe Maybe (Exp ())
me = case Maybe (Exp ())
me of
    Maybe (Exp ())
Nothing -> Exp ()
metaNothing
    Just Exp ()
e  -> Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaJust Exp ()
e

---------------------------------------------------
-- some other useful functions at abstract level
consFun, idFun :: Exp ()
consFun :: Exp ()
consFun = () -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Con () QName ()
cons
idFun :: Exp ()
idFun = String -> Exp ()
function String
"id"

con :: Name () -> Exp ()
con :: Name () -> Exp ()
con = () -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Con () (QName () -> Exp ()) -> (Name () -> QName ()) -> Name () -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual ()

cons :: QName ()
cons :: QName ()
cons = () -> SpecialCon () -> QName ()
forall l. l -> SpecialCon l -> QName l
Special () (() -> SpecialCon ()
forall l. l -> SpecialCon l
Cons ())

fcomp, choice, append :: Name ()
fcomp :: Name ()
fcomp = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
"."
choice :: Name ()
choice = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
"+++"
append :: Name ()
append = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
"++"

just_name, nothing_name, left_name, right_name :: Name ()
just_name :: Name ()
just_name    = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"Just"
nothing_name :: Name ()
nothing_name = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"Nothing"
left_name :: Name ()
left_name    = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"Left"
right_name :: Name ()
right_name   = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
"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 :: XName () -> [Exp ()] -> Maybe (Exp ()) -> [Exp ()] -> Exp ()
metaGenElement XName ()
name [Exp ()]
ats Maybe (Exp ())
mat [Exp ()]
cs =
    let (Maybe String
d,String
n) = XName () -> (Maybe String, String)
xNameParts XName ()
name
        ne :: Exp ()
ne    = [Exp ()] -> Exp ()
tuple [Maybe (Exp ()) -> Exp ()
metaMkMaybe (Maybe (Exp ()) -> Exp ()) -> Maybe (Exp ()) -> Exp ()
forall a b. (a -> b) -> a -> b
$ (String -> Exp ()) -> Maybe String -> Maybe (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> (String -> Exp ()) -> String -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
strE) Maybe String
d, Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
n]
        m :: Exp () -> Exp ()
m = (Exp () -> Exp ())
-> (Exp () -> Exp () -> Exp ())
-> Maybe (Exp ())
-> Exp ()
-> Exp ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp () -> Exp ()
forall a. a -> a
id (\Exp ()
x Exp ()
y -> Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp ()
y Exp () -> Exp () -> Exp ()
`metaAppend` ([Exp ()] -> Exp ()
metaMap [Exp ()
argAsAttr, Exp ()
x])) Maybe (Exp ())
mat
        attrs :: Exp ()
attrs = Exp () -> Exp ()
m (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ (Exp () -> Exp ()) -> [Exp ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Exp () -> Exp ()
metaAsAttr [Exp ()]
ats
     in String -> [Exp ()] -> Exp ()
metaFunction String
"genElement" [Exp ()
ne, Exp ()
attrs, [Exp ()] -> Exp ()
listE [Exp ()]
cs]

-- | Create an empty xml tag, given its domain, name and attributes.
metaGenEElement :: XName () -> [Exp ()] -> Maybe (Exp ()) -> Exp ()
metaGenEElement :: XName () -> [Exp ()] -> Maybe (Exp ()) -> Exp ()
metaGenEElement XName ()
name [Exp ()]
ats Maybe (Exp ())
mat =
    let (Maybe String
d,String
n) = XName () -> (Maybe String, String)
xNameParts XName ()
name
        ne :: Exp ()
ne    = [Exp ()] -> Exp ()
tuple [Maybe (Exp ()) -> Exp ()
metaMkMaybe (Maybe (Exp ()) -> Exp ()) -> Maybe (Exp ()) -> Exp ()
forall a b. (a -> b) -> a -> b
$ (String -> Exp ()) -> Maybe String -> Maybe (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> (String -> Exp ()) -> String -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
strE) Maybe String
d, Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
n]
        m :: Exp () -> Exp ()
m = (Exp () -> Exp ())
-> (Exp () -> Exp () -> Exp ())
-> Maybe (Exp ())
-> Exp ()
-> Exp ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp () -> Exp ()
forall a. a -> a
id (\Exp ()
x Exp ()
y -> Exp () -> Exp ()
paren (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Exp ()
y Exp () -> Exp () -> Exp ()
`metaAppend` ([Exp ()] -> Exp ()
metaMap [Exp ()
argAsAttr, Exp ()
x])) Maybe (Exp ())
mat
        attrs :: Exp ()
attrs = Exp () -> Exp ()
m (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ (Exp () -> Exp ()) -> [Exp ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Exp () -> Exp ()
metaAsAttr [Exp ()]
ats
     in String -> [Exp ()] -> Exp ()
metaFunction String
"genEElement" [Exp ()
ne, Exp ()
attrs]

-- | Create an attribute by applying the overloaded @asAttr@
metaAsAttr :: Exp () -> Exp ()
metaAsAttr :: Exp () -> Exp ()
metaAsAttr e :: Exp ()
e@(Lit ()
_ (String ()
_ String
_ String
_)) = String -> [Exp ()] -> Exp ()
metaFunction String
"asAttr" [Exp () -> Exp ()
metaFromStringLit Exp ()
e] -- [ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))]
metaAsAttr Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"asAttr" [Exp ()
e]

argAsAttr :: Exp ()
argAsAttr :: Exp ()
argAsAttr = Name () -> Exp ()
var (Name () -> Exp ()) -> Name () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Name ()
name String
"asAttr"

-- | Create a property from an attribute and a value.
metaAssign :: Exp () -> Exp () -> Exp ()
metaAssign :: Exp () -> Exp () -> Exp ()
metaAssign Exp ()
e1 Exp ()
e2 = Exp () -> QOp () -> Exp () -> Exp ()
infixApp Exp ()
e1 QOp ()
assignOp Exp ()
e2
  where assignOp :: QOp ()
assignOp = () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QConOp () (QName () -> QOp ()) -> QName () -> QOp ()
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () (Name () -> QName ()) -> Name () -> QName ()
forall a b. (a -> b) -> a -> b
$ () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
":="

-- | Make xml out of some expression by applying the overloaded function
-- @asChild@.
metaAsChild :: Exp () -> Exp ()
metaAsChild :: Exp () -> Exp ()
metaAsChild Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"asChild" [Exp () -> Exp ()
paren Exp ()
e]

-- | convert a 'String' literal to lazy 'Text' by calling a function named 'fromStringLit'
metaFromStringLit :: Exp () -> Exp ()
metaFromStringLit :: Exp () -> Exp ()
metaFromStringLit Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"fromStringLit" [Exp ()
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 :: XName () -> Name () -> Exp ()
metaExtract XName ()
name Name ()
attrs =
    let (Maybe String
d,String
n) = XName () -> (Maybe String, String)
xNameParts XName ()
name
        np :: Exp ()
np    = [Exp ()] -> Exp ()
tuple [Maybe (Exp ()) -> Exp ()
metaMkMaybe (Maybe (Exp ()) -> Exp ()) -> Maybe (Exp ()) -> Exp ()
forall a b. (a -> b) -> a -> b
$ (String -> Exp ()) -> Maybe String -> Maybe (Exp ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Exp ()
strE Maybe String
d, String -> Exp ()
strE String
n]
     in String -> [Exp ()] -> Exp ()
metaFunction String
"extract" [Exp ()
np, Name () -> Exp ()
var Name ()
attrs]

-- | Generate a pattern under the Tag data constructor.
metaTag :: (Maybe String) -> String -> Pat () -> Pat () -> Pat ()
metaTag :: Maybe String -> String -> Pat () -> Pat () -> Pat ()
metaTag Maybe String
dom String
name Pat ()
ats Pat ()
cpat =
    let d :: Pat ()
d = Maybe (Pat ()) -> Pat ()
metaPMkMaybe (Maybe (Pat ()) -> Pat ()) -> Maybe (Pat ()) -> Pat ()
forall a b. (a -> b) -> a -> b
$ (String -> Pat ()) -> Maybe String -> Maybe (Pat ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Pat ()
strP Maybe String
dom
        n :: Pat ()
n = [Pat ()] -> Pat ()
pTuple [Pat ()
d, String -> Pat ()
strP String
name]
     in String -> [Pat ()] -> Pat ()
metaConPat String
"Element" [Pat ()
n, Pat ()
ats, Pat ()
cpat]

-- | Generate a pattern under the PCDATA data constructor.
metaPcdata :: String -> Pat ()
metaPcdata :: String -> Pat ()
metaPcdata String
s = String -> [Pat ()] -> Pat ()
metaConPat String
"CDATA" [String -> Pat ()
strP String
s]

metaMkName :: XName () -> Exp ()
metaMkName :: XName () -> Exp ()
metaMkName XName ()
n = case XName ()
n of
    XName ()
_ String
s      -> Exp () -> Exp ()
metaFromStringLit (String -> Exp ()
strE String
s)
    XDomName ()
_ String
d String
s -> [Exp ()] -> Exp ()
tuple [Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
d, Exp () -> Exp ()
metaFromStringLit (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
s]

--    XName s      -> textTypeSig (strE s)
--    XDomName d s -> tuple [textTypeSig $ strE d, textTypeSig $ strE s]
--    where
--      textTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))