Ticket #3865: testinput

    -- | Generate declarations for optional patterns, ? and #?.
    -- (Unfortunally we must place this function here since both variations
    -- of transformations of optional patterns should be able to call it...)
    mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
    mkOptDecl s greedy nvt@(_, vs, t) = do
        -- Un nome, s'il vouz plaît.
        n <- genMatchName
        let -- Generate a generator for matching the subpattern
            (g, val) = mkGenExp s nvt               -- (harp_valX, (foo, bar, ...)) <- harp_matchY
            -- ... and apply a Just to its value
            ret1 = metaReturn $ tuple               -- return (Just harp_val1, (foo, bar, ...))
                    [app (var just_name)
                     (var val), varTuple vs]
            -- ... and do those two steps in a do-expression
            exp1 = doE [g, qualStmt ret1]           -- do ....
            -- For the non-matching branch, all the variables should be empty
            ids  = map (const idFun) vs             -- (id, id, ...)
            -- ... and the value should be Nothing.
            ret2 = metaReturn $ tuple               -- return (Nothing, (id, id, ...))
                    [var nothing_name, tuple ids]   -- i.e. no vars were bound
            -- The order of the arguments to the choice (+++) operator
            -- is determined by greed...
            mc   = if greedy
                    then metaChoice        -- standard order
                    else (flip metaChoice) -- reversed order
            -- ... and then apply it to the branches.
            rhs  = (paren exp1) `mc`                -- (do ....) +++
                    (paren ret2)                    --  (return (Nothing, .....))
        -- Finally we create a declaration for this function and
        -- add it to the store.
        pushDecl $ nameBind s n rhs                 -- harp_matchZ = (do ....) +++ (return ....)
        -- The type of the returned value will be Maybe the type
        -- of the value of the subpattern.
        return (n, vs, M t)

    -- | Generate declarations for star patterns, * and #*
    -- (Unfortunally we must place this function here since both variations
    -- of transformations of repeating patterns should be able to call it...)
    mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
    mkStarDecl s greedy (mname, vs, t) = do
        -- Ett namn, tack!
        n <- genMatchName
        let -- Create a generator that matches the subpattern
            -- many times, either greedily or non-greedily
            g = mkManyGen s greedy mname
            -- ... and unzip the result, choosing the proper unzip
            -- function depending on the number of variables returned.
            metaUnzipK = mkMetaUnzip s (length vs)
            -- ... first unzip values from variables
            dec1    = patBind s (pvarTuple [valname, varsname])
                    (metaUnzip $ var valsvarsname)
            -- ... and then unzip the variables
            dec2    = patBind s (pvarTuple vs)
                    (metaUnzipK $ var varsname)
            -- ... fold all the values for variables
            retExps = map ((app foldCompFun) . var) vs
            -- ... and return value and variables
            ret     = metaReturn $ tuple $
                    [var valname, tuple retExps]
        -- Finally we need to generate a function that does all this,
        -- using a let-statement for the non-monadic stuff and a
        -- do-expression to wrap it all in.
        pushDecl $ nameBind s n $
            doE [g, letStmt [dec1, dec2], qualStmt ret]
        -- The type of the returned value is a list ([]) of the
        -- type of the subpattern.
        return (n, vs, L t)

    -- | Generate declarations for plus patterns, + and #+
    -- (Unfortunally we must place this function here since both variations
    -- of transformations of non-empty repeating patterns should be able to call it...)
    mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
    mkPlusDecl s greedy nvt@(mname, vs, t) = do
        -- and now I've run out of languages...
        n <- genMatchName
        let k = length vs
            -- First we want a generator to match the
            -- subpattern exactly one time
            (g1, val1) = mkGenExp s nvt                     -- (harp_valX, (foo, ...)) <- harpMatchY
            -- ... and then one that matches it many times.
            g2         = mkManyGen s greedy mname           -- harp_vvs <- manyMatch harpMatchY
            -- ... we want to unzip the result, using
            -- the proper unzip function
            metaUnzipK = mkMetaUnzip s k
            -- ... first unzip values from variables
            dec1    = patBind s                             -- (harp_vals, harp_vars) = unzip harp_vvs
                        (pvarTuple [valsname, varsname])
                        (metaUnzip $ var valsvarsname)
            -- .. now we need new fresh names for variables
            -- since the ordinary ones are already taken.
            vlvars  = genNames "harp_vl" k
            -- ... and then we can unzip the variables
            dec2    = patBind s (pvarTuple vlvars)          -- (harp_vl1, ...) = unzipK harp_vars
                        (metaUnzipK $ var varsname)
            -- .. and do the unzipping in a let-statement
            letSt   = letStmt [dec1, dec2]
            -- ... fold variables from the many-match,
            -- prepending the variables from the single match
            retExps = map mkRetFormat $ zip vs vlvars       -- foo . (foldComp harp_vl1), ...
            -- ... prepend values from the single match to
            -- those of the many-match.
            retVal  = (var val1) `metaCons`
                        (var valsname)                      -- harp_valX : harp_vals
            -- ... return all values and variables
            ret     = metaReturn $ tuple $                  -- return (harp_valX:harpVals,
                        [retVal, tuple retExps]             --   (foo . (...), ...))
            -- ... and wrap all of it in a do-expression.
            rhs     = doE [g1, g2, letSt, qualStmt ret]
        -- Finally we create a declaration for this function and
        -- add it to the store.
        pushDecl $ nameBind s n rhs
        -- The type of the returned value is a list ([]) of the
        -- type of the subpattern.
        return (n, vs, L t)

      where mkRetFormat :: (Name, Name) -> Exp
            mkRetFormat (v, vl) =
                -- Prepend variables using function composition.
                (var v) `metaComp`
                  (paren $ (app foldCompFun) $ var vl)


