{-# LANGUAGE CPP #-}
module Language.Haskell.HSX.Transform (
transform
, 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)
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)
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
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
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 = a -> a
forall a. a -> a
id
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'
transformDecl :: Decl () -> HsxM (Decl ())
transformDecl :: Decl () -> HsxM (Decl ())
transformDecl Decl ()
d = case Decl ()
d of
PatBind ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls -> do
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]
([Pat ()
pat''], [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
pat']
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
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'
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
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
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
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
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
transformMatch :: Match () -> HsxM (Match ())
transformMatch :: Match () -> HsxM (Match ())
transformMatch (Match ()
l Name ()
name [Pat ()]
pats Rhs ()
rhs Maybe (Binds ())
decls) = do
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
([Pat ()]
pats'', [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()]
pats'
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
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'
mkRhs :: [Guard ()] -> [(Name (), Pat ())] -> Rhs () -> HsxM (Rhs ())
mkRhs :: [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs [Guard ()]
guards [NameBind ()]
rnps (UnGuardedRhs ()
l Exp ()
rhs) = do
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
[] -> 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'
[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
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
[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
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'
addLetDecls :: [(Name (), Pat ())] -> Exp () -> Exp ()
addLetDecls :: [NameBind ()] -> Exp () -> Exp ()
addLetDecls [] Exp ()
e = Exp ()
e
addLetDecls [NameBind ()]
rnps Exp ()
e =
[Decl ()] -> Exp () -> Exp ()
letE ((NameBind () -> Decl ()) -> [NameBind ()] -> [Decl ()]
forall a b. (a -> b) -> [a] -> [b]
map NameBind () -> Decl ()
mkDecl [NameBind ()]
rnps) Exp ()
e
mkDecl :: (Name (), Pat ()) -> Decl ()
mkDecl :: NameBind () -> Decl ()
mkDecl (Name ()
n,Pat ()
p) = Pat () -> Exp () -> Decl ()
patBind Pat ()
p (Name () -> Exp ()
var Name ()
n)
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'
transformExpM :: Exp () -> HsxM (Exp ())
transformExpM :: Exp () -> HsxM (Exp ())
transformExpM Exp ()
e = case Exp ()
e of
XTag ()
_ XName ()
name [XAttr ()]
attrs Maybe (Exp ())
mattr [Exp ()]
cs -> do
HsxM ()
setXmlTransformed
let
as :: [Exp ()]
as = (XAttr () -> Exp ()) -> [XAttr ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
[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
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'
XETag ()
_ XName ()
name [XAttr ()]
attrs Maybe (Exp ())
mattr -> do
HsxM ()
setXmlTransformed
let
as :: [Exp ()]
as = (XAttr () -> Exp ()) -> [XAttr ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
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
XChildTag ()
_ [Exp ()]
cs -> do
HsxM ()
setXmlTransformed
[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
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'
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
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'
Lambda ()
l [Pat ()]
pats Exp ()
rhs -> do
let
([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
([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
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'
Let ()
_ (BDecls ()
_ [Decl ()]
ds) Exp ()
e -> do
[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'
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'
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'
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'
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
([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]
([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
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'
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
where
transformChild :: Exp () -> HsxM (Exp ())
transformChild :: Exp () -> HsxM (Exp ())
transformChild Exp ()
e = do
Exp ()
te <- 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 ()
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 Exp ()
e = Exp ()
e
transformLetDecls :: [Decl ()] -> HsxM [Decl ()]
transformLetDecls :: [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds = do
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
([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
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
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
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!"
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
Rhs ()
rhs' <- [Guard ()] -> [NameBind ()] -> Rhs () -> HsxM (Rhs ())
mkRhs [] [] Rhs ()
rhs
[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
$ (() -> 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'
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'
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
data StmtType = DoStmt | GuardStmt | ListCompStmt
transformStmt :: StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt :: StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
t Stmt ()
s = case Stmt ()
s of
Generator ()
s Pat ()
p Exp ()
e -> do
let
guardFun :: Guard () -> Stmt ()
guardFun = case StmtType
t of
StmtType
DoStmt -> Guard () -> Stmt ()
monadify
StmtType
ListCompStmt -> Guard () -> Stmt ()
monadify
StmtType
GuardStmt -> Guard () -> Stmt ()
mkStmtGuard
([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]
([Pat ()
p''], [Guard ()]
ags, [Guard ()]
gs, [Decl ()]
ds) <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
p']
let lt :: [Stmt ()]
lt = case [Decl ()]
ds of
[] -> []
[Decl ()]
_ -> [[Decl ()] -> Stmt ()
letStmt [Decl ()]
ds]
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)
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 ()
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)
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
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
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
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)
transformAlt :: Alt () -> HsxM (Alt ())
transformAlt :: Alt () -> HsxM (Alt ())
transformAlt (Alt ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls) = do
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]
([Pat ()
pat''], [Guard ()]
attrGuards, [Guard ()]
guards, [Decl ()]
decls'') <- [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns [Pat ()
pat']
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
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'
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
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)
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)
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
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
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
Name ()
n <- RN (Name ())
genVarName
(Pat (), [NameBind ()]) -> RN (Pat (), [NameBind ()])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name () -> Pat ()
pvar Name ()
n, [(Name ()
n,Pat ()
p)])
renameLetDecls :: [Decl ()] -> [Decl ()]
renameLetDecls :: [Decl ()] -> [Decl ()]
renameLetDecls [Decl ()]
ds =
let
([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
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)
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
PatBind ()
l Pat ()
pat Rhs ()
rhs Maybe (Binds ())
decls -> do
(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, [])
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
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)
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
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
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
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)
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')
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
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
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
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
trPattern :: Pat () -> Tr (Pat ())
trPattern :: Pat () -> Tr (Pat ())
trPattern Pat ()
p = case Pat ()
p of
PRPat ()
_ [RPat ()]
rps -> do
Name ()
n <- Tr (Name ())
genPatName
(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)
Name ()
topmname <- Name () -> [Name ()] -> Tr (Name ())
mkTopDecl Name ()
mname [Name ()]
vars
[Name ()] -> Name () -> Name () -> Tr ()
mkGuard [Name ()]
vars Name ()
topmname Name ()
n
Tr ()
setHarpTransformedT
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
PXTag ()
_ XName ()
name [PXAttr ()]
attrs Maybe (Pat ())
mattr [Pat ()]
cpats -> do
Pat ()
an <- case (Maybe (Pat ())
mattr, [PXAttr ()]
attrs) of
(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
(Maybe (Pat ())
_, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
wildcard
(Maybe (Pat ())
_, [PXAttr ()]
_) -> do
Name ()
n <- Tr (Name ())
genAttrName
Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
n [PXAttr ()]
attrs Maybe (Pat ())
mattr
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
Pat ()
cpat' <- case [Pat ()]
cpats of
(p :: Pat ()
p@(PXRPats ()
_ [RPat ()]
_)):[] -> Pat () -> Tr (Pat ())
trPattern Pat ()
p
[Pat ()]
_ -> Pat () -> Tr (Pat ())
trPattern (() -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList () [Pat ()]
cpats)
Tr ()
setHarpTransformedT
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'
PXETag ()
_ XName ()
name [PXAttr ()]
attrs Maybe (Pat ())
mattr -> do
Pat ()
an <- case (Maybe (Pat ())
mattr, [PXAttr ()]
attrs) of
(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
(Maybe (Pat ())
_, []) -> Pat () -> Tr (Pat ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
wildcard
(Maybe (Pat ())
_, [PXAttr ()]
_) -> do
Name ()
n <- Tr (Name ())
genAttrName
Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
n [PXAttr ()]
attrs Maybe (Pat ())
mattr
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
Tr ()
setHarpTransformedT
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
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)
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
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
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
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
mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
attrs [PXAttr ()
_ XName ()
n Pat ()
q] Maybe (Pat ())
mattr = do
let rhs :: Exp ()
rhs = XName () -> Name () -> Exp ()
metaExtract XName ()
n Name ()
attrs
pat :: Pat ()
pat = Pat () -> Pat ()
metaPJust Pat ()
q
rml :: Pat ()
rml = case Maybe (Pat ())
mattr of
Maybe (Pat ())
Nothing -> Pat ()
wildcard
Just Pat ()
ap -> Pat ()
ap
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
let rhs :: Exp ()
rhs = XName () -> Name () -> Exp ()
metaExtract XName ()
a Name ()
attrs
pat :: Pat ()
pat = Pat () -> Pat ()
metaPJust Pat ()
q
Name ()
newAttrs <- Tr (Name ())
genAttrName
Pat () -> Exp () -> Tr ()
pushAttrGuard ([Pat ()] -> Pat ()
pTuple [Pat ()
pat, Name () -> Pat ()
pvar Name ()
newAttrs]) Exp ()
rhs
Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards Name ()
newAttrs [PXAttr ()]
xs Maybe (Pat ())
mattr
mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())
mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())
mkTopDecl Name ()
mname [Name ()]
vars =
do
Name ()
n <- Tr (Name ())
genMatchName
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
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]
g :: Exp ()
g = Name () -> Exp ()
var Name ()
mname
a :: Stmt ()
a = Pat () -> Exp () -> Stmt ()
genStmt Pat ()
pat Exp ()
g
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
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
e :: Exp ()
e = [Stmt ()] -> Exp ()
doE [Stmt ()
a,Stmt ()
b]
in Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
e
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
ge :: Exp ()
ge = Exp () -> [Exp ()] -> Exp ()
appFun Exp ()
runMatchFun [Name () -> Exp ()
var Name ()
mname, Name () -> Exp ()
var Name ()
n]
Pat () -> Exp () -> Tr ()
pushGuard (Name () -> [Pat ()] -> Pat ()
pApp Name ()
just_name [Pat ()
tvs]) Exp ()
ge
data MType = S
| L MType
| E MType MType
| M MType
type MFunMetaInfo l = (Name l, [Name l], MType)
trRPat :: Bool -> RPat () -> Tr (MFunMetaInfo ())
trRPat :: Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp = case RPat ()
rp of
RPPat ()
_ Pat ()
p -> Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
p
where
mkBaseDecl :: Bool -> Pat () -> Tr (MFunMetaInfo ())
mkBaseDecl :: Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
p = case Pat ()
p of
PWildCard ()
_ -> Tr (Name (), [Name ()], MType)
mkWCMatch
PVar ()
_ Name ()
v -> Bool -> Name () -> Tr (Name (), [Name ()], MType)
mkVarMatch Bool
linear Name ()
v
PXPatTag ()
_ Pat ()
q -> Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBaseDecl Bool
linear Pat ()
q
Pat ()
p -> do
(Name ()
name, [Name ()]
vars, MType
_) <- Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBasePat Bool
linear Pat ()
p
Name ()
newname <- Name () -> Tr (Name ())
mkBaseMatch Name ()
name
(Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
newname, [Name ()]
vars, MType
S)
mkBasePat :: Bool -> Pat () -> Tr (MFunMetaInfo ())
mkBasePat :: Bool -> Pat () -> Tr (Name (), [Name ()], MType)
mkBasePat Bool
b Pat ()
p =
do
Name ()
n <- Tr (Name ())
genMatchName
let vs :: [Name ()]
vs = Pat () -> [Name ()]
gatherPVars Pat ()
p
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)
basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
basePatDecl Bool
linear Name ()
f [Name ()]
vs Pat ()
p = do
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"
Exp ()
rhs <- Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())
baseCaseE Bool
linear Pat ()
p Name ()
a [Name ()]
vs
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
let alt1 :: Alt ()
alt1 = Pat () -> Exp () -> Alt ()
alt Pat ()
p
(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))
alt2 :: Alt ()
alt2 = Pat () -> Exp () -> Alt ()
alt Pat ()
wildcard (Name () -> Exp ()
con Name ()
nothing_name)
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
| Bool
linear = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
| Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)
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
PXPatTag ()
_ Pat ()
q -> Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardDecl Bool
linear Pat ()
q [Stmt ()]
gs
Pat ()
p -> do
(Name ()
name, [Name ()]
vars, MType
_) <- Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardPat Bool
linear Pat ()
p [Stmt ()]
gs
Name ()
newname <- Name () -> Tr (Name ())
mkBaseMatch Name ()
name
(Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
newname, [Name ()]
vars, MType
S)
mkGuardPat :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())
mkGuardPat :: Bool -> Pat () -> [Stmt ()] -> Tr (Name (), [Name ()], MType)
mkGuardPat Bool
b Pat ()
p [Stmt ()]
gs =
do
Name ()
n <- Tr (Name ())
genMatchName
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
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)
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
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"
Exp ()
rhs <- Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())
guardedCaseE Bool
linear Pat ()
p [Stmt ()]
gs Name ()
a [Name ()]
vs
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
let alt1 :: Alt ()
alt1 = Pat () -> [Stmt ()] -> Exp () -> Binds () -> Alt ()
altGW Pat ()
p [Stmt ()]
gs
(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 [])
alt2 :: Alt ()
alt2 = Pat () -> Exp () -> Alt ()
alt Pat ()
wildcard (Name () -> Exp ()
con Name ()
nothing_name)
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
| Bool
linear = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
| Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)
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
mkSeqDecl :: [MFunMetaInfo ()] -> Tr (MFunMetaInfo ())
mkSeqDecl :: [(Name (), [Name ()], MType)] -> Tr (Name (), [Name ()], MType)
mkSeqDecl [(Name (), [Name ()], MType)]
nvts = do
Name ()
name <- Tr (Name ())
genMatchName
let
([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
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
fldecls :: [Decl ()]
fldecls = [(Name (), MType)] -> [Decl ()]
flattenVals [(Name (), MType)]
vals
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 [Name () -> Exp ()
var Name ()
retname, [Name ()] -> Exp ()
varTuple [Name ()]
vars]
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]
++
[[Decl ()] -> Stmt ()
letStmt [Decl ()]
fldecls, Stmt ()
ret]
Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
name Exp ()
rhs
(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)
flattenVals :: [(Name (), MType)] -> [Decl ()]
flattenVals :: [(Name (), MType)] -> [Decl ()]
flattenVals [(Name (), MType)]
nts =
let
([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
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
newname :: Name ()
newname = Name () -> String -> Name ()
extendVar Name ()
name String
"f"
f :: Exp ()
f = MType -> Exp ()
flatten MType
mt
in (Name ()
newname, Name () -> Exp () -> Decl ()
nameBind Name ()
newname (Exp () -> Decl ()) -> Exp () -> Decl ()
forall a b. (a -> b) -> a -> b
$
Exp () -> Exp () -> Exp ()
app Exp ()
f (Name () -> Exp ()
var Name ()
name))
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
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
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
RPCAs ()
_ Name ()
v RPat ()
rp -> do
nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
name, [Name ()]
vs, MType
mt) <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp
Name ()
n <- (Name (), [Name ()], MType) -> Tr (Name ())
mkCAsDecl (Name (), [Name ()], MType)
nvt
(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
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
RPAs ()
_ Name ()
v RPat ()
rp
| Bool
linear ->
do
nvt :: (Name (), [Name ()], MType)
nvt@(Name ()
name, [Name ()]
vs, MType
mt) <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp
Name ()
n <- (Name (), [Name ()], MType) -> Tr (Name ())
mkAsDecl (Name (), [Name ()], MType)
nvt
(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)
| 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
mkAsDecl :: MFunMetaInfo () -> Tr (Name ())
mkAsDecl :: (Name (), [Name ()], MType) -> Tr (Name ())
mkAsDecl = (Exp () -> Exp ()) -> (Name (), [Name ()], MType) -> Tr (Name ())
asDecl Exp () -> Exp ()
metaConst
RPParen ()
_ RPat ()
rp -> Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
linear RPat ()
rp
RPOp ()
_ RPat ()
rp (RPOpt ()
_)->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkOptDecl Bool
False (Name (), [Name ()], MType)
nvt
RPOp ()
_ RPat ()
rp (RPOptG ()
_) ->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkOptDecl Bool
True (Name (), [Name ()], MType)
nvt
RPEither ()
_ RPat ()
rp1 RPat ()
rp2 ->
do
(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
(Name (), [Name ()], MType)
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkEitherDecl (Name (), [Name ()], MType)
nvt1 (Name (), [Name ()], MType)
nvt2
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
Name ()
n <- Tr (Name ())
genMatchName
let
(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
allvs :: [Name ()]
allvs = [Name ()]
vs1 [Name ()] -> [Name ()] -> [Name ()]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name ()]
vs2
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
ret1 :: Exp ()
ret1 = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple
[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
[Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
right_name)
(Name () -> Exp ()
var Name ()
v2), [Exp ()] -> Exp ()
tuple [Exp ()]
vals2]
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]
rhs :: Exp ()
rhs = (Exp () -> Exp ()
paren Exp ()
exp1) Exp () -> Exp () -> Exp ()
`metaChoice`
(Exp () -> Exp ()
paren Exp ()
exp2)
Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
(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
then Name () -> Exp ()
var Name ()
v
else Exp ()
idFun
RPOp ()
_ RPat ()
rp (RPStar ()
_) ->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
False (Name (), [Name ()], MType)
nvt
RPOp ()
_ RPat ()
rp (RPStarG ()
_) ->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
True (Name (), [Name ()], MType)
nvt
RPOp ()
_ RPat ()
rp (RPPlus ()
_) ->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkPlusDecl Bool
False (Name (), [Name ()], MType)
nvt
RPOp ()
_ RPat ()
rp (RPPlusG ()
_) ->
do
(Name (), [Name ()], MType)
nvt <- Bool -> RPat () -> Tr (Name (), [Name ()], MType)
trRPat Bool
False RPat ()
rp
Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkPlusDecl Bool
True (Name (), [Name ()], MType)
nvt
where
mkVarMatch :: Bool -> Name () -> Tr (MFunMetaInfo ())
mkVarMatch :: Bool -> Name () -> Tr (Name (), [Name ()], MType)
mkVarMatch Bool
linear Name ()
v = do
Name ()
n <- Tr (Name ())
genMatchName
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
$
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)
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
(Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [Name ()
v], MType
S)
where retVar :: Bool -> Name () -> Exp ()
retVar :: Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v
| Bool
linear = Exp () -> Exp ()
metaConst (Name () -> Exp ()
var Name ()
v)
| Bool
otherwise = Exp () -> Exp () -> Exp ()
app Exp ()
consFun (Name () -> Exp ()
var Name ()
v)
mkWCMatch :: Tr (MFunMetaInfo ())
mkWCMatch :: Tr (Name (), [Name ()], MType)
mkWCMatch = do
Name ()
n <- Tr (Name ())
genMatchName
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
$
Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) (() -> Exp ()
forall l. l -> Exp l
unit_con ())
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
(Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, [], MType
S)
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 ()
_ -> []
mkBaseMatch :: Name () -> Tr (Name ())
mkBaseMatch :: Name () -> Tr (Name ())
mkBaseMatch Name ()
name =
do
Name ()
n <- Tr (Name ())
genMatchName
Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> Decl ()
baseMatchDecl Name ()
n Name ()
name
Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return Name ()
n
baseMatchDecl :: Name () -> Name () -> Decl ()
baseMatchDecl :: Name () -> Name () -> Decl ()
baseMatchDecl Name ()
newname Name ()
oldname =
let e :: Exp ()
e = Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun (Name () -> Exp ()
var Name ()
oldname)
in Name () -> Exp () -> Decl ()
nameBind Name ()
newname Exp ()
e
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
pat :: Pat ()
pat = [Pat ()] -> Pat ()
pTuple [Name () -> Pat ()
pvar Name ()
valname, [Name ()] -> Pat ()
pvarTuple [Name ()]
vars]
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]
:
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
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)
mkManyGen :: Bool -> Name () -> Stmt ()
mkManyGen :: Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname =
let mf :: Exp ()
mf = if Bool
greedy then Exp ()
gManyMatchFun else Exp ()
manyMatchFun
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)
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
Name ()
n <- Tr (Name ())
genMatchName
let
(Stmt ()
g, Name ()
val) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt
vars :: [Exp ()]
vars = (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
vs
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
[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]
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]
Name () -> Tr (Name ())
forall (m :: * -> *) a. Monad m => a -> m a
return Name ()
n
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
Name ()
n <- Tr (Name ())
genMatchName
let
(Stmt ()
g, Name ()
val) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt
ret1 :: Exp ()
ret1 = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple
[Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name)
(Name () -> Exp ()
var Name ()
val), [Name ()] -> Exp ()
varTuple [Name ()]
vs]
exp1 :: Exp ()
exp1 = [Stmt ()] -> Exp ()
doE [Stmt ()
g, Exp () -> Stmt ()
qualStmt Exp ()
ret1]
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
ret2 :: Exp ()
ret2 = Exp () -> Exp ()
metaReturn (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple
[Name () -> Exp ()
con Name ()
nothing_name, [Exp ()] -> Exp ()
tuple [Exp ()]
ids]
mc :: Exp () -> Exp () -> Exp ()
mc = if Bool
greedy
then Exp () -> Exp () -> Exp ()
metaChoice
else ((Exp () -> Exp () -> Exp ()) -> Exp () -> Exp () -> Exp ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp () -> Exp () -> Exp ()
metaChoice)
rhs :: Exp ()
rhs = (Exp () -> Exp ()
paren Exp ()
exp1) Exp () -> Exp () -> Exp ()
`mc`
(Exp () -> Exp ()
paren Exp ()
ret2)
Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
(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)
mkStarDecl :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
mkStarDecl :: Bool
-> (Name (), [Name ()], MType) -> Tr (Name (), [Name ()], MType)
mkStarDecl Bool
greedy (Name ()
mname, [Name ()]
vs, MType
t) = do
Name ()
n <- Tr (Name ())
genMatchName
let
g :: Stmt ()
g = Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname
metaUnzipK :: Exp () -> Exp ()
metaUnzipK = Int -> Exp () -> Exp ()
mkMetaUnzip ([Name ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name ()]
vs)
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)
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)
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
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]
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]
(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)
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
Name ()
n <- Tr (Name ())
genMatchName
let k :: Int
k = [Name ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name ()]
vs
(Stmt ()
g1, Name ()
val1) = (Name (), [Name ()], MType) -> (Stmt (), Name ())
mkGenExp (Name (), [Name ()], MType)
nvt
g2 :: Stmt ()
g2 = Bool -> Name () -> Stmt ()
mkManyGen Bool
greedy Name ()
mname
metaUnzipK :: Exp () -> Exp ()
metaUnzipK = Int -> Exp () -> Exp ()
mkMetaUnzip Int
k
dec1 :: Decl ()
dec1 = Pat () -> Exp () -> Decl ()
patBind
([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)
vlvars :: [Name ()]
vlvars = String -> Int -> [Name ()]
genNames String
"harp_vl" Int
k
dec2 :: Decl ()
dec2 = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()]
vlvars)
(Exp () -> Exp ()
metaUnzipK (Exp () -> Exp ()) -> Exp () -> Exp ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
varsname)
letSt :: Stmt ()
letSt = [Decl ()] -> Stmt ()
letStmt [Decl ()
dec1, Decl ()
dec2]
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
retVal :: Exp ()
retVal = (Name () -> Exp ()
var Name ()
val1) Exp () -> Exp () -> Exp ()
`metaCons`
(Name () -> Exp ()
var Name ()
valsname)
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
$
[Exp ()
retVal, [Exp ()] -> Exp ()
tuple [Exp ()]
retExps]
rhs :: Exp ()
rhs = [Stmt ()] -> Exp ()
doE [Stmt ()
g1, Stmt ()
g2, Stmt ()
letSt, Exp () -> Stmt ()
qualStmt Exp ()
ret]
Decl () -> Tr ()
pushDecl (Decl () -> Tr ()) -> Decl () -> Tr ()
forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
(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) =
(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)
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
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)
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
rhs2 :: Exp ()
rhs2 = Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
var Name ()
uz) (Name () -> Exp ()
var Name ()
xs)
dec2 :: Decl ()
dec2 = Pat () -> Exp () -> Decl ()
patBind ([Name ()] -> Pat ()
pvarTuple [Name ()]
lvs) Exp ()
rhs2
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
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)
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
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
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"
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]
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]
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]
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"
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
":="
metaAsChild :: Exp () -> Exp ()
metaAsChild :: Exp () -> Exp ()
metaAsChild Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"asChild" [Exp () -> Exp ()
paren Exp ()
e]
metaFromStringLit :: Exp () -> Exp ()
metaFromStringLit :: Exp () -> Exp ()
metaFromStringLit Exp ()
e = String -> [Exp ()] -> Exp ()
metaFunction String
"fromStringLit" [Exp ()
e]
metaExtract :: XName () -> Name () -> Exp ()
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]
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]
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]