-- |
--
-- Module:      Control.Egison.QQ
-- Description: Quasi-quoter to construct queries
-- Stability:   experimental
--
-- This module provides 'QuasiQuoter' that builds 'Query' from nice pattern expressions.

{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}

module Control.Egison.QQ
  ( mc
  , PP(..)
  )
where

-- imports to create 'Name' in compilation
import           Control.Monad                  ( MonadPlus(..) )
import           Control.Monad.Search           ( MonadSearch(..) )

-- main
import           Data.Maybe                     ( mapMaybe )
import           Text.Read                      ( readMaybe )
import           Data.Foldable                  ( foldrM )

import           Language.Haskell.TH            ( Q
                                                , Loc(..)
                                                , Exp(..)
                                                , Pat(..)
                                                , Dec(..)
                                                , Body(..)
                                                , Name
                                                , location
                                                , extsEnabled
                                                , newName
                                                , mkName
                                                , nameBase
                                                )
import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
import           Language.Haskell.TH           as TH
                                                ( Extension )
import           Language.Haskell.Meta.Syntax.Translate
                                                ( toExp )
import           Language.Haskell.Exts.Extension
                                                ( Extension(EnableExtension) )
import           Language.Haskell.Exts.Extension
                                               as Exts
                                                ( KnownExtension )
import           Language.Haskell.Exts.Parser   ( ParseResult(..)
                                                , defaultParseMode
                                                , parseExpWithMode
                                                )
import qualified Language.Haskell.Exts.Parser  as Exts
                                                ( ParseMode(..) )
import           Language.Egison.Syntax.Pattern
                                               as Pat
                                                ( Expr(..) )
import qualified Language.Egison.Parser.Pattern
                                               as Pat
                                                ( parseNonGreedy )
import           Language.Egison.Parser.Pattern ( Fixity(..)
                                                , ParseFixity(..)
                                                , Associativity(..)
                                                , Precedence(..)
                                                )
import           Language.Egison.Parser.Pattern.Mode.Haskell.TH
                                                ( ParseMode(..) )

-- | Quasi-quoter for pattern expressions.
mc :: QuasiQuoter
mc :: QuasiQuoter
mc = QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
compile
                 , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
forall a. HasCallStack => a
undefined
                 , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined
                 , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
forall a. HasCallStack => a
undefined
                 }

listFixities :: [ParseFixity Name String]
listFixities :: [ParseFixity Name String]
listFixities =
  [ Fixity Name
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall n s. Fixity n -> ExtParser s () -> ParseFixity n s
ParseFixity (Associativity -> Precedence -> Name -> Fixity Name
forall n. Associativity -> Precedence -> n -> Fixity n
Fixity Associativity
AssocRight (Int -> Precedence
Precedence Int
5) (String -> Name
mkName String
"join")) ((Tokens String -> Either String ()) -> ParseFixity Name String)
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String ()
forall {a}. (Eq a, Show a) => a -> a -> Either String ()
parser String
"++"
  , Fixity Name
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall n s. Fixity n -> ExtParser s () -> ParseFixity n s
ParseFixity (Associativity -> Precedence -> Name -> Fixity Name
forall n. Associativity -> Precedence -> n -> Fixity n
Fixity Associativity
AssocRight (Int -> Precedence
Precedence Int
5) (String -> Name
mkName String
"cons")) ((Tokens String -> Either String ()) -> ParseFixity Name String)
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String ()
forall {a}. (Eq a, Show a) => a -> a -> Either String ()
parser String
":"
  , Fixity Name
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall n s. Fixity n -> ExtParser s () -> ParseFixity n s
ParseFixity (Associativity -> Precedence -> Name -> Fixity Name
forall n. Associativity -> Precedence -> n -> Fixity n
Fixity Associativity
AssocRight (Int -> Precedence
Precedence Int
5) (String -> Name
mkName String
"app" )) ((Tokens String -> Either String ()) -> ParseFixity Name String)
-> (Tokens String -> Either String ()) -> ParseFixity Name String
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String ()
forall {a}. (Eq a, Show a) => a -> a -> Either String ()
parser String
"$"
  ]
 where
  parser :: a -> a -> Either String ()
