-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Exts.Build
-- Copyright   :  (c) The GHC Team, 1997-2000,
--                (c) Niklas Broberg 2004
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
-- Stability   :  experimental
-- Portability :  portable
--
-- This module contains combinators to use when building
-- Haskell source trees programmatically, as opposed to
-- parsing them from a string. The contents here are quite
-- experimental and will likely receive a lot of attention
-- when the rest has stabilised.
--
-----------------------------------------------------------------------------

module Language.Haskell.Exts.Build (

    -- * Syntax building functions
    name,       -- :: String -> Name ()
    sym,        -- :: String -> Name ()
    var,        -- :: Name () -> Exp ()
    op,         -- :: Name () -> QOp
    qvar,       -- :: Module -> Name () -> Exp ()
    pvar,       -- :: Name () -> Pat ()
    app,        -- :: Exp () -> Exp () -> Exp ()
    infixApp,   -- :: Exp () -> QOp -> Exp () -> Exp ()
    appFun,     -- :: Exp () -> [Exp] -> Exp ()
    pApp,       -- :: Name () -> [Pat] -> Pat ()
    tuple,      -- :: [Exp] -> Exp ()
    pTuple,     -- :: [Pat] -> Pat ()
    varTuple,   -- :: [Name] -> Exp ()
    pvarTuple,  -- :: [Name] -> Pat ()
    function,   -- :: String -> Exp ()
    strE,       -- :: String -> Exp ()
    charE,      -- :: Char -> Exp ()
    intE,       -- :: Integer -> Exp ()
    strP,       -- :: String -> Pat ()
    charP,      -- :: Char -> Pat ()
    intP,       -- :: Integer -> Pat ()
    doE,        -- :: [Stmt] -> Exp ()
    lamE,       -- :: SrcLoc -> [Pat] -> Exp () -> Exp ()
    letE,       -- :: [Decl] -> Exp () -> Exp ()
    caseE,      -- :: Exp () -> [Alt] -> Exp ()
    alt,        -- :: SrcLoc -> Pat () -> Exp () -> Alt
    altGW,      -- :: SrcLoc -> Pat () -> [Stmt] -> Exp () -> Binds -> Alt
    listE,      -- :: [Exp] -> Exp ()
    eList,      -- :: Exp ()
    peList,     -- :: Pat ()
    paren,      -- :: Exp () -> Exp ()
    pParen,     -- :: Pat () -> Pat ()
    qualStmt,   -- :: Exp () -> Stmt
    genStmt,    -- :: SrcLoc -> Pat () -> Exp () -> Stmt
    letStmt,    -- :: [Decl] -> Stmt
    binds,      -- :: [Decl] -> Binds
    noBinds,    -- :: Binds
    wildcard,   -- :: Pat ()
    genNames,   -- :: String -> Int -> [Name]

    -- * More advanced building
    sfun,           -- :: SrcLoc -> Name () -> [Name] -> Rhs -> Binds -> Decl ()
    simpleFun,      -- :: SrcLoc -> Name () -> Name () -> Exp () -> Decl ()
    patBind,        -- :: SrcLoc -> Pat () -> Exp () -> Decl ()
    patBindWhere,   -- :: SrcLoc -> Pat () -> Exp () -> [Decl] -> Decl ()
    nameBind,       -- :: SrcLoc -> Name () -> Exp () -> Decl ()
    metaFunction,   -- :: String -> [Exp] -> Exp ()
    metaConPat      -- :: String -> [Pat] -> Pat ()
  ) where

import Language.Haskell.Exts.Syntax

-----------------------------------------------------------------------------
-- Help functions for Abstract syntax

-- | An identifier with the given string as its name.
--   The string should be a valid Haskell identifier.
name :: String -> Name ()
name :: String -> Name ()
name = () -> String -> Name ()
forall l. l -> String -> Name l
Ident ()

-- | A symbol identifier. The string should be a valid
--   Haskell symbol identifier.
sym :: String -> Name ()
sym :: String -> Name ()
sym = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol ()

-- | A local variable as expression.
var :: Name () -> Exp ()
var :: Name () -> Exp ()
var = () -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Var () (QName () -> Exp ()) -> (Name () -> QName ()) -> Name () -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual ()

-- | Use the given identifier as an operator.
op :: Name () -> QOp ()
op :: Name () -> QOp ()
op = () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (QName () -> QOp ()) -> (Name () -> QName ()) -> Name () -> QOp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual ()

