module Language.Haskell.TH.Desugar.Core where
import Prelude hiding (mapM, foldl, foldr, all, elem, exp)
import Language.Haskell.TH hiding (match, clause, cxt)
import Language.Haskell.TH.Syntax hiding (lift)
import Control.Applicative
import Control.Monad hiding (mapM)
import Control.Monad.Zip
import Control.Monad.Writer hiding (mapM)
import Data.Foldable
import Data.Traversable
import Data.Data hiding (Fixity)
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
deriving (Show, Typeable, Data)
data DLetDec = DFunD Name [DClause]
| DValD DPat DExp
| DSigD Name DType
| DInfixD Fixity Name
deriving (Show, Typeable, Data)
data DPat = DLitP Lit
| DVarP Name
| DConP Name [DPat]
| DTildeP DPat
| DBangP DPat
| DWildP
deriving (Show, Typeable, Data)
data DType = DForallT [DTyVarBndr] DCxt DType
| DAppT DType DType
| DSigT DType DKind
| DVarT Name
| DConT Name
| DArrowT
| DLitT TyLit
deriving (Show, Typeable, Data)
data DKind = DForallK [Name] DKind
| DVarK Name
| DConK Name [DKind]
| DArrowK DKind DKind
| DStarK
deriving (Show, Typeable, Data)
type DCxt = [DPred]
data DPred = DClassP Name [DType]
| DEqualP DType DType
deriving (Show, Typeable, Data)
data DTyVarBndr = DPlainTV Name
| DKindedTV Name DKind
deriving (Show, Typeable, Data)
data DMatch = DMatch DPat DExp
deriving (Show, Typeable, Data)
data DClause = DClause [DPat] DExp
deriving (Show, Typeable, Data)
dsExp :: Quasi q => 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 <- qNewName "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 <- qNewName "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 <$> dsLetDecs decs <*> dsExp exp
dsExp (CaseE exp matches) = do
scrutinee <- qNewName "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 :: Quasi q => 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 :: Quasi q => 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 :: Quasi q => Con -> q DMatch
con_to_dmatch (RecC con_name args) = do
let con_field_names = map fst_of_3 args
field_var_names <- mapM (qNewName . 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 :: Quasi q => [Pat] -> DExp -> q DExp
dsLam pats exp
| Just names <- mapM stripVarP_maybe pats
= return $ DLamE names exp
| otherwise
= do arg_names <- replicateM (length pats) (qNewName "arg")
let scrutinee = mkTupleDExp (map DVarE arg_names)
(pats', exp') <- dsPatsOverExp pats exp
let match = DMatch (mkTupleDPat pats') exp'
return $ DLamE arg_names (DCaseE scrutinee [match])
dsMatches :: Quasi q
=> Name
-> [Match]
-> q [DMatch]
dsMatches scr = go
where
go :: Quasi q => [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', exp'') <- dsPatOverExp pat exp'
return (DMatch pat' exp'' : rest')
dsBody :: Quasi q
=> Body
-> [Dec]
-> DExp
-> q DExp
dsBody (NormalB exp) decs _ =
maybeDLetE <$> dsLetDecs decs <*> dsExp exp
dsBody (GuardedB guarded_exps) decs failure =
maybeDLetE <$> dsLetDecs 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 :: Quasi q
=> [(Guard, Exp)]
-> DExp
-> q DExp
dsGuards [] thing_inside = return thing_inside
dsGuards ((NormalG gd, exp) : rest) thing_inside =
dsGuards ((PatG [NoBindS gd], 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 :: Quasi q
=> [Stmt]
-> DExp
-> DExp
-> q DExp
dsGuardStmts [] success _failure = return success
dsGuardStmts (BindS pat exp : rest) success failure = do
success' <- dsGuardStmts rest success failure
(pat', success'') <- dsPatOverExp pat success'
exp' <- dsExp exp
return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure]
dsGuardStmts (LetS decs : rest) success failure = do
decs' <- dsLetDecs 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 :: Quasi q => [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 <$> dsLetDecs 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 :: Quasi q => [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 <$> dsLetDecs 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 :: Quasi q => [[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)
dsPatOverExp :: Quasi q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp pat exp = do
(pat', vars) <- runWriterT $ dsPat pat
let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars
return (pat', maybeDLetE name_decs exp)
dsPatsOverExp :: Quasi q => [Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp pats exp = do
(pats', vars) <- runWriterT $ mapM dsPat pats
let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars
return (pats', maybeDLetE name_decs exp)
dsPatX :: Quasi q => Pat -> q (DPat, [(Name, DExp)])
dsPatX = runWriterT . dsPat
type PatM q = WriterT [(Name, DExp)] q
dsPat :: Quasi q => Pat -> PatM q DPat
dsPat (LitP lit) = return $ DLitP lit
dsPat (VarP n) = return $ DVarP n
dsPat (TupP pats) = DConP (tupleDataName (length pats)) <$> mapM dsPat pats
dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) <$>
mapM dsPat pats
dsPat (ConP name pats) = DConP name <$> mapM dsPat pats
dsPat (InfixP p1 name p2) = DConP name <$> mapM dsPat [p1, p2]
dsPat (UInfixP _ _ _) =
fail "Cannot desugar unresolved infix operators."
dsPat (ParensP pat) = dsPat pat
dsPat (TildeP pat) = DTildeP <$> dsPat pat
dsPat (BangP pat) = DBangP <$> dsPat pat
dsPat (AsP name pat) = do
pat' <- dsPat pat
pat'' <- lift $ removeWilds pat'
tell [(name, dPatToDExp pat'')]
return pat''
dsPat WildP = return DWildP
dsPat (RecP con_name field_pats) = do
con <- lift $ dataConNameToCon con_name
reordered <- case con of
RecC _name fields -> reorderFieldsPat fields field_pats
_ -> lift $ impossible $ "Record syntax used with non-record constructor "
++ (show con_name) ++ "."
return $ DConP con_name reordered
dsPat (ListP pats) = go pats
where go [] = return $ DConP '[] []
go (h : t) = do
h' <- dsPat h
t' <- go t
return $ DConP '(:) [h', t']
dsPat (SigP _ _) =
lift $ 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."
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 :: Quasi q => 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 <$> qNewName "wild"
dsLetDecs :: Quasi q => [Dec] -> q [DLetDec]
dsLetDecs = concatMapM dsLetDec
dsLetDec :: Quasi q => Dec -> q [DLetDec]
dsLetDec (FunD name clauses) = do
clauses' <- dsClauses name clauses
return [DFunD name clauses']
dsLetDec (ValD pat body where_decs) = do
(pat', vars) <- dsPatX pat
body' <- dsBody body where_decs error_exp
let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars
return $ DValD pat' body' : extras
where
error_exp = DAppE (DVarE 'error) (DLitE
(StringL $ "Non-exhaustive patterns for " ++ pprint pat))
dsLetDec (SigD name ty) = do
ty' <- dsType ty
return [DSigD name ty']
dsLetDec (InfixD fixity name) = return [DInfixD fixity name]
dsLetDec _dec = impossible "Illegal declaration in let expression."
dsClauses :: Quasi q
=> Name
-> [Clause]
-> q [DClause]
dsClauses _ [] = return []
dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do
rest' <- dsClauses n rest
exp' <- dsExp exp
where_decs' <- dsLetDecs where_decs
let exp_with_wheres = maybeDLetE where_decs' exp'
(pats', exp'') <- dsPatsOverExp pats exp_with_wheres
return $ DClause pats' exp'' : rest'
dsClauses n clauses@(Clause outer_pats _ _ : _) = do
arg_names <- replicateM (length outer_pats) (qNewName "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 :: Quasi q => DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do
exp <- dsBody body where_decs failure_exp
(pats', exp') <- dsPatsOverExp pats exp
return (DMatch (mkTupleDPat pats') exp' : failure_matches)
where
failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))
scrutinee failure_matches
dsType :: Quasi q => 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 :: Quasi q => TyVarBndr -> q DTyVarBndr
dsTvb (PlainTV n) = return $ DPlainTV n
dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k
dsPred :: Quasi q => Pred -> q DPred
dsPred (ClassP n tys) = DClassP n <$> mapM dsType tys
dsPred (EqualP t1 t2) = DEqualP <$> dsType t1 <*> dsType t2
dsKind :: Quasi q => 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 :: Quasi q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields = reorderFields' dsExp
reorderFieldsPat :: Quasi q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat field_decs field_pats =
reorderFields' dsPat field_decs field_pats (repeat DWildP)
reorderFields' :: (Applicative m, Monad m)
=> (a -> m da)
-> [VarStrictType] -> [(Name, a)]
-> [da] -> m [da]
reorderFields' _ [] _ _ = return []
reorderFields' ds_thing ((field_name, _, _) : rest)
field_things (deflt : rest_deflt) = do
rest' <- reorderFields' ds_thing rest field_things rest_deflt
case find (\(thing_name, _) -> thing_name == field_name) field_things of
Just (_, thing) -> (: rest') <$> ds_thing thing
Nothing -> return $ deflt : rest'
reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar."
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