parser a
symbol a
content | a
symbol a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
content = () -> Either String ()
forall a b. b -> Either a b
Right ()
                        | Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
symbol String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is expected"

parseMode :: Q Exts.ParseMode
parseMode :: Q ParseMode
parseMode = do
  Loc { String
loc_filename :: String
loc_filename :: Loc -> String
loc_filename } <- Q Loc
location
  [Extension]
extensions <- (Extension -> Maybe Extension) -> [Extension] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((KnownExtension -> Extension)
-> Maybe KnownExtension -> Maybe Extension
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KnownExtension -> Extension
EnableExtension (Maybe KnownExtension -> Maybe Extension)
-> (Extension -> Maybe KnownExtension)
-> Extension
-> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> Maybe KnownExtension
convertExt) ([Extension] -> [Extension]) -> Q [Extension] -> Q [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Extension]
extsEnabled
  ParseMode -> Q ParseMode
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseMode
defaultParseMode { Exts.parseFilename = loc_filename, Exts.extensions }
 where
  convertExt :: TH.Extension -> Maybe Exts.KnownExtension
  convertExt :: Extension -> Maybe KnownExtension
convertExt = String -> Maybe KnownExtension
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe KnownExtension)
-> (Extension -> String) -> Extension -> Maybe KnownExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall a. Show a => a -> String
show

parseExp :: Exts.ParseMode -> String -> Q Exp
parseExp :: ParseMode -> String -> Q Exp
parseExp ParseMode
mode String
content = case ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
parseExpWithMode ParseMode
mode String
content of
  ParseOk Exp SrcSpanInfo
x       -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
toExp Exp SrcSpanInfo
x
  ParseFailed SrcLoc
_ String
e -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e

compile :: String -> Q Exp
compile :: String -> Q Exp
compile String
content = do
  ParseMode
mode        <- Q ParseMode
parseMode
  (Expr Name Name Exp
pat, String
rest) <- ParseMode -> String -> Q (Expr Name Name Exp, String)
parsePatternExpr ParseMode
mode String
content
  String
bodySource  <- String -> Q String
forall {f :: * -> *}. MonadFail f => String -> f String
takeBody String
rest
  Exp
body        <- ParseMode -> String -> Q Exp
parseExp ParseMode
mode String
bodySource
  Expr Name Name Exp -> Exp -> Q Exp
compilePattern Expr Name Name Exp
pat Exp
body
 where
  takeBody :: String -> f String
takeBody (Char
'-' : Char
'>' : String
xs) = String -> f String
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
xs
  takeBody String
xs               = String -> f String
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f String) -> String -> f String
forall a b. (a -> b) -> a -> b
$ String
"\"->\" is expected, but found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
xs

parsePatternExpr
  :: Exts.ParseMode -> String -> Q (Pat.Expr Name Name Exp, String)
parsePatternExpr :: ParseMode -> String -> Q (Expr Name Name Exp, String)
parsePatternExpr ParseMode
haskellMode String
content = case ParseMode
-> String -> Either (Errors String) (Expr Name Name Exp, String)
forall a s mode (m :: * -> *).
(Parsable a s mode, MonadError (Errors s) m) =>
mode -> s -> m (a, s)
forall (m :: * -> *).
MonadError (Errors String) m =>
ParseMode -> String -> m (Expr Name Name Exp, String)
Pat.parseNonGreedy ParseMode
mode String
content of
  Left  Errors String
e -> String -> Q (Expr Name Name Exp, String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Expr Name Name Exp, String))
-> String -> Q (Expr Name Name Exp, String)
forall a b. (a -> b) -> a -> b
$ Errors String -> String
forall a. Show a => a -> String
show Errors String
e
  Right (Expr Name Name Exp, String)
x -> (Expr Name Name Exp, String) -> Q (Expr Name Name Exp, String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr Name Name Exp, String)
x
  where mode :: ParseMode