--------------------------------------------------------------------------
-- HaRP-specific functions and ids

-- | Functions and ids from the @Match@ module,
-- used in the generated matching functions
runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: Exp
runMatchFun = match_qual runMatch_name
baseMatchFun = match_qual baseMatch_name
manyMatchFun = match_qual manyMatch_name
gManyMatchFun = match_qual gManyMatch_name

runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: Name
runMatch_name = Ident "runMatch"
baseMatch_name = Ident "baseMatch"
manyMatch_name = Ident "manyMatch"
gManyMatch_name = Ident "gManyMatch"

match_mod, match_qual_mod :: ModuleName
match_mod = ModuleName "Harp.Match"
match_qual_mod = ModuleName "HaRPMatch"

match_qual :: Name -> Exp
match_qual = qvar match_qual_mod

choiceOp :: QOp
choiceOp = QVarOp $ Qual match_qual_mod choice

appendOp :: QOp
appendOp = QVarOp $ UnQual append

-- foldComp = foldl (.) id, i.e. fold by composing
foldCompFun :: Exp
foldCompFun = match_qual $ Ident "foldComp"

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

matchFunction :: String -> [Exp] -> Exp
matchFunction s es = mf s (reverse es)
  where mf s []     = match_qual $ Ident s
        mf s (e:es) = app (mf s es) e

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

varsname :: Name
varsname = name "harp_vars"

valname :: Name
valname = name "harp_val"

valsname :: Name
valsname = name "harp_vals"

valsvarsname :: Name
valsvarsname = name "harp_vvs"

mkValName :: Int -> Name
mkValName k = name $ "harp_val" ++ show k

extendVar :: Name -> String -> Name
extendVar (Ident n) s = Ident $ n ++ s
extendVar n _ = n

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

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

metaReturn, metaConst, metaMap, metaUnzip :: Exp -> Exp
metaReturn e = metaFunction "return" [e]
metaConst e  = metaFunction "const" [e]
metaMap e    = metaFunction "map" [e]
metaUnzip e  = metaFunction "unzip" [e]

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

metaConcat :: [Exp] -> Exp
metaConcat es = metaFunction "concat" [listE es]

metaAppend :: Exp -> Exp -> Exp
metaAppend l1 l2 = infixApp l1 appendOp l2

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

metaPCons :: Pat -> Pat -> Pat
metaPCons p1 p2 = PInfixApp p1 cons p2

metaCons, metaComp :: Exp -> Exp -> Exp
metaCons e1 e2 = infixApp e1 (QConOp cons) e2
metaComp e1 e2 = infixApp e1 (op fcomp) e2

metaPJust :: Pat -> Pat
metaPJust p = pApp just_name [p]

metaPNothing :: Pat
metaPNothing = pvar nothing_name

metaPMkMaybe :: Maybe Pat -> Pat
metaPMkMaybe mp = case mp of
    Nothing -> metaPNothing
    Just p  -> pParen $ metaPJust p

metaJust :: Exp -> Exp
metaJust e = app (var just_name) e

metaNothing :: Exp
metaNothing = var nothing_name

metaMkMaybe :: Maybe Exp -> Exp
metaMkMaybe me = case me of
    Nothing -> metaNothing
    Just e  -> paren $ metaJust e

---------------------------------------------------
-- some other useful functions at abstract level
consFun, idFun :: Exp
consFun = Con cons
idFun = function "id"

cons :: QName
cons = Special Cons

fcomp, choice, append :: Name
fcomp = Symbol "."
choice = Symbol "+++"
append = Symbol "++"

just_name, nothing_name, left_name, right_name :: Name
just_name = Ident "Just"
nothing_name = Ident "Nothing"
left_name = Ident "Left"
right_name = Ident "Right"

------------------------------------------------------------------------
-- Help functions for meta programming xml

{- No longer used.
hsx_data_mod :: ModuleName
hsx_data_mod = ModuleName "HSP.Data"

-- Also no longer used, literal PCDATA should be considered a string.
-- | Create an xml PCDATA value
metaMkPcdata :: String -> Exp
metaMkPcdata s = metaFunction "pcdata" [strE s]
-}

-- | Create an xml tag, given its domain, name, attributes and
-- children.
metaGenElement :: XName -> [Exp] -> Maybe Exp -> [Exp] -> Exp
metaGenElement name ats mat cs =
    let (d,n) = xNameParts name
        ne    = tuple [metaMkMaybe $ fmap strE d, strE n]
        m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaAsAttr x)) mat
        attrs = m $ listE $ map metaAsAttr ats
     in metaFunction "genElement" [ne, attrs, listE cs]

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

-- | Create an attribute by applying the overloaded @asAttr@
metaAsAttr :: Exp -> Exp
metaAsAttr e = metaFunction "asAttr" [e]

-- | Create a property from an attribute and a value.
metaAssign :: Exp -> Exp -> Exp
metaAssign e1 e2 = infixApp e1 assignOp e2
  where assignOp = QVarOp $ UnQual $ Symbol ":="

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


-- TODO: We need to fix the stuff below so pattern matching on XML could also be overloaded.
-- Right now it only works on HSP XML, or anything that is syntactically identical to it.

-- | Lookup an attribute in the set of attributes.
metaExtract :: XName -> Name -> Exp
metaExtract name attrs =
    let (d,n) = xNameParts name
        np    = tuple [metaMkMaybe $ fmap strE d, strE n]
     in metaFunction "extract" [np, var attrs]

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

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

metaMkName :: XName -> Exp
metaMkName n = case n of
    XName s      -> strE s
    XDomName d s -> tuple [strE d, strE s]