-- | A qualified variable as expression.
qvar :: ModuleName () -> Name () -> Exp ()
qvar :: ModuleName () -> Name () -> Exp ()
qvar ModuleName ()
m Name ()
n = () -> QName () -> Exp ()
forall l. l -> QName l -> Exp l
Var () (QName () -> Exp ()) -> QName () -> Exp ()
forall a b. (a -> b) -> a -> b
$ () -> ModuleName () -> Name () -> QName ()
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
m Name ()
n

-- | A pattern variable.
pvar :: Name () -> Pat ()
pvar :: Name () -> Pat ()
pvar = () -> Name () -> Pat ()
forall l. l -> Name l -> Pat l
PVar ()

-- | Application of expressions by juxtaposition.
app :: Exp () -> Exp () -> Exp ()
app :: Exp () -> Exp () -> Exp ()
app = () -> Exp () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l -> Exp l
App ()

-- | Apply an operator infix.
infixApp :: Exp () -> QOp () -> Exp () -> Exp ()
infixApp :: Exp () -> QOp () -> Exp () -> Exp ()
infixApp = () -> Exp () -> QOp () -> Exp () -> Exp ()
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp ()

-- | Apply a function to a list of arguments.
appFun :: Exp () -> [Exp ()] -> Exp ()
appFun :: Exp () -> [Exp ()] -> Exp ()
appFun Exp ()
f [] = Exp ()
f
appFun Exp ()
f (Exp ()
a:[Exp ()]
as) = Exp () -> [Exp ()] -> Exp ()
appFun (Exp () -> Exp () -> Exp ()
app Exp ()
f Exp ()
a) [Exp ()]
as

-- | A constructor pattern, with argument patterns.
pApp :: Name () -> [Pat ()] -> Pat ()
pApp :: Name () -> [Pat ()] -> Pat ()
pApp Name ()
n [Pat ()]
ps = () -> QName () -> [Pat ()] -> Pat ()
forall l. l -> QName l -> [Pat l] -> Pat l
PApp () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name ()
n) [Pat ()]
ps

-- | A tuple expression.
tuple :: [Exp ()] -> Exp ()
tuple :: [Exp ()] -> Exp ()
tuple = () -> Boxed -> [Exp ()] -> Exp ()
forall l. l -> Boxed -> [Exp l] -> Exp l
Tuple () Boxed
Boxed

-- | A tuple pattern.
pTuple :: [Pat ()] -> Pat ()
pTuple :: [Pat ()] -> Pat ()
pTuple = () -> Boxed -> [Pat ()] -> Pat ()
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple () Boxed
Boxed