mode = ParseMode { ParseMode
haskellMode :: ParseMode
haskellMode :: ParseMode
haskellMode, fixities :: Maybe [ParseFixity Name String]
fixities = [ParseFixity Name String] -> Maybe [ParseFixity Name String]
forall a. a -> Maybe a
Just [ParseFixity Name String]
listFixities }

compilePattern :: Pat.Expr Name Name Exp -> Exp -> Q Exp
compilePattern :: Expr Name Name Exp -> Exp -> Q Exp
compilePattern Expr Name Name Exp
pat Exp
body = do
  Name
mName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mat"
  Name
tName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tgt"
  Exp
body' <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
pat Name
mName Name
tName (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) Exp
body)
  case Expr Name Name Exp
pat of
    Expr Name Name Exp
Pat.Wildcard   -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Pat
WildP, Pat
WildP]] Exp
body'
    Pat.Variable Name
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Pat
WildP, Name -> Pat
VarP Name
tName]] Exp
body'
    Expr Name Name Exp
_              -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP [Name -> Pat
VarP Name
mName, Name -> Pat
VarP Name
tName]] Exp
body'
 where
  let_ :: Pat -> Exp -> Exp -> Exp
let_ Pat
p Exp
e1 = [Dec] -> Exp -> Exp
LetE [Pat -> Body -> [Dec] -> Dec
ValD Pat
p (Exp -> Body
NormalB Exp
e1) []]
  sbind_ :: Exp -> Exp -> Exp
sbind_ Exp
x Exp
f = Exp -> Exp
ParensE (Exp -> Exp -> Exp -> Exp
UInfixE (Exp -> Exp
ParensE Exp
x) (Name -> Exp
VarE Name
sbindOp) (Exp -> Exp
ParensE Exp
f))
  plusName :: Name
plusName = 'Control.Monad.mplus
  sbindOp :: Name
sbindOp  = '(>>=)
  lnotName :: Name
lnotName = 'Control.Monad.Search.lnot
  go :: Pat.Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
  go :: Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
Pat.Wildcard     Name
_ Name
_     Exp
body = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
body
  go (Pat.Variable Name
x) Name
_ Name
tName Exp
body = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Exp -> Exp -> Exp
let_ (Name -> Pat
VarP Name
x) (Name -> Exp
VarE Name
tName) Exp
body
  go (Pat.Value Exp
e) Name
mName Name
tName Exp
body =
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE
                   (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"value")) Exp
e) ([Maybe Exp] -> Exp
TupE [])) (Name -> Exp
VarE Name
mName)
                   )
                   (Name -> Exp
VarE Name
tName)
                 )
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP []] Exp
body
  go (Pat.Predicate Exp
e) Name
_ Name
tName Exp
body =
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Control.Monad.Search.guard) (Exp -> Exp -> Exp
AppE Exp
e (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP []] Exp
body
  go (Pat.And Expr Name Name Exp
p1 Expr Name Name Exp
p2) Name
mName Name
tName Exp
body =
    Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p2 Name
mName Name
tName Exp
body Q Exp -> (Exp -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p1 Name
mName Name
tName
  go (Pat.Or Expr Name Name Exp
p1 Expr Name Name Exp
p2) Name
mName Name
tName Exp
body = do
    Exp
r1 <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p1 Name
mName Name
tName (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) ([Maybe Exp] -> Exp
TupE []))
    Exp
r2 <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p2 Name
mName Name
tName (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) ([Maybe Exp] -> Exp
TupE []))
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
plusName) Exp
r1) Exp
r2 Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP []] Exp
body
  go (Pat.Not Expr Name Name Exp
p) Name
mName Name
tName Exp
body = do
    Exp
