module Language.Haskell.TH.Desugar.Core where
import Prelude hiding (mapM, foldl, foldr, all, elem)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Applicative
import Control.Monad hiding (mapM)
import Control.Monad.Zip
import Data.Foldable
import Data.Traversable
import qualified Data.Set as S
import GHC.Exts
import Language.Haskell.TH.Desugar.Util
data DExp = DVarE Name
| DConE Name
| DLitE Lit
| DAppE DExp DExp
| DLamE [Name] DExp
| DCaseE DExp [DMatch]
| DLetE [DLetDec] DExp
| DSigE DExp DType
data DLetDec = DFunD Name [DClause]
| DValD DPat DExp
| DSigD Name DType
| DInfixD Fixity Name
data DPat = DLitP Lit
| DVarP Name
| DConP Name [DPat]
| DTildeP DPat
| DBangP DPat
| DWildP
data DType = DForallT [DTyVarBndr] DCxt DType
| DAppT DType DType
| DSigT DType DKind
| DVarT Name
| DConT Name
| DArrowT
| DLitT TyLit
data DKind = DForallK [Name] DKind
| DVarK Name
| DConK Name [DKind]
| DArrowK DKind DKind
| DStarK
type DCxt = [DPred]
data DPred = DClassP Name [DType]
| DEqualP DType DType
data DTyVarBndr = DPlainTV Name
| DKindedTV Name DKind
#if __GLASGOW_HASKELL__ >= 707
| DRoledTV Name Role
| DKindedRoledTV Name DKind Role
#endif
data DMatch = DMatch DPat DExp
data DClause = DClause [DPat] DExp
dsExp :: Exp -> Q DExp
dsExp (VarE n) = return $ DVarE n
dsExp (ConE n) = return $ DConE n
dsExp (LitE lit) = return $ DLitE lit
dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2
dsExp (InfixE Nothing op Nothing) = dsExp op
dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs)
dsExp (InfixE Nothing op (Just rhs)) = do
lhsName <- newName "lhs"
op' <- dsExp op
rhs' <- dsExp rhs
return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])
dsExp (InfixE (Just lhs) op (Just rhs)) =
DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs
dsExp (UInfixE _ _ _) =
fail "Cannot desugar unresolved infix operators."
dsExp (ParensE exp) = dsExp exp
dsExp (LamE pats exp) = dsLam pats =<< dsExp exp
dsExp (LamCaseE matches) = do
x <- newName "x"
matches' <- dsMatches x matches
return $ DLamE [x] (DCaseE (DVarE x) matches')
dsExp (TupE exps) = do
exps' <- mapM dsExp exps
return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps'
dsExp (UnboxedTupE exps) =
foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps
dsExp (CondE e1 e2 e3) = do
e1' <- dsExp e1
e2' <- dsExp e2
e3' <- dsExp e3
return $ DCaseE e1' [DMatch (DConP 'True []) e2', DMatch (DConP 'False []) e3']
dsExp (MultiIfE guarded_exps) =
let failure = DAppE (DVarE 'error) (DLitE (StringL "None-exhaustive guards in multi-way if")) in
dsGuards guarded_exps failure
dsExp (LetE decs exp) = DLetE <$> mapM dsLetDec decs <*> dsExp exp
dsExp (CaseE exp matches) = do
scrutinee <- newName "scrutinee"
exp' <- dsExp exp
matches' <- dsMatches scrutinee matches
return $ DLetE [DValD (DVarP scrutinee) exp'] $
DCaseE (DVarE scrutinee) matches'
dsExp (DoE stmts) = dsDoStmts stmts
dsExp (CompE stmts) = dsComp stmts
dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp
dsExp (ArithSeqE (FromThenR exp1 exp2)) =
DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2
dsExp (ArithSeqE (FromToR exp1 exp2)) =
DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2
dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =
DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>
dsExp e2) <*>
dsExp e3
dsExp (ListE exps) = go exps
where go [] = return $ DConE '[]
go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t
dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty
dsExp (RecConE con_name field_exps) = do
con <- dataConNameToCon con_name
reordered <- case con of
RecC _name fields -> reorderFields fields field_exps
(repeat $ DVarE 'undefined)
_ -> impossible $ "Record syntax used with non-record constructor "
++ (show con_name) ++ "."
return $ foldl DAppE (DConE con_name) reordered
dsExp (RecUpdE exp field_exps) = do
first_name <- case field_exps of
((name, _) : _) -> return name
_ -> impossible "Record update with no fields listed."
info <- reifyWithWarning first_name
applied_type <- case info of
VarI _name ty _m_dec _fixity -> extract_first_arg ty
_ -> impossible "Record update with an invalid field name."
type_name <- extract_type_name applied_type
(_, cons) <- getDataD "This seems to be an error in GHC." type_name
let filtered_cons = filter_cons_with_names cons (map fst field_exps)
exp' <- dsExp exp
matches <- mapM con_to_dmatch filtered_cons
return $ DCaseE exp' (matches ++ [error_match])
where
extract_first_arg :: Type -> Q Type
extract_first_arg (AppT (AppT ArrowT arg) _) = return arg
extract_first_arg (ForallT _ _ t) = extract_first_arg t
extract_first_arg (SigT t _) = extract_first_arg t
extract_first_arg _ = impossible "Record selector not a function."
extract_type_name :: Type -> Q Name
extract_type_name (AppT t1 _) = extract_type_name t1
extract_type_name (SigT t _) = extract_type_name t
extract_type_name (ConT n) = return n
extract_type_name _ = impossible "Record selector domain not a datatype."
filter_cons_with_names cons field_names =
filter (\case RecC _con_name args -> let con_field_names = map fst_of_3 args in
all (`elem` con_field_names) field_names
_ -> False) cons
con_to_dmatch :: Con -> Q DMatch
con_to_dmatch (RecC con_name args) = do
let con_field_names = map fst_of_3 args
field_var_names <- mapM (newName . nameBase) con_field_names
DMatch (DConP con_name (map DVarP field_var_names)) <$>
(foldl DAppE (DConE con_name) <$>
(reorderFields args field_exps (map DVarE field_var_names)))
con_to_dmatch _ = impossible "Internal error within th-desugar."
error_match = DMatch DWildP (DAppE (DVarE 'error)
(DLitE (StringL "Non-exhaustive patterns in record update")))
fst_of_3 (x, _, _) = x
dsLam :: [Pat] -> DExp -> Q DExp
dsLam pats exp
| Just names <- mapM stripVarP_maybe pats
= return $ DLamE names exp
| otherwise
= do arg_names <- replicateM (length pats) (newName "arg")
let scrutinee = mkTupleDExp (map DVarE arg_names)
(pats', xform) <- dsPats pats
let match = DMatch (mkTupleDPat pats') (xform exp)
return $ DLamE arg_names (DCaseE scrutinee [match])
dsMatches :: Name
-> [Match]
-> Q [DMatch]
dsMatches scr = go
where
go :: [Match] -> Q [DMatch]
go [] = return []
go (Match pat body where_decs : rest) = do
rest' <- go rest
let failure = DCaseE (DVarE scr) rest'
exp' <- dsBody body where_decs failure
(pat', xform) <- dsPat pat
return (DMatch pat' (xform exp') : rest')
dsBody :: Body
-> [Dec]
-> DExp
-> Q DExp
dsBody (NormalB exp) decs _ =
maybeDLetE <$> mapM dsLetDec decs <*> dsExp exp
dsBody (GuardedB guarded_exps) decs failure =
maybeDLetE <$> mapM dsLetDec decs <*> dsGuards guarded_exps failure
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE [] exp = exp
maybeDLetE decs exp = DLetE decs exp
maybeDCaseE :: String -> DExp -> [DMatch] -> DExp
maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err))
maybeDCaseE _ scrut matches = DCaseE scrut matches
dsGuards :: [(Guard, Exp)]
-> DExp
-> Q DExp
dsGuards [] thing_inside = return thing_inside
dsGuards ((NormalG guard, exp) : rest) thing_inside =
dsGuards ((PatG [NoBindS guard], exp) : rest) thing_inside
dsGuards ((PatG stmts, exp) : rest) thing_inside = do
success <- dsExp exp
failure <- dsGuards rest thing_inside
dsGuardStmts stmts success failure
dsGuardStmts :: [Stmt]
-> DExp
-> DExp
-> Q DExp
dsGuardStmts [] success _failure = return success
dsGuardStmts (BindS pat exp : rest) success failure = do
(pat', xform) <- dsPat pat
exp' <- dsExp exp
success' <- dsGuardStmts rest success failure
return $ DCaseE exp' [DMatch pat' (xform success'), DMatch DWildP failure]
dsGuardStmts (LetS decs : rest) success failure = do
decs' <- mapM dsLetDec decs
success' <- dsGuardStmts rest success failure
return $ DLetE decs' success'
dsGuardStmts (NoBindS exp : rest) success failure = do
exp' <- dsExp exp
success' <- dsGuardStmts rest success failure
return $ DCaseE exp' [ DMatch (DConP 'True []) success'
, DMatch (DConP 'False []) failure ]
dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."
dsDoStmts :: [Stmt] -> Q DExp
dsDoStmts [] = impossible "do-expression ended with something other than bare statement."
dsDoStmts [NoBindS exp] = dsExp exp
dsDoStmts (BindS pat exp : rest) = do
exp' <- dsExp exp
rest' <- dsDoStmts rest
DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'
dsDoStmts (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsDoStmts rest
dsDoStmts (NoBindS exp : rest) = do
exp' <- dsExp exp
rest' <- dsDoStmts rest
return $ DAppE (DAppE (DVarE '(>>)) exp') rest'
dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement."
dsComp :: [Stmt] -> Q DExp
dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement."
dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp
dsComp (BindS pat exp : rest) = do
exp' <- dsExp exp
rest' <- dsComp rest
DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'
dsComp (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsComp rest
dsComp (NoBindS exp : rest) = do
exp' <- dsExp exp
rest' <- dsComp rest
return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'
dsComp (ParS stmtss : rest) = do
(pat, exp) <- dsParComp stmtss
rest' <- dsComp rest
DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest'
dsParComp :: [[Stmt]] -> Q (Pat, DExp)
dsParComp [] = impossible "Empty list of parallel comprehension statements."
dsParComp [r] = do
let rv = foldMap extractBoundNamesStmt r
dsR <- dsComp (r ++ [mk_tuple_stmt rv])
return (mk_tuple_pat rv, dsR)
dsParComp (q : rest) = do
let qv = foldMap extractBoundNamesStmt q
(rest_pat, rest_exp) <- dsParComp rest
dsQ <- dsComp (q ++ [mk_tuple_stmt qv])
let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp
return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped)
mk_tuple_stmt :: S.Set Name -> Stmt
mk_tuple_stmt name_set =
NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set))
mk_tuple_pat :: S.Set Name -> Pat
mk_tuple_pat name_set =
mkTuplePat (S.foldr ((:) . VarP) [] name_set)
dsPat :: Pat -> Q (DPat, DExp -> DExp)
dsPat (LitP lit) = return (DLitP lit, id)
dsPat (VarP n) = return (DVarP n, id)
dsPat (TupP pats) = dsConPats (tupleDataName (length pats)) pats
dsPat (UnboxedTupP pats) = dsConPats (unboxedTupleDataName (length pats)) pats
dsPat (ConP name pats) = dsConPats name pats
dsPat (InfixP p1 name p2) = dsConPats name [p1, p2]
dsPat (UInfixP _ _ _) =
fail "Cannot desugar unresolved infix operators."
dsPat (ParensP pat) = dsPat pat
dsPat (TildeP pat) = dsPatModifier DTildeP pat
dsPat (BangP pat) = dsPatModifier DBangP pat
dsPat (AsP name pat) = do
(pat', xform) <- dsPat pat
pat'' <- removeWilds pat'
let xform' exp = DLetE [DValD (DVarP name) (dPatToDExp pat'')] (xform exp)
return (pat'', xform')
dsPat WildP = return (DWildP, id)
dsPat (RecP con_name field_pats) = do
con <- dataConNameToCon con_name
(reordered, xform) <- case con of
RecC _name fields -> reorderFieldsPat fields field_pats
_ -> impossible $ "Record syntax used with non-record constructor "
++ (show con_name) ++ "."
return (DConP con_name reordered, xform)
dsPat (ListP pats) = go pats
where go [] = return (DConP '[] [], id)
go (h : t) = do
(h', xform_h) <- dsPat h
(t', xform_t) <- go t
return (DConP '(:) [h', t'], xform_h . xform_t)
dsPat (SigP _ _) =
impossible ("At last check (Aug 2013), type patterns in signatures are not\n" ++
"supported in GHC. They are not supported in th-desugar either.")
dsPat (ViewP _ _) =
fail "View patterns are not supported in th-desugar. Use pattern guards instead."
dsPats :: [Pat] -> Q ([DPat], DExp -> DExp)
dsPats pats = do
(pats', xforms) <- mapAndUnzipM dsPat pats
return (pats', foldr (.) id xforms)
dsConPats :: Name -> [Pat] -> Q (DPat, DExp -> DExp)
dsConPats name pats = do
(pats', xform) <- dsPats pats
return (DConP name pats', xform)
dsPatModifier :: (DPat -> DPat) -> Pat -> Q (DPat, DExp -> DExp)
dsPatModifier mod pat = do
(pat', xform) <- dsPat pat
return (mod pat', xform)
dPatToDExp :: DPat -> DExp
dPatToDExp (DLitP lit) = DLitE lit
dPatToDExp (DVarP name) = DVarE name
dPatToDExp (DConP name pats) = foldl DAppE (DConE name) (map dPatToDExp pats)
dPatToDExp (DTildeP pat) = dPatToDExp pat
dPatToDExp (DBangP pat) = dPatToDExp pat
dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"
removeWilds :: DPat -> Q DPat
removeWilds p@(DLitP _) = return p
removeWilds p@(DVarP _) = return p
removeWilds (DConP con_name pats) = DConP con_name <$> mapM removeWilds pats
removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat
removeWilds (DBangP pat) = DBangP <$> removeWilds pat
removeWilds DWildP = DVarP <$> newName "wild"
dsLetDec :: Dec -> Q DLetDec
dsLetDec (FunD name clauses) = DFunD name <$> dsClauses name clauses
dsLetDec (ValD pat body where_decs) = do
(pat', xform) <- dsPat pat
DValD pat' <$> (xform <$> dsBody body where_decs error_exp)
where
error_exp = DAppE (DVarE 'error) (DLitE
(StringL $ "Non-exhaustive patterns for " ++ pprint pat))
dsLetDec (SigD name ty) = DSigD name <$> dsType ty
dsLetDec (InfixD fixity name) = return $ DInfixD fixity name
dsLetDec _dec = impossible "Illegal declaration in let expression."
dsClauses :: Name
-> [Clause]
-> Q [DClause]
dsClauses _ [] = return []
dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do
(pats', xform) <- dsPats pats
(:) <$>
DClause pats' <$> (xform <$> (maybeDLetE <$> mapM dsLetDec where_decs <*> dsExp exp)) <*>
dsClauses n rest
dsClauses n clauses@(Clause pats _ _ : _) = do
arg_names <- replicateM (length pats) (newName "arg")
let scrutinee = mkTupleDExp (map DVarE arg_names)
clause <- DClause (map DVarP arg_names) <$>
(DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)
return [clause]
where
clause_to_dmatch :: DExp -> Clause -> [DMatch] -> Q [DMatch]
clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do
(pats', xform) <- dsPats pats
let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))
scrutinee failure_matches
exp <- dsBody body where_decs failure_exp
return (DMatch (mkTupleDPat pats') (xform exp) : failure_matches)
dsType :: Type -> Q DType
dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> mapM dsPred preds <*> dsType ty
dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2
dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsKind ki
dsType (VarT name) = return $ DVarT name
dsType (ConT name) = return $ DConT name
dsType (PromotedT name) = return $ DConT name
dsType (TupleT n) = return $ DConT (tupleTypeName n)
dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)
dsType ArrowT = return DArrowT
dsType ListT = return $ DConT ''[]
dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)
dsType PromotedNilT = return $ DConT '[]
dsType PromotedConsT = return $ DConT '(:)
dsType StarT = impossible "The kind * seen in a type."
dsType ConstraintT = impossible "The kind `Constraint' seen in a type."
dsType (LitT lit) = return $ DLitT lit
dsTvb :: TyVarBndr -> Q DTyVarBndr
dsTvb (PlainTV n) = return $ DPlainTV n
dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k
#if __GLASGOW_HASKELL__ >= 707
dsTvb (RoledTV n r) = return $ DRoledTV n r
dsTvb (KindedRoledTV n k r) = DKindedRoledTV n <$> dsKind k <*> pure r
#endif
dsPred :: Pred -> Q DPred
dsPred (ClassP n tys) = DClassP n <$> mapM dsType tys
dsPred (EqualP t1 t2) = DEqualP <$> dsType t1 <*> dsType t2
dsKind :: Kind -> Q DKind
dsKind (ForallT tvbs cxt ki)
| [] <- cxt
, Just names <- mapM stripPlainTV_maybe tvbs
= DForallK names <$> dsKind ki
| otherwise
= impossible "Annotations of kind variables or kind constraints."
dsKind (AppT (AppT ArrowT k1) k2) = DArrowK <$> dsKind k1 <*> dsKind k2
dsKind (AppT k1 k2) = do
k1' <- dsKind k1
(con_name, args) <- case k1' of
DConK n as -> return (n, as)
_ -> impossible "Illegal kind application."
k2' <- dsKind k2
return $ DConK con_name (args ++ [k2'])
dsKind k@(SigT _ _) = impossible $ "Super-kind signature in kind " ++ (pprint k)
dsKind (VarT name) = return $ DVarK name
dsKind (ConT name) = return $ DConK name []
dsKind (PromotedT name) = impossible $ "Promoted data constructor " ++ show name ++ " in kind."
dsKind (TupleT n) = return $ DConK (tupleTypeName n) []
dsKind (UnboxedTupleT _) = impossible "Unboxed tuple kind."
dsKind ArrowT = impossible "Unsaturated (->) in kind."
dsKind ListT = return $ DConK ''[] []
dsKind (PromotedTupleT _) = impossible "Promoted tuple used as a kind."
dsKind PromotedNilT = impossible "Promoted [] used as a kind."
dsKind PromotedConsT = impossible "Promoted (:) used as a kind."
dsKind StarT = return DStarK
dsKind ConstraintT = return $ DConK ''Constraint []
dsKind (LitT _) = impossible "Literal used in a kind."
reorderFields :: [VarStrictType] -> [FieldExp] -> [DExp] -> Q [DExp]
reorderFields [] _ _ = return []
reorderFields ((field_name, _, _) : rest) field_exps (deflt : rest_deflt) = do
rest' <- reorderFields rest field_exps rest_deflt
case find (\(exp_name, _) -> exp_name == field_name) field_exps of
Just (_, exp) -> (: rest') <$> dsExp exp
Nothing -> return $ deflt : rest'
reorderFields (_ : _) _ [] = impossible "Internal error in th-desugar."
reorderFieldsPat :: [VarStrictType] -> [FieldPat] -> Q ([DPat], DExp -> DExp)
reorderFieldsPat [] _ = return ([], id)
reorderFieldsPat ((field_name, _, _) : rest) field_pats = do
(rest', rest_xform) <- reorderFieldsPat rest field_pats
case find (\(pat_name, _) -> pat_name == field_name) field_pats of
Just (_, pat) -> do
(pat', xform) <- dsPat pat
return $ (pat' : rest', xform . rest_xform)
Nothing -> return (DWildP : rest', rest_xform)
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp [exp] = exp
mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps
mkTupleExp :: [Exp] -> Exp
mkTupleExp [exp] = exp
mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat [pat] = pat
mkTupleDPat pats = DConP (tupleDataName (length pats)) pats
mkTuplePat :: [Pat] -> Pat
mkTuplePat [pat] = pat
mkTuplePat pats = ConP (tupleDataName (length pats)) pats