-- | A tuple expression consisting of variables only.
varTuple :: [Name ()] -> Exp ()
varTuple :: [Name ()] -> Exp ()
varTuple [Name ()]
ns = [Exp ()] -> Exp ()
tuple ([Exp ()] -> Exp ()) -> [Exp ()] -> Exp ()
forall a b. (a -> b) -> a -> b
$ (Name () -> Exp ()) -> [Name ()] -> [Exp ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Exp ()
var [Name ()]
ns

-- | A tuple pattern consisting of variables only.
pvarTuple :: [Name ()] -> Pat ()
pvarTuple :: [Name ()] -> Pat ()
pvarTuple [Name ()]
ns = [Pat ()] -> Pat ()
pTuple ([Pat ()] -> Pat ()) -> [Pat ()] -> Pat ()
forall a b. (a -> b) -> a -> b
$ (Name () -> Pat ()) -> [Name ()] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Pat ()
pvar [Name ()]
ns

-- | A function with a given name.
function :: String -> Exp ()
function :: String -> Exp ()
function = Name () -> Exp ()
var (Name () -> Exp ()) -> (String -> Name ()) -> String -> Exp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> String -> Name ()
forall l. l -> String -> Name l
Ident ()

-- | A literal string expression.
strE :: String -> Exp ()
strE :: String -> Exp ()
strE String
s = () -> Literal () -> Exp ()
forall l. l -> Literal l -> Exp l
Lit () (() -> String -> String -> Literal ()
forall l. l -> String -> String -> Literal l
String () String
s String
s)

-- | A literal character expression.
charE :: Char -> Exp ()
charE :: Char -> Exp ()
charE Char
c = () -> Literal () -> Exp ()
forall l. l -> Literal l -> Exp l
Lit () (() -> Char -> String -> Literal ()
forall l. l -> Char -> String -> Literal l
Char () Char
c [Char
c])

-- | A literal integer expression.
intE :: Integer -> Exp ()
intE :: Integer -> Exp ()
intE Integer
n = () -> Literal () -> Exp ()
forall l. l -> Literal l -> Exp l
Lit () (() -> Integer -> String -> Literal ()
forall l. l -> Integer -> String -> Literal l
Int () Integer
n (Integer -> String
forall a. Show a => a -> String
show Integer
n))

-- | A literal string pattern.
strP :: String -> Pat ()
strP :: String -> Pat ()
strP String
s = () -> Sign () -> Literal () -> Pat ()
forall l. l -> Sign l -> Literal l -> Pat l
PLit () (() -> Sign ()
forall l. l -> Sign l
Signless ()) (() -> String -> String -> Literal ()
forall l. l -> String -> String -> Literal l
String () String
s String
s)

-- | A literal character pattern.
charP :: Char -> Pat ()
charP :: Char -> Pat ()
charP Char
x = () -> Sign () -> Literal () -> Pat ()
forall l. l -> Sign l -> Literal l -> Pat l
PLit () (() -> Sign ()
forall l. l -> Sign l
Signless ()) (() -> Char -> String -> Literal ()
forall l. l -> Char -> String -> Literal l
Char () Char
x [Char
x])

-- | A literal integer pattern.
intP :: Integer -> Pat ()
intP :: Integer -> Pat ()
intP Integer
x = () -> Sign () -> Literal () -> Pat ()
forall l. l -> Sign l -> Literal l -> Pat l
PLit ()
          (if Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 then () -> Sign ()
forall l. l -> Sign l
Signless () else () -> Sign ()
forall l. l -> Sign l
Negative ())
          (() -> Integer -> String -> Literal ()
forall l. l -> Integer -> String -> Literal l
Int () (Integer -> Integer
forall a. Num a => a -> a
abs Integer
x) (Integer -> String
forall a. Show a => a -> String
show Integer
x))

-- | A do block formed by the given statements.
--   The last statement in the list should be
--   a 'Qualifier' expression.
doE :: [Stmt ()] -> Exp ()
doE :: [Stmt ()] -> Exp ()
doE = () -> [Stmt ()] -> Exp ()
forall l. l -> [Stmt l] -> Exp l
Do ()

-- | Lambda abstraction, given a list of argument
--   patterns and an expression body.
lamE :: [Pat ()] -> Exp () -> Exp ()
lamE :: [Pat ()] -> Exp () -> Exp ()
lamE = () -> [Pat ()] -> Exp () -> Exp ()
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda ()

-- | A @let@ ... @in@ block.
letE :: [Decl ()] -> Exp () -> Exp ()
letE :: [Decl ()] -> Exp () -> Exp ()
letE [Decl ()]
ds Exp ()
e = () -> Binds () -> Exp () -> Exp ()
forall l. l -> Binds l -> Exp l -> Exp l
Let () ([Decl ()] -> Binds ()
binds [Decl ()]
ds) Exp ()
e

-- | A @case@ expression.
caseE :: Exp () -> [Alt ()] -> Exp ()
caseE :: Exp () -> [Alt ()] -> Exp ()
caseE = () -> Exp () -> [Alt ()] -> Exp ()
forall l. l -> Exp l -> [Alt l] -> Exp l
Case ()

-- | An unguarded alternative in a @case@ expression.
alt :: Pat () -> Exp () -> Alt ()
alt :: Pat () -> Exp () -> Alt ()
alt Pat ()
p Exp ()
e = () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Alt ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt () Pat ()
p (Exp () -> Rhs ()
unGAlt Exp ()
e) Maybe (Binds ())
noBinds

-- | An alternative with a single guard in a @case@ expression.
altGW :: Pat () -> [Stmt ()] -> Exp () -> Binds () -> Alt ()
altGW :: Pat () -> [Stmt ()] -> Exp () -> Binds () -> Alt ()
altGW Pat ()
p [Stmt ()]
gs Exp ()
e Binds ()
w = () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Alt ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt () Pat ()
p ([Stmt ()] -> Exp () -> Rhs ()
gAlt [Stmt ()]
gs Exp ()
e) (Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just Binds ()
w)

-- | An unguarded righthand side of a @case@ alternative.
unGAlt :: Exp () -> Rhs ()
unGAlt :: Exp () -> Rhs ()
unGAlt = () -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
UnGuardedRhs ()

-- | An list of guarded righthand sides for a @case@ alternative.
gAlts :: [([Stmt ()],Exp ())] -> Rhs ()
gAlts :: [([Stmt ()], Exp ())] -> Rhs ()
gAlts [([Stmt ()], Exp ())]
as = () -> [GuardedRhs ()] -> Rhs ()
forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss () ([GuardedRhs ()] -> Rhs ()) -> [GuardedRhs ()] -> Rhs ()
forall a b. (a -> b) -> a -> b
$ (([Stmt ()], Exp ()) -> GuardedRhs ())
-> [([Stmt ()], Exp ())] -> [GuardedRhs ()]
forall a b. (a -> b) -> [a] -> [b]
map (\([Stmt ()]
gs,Exp ()
e) -> () -> [Stmt ()] -> Exp () -> GuardedRhs ()
forall l. l -> [Stmt l] -> Exp l -> GuardedRhs l
GuardedRhs () [Stmt ()]
gs Exp ()
e) [([Stmt ()], Exp ())]
as

-- | A single guarded righthand side for a @case@ alternative.
gAlt :: [Stmt ()] -> Exp () -> Rhs ()
gAlt :: [Stmt ()] -> Exp () -> Rhs ()
gAlt [Stmt ()]
gs Exp ()
e = [([Stmt ()], Exp ())] -> Rhs ()
gAlts [([Stmt ()]
gs,Exp ()
e)]

-- | A list expression.
listE :: [Exp ()] -> Exp ()
listE :: [Exp ()] -> Exp ()
listE = () -> [Exp ()] -> Exp ()
forall l. l -> [Exp l] -> Exp l
List ()

-- | The empty list expression.
eList :: Exp ()
eList :: Exp ()
eList = () -> [Exp ()] -> Exp ()
forall l. l -> [Exp l] -> Exp l
List () []

-- | The empty list pattern.
peList :: Pat ()
peList :: Pat ()
peList = () -> [Pat ()] -> Pat ()
forall l. l -> [Pat l] -> Pat l
PList () []

-- | Put parentheses around an expression.
paren :: Exp () -> Exp ()
paren :: Exp () -> Exp ()
paren = () -> Exp () -> Exp ()
forall l. l -> Exp l -> Exp l
Paren ()

-- | Put parentheses around a pattern.
pParen :: Pat () -> Pat ()
pParen :: Pat () -> Pat ()
pParen = () -> Pat () -> Pat ()
forall l. l -> Pat l -> Pat l
PParen ()

-- | A qualifier expression statement.
qualStmt :: Exp () -> Stmt ()
qualStmt :: Exp () -> Stmt ()
qualStmt = () -> Exp () -> Stmt ()
forall l. l -> Exp l -> Stmt l
Qualifier ()

-- | A generator statement: /pat/ @<-@ /exp/
genStmt :: Pat () -> Exp () -> Stmt ()
genStmt :: Pat () -> Exp () -> Stmt ()
genStmt = () -> Pat () -> Exp () -> Stmt ()
forall l. l -> Pat l -> Exp l -> Stmt l
Generator ()

-- | A @let@ binding group as a statement.
letStmt :: [Decl ()] -> Stmt ()
letStmt :: [Decl ()] -> Stmt ()
letStmt [Decl ()]
ds = () -> Binds () -> Stmt ()
forall l. l -> Binds l -> Stmt l
LetStmt () (Binds () -> Stmt ()) -> Binds () -> Stmt ()
forall a b. (a -> b) -> a -> b
$ [Decl ()] -> Binds ()
binds [Decl ()]
ds

-- | Hoist a set of declarations to a binding group.
binds :: [Decl ()] -> Binds ()
binds :: [Decl ()] -> Binds ()
binds = () -> [Decl ()] -> Binds ()
forall l. l -> [Decl l] -> Binds l
BDecls ()

-- | An empty binding group.
noBinds :: Maybe (Binds ())
noBinds :: Maybe (Binds ())
noBinds = Maybe (Binds ())
forall a. Maybe a
Nothing

-- | The wildcard pattern: @_@
wildcard :: Pat ()
wildcard :: Pat ()
wildcard = () -> Pat ()
forall l. l -> Pat l
PWildCard ()

-- | Generate k names by appending numbers 1 through k to a given string.
genNames :: String -> Int -> [Name ()]
genNames :: String -> Int -> [Name ()]
genNames String
s Int
k = [ () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
1..Int
k] ]