r <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p Name
mName Name
tName (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) ([Maybe Exp] -> Exp
TupE []))
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
lnotName) Exp
r Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP []] Exp
body
  go (Pat.Collection [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body =
    Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go ([Expr Name Name Exp] -> Expr Name Name Exp
desugarCollection [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body
  go (Pat.Tuple [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body = Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go ([Expr Name Name Exp] -> Expr Name Name Exp
desugarTuple [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body
  -- PROBLEM: Ad-hoc optimization
  go (Pat.Infix Name
c1 Expr Name Name Exp
Pat.Wildcard (Pat.Infix Name
c2 Expr Name Name Exp
p Expr Name Name Exp
Pat.Wildcard)) Name
mName Name
tName Exp
body
    | Name -> String
nameBase Name
c1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"join", Name -> String
nameBase Name
c2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cons" = Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go
      (Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pattern (String -> Name
mkName String
"elm") [Expr Name Name Exp
p])
      Name
mName
      Name
tName
      Exp
body
  -- PROBLEM: Ad-hoc optimization
  go (Pat.Infix Name
c1 Expr Name Name Exp
p1 (Pat.Infix Name
c2 Expr Name Name Exp
p2 Expr Name Name Exp
p3)) Name
mName Name
tName Exp
body
    | Name -> String
nameBase Name
c1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"join", Name -> String
nameBase Name
c2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cons" = Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go
      (Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pattern (String -> Name
mkName String
"joinCons") [Expr Name Name Exp
p1, Expr Name Name Exp
p2, Expr Name Name Exp
p3])
      Name
mName
      Name
tName
      Exp
body
  -- PROBLEM: Ad-hoc optimization
  go (Pat.Infix Name
c1 Expr Name Name Exp
p1 (Pat.Infix Name
c2 Expr Name Name Exp
p2 Expr Name Name Exp
p3)) Name
mName Name
tName Exp
body
    | Name -> String
nameBase Name
c1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"app", Name -> String
nameBase Name
c2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"cons" = Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go
      (Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pattern (String -> Name
mkName String
"appCons") [Expr Name Name Exp
p1, Expr Name Name Exp
p2, Expr Name Name Exp
p3])
      Name
mName
      Name
tName
      Exp
body
  go (Pat.Infix Name
n Expr Name Name Exp
p1 Expr Name Name Exp
p2) Name
mName Name
tName Exp
body =
    Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go (Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pattern Name
n [Expr Name Name Exp
p1, Expr Name Name Exp
p2]) Name
mName Name
tName Exp
body
  go (Pat.Pattern Name
cName []) Name
mName Name
tName Exp
body =
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
cName) ([Maybe Exp] -> Exp
TupE [])) (Name -> Exp
VarE Name
mName)) (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP []] Exp
body
  go (Pat.Pattern Name
cName [Expr Name Name Exp
p]) Name
mName Name
tName Exp
body | Expr Name Name Exp -> Bool
isPatVar Expr Name Name Exp
p = do
    Name
mName' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpM"
    Name
tName' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpT"
    let pp :: Exp
pp = Expr Name Name Exp -> Exp
toPP Expr Name Name Exp
p
    Exp
body' <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p Name
mName' Name
tName' Exp
body
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
cName) Exp
pp) (Name -> Exp
VarE Name
mName)) (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [Expr Name Name Exp -> Name -> Pat
tNameToVar Expr Name Name Exp
p Name
tName'] Exp
body'
  go (Pat.Pattern Name
cName [Expr Name Name Exp
p]) Name
mName Name
tName Exp
body = do
    Name
mName' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpM"
    Name
tName' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpT"
    let pp :: Exp
pp = Expr Name Name Exp -> Exp
toPP Expr Name Name Exp
p
    Exp
body' <- Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p Name
mName' Name
tName' Exp
body
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Pat -> Exp -> Exp -> Exp
let_
                 (Expr Name Name Exp -> Name -> Pat
mNameToVar Expr Name Name Exp
p Name
mName')
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName (Name -> String
forall a. Show a => a -> String
show Name
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"M"))) (Name -> Exp
VarE Name
mName))
                       (Name -> Exp
VarE Name
tName)
                 )
      (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
cName) Exp
pp) (Name -> Exp
VarE Name
mName)) (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [Expr Name Name Exp -> Name -> Pat
tNameToVar Expr Name Name Exp
p Name
tName'] Exp
body'
  go (Pat.Pattern Name
cName [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body | (Expr Name Name Exp -> Bool) -> [Expr Name Name Exp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Name Name Exp -> Bool
isPatVar [Expr Name Name Exp]
ps = do
    [Name]
mNames <- (Expr Name Name Exp -> Q Name) -> [Expr Name Name Exp] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Expr Name Name Exp
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpM") [Expr Name Name Exp]
ps
    [Name]
tNames <- (Expr Name Name Exp -> Q Name) -> [Expr Name Name Exp] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Expr Name Name Exp
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpT") [Expr Name Name Exp]
ps
#if MIN_VERSION_template_haskell(2,16,0)
    let pps :: [Maybe Exp]
pps = (Expr Name Name Exp -> Maybe Exp)
-> [Expr Name Name Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp)
-> (Expr Name Name Exp -> Exp) -> Expr Name Name Exp -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Name Name Exp -> Exp
toPP) [Expr Name Name Exp]
ps
#else
    let pps = map toPP ps
#endif
    Exp
body' <- ((Expr Name Name Exp, Name, Name) -> Exp -> Q Exp)
-> Exp -> [(Expr Name Name Exp, Name, Name)] -> Q Exp
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Expr Name Name Exp, Name, Name) -> Exp -> Q Exp
go' Exp
body ([Expr Name Name Exp]
-> [Name] -> [Name] -> [(Expr Name Name Exp, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Expr Name Name Exp]
ps [Name]
mNames [Name]
tNames)
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
cName) ([Maybe Exp] -> Exp
TupE [Maybe Exp]
pps)) (Name -> Exp
VarE Name
mName)) (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP ((Expr Name Name Exp -> Name -> Pat)
-> [Expr Name Name Exp] -> [Name] -> [Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expr Name Name Exp -> Name -> Pat
tNameToVar [Expr Name Name Exp]
ps [Name]
tNames)] Exp
body'
  go (Pat.Pattern Name
cName [Expr Name Name Exp]
ps) Name
mName Name
tName Exp
body = do
    [Name]
mNames <- (Expr Name Name Exp -> Q Name) -> [Expr Name Name Exp] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Expr Name Name Exp
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpM") [Expr Name Name Exp]
ps
    [Name]
tNames <- (Expr Name Name Exp -> Q Name) -> [Expr Name Name Exp] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Expr Name Name Exp
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"tmpT") [Expr Name Name Exp]
ps
#if MIN_VERSION_template_haskell(2,16,0)
    let pps :: [Maybe Exp]
pps = (Expr Name Name Exp -> Maybe Exp)
-> [Expr Name Name Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp)
-> (Expr Name Name Exp -> Exp) -> Expr Name Name Exp -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Name Name Exp -> Exp
toPP) [Expr Name Name Exp]
ps
#else
    let pps = map toPP ps
