{-# 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 :: forall a. a -> HsxM a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a 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 :: forall a. a -> HsxM a
return a
x = forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
s -> (a
x,HsxState
s))
(MkHsxM HsxState -> (a, HsxState)
f) >>= :: forall a b. HsxM a -> (a -> HsxM b) -> HsxM b
>>= a -> HsxM b
k = 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 :: forall a. String -> HsxM a
fail String
str = forall a. HasCallStack => String -> a
error String
str
{-# INLINE fail #-}
#endif
getHsxState :: HsxM HsxState
getHsxState :: HsxM HsxState
getHsxState = forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
s -> (HsxState
s, HsxState
s))
setHsxState :: HsxState -> HsxM ()
setHsxState :: HsxState -> HsxM ()
setHsxState HsxState
s = forall a. (HsxState -> (a, HsxState)) -> HsxM a
MkHsxM (\HsxState
_ -> ((),HsxState
s))
instance Functor HsxM where
fmap :: forall a b. (a -> b) -> HsxM a -> HsxM b
fmap a -> b
f HsxM a
hma = do a
a <- HsxM a
hma
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. 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)) = forall a. HsxM a -> (a, HsxState)
runHsxM forall a b. (a -> b) -> a -> b
$ 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 (:) forall a b. (a -> b) -> a -> b
$ 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 forall a. Maybe a
Nothing
(forall a. a -> Maybe a
Just ModuleName ()
match_qual_mod)
forall a. Maybe a
Nothing
else forall a. a -> a
id
imps2 :: a -> a
imps2 = forall a. a -> a
id
in forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module ()
l Maybe (ModuleHead ())
m [ModulePragma ()]
pragmas ([ImportDecl ()] -> [ImportDecl ()]
imps1 forall a b. (a -> b) -> a -> b
$ 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) = forall a b. [(a, b)] -> ([a], [b])
unzip 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 forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
Maybe (Binds ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (BDecls ()
l [Decl ()]
ds)
-> do [Decl ()]
ds' <- [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> [Decl l] -> Binds l
BDecls ()
l forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds'
Maybe (Binds ())
_ -> forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> [Match l] -> Decl l
FunBind ()
l) forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl ()
d
InstDecl ()
l Maybe (Overlap ())
mo InstRule ()
irule (Just [InstDecl ()]
idecls) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l.
l
-> Maybe (Overlap l) -> InstRule l -> Maybe [InstDecl l] -> Decl l
InstDecl ()
l Maybe (Overlap ())
mo InstRule ()
irule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl ()
d
ClassDecl ()
l Maybe (Context ())
c DeclHead ()
dh [FunDep ()]
fd (Just [ClassDecl ()]
cdecls) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l.
l
-> Maybe (Context l)
-> DeclHead l
-> [FunDep l]
-> Maybe [ClassDecl l]
-> Decl l
ClassDecl ()
l Maybe (Context ())
c DeclHead ()
dh [FunDep ()]
fd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ 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 ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Exp l -> Decl l
SpliceDecl ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Decl l -> InstDecl l
InsDecl ()
l) forall a b. (a -> b) -> a -> b
$ Decl () -> HsxM (Decl ())
transformDecl Decl ()
decl
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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Decl l -> ClassDecl l
ClsDecl ()
l) forall a b. (a -> b) -> a -> b
$ Decl () -> HsxM (Decl ())
transformDecl Decl ()
decl
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) = forall a b. [(a, b)] -> ([a], [b])
unzip 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 forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
Maybe (Binds ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (BDecls ()
l [Decl ()]
ds)
-> do [Decl ()]
ds' <- [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> [Decl l] -> Binds l
BDecls ()
l forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds'
Maybe (Binds ())
_ -> forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls [NameBind ()]
rnps Exp ()
rhs
case [Guard ()]
guards of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> Rhs l
UnGuardedRhs ()
l Exp ()
rhs'
[Guard ()]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss ()
l [forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs ()
l (forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
mkStmtGuard [Guard ()]
guards) Exp ()
rhs']
mkRhs [Guard ()]
guards [NameBind ()]
rnps (GuardedRhss ()
l [GuardedRhs ()]
gdrhss) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss ()
l) forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls [NameBind ()]
rnps Exp ()
rhs
[Stmt ()]
oldgs' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs ()
l ((forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
mkStmtGuard [Guard ()]
gs) 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 (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
_) = forall a. HsxM a -> (a, HsxState)
runHsxM 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 = forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
[Exp ()]
cs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformChild [Exp ()]
cs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren 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 = forall a b. (a -> b) -> [a] -> [b]
map XAttr () -> Exp ()
mkAttr [XAttr ()]
attrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp () -> HsxM (Exp ())
transformChild [Exp ()]
cs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaAsChild forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE [Exp ()]
cs'
XPcdata ()
_ String
pcdata -> do HsxM ()
setXmlTransformed
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaFromStringLit 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaAsChild Exp ()
e'
Lambda ()
l [Pat ()]
pats Exp ()
rhs -> do
let
([Pat ()]
ps, [[NameBind ()]]
rnpss) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()]
pats
([Name ()]
rns, [Pat ()]
rps) = forall a b. [(a, b)] -> ([a], [b])
unzip (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 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Binds l -> Exp l -> Exp l
Let ()
l (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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt () -> HsxM (Alt ())
transformAlt [Alt ()]
alts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> [Alt l] -> Exp l
Case ()
l Exp ()
e' [Alt ()]
alts'
Do ()
l [Stmt ()]
stmts -> do
[Stmt ()]
stmts' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [Stmt l] -> Exp l
Do ()
l [Stmt ()]
stmts'
MDo ()
l [Stmt ()]
stmts -> do
[Stmt ()]
stmts' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualStmt () -> HsxM [QualStmt ()]
transformQualStmt [QualStmt ()]
stmts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualStmt () -> HsxM [QualStmt ()]
transformQualStmt) [[QualStmt ()]]
stmtss
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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]) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()
pat]
([Name ()]
rns, [Pat ()]
rps) = 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 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Exp l -> Exp l
Proc ()
l Pat ()
p Exp ()
rhs'
InfixApp ()
l Exp ()
e1 QOp ()
op Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2
(\Exp ()
e1 Exp ()
e2 -> 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 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
App ()
l)
NegApp ()
l Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Exp l -> Exp l
NegApp ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
If ()
l Exp ()
e1 Exp ()
e2 Exp ()
e3 -> forall a.
Exp ()
-> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp Exp ()
e1 Exp ()
e2 Exp ()
e3 (forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
If ()
l)
Tuple ()
l Boxed
bx [Exp ()]
es -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Boxed -> [Exp l] -> Exp l
Tuple ()
l Boxed
bx) forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> [Exp l] -> Exp l
List ()
l) forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Exp l -> Exp l
Paren ()
l) 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> QOp l -> Exp l
LeftSection ()
l Exp ()
e' QOp ()
op
RightSection ()
l QOp ()
op Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> QOp l -> Exp l -> Exp l
RightSection ()
l QOp ()
op) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
RecConstr ()
l QName ()
n [FieldUpdate ()]
fus -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> QName l -> [FieldUpdate l] -> Exp l
RecConstr ()
l QName ()
n) forall a b. (a -> b) -> a -> b
$ 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate [FieldUpdate ()]
fus
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> [FieldUpdate l] -> Exp l
RecUpdate ()
l Exp ()
e' [FieldUpdate ()]
fus'
EnumFrom ()
l Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Exp l -> Exp l
EnumFrom ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
EnumFromTo ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
EnumFromTo ()
l)
EnumFromThen ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
EnumFromThen ()
l)
EnumFromThenTo ()
l Exp ()
e1 Exp ()
e2 Exp ()
e3 -> forall a.
Exp ()
-> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp Exp ()
e1 Exp ()
e2 Exp ()
e3 (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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> Type l -> Exp l
ExpTypeSig ()
l Exp ()
e' Type ()
t
SpliceExp ()
l Splice ()
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Splice l -> Exp l
SpliceExp ()
l) forall a b. (a -> b) -> a -> b
$ Splice () -> HsxM (Splice ())
transformSplice Splice ()
s
LeftArrApp ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
LeftArrApp ()
l)
RightArrApp ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
RightArrApp ()
l)
LeftArrHighApp ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
LeftArrHighApp ()
l)
RightArrHighApp ()
l Exp ()
e1 Exp ()
e2 -> forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e1 Exp ()
e2 (forall l. l -> Exp l -> Exp l -> Exp l
RightArrHighApp ()
l)
CorePragma ()
l String
s Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> String -> Exp l -> Exp l
CorePragma ()
l String
s) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
SCCPragma ()
l String
s Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> String -> Exp l -> Exp l
SCCPragma ()
l String
s) 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> String -> (Int, Int) -> (Int, Int) -> Exp l -> Exp l
GenPragma ()
l String
s (Int, Int)
a (Int, Int)
b) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
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
forall (m :: * -> *) a. Monad m => a -> m a
return 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) =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> QName l -> Exp l -> FieldUpdate l
FieldUpdate ()
l QName ()
n) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
transformFieldUpdate FieldUpdate ()
fup = 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> Exp l -> Splice l
ParenSplice ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
Splice ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Splice ()
s
transform2exp :: Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp :: forall a. 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a.
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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
[] -> 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') <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (BDecls ()
l'' [Decl ()]
decls) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Decl l] -> Binds l
BDecls ()
l'') forall a b. (a -> b) -> a -> b
$ [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
decls
Just (IPBinds ()
l'' [IPBind ()]
decls) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [IPBind l] -> Binds l
IPBinds ()
l'') forall a b. (a -> b) -> a -> b
$ 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 ()]
_ -> forall a. HasCallStack => String -> a
error String
"This should not happen since we have called renameLetDecls already!"
ags' :: [Decl ()]
ags' = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Guard () -> [Decl ()] -> Decl ()
mkDeclGuard 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind ()
l'' Pat ()
pat' Rhs ()
rhs' Maybe (Binds ())
decls') forall a. a -> [a] -> [a]
: [Decl ()]
ags' forall a. [a] -> [a] -> [a]
++ [Decl ()]
gs' 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Decl ()
d'forall a. a -> [a] -> [a]
:[Decl ()]
ds'
transformIPBind :: IPBind () -> HsxM (IPBind ())
transformIPBind :: IPBind () -> HsxM (IPBind ())
transformIPBind (IPBind ()
l IPName ()
n Exp ()
e) =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l. l -> IPName l -> Exp l -> IPBind l
IPBind ()
l IPName ()
n) 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) = forall a b. [(a, b)] -> ([a], [b])
unzip 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' = forall a b. (a -> b) -> [a] -> [b]
map Guard () -> Stmt ()
guardFun ([Guard ()]
ags forall a. [a] -> [a] -> [a]
++ [Guard ()]
gs)
Exp ()
e' <- Exp () -> HsxM (Exp ())
transformExpM forall a b. (a -> b) -> a -> b
$ [NameBind ()] -> Exp () -> Exp ()
addLetDecls (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Exp ()
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Exp l -> Stmt l
Generator ()
s Pat ()
p'' Exp ()
e'forall a. a -> [a] -> [a]
:[Stmt ()]
lt 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 forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
paren Exp ()
e)
Qualifier ()
l Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Exp ()
e -> [forall l. l -> Exp l -> Stmt l
Qualifier ()
l forall a b. (a -> b) -> a -> b
$ Exp ()
e]) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
LetStmt ()
_ (BDecls ()
_ [Decl ()]
ds) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Decl ()]
ds -> [[Decl ()] -> Stmt ()
letStmt [Decl ()]
ds]) forall a b. (a -> b) -> a -> b
$ [Decl ()] -> HsxM [Decl ()]
transformLetDecls [Decl ()]
ds
LetStmt ()
l (IPBinds ()
l' [IPBind ()]
is) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[IPBind ()]
is -> [forall l. l -> Binds l -> Stmt l
LetStmt ()
l (forall l. l -> [IPBind l] -> Binds l
IPBinds ()
l' [IPBind ()]
is)]) forall a b. (a -> b) -> a -> b
$ 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 ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Stmt l] -> Stmt l
RecStmt ()
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall l. l -> Stmt l -> QualStmt l
QualStmt ()
l)) forall a b. (a -> b) -> a -> b
$ StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt StmtType
ListCompStmt Stmt ()
s
ThenTrans ()
l Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Exp l -> QualStmt l
ThenTrans ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
ThenBy ()
l Exp ()
e Exp ()
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e Exp ()
f (forall l. l -> Exp l -> Exp l -> QualStmt l
ThenBy ()
l)
GroupBy ()
l Exp ()
e -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Exp l -> QualStmt l
GroupBy ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
GroupUsing ()
l Exp ()
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Exp l -> QualStmt l
GroupUsing ()
l) forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
f
GroupByUsing ()
l Exp ()
e Exp ()
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp Exp ()
e Exp ()
f (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) = forall a b. [(a, b)] -> ([a], [b])
unzip 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 forall a. [a] -> [a] -> [a]
++ [Guard ()]
guards) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
rnpss) Rhs ()
rhs
Maybe (Binds ())
decls' <- case Maybe (Binds ())
decls of
Maybe (Binds ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (BDecls ()
l' [Decl ()]
ds) -> do [Decl ()]
ds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl () -> HsxM (Decl ())
transformDecl [Decl ()]
ds
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> [Decl l] -> Binds l
BDecls ()
l' forall a b. (a -> b) -> a -> b
$ [Decl ()]
decls'' forall a. [a] -> [a] -> [a]
++ [Decl ()]
ds
Maybe (Binds ())
_ -> forall a. HasCallStack => String -> a
error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall a. a -> RN a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a 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 :: forall a. a -> RN a
return a
a = forall a. (Int -> (a, Int)) -> RN a
RN forall a b. (a -> b) -> a -> b
$ \Int
s -> (a
a,Int
s)
(RN Int -> (a, Int)
f) >>= :: forall a b. RN a -> (a -> RN b) -> RN b
>>= a -> RN b
k = forall a. (Int -> (a, Int)) -> RN a
RN 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 :: forall a b. (a -> b) -> RN a -> RN b
fmap a -> b
f RN a
rna = do a
a <- RN a
rna
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
runRename :: RN a -> a
runRename :: forall a. 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 = forall a. (Int -> (a, Int)) -> RN a
RN forall a b. (a -> b) -> a -> b
$ \Int
s -> (Int
s,Int
s)
setRNState :: RNState -> RN ()
setRNState :: Int -> RN ()
setRNState Int
s = forall a. (Int -> (a, Int)) -> RN a
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 forall a b. (a -> b) -> a -> b
$ Int
kforall a. Num a => a -> a -> a
+Int
1
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Name ()
name forall a b. (a -> b) -> a -> b
$ String
"harp_rnvar" forall a. [a] -> [a] -> [a]
++ 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 :: forall a b c d. 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
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 :: forall a b c d.
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (b -> b -> c
f b
q1 b
q2, [d]
ms1 forall a. [a] -> [a] -> [a]
++ [d]
ms2)
renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat :: forall a b c d.
[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) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> c
f [b]
qs, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[d]]
mss)
renameRPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats [Pat ()]
ps = forall a. RN a -> a
runRename forall a b. (a -> b) -> a -> b
$ 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 -> 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 -> 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 -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PTuple ()
l Boxed
bx [Pat ()]
ps -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PList ()
l [Pat ()]
ps -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PParen ()
l Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PRec ()
l QName ()
n [PatField ()]
pfs -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [PatField ()]
pfs (forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> RN (PatField (), [NameBind ()])
renameRPf
PAsPat ()
l Name ()
n Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PIrrPat ()
l Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PIrrPat ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PXPatTag ()
l Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PXPatTag ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameRP
PatTypeSig ()
l Pat ()
p Type ()
t -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (\Pat ()
p -> forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig ()
l Pat ()
p Type ()
t) Pat () -> RN (Pat (), [NameBind ()])
renameRP
Pat ()
_ -> 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) = forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameRP
renameRPf PatField ()
pf = 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) = forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (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
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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. RN a -> a
runRename forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(Name ()
n,Pat ()
p) -> NameBind () -> Decl ()
mkDecl (Name ()
n,Pat ()
p)) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
smss)
in [Decl ()]
ds' 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(Name ()
n,Pat ()
p) -> (Name ()
n, Pat ()
p)) [NameBind ()]
ms
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind ()
l Pat ()
p Rhs ()
rhs Maybe (Binds ())
decls, [NameBind ()]
sms)
Decl ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Decl ()
d, [])
renameIrrPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats [Pat ()]
ps = forall a. RN a -> a
runRename (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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall l. l -> Pat l -> Pat l
PIrrPat ()
l Pat ()
q, [NameBind ()]
ms)
PInfixApp ()
l Pat ()
p1 QName ()
n Pat ()
p2 -> 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 -> 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 -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
PTuple ()
l Boxed
bx [Pat ()]
ps -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
PList ()
l [Pat ()]
ps -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
PParen ()
l Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
PRec ()
l QName ()
n [PatField ()]
pfs -> forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [PatField ()]
pfs (forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> RN (PatField (), [NameBind ()])
renameIrrPf
PAsPat ()
l Name ()
n Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
PatTypeSig ()
l Pat ()
p Type ()
t -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (\Pat ()
p -> 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) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [])
Just Pat ()
at -> do (Pat ()
at', [NameBind ()]
ns) <- Pat () -> RN (Pat (), [NameBind ()])
renameIrrP Pat ()
at
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Pat ()
at', [NameBind ()]
ns)
(Pat ()
q, [NameBind ()]
ns) <- forall a b c d.
[a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat [Pat ()]
ps (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
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat ()
q, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
nss forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns1 forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns)
PXETag ()
l XName ()
n [PXAttr ()]
attrs Maybe (Pat ())
mat -> do ([PXAttr ()]
as, [[NameBind ()]]
nss) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [])
Just Pat ()
at -> do (Pat ()
at', [NameBind ()]
ns) <- Pat () -> RN (Pat (), [NameBind ()])
renameIrrP Pat ()
at
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Pat ()
at', [NameBind ()]
ns)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall l. l -> XName l -> [PXAttr l] -> Maybe (Pat l) -> Pat l
PXETag ()
l XName ()
n [PXAttr ()]
as Maybe (Pat ())
mat', forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NameBind ()]]
nss forall a. [a] -> [a] -> [a]
++ [NameBind ()]
ns1)
PXPatTag ()
l Pat ()
p -> forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PXPatTag ()
l) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
Pat ()
_ -> 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) = forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> RN (Pat (), [NameBind ()])
renameIrrP
renameIrrPf PatField ()
pf = 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) = forall a b c d. a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat Pat ()
p (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 = 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 :: forall a. a -> Tr a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a 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 :: forall a. a -> Tr a
return a
a = forall a. (State -> HsxM (a, State)) -> Tr a
Tr forall a b. (a -> b) -> a -> b
$ \State
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, State
s)
(Tr State -> HsxM (a, State)
f) >>= :: forall a b. Tr a -> (a -> Tr b) -> Tr b
>>= a -> Tr b
k = forall a. (State -> HsxM (a, State)) -> Tr a
Tr 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 :: forall a b. (a -> b) -> Tr a -> Tr b
fmap a -> b
f Tr a
tra = Tr a
tra forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
liftTr :: HsxM a -> Tr a
liftTr :: forall a. HsxM a -> Tr a
liftTr HsxM a
hma = forall a. (State -> HsxM (a, State)) -> Tr a
Tr forall a b. (a -> b) -> a -> b
$ \State
s -> do a
a <- HsxM a
hma
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, State
s)
initState :: (Int, Int, Int, [a], [a], [a])
initState = 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 :: forall a. 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 forall {a} {a} {a}. (Int, Int, Int, [a], [a], [a])
initState
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall a. [a] -> [a]
reverse [Guard ()]
gs1, forall a. [a] -> [a]
reverse [Guard ()]
gs2, forall a. [a] -> [a]
reverse [Decl ()]
ds)
runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
runTrFromTo :: forall a.
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 forall a b. (a -> b) -> a -> b
$ forall {a} {b} {c} {a} {a} {a}.
Num a =>
b -> c -> (a, b, c, [a], [a], [a])
initStateFrom Int
k Int
l
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall a. [a] -> [a]
reverse [Guard ()]
gs1, forall a. [a] -> [a]
reverse [Guard ()]
gs2, forall a. [a] -> [a]
reverse [Decl ()]
ds, Int
k', Int
l')
getState :: Tr State
getState :: Tr State
getState = forall a. (State -> HsxM (a, State)) -> Tr a
Tr forall a b. (a -> b) -> a -> b
$ \State
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (State
s,State
s)
setState :: State -> Tr ()
setState :: State -> Tr ()
setState State
s = forall a. (State -> HsxM (a, State)) -> Tr a
Tr forall a b. (a -> b) -> a -> b
$ \State
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((),State
s)
updateState :: (State -> (a,State)) -> Tr a
updateState :: forall a. (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'
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
pushGuard :: Pat () -> Exp () -> Tr ()
pushGuard :: Pat () -> Exp () -> Tr ()
pushGuard Pat ()
p Exp ()
e = forall a. (State -> (a, State)) -> Tr a
updateState 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)forall a. a -> [a] -> [a]
:[Guard ()]
gs2,[Decl ()]
ds))
pushDecl :: Decl () -> Tr ()
pushDecl :: Decl () -> Tr ()
pushDecl Decl ()
d = forall a. (State -> (a, State)) -> Tr a
updateState 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 ()
dforall a. a -> [a] -> [a]
:[Decl ()]
ds))
pushAttrGuard :: Pat () -> Exp () -> Tr ()
pushAttrGuard :: Pat () -> Exp () -> Tr ()
pushAttrGuard Pat ()
p Exp ()
e = forall a. (State -> (a, State)) -> Tr a
updateState 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)forall a. a -> [a] -> [a]
:[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
genMatchName :: Tr (Name ())
genMatchName :: Tr (Name ())
genMatchName = do Int
k <- forall a. (State -> (a, State)) -> Tr a
updateState forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> (Int
n,(Int
nforall a. Num a => a -> a -> a
+Int
1,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Name l
Ident () forall a b. (a -> b) -> a -> b
$ String
"harp_match" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
genPatName :: Tr (Name ())
genPatName :: Tr (Name ())
genPatName = do Int
k <- forall a. (State -> (a, State)) -> Tr a
updateState forall a b. (a -> b) -> a -> b
$ \(Int
n,Int
m,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds) -> (Int
m,(Int
n,Int
mforall a. Num a => a -> a -> a
+Int
1,Int
a,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Name l
Ident () forall a b. (a -> b) -> a -> b
$ String
"harp_pat" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
genAttrName :: Tr (Name ())
genAttrName :: Tr (Name ())
genAttrName = do Int
k <- forall a. (State -> (a, State)) -> Tr a
updateState 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
aforall a. Num a => a -> a -> a
+Int
1,[Guard ()]
gs1,[Guard ()]
gs2,[Decl ()]
ds))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Name l
Ident () forall a b. (a -> b) -> a -> b
$ String
"hsx_attrs" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
setHarpTransformedT, setXmlTransformedT :: Tr ()
setHarpTransformedT :: Tr ()
setHarpTransformedT = forall a. HsxM a -> Tr a
liftTr HsxM ()
setHarpTransformed
setXmlTransformedT :: Tr ()
setXmlTransformedT = forall a. HsxM a -> Tr a
liftTr HsxM ()
setXmlTransformed
tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat :: forall a b c. 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ b -> c
f b
q
tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat :: forall a b c. 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [a]
ps [b] -> c
f a -> Tr b
tr = do [b]
qs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> Tr b
tr [a]
ps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [b] -> c
f [b]
qs
trPatterns :: [Pat ()] -> Tr [Pat ()]
trPatterns :: [Pat ()] -> Tr [Pat ()]
trPatterns = 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 (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
forall (m :: * -> *) a. Monad m => a -> m a
return 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, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat ()
ap
(Maybe (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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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
forall (m :: * -> *) a. Monad m => a -> m a
return 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, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat ()
ap
(Maybe (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
forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Pat ()
metaPcdata String
st)
PXPatTag ()
_ Pat ()
p -> Tr ()
setHarpTransformedT 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 forall a b. (a -> b) -> a -> b
$ forall l. l -> [RPat l] -> Pat l
PRPat ()
l [RPat ()]
rps
PViewPat ()
l Exp ()
e Pat ()
p -> do
Exp ()
e' <- forall a. HsxM a -> Tr a
liftTr forall a b. (a -> b) -> a -> b
$ Exp () -> HsxM (Exp ())
transformExpM Exp ()
e
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> Exp l -> Pat l -> Pat l
PViewPat ()
l Exp ()
e') Pat () -> Tr (Pat ())
trPattern
PVar ()
_ Name ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
PLit ()
_ Sign ()
_ Literal ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
PInfixApp ()
l Pat ()
p1 QName ()
op Pat ()
p2 -> forall a b c. a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat Pat ()
p1 Pat ()
p2 (\Pat ()
p1 Pat ()
p2 -> 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 -> forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (forall l. l -> QName l -> [Pat l] -> Pat l
PApp ()
l QName ()
n) Pat () -> Tr (Pat ())
trPattern
PTuple ()
l Boxed
bx [Pat ()]
ps -> forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple ()
l Boxed
bx) Pat () -> Tr (Pat ())
trPattern
PList ()
l [Pat ()]
ps -> forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [Pat ()]
ps (forall l. l -> [Pat l] -> Pat l
PList ()
l) Pat () -> Tr (Pat ())
trPattern
PParen ()
l Pat ()
p -> forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PParen ()
l) Pat () -> Tr (Pat ())
trPattern
PRec ()
l QName ()
n [PatField ()]
pfs -> forall a b c. [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat [PatField ()]
pfs (forall l. l -> QName l -> [PatField l] -> Pat l
PRec ()
l QName ()
n) PatField () -> Tr (PatField ())
trPatternField
PAsPat ()
l Name ()
n Pat ()
p -> forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> Name l -> Pat l -> Pat l
PAsPat ()
l Name ()
n) Pat () -> Tr (Pat ())
trPattern
PWildCard ()
l -> forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
PIrrPat ()
l Pat ()
p -> forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PIrrPat ()
l) Pat () -> Tr (Pat ())
trPattern
PatTypeSig ()
l Pat ()
p Type ()
t -> forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (\Pat ()
p -> forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig ()
l Pat ()
p Type ()
t) Pat () -> Tr (Pat ())
trPattern
PQuasiQuote ()
_ String
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Pat ()
p
PBangPat ()
l Pat ()
p -> forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> Pat l -> Pat l
PBangPat ()
l) Pat () -> Tr (Pat ())
trPattern
PNPlusK ()
_ Name ()
_ Integer
_ -> 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) =
forall a b c. a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat Pat ()
p (forall l. l -> QName l -> Pat l -> PatField l
PFieldPat ()
l QName ()
n) Pat () -> Tr (Pat ())
trPattern
trPatternField PatField ()
p = 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 forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> [Name ()] -> Decl ()
topDecl Name ()
n Name ()
mname [Name ()]
vars
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 = 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 forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn 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
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decl () -> Tr ()
pushDecl
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 = forall l. l -> String -> Name l
Ident () 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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) forall a b. (a -> b) -> a -> b
$
[Exp ()] -> Exp ()
tuple (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' <- forall a. HsxM a -> Tr a
liftTr forall a b. (a -> b) -> a -> b
$ Alt () -> HsxM (Alt ())
transformAlt Alt ()
alt1
forall (m :: * -> *) a. Monad m => a -> m a
return 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
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 forall a. [a] -> [a] -> [a]
++ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decl () -> Tr ()
pushDecl
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 = forall l. l -> String -> Name l
Ident () 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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) forall a b. (a -> b) -> a -> b
$
[Exp ()] -> Exp ()
tuple (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' <- forall a. HsxM a -> Tr a
liftTr forall a b. (a -> b) -> a -> b
$ Alt () -> HsxM (Alt ())
transformAlt Alt ()
alt1
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- 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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps Int
0 [(Name (), [Name ()], MType)]
nvts
vars :: [Name ()]
vars = 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 forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn 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 forall a b. (a -> b) -> a -> b
$ [Stmt ()]
gs forall a. [a] -> [a] -> [a]
++
[[Decl ()] -> Stmt ()
letStmt [Decl ()]
fldecls, Stmt ()
ret]
Decl () -> Tr ()
pushDecl forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
name Exp ()
rhs
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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
app
(Exp () -> Exp ()
paren forall a b. (a -> b) -> a -> b
$ Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun
([Exp ()] -> Exp ()
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
nns)) forall a b. (a -> b) -> a -> b
$ Exp ()
eList
in [Decl ()]
ds 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 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 forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
metaMap [Exp ()
f]
in Exp () -> Exp ()
paren 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 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 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
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, (Name ()
vforall 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 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
forall (m :: * -> *) a. Monad m => a -> m a
return (Name ()
n, (Name ()
vforall a. a -> [a] -> [a]
:[Name ()]
vs), MType
mt)
| Bool
otherwise -> case Name ()
v of
Ident () String
n -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Attempting to bind variable "forall a. [a] -> [a] -> [a]
++String
nforall a. [a] -> [a] -> [a]
++
String
" inside the context of a numerable regular pattern"
Name ()
_ -> forall a. HasCallStack => String -> a
error 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 forall a. Eq a => [a] -> [a] -> [a]
`union` [Name ()]
vs2
vals1 :: [Exp ()]
vals1 = forall a b. (a -> b) -> [a] -> [b]
map ([Name ()] -> Name () -> Exp ()
varOrId [Name ()]
vs1) [Name ()]
allvs
vals2 :: [Exp ()]
vals2 = forall a b. (a -> b) -> [a] -> [b]
map ([Name ()] -> Name () -> Exp ()
varOrId [Name ()]
vs2) [Name ()]
allvs
ret1 :: Exp ()
ret1 = Exp () -> Exp ()
metaReturn 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 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 forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
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 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 forall a b. (a -> b) -> a -> b
$ [Pat ()] -> Exp () -> Exp ()
lamE [Name () -> Pat ()
pvar Name ()
v] forall a b. (a -> b) -> a -> b
$
Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name)
(Exp () -> Exp ()
paren forall a b. (a -> b) -> a -> b
$ Bool -> Name () -> Exp ()
retVar Bool
linear Name ()
v)
Decl () -> Tr ()
pushDecl forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n forall a b. (a -> b) -> a -> b
$
Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun Exp ()
e
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 forall a b. (a -> b) -> a -> b
$ [Pat ()] -> Exp () -> Exp ()
lamE [Pat ()
wildcard] forall a b. (a -> b) -> a -> b
$
Exp () -> Exp () -> Exp ()
app (Name () -> Exp ()
con Name ()
just_name) (forall l. l -> Exp l
unit_con ())
Decl () -> Tr ()
pushDecl forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n forall a b. (a -> b) -> a -> b
$
Exp () -> Exp () -> Exp ()
app Exp ()
baseMatchFun Exp ()
e
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 forall a. [a] -> [a] -> [a]
++
Pat () -> [Name ()]
gatherPVars Pat ()
p2
PApp ()
_ QName ()
_ [Pat ()]
ps -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
ps
PTuple ()
_ Boxed
_ [Pat ()]
ps -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
ps
PList ()
_ [Pat ()]
ps -> 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 -> 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 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 -> 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 ->
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PXAttr () -> [Name ()]
gatherAttrVars [PXAttr ()]
attrs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat () -> [Name ()]
gatherPVars [Pat ()]
cps 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 ->
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PXAttr () -> [Name ()]
gatherAttrVars [PXAttr ()]
attrs 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 forall a. [a] -> [a] -> [a]
++ RPat () -> [Name ()]
gatherRPVars RPat ()
rq2
RPSeq ()
_ [RPat ()]
rqs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RPat () -> [Name ()]
gatherRPVars [RPat ()]
rqs
RPCAs ()
_ Name ()
n RPat ()
rq -> Name ()
n forall a. a -> [a] -> [a]
: RPat () -> [Name ()]
gatherRPVars RPat ()
rq
RPAs ()
_ Name ()
n RPat ()
rq -> Name ()
n 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 forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ Name () -> Name () -> Decl ()
baseMatchDecl Name ()
n Name ()
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)) forall a. a -> [a] -> [a]
:
Int
-> [(Name (), [Name ()], MType)] -> [(Stmt (), (Name (), MType))]
mkGenExps (Int
kforall 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) 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 = forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
vs
ret :: Stmt ()
ret = Exp () -> Stmt ()
qualStmt forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaReturn forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple
[Name () -> Exp ()
var Name ()
val, [Exp ()] -> Exp ()
tuple forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
mf (Name () -> Exp ()
var Name ()
val) forall a. a -> [a] -> [a]
: [Exp ()]
vars]
Decl () -> Tr ()
pushDecl forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n forall a b. (a -> b) -> a -> b
$ [Stmt ()] -> Exp ()
doE [Stmt ()
g, Stmt ()
ret]
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 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Exp ()
idFun) [Name ()]
vs
ret2 :: Exp ()
ret2 = Exp () -> Exp ()
metaReturn 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 (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 forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
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 (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 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 forall a b. (a -> b) -> a -> b
$ Name () -> Exp ()
var Name ()
varsname)
retExps :: [Exp ()]
retExps = forall a b. (a -> b) -> [a] -> [b]
map ((Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name () -> Exp ()
var) [Name ()]
vs
ret :: Exp ()
ret = Exp () -> Exp ()
metaReturn forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple forall a b. (a -> b) -> a -> b
$
[Name () -> Exp ()
var Name ()
valname, [Exp ()] -> Exp ()
tuple [Exp ()]
retExps]
Decl () -> Tr ()
pushDecl forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n forall a b. (a -> b) -> a -> b
$
[Stmt ()] -> Exp ()
doE [Stmt ()
g, [Decl ()] -> Stmt ()
letStmt [Decl ()
dec1, Decl ()
dec2], Exp () -> Stmt ()
qualStmt Exp ()
ret]
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 = 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 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 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 = forall a b. (a -> b) -> [a] -> [b]
map (Name (), Name ()) -> Exp ()
mkRetFormat forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple 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 forall a b. (a -> b) -> a -> b
$ Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
rhs
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 forall a b. (a -> b) -> a -> b
$ (Exp () -> Exp () -> Exp ()
app Exp ()
foldCompFun) 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 = forall l. l -> String -> Name l
Ident () String
"runMatch"
baseMatch_name :: Name ()
baseMatch_name = forall l. l -> String -> Name l
Ident () String
"baseMatch"
manyMatch_name :: Name ()
manyMatch_name = forall l. l -> String -> Name l
Ident () String
"manyMatch"
gManyMatch_name :: Name ()
gManyMatch_name = forall l. l -> String -> Name l
Ident () String
"gManyMatch"
match_mod, match_qual_mod :: ModuleName ()
match_mod :: ModuleName ()
match_mod = forall l. l -> String -> ModuleName l
ModuleName () String
"Harp.Match"
match_qual_mod :: ModuleName ()
match_qual_mod = 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 = forall l. l -> QName l -> QOp l
QVarOp () forall a b. (a -> b) -> a -> b
$ forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
match_qual_mod Name ()
choice
appendOp :: QOp ()
appendOp :: QOp ()
appendOp = forall l. l -> QName l -> QOp l
QVarOp () forall a b. (a -> b) -> a -> b
$ forall l. l -> Name l -> QName l
UnQual () Name ()
append
foldCompFun :: Exp ()
foldCompFun :: Exp ()
foldCompFun = Name () -> Exp ()
match_qual forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Name l
Ident () String
"foldComp"
mkMetaUnzip :: Int -> Exp () -> Exp ()
mkMetaUnzip :: Int -> Exp () -> Exp ()
mkMetaUnzip Int
k | Int
k forall a. Ord a => a -> a -> Bool
<= Int
7 = let n :: String
n = String
"unzip" forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ String
"unzip" forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
tuple forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name (), Name ()) -> Exp ()
appCons forall a b. (a -> b) -> a -> b
$ 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] 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 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 (forall a. [a] -> [a]
reverse [Exp ()]
es)
where mf :: String -> [Exp ()] -> Exp ()
mf String
s [] = Name () -> Exp ()
match_qual forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String
"harp_val" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
extendVar :: Name () -> String -> Name ()
extendVar :: Name () -> String -> Name ()
extendVar (Ident ()
l String
n) String
s = forall l. l -> String -> Name l
Ident ()
l forall a b. (a -> b) -> a -> b
$ String
n 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 -> (forall a. Maybe a
Nothing, String
s)
XDomName ()
_ String
d String
s -> (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 = 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 (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 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 forall a b. (a -> b) -> a -> b
$ Exp () -> Exp ()
metaJust Exp ()
e
consFun, idFun :: Exp ()
consFun :: Exp ()
consFun = 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 = forall l. l -> QName l -> Exp l
Con () forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Name l -> QName l
UnQual ()
cons :: QName ()
cons :: QName ()
cons = forall l. l -> SpecialCon l -> QName l
Special () (forall l. l -> SpecialCon l
Cons ())
fcomp, choice, append :: Name ()
fcomp :: Name ()
fcomp = forall l. l -> String -> Name l
Symbol () String
"."
choice :: Name ()
choice = forall l. l -> String -> Name l
Symbol () String
"+++"
append :: Name ()
append = forall l. l -> String -> Name l
Symbol () String
"++"
just_name, nothing_name, left_name, right_name :: Name ()
just_name :: Name ()
just_name = forall l. l -> String -> Name l
Ident () String
"Just"
nothing_name :: Name ()
nothing_name = forall l. l -> String -> Name l
Ident () String
"Nothing"
left_name :: Name ()
left_name = forall l. l -> String -> Name l
Ident () String
"Left"
right_name :: Name ()
right_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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp () -> Exp ()
metaFromStringLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
strE) Maybe String
d, Exp () -> Exp ()
metaFromStringLit forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
n]
m :: Exp () -> Exp ()
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Exp ()
x Exp ()
y -> Exp () -> Exp ()
paren 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 forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp () -> Exp ()
metaFromStringLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp ()
strE) Maybe String
d, Exp () -> Exp ()
metaFromStringLit forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
n]
m :: Exp () -> Exp ()
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Exp ()
x Exp ()
y -> Exp () -> Exp ()
paren 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 forall a b. (a -> b) -> a -> b
$ [Exp ()] -> Exp ()
listE forall a b. (a -> b) -> a -> b
$ 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 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 = forall l. l -> QName l -> QOp l
QConOp () forall a b. (a -> b) -> a -> b
$ forall l. l -> Name l -> QName l
UnQual () forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
d, Exp () -> Exp ()
metaFromStringLit forall a b. (a -> b) -> a -> b
$ String -> Exp ()
strE String
s]