-------------------------------------------------------------------------------
-- Some more specialised help functions

-- | A function with a single clause
sfun :: Name () -> [Name ()] -> (Rhs ()) -> Maybe (Binds ()) -> Decl ()
sfun :: Name () -> [Name ()] -> Rhs () -> Maybe (Binds ()) -> Decl ()
sfun Name ()
f [Name ()]
pvs Rhs ()
rhs Maybe (Binds ())
bs = () -> [Match ()] -> Decl ()
forall l. l -> [Match l] -> Decl l
FunBind () [() -> Name () -> [Pat ()] -> Rhs () -> Maybe (Binds ()) -> Match ()
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match () Name ()
f ((Name () -> Pat ()) -> [Name ()] -> [Pat ()]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Pat ()
pvar [Name ()]
pvs) Rhs ()
rhs Maybe (Binds ())
bs]

-- | A function with a single clause, a single argument, no guards
-- and no where declarations
simpleFun :: Name () -> Name () -> Exp () -> Decl ()
simpleFun :: Name () -> Name () -> Exp () -> Decl ()
simpleFun Name ()
f Name ()
a Exp ()
e = let rhs :: Rhs ()
rhs = () -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
UnGuardedRhs () Exp ()
e
             in Name () -> [Name ()] -> Rhs () -> Maybe (Binds ()) -> Decl ()