#endif
    Exp
body' <- ((Expr Name Name Exp, Name, Name) -> Exp -> Q Exp)
-> Exp -> [(Expr Name Name Exp, Name, Name)] -> Q Exp
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Expr Name Name Exp, Name, Name) -> Exp -> Q Exp
go' Exp
body ([Expr Name Name Exp]
-> [Name] -> [Name] -> [(Expr Name Name Exp, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Expr Name Name Exp]
ps [Name]
mNames [Name]
tNames)
    Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$        Pat -> Exp -> Exp -> Exp
let_
                 ([Pat] -> Pat
TupP ((Expr Name Name Exp -> Name -> Pat)
-> [Expr Name Name Exp] -> [Name] -> [Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expr Name Name Exp -> Name -> Pat
mNameToVar [Expr Name Name Exp]
ps [Name]
mNames))
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName (Name -> String
forall a. Show a => a -> String
show Name
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"M"))) (Name -> Exp
VarE Name
mName))
                       (Name -> Exp
VarE Name
tName)
                 )
      (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$        Exp -> Exp -> Exp
AppE
                 (Name -> Exp
VarE 'fromList)
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
cName) ([Maybe Exp] -> Exp
TupE [Maybe Exp]
pps)) (Name -> Exp
VarE Name
mName)) (Name -> Exp
VarE Name
tName))
      Exp -> Exp -> Exp
`sbind_` [Pat] -> Exp -> Exp
LamE [[Pat] -> Pat
TupP ((Expr Name Name Exp -> Name -> Pat)
-> [Expr Name Name Exp] -> [Name] -> [Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expr Name Name Exp -> Name -> Pat
tNameToVar [Expr Name Name Exp]
ps [Name]
tNames)] Exp
body'
  go' :: (Pat.Expr Name Name Exp, Name, Name) -> Exp -> Q Exp
  go' :: (Expr Name Name Exp, Name, Name) -> Exp -> Q Exp
go' (Expr Name Name Exp
p, Name
m, Name
t) = Expr Name Name Exp -> Name -> Name -> Exp -> Q Exp
go Expr Name Name Exp
p Name
m Name
t
  isPatVar :: Pat.Expr Name Name Exp -> Bool
  isPatVar :: Expr Name Name Exp -> Bool
isPatVar Expr Name Name Exp
Pat.Wildcard      = Bool
True
  isPatVar (Pat.Variable  Name
_) = Bool
True
  isPatVar (Pat.Predicate Exp
_) = Bool
True
  isPatVar Expr Name Name Exp
_                 = Bool
False
  mNameToVar :: Pat.Expr Name Name Exp -> Name -> Pat
  mNameToVar :: Expr Name Name Exp -> Name -> Pat
mNameToVar Expr Name Name Exp
Pat.Wildcard      Name
_     = Pat
WildP
  mNameToVar (Pat.Variable  Name
_) Name
_     = Pat
WildP
  mNameToVar (Pat.Predicate Exp
_) Name
_     = Pat
WildP
  mNameToVar Expr Name Name Exp
_                 Name
mName = Name -> Pat
VarP Name
mName
  tNameToVar :: Pat.Expr Name Name Exp -> Name -> Pat
  tNameToVar :: Expr Name Name Exp -> Name -> Pat
tNameToVar Expr Name Name Exp
Pat.Wildcard Name
_     = Pat
WildP
  tNameToVar Expr Name Name Exp
_            Name
tName = Name -> Pat
VarP Name
tName

desugarCollection :: [Pat.Expr Name Name Exp] -> Pat.Expr Name Name Exp
desugarCollection :: [Expr Name Name Exp] -> Expr Name Name Exp
desugarCollection = (Expr Name Name Exp -> Expr Name Name Exp -> Expr Name Name Exp)
-> Expr Name Name Exp -> [Expr Name Name Exp] -> Expr Name Name Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expr Name Name Exp -> Expr Name Name Exp -> Expr Name Name Exp
forall {v} {e}. Expr Name v e -> Expr Name v e -> Expr Name v e
go (Expr Name Name Exp -> [Expr Name Name Exp] -> Expr Name Name Exp)
-> Expr Name Name Exp -> [Expr Name Name Exp] -> Expr Name Name Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pat.Pattern (String -> Name
mkName String
"nil") []
  where go :: Expr Name v e -> Expr Name v e -> Expr Name v e
go Expr Name v e
x Expr Name v e
acc = Name -> [Expr Name v e] -> Expr Name v e
forall n v e. n -> [Expr n v e] -> Expr n v e
Pat.Pattern (String -> Name
mkName String
"cons") [Expr Name v e
x, Expr Name v e
acc]

desugarTuple :: [Pat.Expr Name Name Exp] -> Pat.Expr Name Name Exp
desugarTuple :: [Expr Name Name Exp] -> Expr Name Name Exp
desugarTuple [Expr Name Name Exp]
ps = Name -> [Expr Name Name Exp] -> Expr Name Name Exp
forall n v e. n -> [Expr n v e] -> Expr n v e
Pat.Pattern (String -> Name
mkName String
name) [Expr Name Name Exp]
ps
  where name :: String
name = String
"tuple" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Expr Name Name Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Name Name Exp]
ps)

data PP a = WC | VP a | GP

toPP :: Pat.Expr Name Name Exp -> Exp
toPP :: Expr Name Name Exp -> Exp
toPP Expr Name Name Exp
Pat.Wildcard  = Name -> Exp
ConE 'WC
toPP (Pat.Value Exp
e) = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'VP) Exp
e
toPP Expr Name Name Exp
_             = Name -> Exp
ConE 'GP