sfun Name ()
f [Name ()
a] Rhs ()
rhs Maybe (Binds ())
noBinds

-- | A pattern bind where the pattern is a variable, and where
-- there are no guards and no 'where' clause.
patBind :: Pat () -> Exp () -> Decl ()
patBind :: Pat () -> Exp () -> Decl ()
patBind Pat ()
p Exp ()
e = let rhs :: Rhs ()
rhs = () -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
UnGuardedRhs () Exp ()
e
         in () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Decl ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind () Pat ()
p Rhs ()
rhs Maybe (Binds ())
noBinds

-- | A pattern bind where the pattern is a variable, and where
-- there are no guards, but with a 'where' clause.
patBindWhere :: Pat () -> Exp () -> [Decl ()] -> Decl ()
patBindWhere :: Pat () -> Exp () -> [Decl ()] -> Decl ()
patBindWhere Pat ()
p Exp ()
e [Decl ()]
ds = let rhs :: Rhs ()
rhs = () -> Exp () -> Rhs ()
forall l. l -> Exp l -> Rhs l
UnGuardedRhs () Exp ()
e
             in () -> Pat () -> Rhs () -> Maybe (Binds ()) -> Decl ()
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind () Pat ()
p Rhs ()
rhs (if [Decl ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Decl ()]
ds then Maybe (Binds ())
forall a. Maybe a
Nothing else Binds () -> Maybe (Binds ())
forall a. a -> Maybe a
Just ([Decl ()] -> Binds ()
binds [Decl ()]
ds))

-- | Bind an identifier to an expression.
nameBind :: Name () -> Exp () -> Decl ()
nameBind :: Name () -> Exp () -> Decl ()
nameBind Name ()
n Exp ()
e = Pat () -> Exp () -> Decl ()
patBind (Name () -> Pat ()
pvar Name ()
n) Exp ()
e

-- | Apply function of a given name to a list of arguments.
metaFunction :: String -> [Exp ()] -> Exp ()
metaFunction :: String -> [Exp ()] -> Exp ()
metaFunction String
s' [Exp ()]
es' = String -> [Exp ()] -> Exp ()
mf String
s' ([Exp ()] -> [Exp ()]
forall a. [a] -> [a]
reverse [Exp ()]
es')
  where mf :: String -> [Exp ()] -> Exp ()
mf String
s []     = Name () -> Exp ()
var (Name () -> Exp ()) -> Name () -> Exp ()
forall a b. (a -> b) -> a -> b
$ String -> Name ()
name String
s
        mf String
s (Exp ()
e:[Exp ()]
es) = Exp () -> Exp () -> Exp ()
app (String -> [Exp ()] -> Exp ()
mf String
s [Exp ()]
es) Exp ()
e

-- | Apply a constructor of a given name to a list of pattern
--   arguments, forming a constructor pattern.
metaConPat :: String -> [Pat ()] -> Pat ()
metaConPat :: String -> [Pat ()] -> Pat ()
metaConPat String
s [Pat ()]
ps = Name () -> [Pat ()] -> Pat ()
pApp (String -> Name ()
name String
s) [Pat ()]
ps