{- Language/Haskell/TH/Desugar/Core.hs (c) Richard Eisenberg 2013 rae@cs.brynmawr.edu Desugars full Template Haskell syntax into a smaller core syntax for further processing. The desugared types and constructors are prefixed with a D. -} {-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables, TupleSections, DeriveDataTypeable, DeriveGeneric #-} module Language.Haskell.TH.Desugar.Core where import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and) import Language.Haskell.TH hiding (Extension(..), match, clause, cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax hiding (Extension(..), lift) import Control.Monad hiding (forM_, mapM) import qualified Control.Monad.Fail as Fail import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Control.Monad.Zip import Data.Data (Data) import Data.Either (lefts) import Data.Foldable as F hiding (concat, notElem) import qualified Data.Map as M import Data.Map (Map) import Data.Maybe (isJust, mapMaybe) import Data.Monoid (All(..)) import qualified Data.Set as S import Data.Set (Set) import Data.Traversable #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif #if __GLASGOW_HASKELL__ >= 807 import GHC.Classes (IP(..)) #else import qualified Language.Haskell.TH as LangExt (Extension(..)) #endif #if __GLASGOW_HASKELL__ >= 902 import Data.List.NonEmpty (NonEmpty(..)) import GHC.Records (HasField(..)) #endif import GHC.Exts import GHC.Generics (Generic) import Language.Haskell.TH.Desugar.AST import Language.Haskell.TH.Desugar.FV import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.OSet (OSet) import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Reify -- | Desugar an expression dsExp :: DsMonad 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 <- newUniqueName "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) = do exp' <- dsExp exp (pats', exp'') <- dsPatsOverExp pats exp' mkDLamEFromDPats pats' exp'' dsExp (LamCaseE matches) = do x <- newUniqueName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = dsTup tupleDataName exps dsExp (UnboxedTupE exps) = dsTup unboxedTupleDataName exps dsExp (CondE e1 e2 e3) = dsExp (CaseE e1 [mkBoolMatch 'True e2, mkBoolMatch 'False e3]) where mkBoolMatch :: Name -> Exp -> Match mkBoolMatch boolDataCon rhs = Match (ConP boolDataCon #if __GLASGOW_HASKELL__ >= 901 [] #endif []) (NormalB rhs) [] dsExp (MultiIfE guarded_exps) = let failure = mkErrorMatchExpr MultiWayIfAlt in dsGuards guarded_exps failure dsExp (LetE decs exp) = do (decs', ip_binder) <- dsLetDecs decs exp' <- dsExp exp return $ DLetE decs' $ ip_binder exp' -- the following special case avoids creating a new "let" when it's not -- necessary. See #34. dsExp (CaseE (VarE scrutinee) matches) = do matches' <- dsMatches scrutinee matches return $ DCaseE (DVarE scrutinee) matches' dsExp (CaseE exp matches) = do scrutinee <- newUniqueName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarP scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches' #if __GLASGOW_HASKELL__ >= 900 dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts #else dsExp (DoE stmts) = dsDoStmts Nothing stmts #endif 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 <- reorder con return $ foldl DAppE (DConE con_name) reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields fields ForallC _ _ c -> reorder c GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields fields reorder_fields fields = reorderFields con_name fields field_exps (repeat $ DVarE 'undefined) non_record fields | null field_exps -- Special case: record construction is allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that no -- records are given in the expression itself. (See #59). -- -- Con{} desugars down to Con undefined ... undefined. = return $ replicate (length fields) $ DVarE 'undefined | otherwise = impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." dsExp (RecUpdE exp field_exps) = do -- here, we need to use one of the field names to find the tycon, somewhat dodgily first_name <- case field_exps of ((name, _) : _) -> return name _ -> impossible "Record update with no fields listed." info <- reifyWithLocals first_name applied_type <- case info of VarI _name ty _m_dec -> 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 let all_matches | length filtered_cons == length cons = matches | otherwise = matches ++ [error_match] return $ DCaseE exp' all_matches where extract_first_arg :: DsMonad 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 :: DsMonad 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 has_names cons where args_contain_names args = let con_field_names = map fst_of_3 args in all (`elem` con_field_names) field_names has_names (RecC _con_name args) = args_contain_names args has_names (RecGadtC _con_name args _ret_ty) = args_contain_names args has_names (ForallC _ _ c) = has_names c has_names _ = False rec_con_to_dmatch con_name args = do let con_field_names = map fst_of_3 args field_var_names <- mapM (newUniqueName . nameBase) con_field_names DMatch (DConP con_name [] (map DVarP field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields con_name args field_exps (map DVarE field_var_names))) con_to_dmatch :: DsMonad q => Con -> q DMatch con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args -- We're assuming the GADT constructor has only one Name here, but since -- this constructor was reified, this assumption should always hold true. con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args con_to_dmatch (ForallC _ _ c) = con_to_dmatch c con_to_dmatch _ = impossible "Internal error within th-desugar." error_match = DMatch DWildP (mkErrorMatchExpr RecUpd) fst_of_3 (x, _, _) = x dsExp (StaticE exp) = DStaticE <$> dsExp exp dsExp (UnboundVarE n) = return (DVarE n) #if __GLASGOW_HASKELL__ >= 801 dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty dsExp (UnboxedSumE exp alt arity) = DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp #endif #if __GLASGOW_HASKELL__ >= 803 dsExp (LabelE str) = return $ DVarE 'fromLabel `DAppTypeE` DLitT (StrTyLit str) #endif #if __GLASGOW_HASKELL__ >= 807 dsExp (ImplicitParamVarE n) = return $ DVarE 'ip `DAppTypeE` DLitT (StrTyLit n) dsExp (MDoE {}) = fail "th-desugar currently does not support RecursiveDo" #endif #if __GLASGOW_HASKELL__ >= 902 dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg dsExp (ProjectionE fields) = case fields of f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs where comp :: DExp -> String -> DExp comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc #endif #if __GLASGOW_HASKELL__ >= 903 dsExp (LamCasesE clauses) = do clauses' <- dsClauses CaseAlt clauses numArgs <- case clauses' of (DClause pats _:_) -> return $ length pats [] -> fail "\\cases expression must have at least one alternative" args <- replicateM numArgs (newUniqueName "x") return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args)) (map dClauseToUnboxedTupleMatch clauses') #endif -- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns -- into a match on a single unboxed tuple pattern. That is, convert this: -- -- @ -- f x y z = rhs -- @ -- -- To this: -- -- @ -- f (# x, y, z #) = rhs -- @ -- -- This is used to desugar @\\cases@ expressions into lambda expressions. dClauseToUnboxedTupleMatch :: DClause -> DMatch dClauseToUnboxedTupleMatch (DClause pats rhs) = DMatch (mkUnboxedTupleDPat pats) rhs #if __GLASGOW_HASKELL__ >= 809 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp dsTup = ds_tup #else dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp dsTup tuple_data_name = ds_tup tuple_data_name . map Just #endif -- | Desugar a tuple (or tuple section) expression. ds_tup :: forall q. DsMonad q => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed) -- data constructor from its arity. -> [Maybe Exp] -- ^ The tuple's subexpressions. 'Nothing' entries -- denote empty fields in a tuple section. -> q DExp ds_tup tuple_data_name mb_exps = do section_exps <- mapM ds_section_exp mb_exps let section_vars = lefts section_exps tup_body = mk_tup_body section_exps if null section_vars then return tup_body -- If this isn't a tuple section, -- don't create a lambda. else mkDLamEFromDPats (map DVarP section_vars) tup_body where -- If dealing with an empty field in a tuple section (Nothing), create a -- unique name and return Left. These names will be used to construct the -- lambda expression that it desugars to. -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.) -- -- If dealing with a tuple subexpression (Just), desugar it and return -- Right. ds_section_exp :: Maybe Exp -> q (Either Name DExp) ds_section_exp = maybe (Left <$> qNewName "ts") (fmap Right . dsExp) mk_tup_body :: [Either Name DExp] -> DExp mk_tup_body section_exps = foldl' apply_tup_body (DConE $ tuple_data_name (length section_exps)) section_exps apply_tup_body :: DExp -> Either Name DExp -> DExp apply_tup_body f (Left n) = f `DAppE` DVarE n apply_tup_body f (Right e) = f `DAppE` e -- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This -- is needed since 'DLamE' takes a list of 'Name's for its bound variables -- instead of 'DPat's, so some reorganization is needed. mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp mkDLamEFromDPats pats exp | Just names <- mapM stripDVarP_maybe pats = return $ DLamE names exp | otherwise = do arg_names <- replicateM (length pats) (newUniqueName "arg") let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) match = DMatch (mkUnboxedTupleDPat pats) exp return $ DLamE arg_names (DCaseE scrutinee [match]) where stripDVarP_maybe :: DPat -> Maybe Name stripDVarP_maybe (DVarP n) = Just n stripDVarP_maybe _ = Nothing #if __GLASGOW_HASKELL__ >= 902 mkGetFieldProj :: String -> DExp mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit field) #endif -- | Desugar a list of matches for a @case@ statement dsMatches :: DsMonad q => Name -- ^ Name of the scrutinee, which must be a bare var -> [Match] -- ^ Matches of the @case@ statement -> q [DMatch] dsMatches scr = go where go :: DsMonad q => [Match] -> q [DMatch] go [] = return [] go (Match pat body where_decs : rest) = do rest' <- go rest let failure = maybeDCaseE CaseAlt (DVarE scr) rest' exp' <- dsBody body where_decs failure (pat', exp'') <- dsPatOverExp pat exp' uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6 if uni_pattern then return [DMatch pat' exp''] else return (DMatch pat' exp'' : rest') -- | Desugar a @Body@ dsBody :: DsMonad q => Body -- ^ body to desugar -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match -> q DExp dsBody (NormalB exp) decs _ = do (decs', ip_binder) <- dsLetDecs decs exp' <- dsExp exp return $ maybeDLetE decs' $ ip_binder exp' dsBody (GuardedB guarded_exps) decs failure = do (decs', ip_binder) <- dsLetDecs decs guarded_exp' <- dsGuards guarded_exps failure return $ maybeDLetE decs' $ ip_binder guarded_exp' -- | If decs is non-empty, delcare them in a let: maybeDLetE :: [DLetDec] -> DExp -> DExp maybeDLetE [] exp = exp maybeDLetE decs exp = DLetE decs exp -- | If matches is non-empty, make a case statement; otherwise make an error statement maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp maybeDCaseE mc _ [] = mkErrorMatchExpr mc maybeDCaseE _ scrut matches = DCaseE scrut matches -- | Desugar guarded expressions dsGuards :: DsMonad q => [(Guard, Exp)] -- ^ Guarded expressions -> DExp -- ^ What to do if none of the guards match -> 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 -- | Desugar the @Stmt@s in a guard dsGuardStmts :: DsMonad q => [Stmt] -- ^ The @Stmt@s to desugar -> DExp -- ^ What to do if the @Stmt@s yield success -> DExp -- ^ What to do if the @Stmt@s yield failure -> 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', ip_binder) <- dsLetDecs decs success' <- dsGuardStmts rest success failure return $ DLetE decs' $ ip_binder success' -- special-case a final pattern containing "otherwise" or "True" -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr dsGuardStmts [NoBindS exp] success _failure | VarE name <- exp , name == 'otherwise = return success | ConE name <- exp , name == 'True = return 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." #if __GLASGOW_HASKELL__ >= 807 dsGuardStmts (RecS {} : _) _ _ = fail "th-desugar currently does not support RecursiveDo" #endif -- | Desugar the @Stmt@s in a @do@ expression dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp dsDoStmts mb_mod = go where go :: [Stmt] -> q DExp go [] = impossible "do-expression ended with something other than bare statement." go [NoBindS exp] = dsExp exp go (BindS pat exp : rest) = do rest' <- go rest dsBindS mb_mod exp pat rest' "do expression" go (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- go rest return $ DLetE decs' $ ip_binder rest' go (NoBindS exp : rest) = do exp' <- dsExp exp rest' <- go rest let sequence_name = mk_qual_do_name mb_mod '(>>) return $ DAppE (DAppE (DVarE sequence_name) exp') rest' go (ParS _ : _) = impossible "Parallel comprehension in a do-statement." #if __GLASGOW_HASKELL__ >= 807 go (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif -- | Desugar the @Stmt@s in a list or monad comprehension dsComp :: DsMonad 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 rest' <- dsComp rest dsBindS Nothing exp pat rest' "monad comprehension" dsComp (LetS decs : rest) = do (decs', ip_binder) <- dsLetDecs decs rest' <- dsComp rest return $ DLetE decs' $ ip_binder 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) <$> mkDLamEFromDPats [pat] rest' #if __GLASGOW_HASKELL__ >= 807 dsComp (RecS {} : _) = fail "th-desugar currently does not support RecursiveDo" #endif -- Desugar a binding statement in a do- or list comprehension. -- -- In the event that the pattern in the statement is partial, the desugared -- case expression will contain a catch-all case that calls 'fail' from either -- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@ -- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from -- 'Monad' is always used.) dsBindS :: forall q. DsMonad q => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp dsBindS mb_mod bind_arg_exp success_pat success_exp ctxt = do bind_arg_exp' <- dsExp bind_arg_exp (success_pat', success_exp') <- dsPatOverExp success_pat success_exp is_univ_pat <- isUniversalPattern success_pat' let bind_into = DAppE (DAppE (DVarE bind_name) bind_arg_exp') if is_univ_pat then bind_into <$> mkDLamEFromDPats [success_pat'] success_exp' else do arg_name <- newUniqueName "arg" fail_name <- mk_fail_name return $ bind_into $ DLamE [arg_name] $ DCaseE (DVarE arg_name) [ DMatch success_pat' success_exp' , DMatch DWildP $ DVarE fail_name `DAppE` DLitE (StringL $ "Pattern match failure in " ++ ctxt) ] where bind_name = mk_qual_do_name mb_mod '(>>=) mk_fail_name :: q Name #if __GLASGOW_HASKELL__ >= 807 -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects -- are always enabled. Furthermore, MonadFailDesugaring is no longer -- enabled by default, so simply use MonadFail.fail. (That happens to -- be the same as Prelude.fail in 8.8+.) mk_fail_name = return fail_MonadFail_name #else mk_fail_name = do mfd <- qIsExtEnabled LangExt.MonadFailDesugaring return $ if mfd then fail_MonadFail_name else fail_Prelude_name #endif fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail #if __GLASGOW_HASKELL__ < 807 fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail #endif -- | Desugar the contents of a parallel comprehension. -- Returns a @Pat@ containing a tuple of all bound variables and an expression -- to produce the values for those variables dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, 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_dpat 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 (DConP (tupleDataName 2) [] [mk_tuple_dpat qv, rest_pat], zipped) -- helper function for dsParComp mk_tuple_stmt :: OSet Name -> Stmt mk_tuple_stmt name_set = NoBindS (mkTupleExp (F.foldr ((:) . VarE) [] name_set)) -- helper function for dsParComp mk_tuple_dpat :: OSet Name -> DPat mk_tuple_dpat name_set = mkTupleDPat (F.foldr ((:) . DVarP) [] name_set) -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern. dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do (pat', vars) <- runWriterT $ dsPat pat let name_decs = map (uncurry (DValD . DVarP)) vars return (pat', maybeDLetE name_decs exp) -- | Desugar multiple patterns. Like 'dsPatOverExp'. dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats let name_decs = map (uncurry (DValD . DVarP)) vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra -- variables that must be bound within the scope of the pattern dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) dsPatX = runWriterT . dsPat -- | Desugaring a pattern also returns the list of variables bound in as-patterns -- and the values they should be bound to. This variables must be brought into -- scope in the "body" of the pattern. type PatM q = WriterT [(Name, DExp)] q -- | Desugar a pattern. dsPat :: DsMonad 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 #if __GLASGOW_HASKELL__ >= 901 dsPat (ConP name tys pats) = DConP name <$> mapM dsType tys <*> mapM dsPat pats #else dsPat (ConP name pats) = DConP name [] <$> mapM dsPat pats #endif 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 <- reorder con return $ DConP con_name [] reordered where reorder con = case con of NormalC _name fields -> non_record fields InfixC field1 _name field2 -> non_record [field1, field2] RecC _name fields -> reorder_fields_pat fields ForallC _ _ c -> reorder c GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields_pat fields reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats non_record fields | null field_pats -- Special case: record patterns are allowed for any -- constructor, regardless of whether the constructor -- actually was declared with records, provided that -- no records are given in the pattern itself. (See #59). -- -- Con{} desugars down to Con _ ... _. = return $ replicate (length fields) DWildP | otherwise = lift $ impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "." 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 pat ty) = DSigP <$> dsPat pat <*> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsPat (UnboxedSumP pat alt arity) = DConP (unboxedSumDataName alt arity) [] <$> ((:[]) <$> dsPat pat) #endif dsPat (ViewP _ _) = fail "View patterns are not supported in th-desugar. Use pattern guards instead." -- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. dPatToDExp :: DPat -> DExp dPatToDExp (DLitP lit) = DLitE lit dPatToDExp (DVarP name) = DVarE name dPatToDExp (DConP name tys pats) = foldl DAppE (foldl DAppTypeE (DConE name) tys) (map dPatToDExp pats) dPatToDExp (DTildeP pat) = dPatToDExp pat dPatToDExp (DBangP pat) = dPatToDExp pat dPatToDExp (DSigP pat ty) = DSigE (dPatToDExp pat) ty dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable removeWilds :: DsMonad q => DPat -> q DPat removeWilds p@(DLitP _) = return p removeWilds p@(DVarP _) = return p removeWilds (DConP con_name tys pats) = DConP con_name tys <$> mapM removeWilds pats removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat removeWilds (DBangP pat) = DBangP <$> removeWilds pat removeWilds (DSigP pat ty) = DSigP <$> removeWilds pat <*> pure ty removeWilds DWildP = DVarP <$> newUniqueName "wild" -- | Desugar @Info@ dsInfo :: DsMonad q => Info -> q DInfo dsInfo (ClassI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) dsInfo (ClassOpI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do [ddec] <- dsDec dec return $ DTyConI ddec Nothing dsInfo (FamilyI dec instances) = do [ddec] <- dsDec dec dinstances <- dsDecs instances return $ DTyConI ddec (Just dinstances) dsInfo (PrimTyConI name arity unlifted) = return $ DPrimTyConI name arity unlifted dsInfo (DataConI name ty parent) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _)) = impossible $ "Declaration supplied with variable: " ++ show name dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty #endif -- | Desugar arbitrary @Dec@s dsDecs :: DsMonad q => [Dec] -> q [DDec] dsDecs = concatMapM dsDec -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = dsTopLevelLetDec d dsDec d@(ValD {}) = dsTopLevelLetDec d dsDec (DataD cxt n tvbs mk cons derivings) = dsDataDec Data cxt n tvbs mk cons derivings dsDec (NewtypeD cxt n tvbs mk con derivings) = dsDataDec Newtype cxt n tvbs mk [con] derivings dsDec (TySynD n tvbs ty) = (:[]) <$> (DTySynD n <$> mapM dsTvbUnit tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) = (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs <*> pure fds <*> dsDecs decs) dsDec (InstanceD over cxt ty decs) = (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = dsTopLevelLetDec d dsDec d@(PragmaD {}) = dsTopLevelLetDec d dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) #if __GLASGOW_HASKELL__ >= 807 dsDec (DataInstD cxt mtvbs lhs mk cons derivings) = case unfoldType lhs of (ConT n, tys) -> dsDataInstDec Data cxt n mtvbs tys mk cons derivings (_, _) -> fail $ "Unexpected data instance LHS: " ++ pprint lhs dsDec (NewtypeInstD cxt mtvbs lhs mk con derivings) = case unfoldType lhs of (ConT n, tys) -> dsDataInstDec Newtype cxt n mtvbs tys mk [con] derivings (_, _) -> fail $ "Unexpected newtype instance LHS: " ++ pprint lhs #else dsDec (DataInstD cxt n tys mk cons derivings) = dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings dsDec (NewtypeInstD cxt n tys mk con derivings) = dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) #endif dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #if __GLASGOW_HASKELL__ >= 801 dsDec (PatSynD n args dir pat) = do dir' <- dsPatSynDir n dir (pat', vars) <- dsPatX pat unless (null vars) $ fail $ "Pattern synonym definition cannot contain as-patterns (@)." return [DPatSynD n args dir' pat'] dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty) dsDec (StandaloneDerivD mds cxt ty) = (:[]) <$> (DStandaloneDerivD <$> mapM dsDerivStrategy mds <*> pure Nothing <*> dsCxt cxt <*> dsType ty) #else dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty) #endif dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #if __GLASGOW_HASKELL__ >= 807 dsDec (ImplicitParamBindD {}) = impossible "Non-`let`-bound implicit param binding" #endif #if __GLASGOW_HASKELL__ >= 809 dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) #endif #if __GLASGOW_HASKELL__ >= 903 dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys) #endif #if __GLASGOW_HASKELL__ >= 906 dsDec (TypeDataD n tys mk cons) = dsDataDec TypeData [] n tys mk cons [] #endif -- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'. dsDataDec :: DsMonad q => DataFlavor -> Cxt -> Name -> [TyVarBndrUnit] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataDec nd cxt n tvbs mk cons derivings = do tvbs' <- mapM dsTvbUnit tvbs let h98_tvbs = case mk of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon. Just {} -> unusedArgument Nothing -> tvbs' h98_return_type = nonFamilyDataReturnType n tvbs' (:[]) <$> (DDataD nd <$> dsCxt cxt <*> pure n <*> pure tvbs' <*> mapM dsType mk <*> concatMapM (dsCon h98_tvbs h98_return_type) cons <*> mapM dsDerivClause derivings) -- | Desugar a 'DataInstD' or a 'NewtypeInstD'. dsDataInstDec :: DsMonad q => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg] -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec] dsDataInstDec nd cxt n mtvbs tys mk cons derivings = do mtvbs' <- mapM (mapM dsTvbUnit) mtvbs tys' <- mapM dsTypeArg tys let lhs' = applyDType (DConT n) tys' h98_tvbs = case (mk, mtvbs') of -- If there's an explicit return kind, we're dealing with a -- GADT, so this argument goes unused in dsCon. (Just {}, _) -> unusedArgument -- H98, and there is an explicit `forall` in front. Just reuse the -- type variable binders from the `forall`. (Nothing, Just tvbs') -> tvbs' -- H98, and no explicit `forall`. Compute the bound variables -- manually. (Nothing, Nothing) -> dataFamInstTvbs tys' h98_fam_inst_type = dataFamInstReturnType n tys' (:[]) <$> (DDataInstD nd <$> dsCxt cxt <*> pure mtvbs' <*> pure lhs' <*> mapM dsType mk <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons <*> mapM dsDerivClause derivings) -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig = return DNoSig dsFamilyResultSig (KindSig k) = DKindSig <$> dsType k dsFamilyResultSig (TyVarSig tvb) = DTyVarSig <$> dsTvbUnit tvb -- | Desugar a @TypeFamilyHead@ dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead dsTypeFamilyHead (TypeFamilyHead n tvbs result inj) = DTypeFamilyHead n <$> mapM dsTvbUnit tvbs <*> dsFamilyResultSig result <*> pure inj typeFamilyHeadName :: TypeFamilyHead -> Name typeFamilyHeadName (TypeFamilyHead n _ _ _) = n -- | Desugar @Dec@s that can appear in a @let@ expression. See the -- documentation for 'dsLetDec' for an explanation of what the return type -- represents. dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp) dsLetDecs decs = do (let_decss, ip_binders) <- mapAndUnzipM dsLetDec decs let let_decs :: [DLetDec] let_decs = concat let_decss ip_binder :: DExp -> DExp ip_binder = foldr (.) id ip_binders return (let_decs, ip_binder) -- | Desugar a single 'Dec' that can appear in a @let@ expression. -- This produces the following output: -- -- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's -- in the event of a value declaration that binds multiple things by way -- of pattern matching. -- -- * A function of type @'DExp' -> 'DExp'@, which should be applied to the -- expression immediately following the 'DLetDec's. This function prepends -- binding forms for any implicit params that were bound in the argument -- 'Dec'. (If no implicit params are bound, this is simply the 'id' -- function.) -- -- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this -- expression: -- -- @ -- let { ?x = 42 } in ?x -- @ -- -- Then the output is: -- -- * @let new_x_val = 42@ -- -- * @\\z -> 'bindIP' \@\"x\" new_x_val z@ -- -- This way, the expression -- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be -- formed. The implicit param binders always come after all the other -- 'DLetDec's to support parallel assignment of implicit params. dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) dsLetDec (FunD name clauses) = do clauses' <- dsClauses (FunRhs name) clauses return ([DFunD name clauses'], id) 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, id) where error_exp = mkErrorMatchExpr (LetDecRhs pat) dsLetDec (SigD name ty) = do ty' <- dsType ty return ([DSigD name ty'], id) dsLetDec (InfixD fixity name) = return ([DInfixD fixity name], id) dsLetDec (PragmaD prag) = do prag' <- dsPragma prag return ([DPragmaD prag'], id) #if __GLASGOW_HASKELL__ >= 807 dsLetDec (ImplicitParamBindD n e) = do new_n_name <- qNewName $ "new_" ++ n ++ "_val" e' <- dsExp e let let_dec :: DLetDec let_dec = DValD (DVarP new_n_name) e' ip_binder :: DExp -> DExp ip_binder = (DVarE 'bindIP `DAppTypeE` DLitT (StrTyLit n) `DAppE` DVarE new_n_name `DAppE`) return ([let_dec], ip_binder) #endif dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar a single 'Dec' corresponding to something that could appear after -- the @let@ in a @let@ expression, but occurring at the top level. Because the -- 'Dec' occurs at the top level, there is nothing that would correspond to the -- @in ...@ part of the @let@ expression. As a consequence, this function does -- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param -- binders (these cannot occur at the top level). dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec] dsTopLevelLetDec = fmap (map DLetDec . fst) . dsLetDec -- Note the use of fst above: we're silently throwing away any implicit param -- binders that dsLetDec returns, since there is invariant that there will be -- no implicit params in the first place. -- | Desugar a single @Con@. -- -- Because we always desugar @Con@s to GADT syntax (see the documentation for -- 'DCon'), it is not always possible to desugar with just a 'Con' alone. -- For instance, we must desugar: -- -- @ -- data Foo a = forall b. MkFoo b -- @ -- -- To this: -- -- @ -- data Foo a :: Type where -- MkFoo :: forall a b. b -> Foo a -- @ -- -- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward -- to figure out (1) what the set of universally quantified type variables -- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason, -- we require passing these as arguments. (If we desugar an actual GADT -- constructor, these arguments are ignored.) dsCon :: DsMonad q => [DTyVarBndrUnit] -- ^ The universally quantified type variables -- (used if desugaring a non-GADT constructor). -> DType -- ^ The original data declaration's type -- (used if desugaring a non-GADT constructor). -> Con -> q [DCon] dsCon univ_dtvbs data_type con = do dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs, dcxt, fields, m_gadt_type) -> case m_gadt_type of Nothing -> let ex_dtvbs = dtvbs expl_dtvbs = changeDTVFlags SpecifiedSpec univ_dtvbs ++ ex_dtvbs impl_dtvbs = changeDTVFlags SpecifiedSpec $ toposortTyVarsOf $ mapMaybe extractTvbKind expl_dtvbs in DCon (impl_dtvbs ++ expl_dtvbs) dcxt n fields data_type Just gadt_type -> let univ_ex_dtvbs = dtvbs in DCon univ_ex_dtvbs dcxt n fields gadt_type -- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes -- depending on what the returned Maybe DType value is: -- -- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC, -- so the returned DTyVarBndrs are both the universally and existentially -- quantified tyvars. -- * If returning Nothing, we're dealing with a non-GADT constructor, so -- the returned DTyVarBndrs are the existentials only. dsCon' :: DsMonad q => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)] dsCon' (NormalC n stys) = do dtys <- mapM dsBangType stys return [(n, [], [], DNormalC False dtys, Nothing)] dsCon' (RecC n vstys) = do vdtys <- mapM dsVarBangType vstys return [(n, [], [], DRecC vdtys, Nothing)] dsCon' (InfixC sty1 n sty2) = do dty1 <- dsBangType sty1 dty2 <- dsBangType sty2 return [(n, [], [], DNormalC True [dty1, dty2], Nothing)] dsCon' (ForallC tvbs cxt con) = do dtvbs <- mapM dsTvbSpec tvbs dcxt <- dsCxt cxt dcons' <- dsCon' con return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) -> (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type) dsCon' (GadtC nms btys rty) = do dbtys <- mapM dsBangType btys drty <- dsType rty sequence $ flip map nms $ \nm -> do mbFi <- reifyFixityWithLocals nm -- A GADT data constructor is declared infix when these three -- properties hold: let decInfix = isInfixDataCon (nameBase nm) -- 1. Its name uses operator syntax -- (e.g., (:*:)) && length dbtys == 2 -- 2. It has exactly two fields && isJust mbFi -- 3. It has a programmer-specified -- fixity declaration return (nm, [], [], DNormalC decInfix dbtys, Just drty) dsCon' (RecGadtC nms vbtys rty) = do dvbtys <- mapM dsVarBangType vbtys drty <- dsType rty return $ flip map nms $ \nm -> (nm, [], [], DRecC dvbtys, Just drty) -- | Desugar a @BangType@. dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty -- | Desugar a @VarBangType@. dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty dsForeign (ExportF cc str n ty) = DExportF cc str n <$> dsType ty -- | Desugar a @Pragma@. dsPragma :: DsMonad q => Pragma -> q DPragma dsPragma (InlineP n inl rm phases) = return $ DInlineP n inl rm phases dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty <*> pure m_inl <*> pure phases dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 dsPragma (RuleP str mtvbs rbs lhs rhs phases) = DRuleP str <$> mapM (mapM dsTvbUnit) mtvbs <*> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases #else dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing <$> mapM dsRuleBndr rbs <*> dsExp lhs <*> dsExp rhs <*> pure phases #endif dsPragma (AnnP target exp) = DAnnP target <$> dsExp exp dsPragma (LineP n str) = return $ DLineP n str #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty #endif #if __GLASGOW_HASKELL__ >= 903 dsPragma (OpaqueP n) = return $ DOpaqueP n #endif -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr dsRuleBndr (RuleVar n) = return $ DRuleVar n dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty #if __GLASGOW_HASKELL__ >= 807 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -- -- This requires a 'Name' as an argument since 'TySynEqn's did not have -- this information prior to GHC 8.8. dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn dsTySynEqn _ (TySynEqn mtvbs lhs rhs) = DTySynEqn <$> mapM (mapM dsTvbUnit) mtvbs <*> dsType lhs <*> dsType rhs #else -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn dsTySynEqn n (TySynEqn lhss rhs) = do lhss' <- mapM dsType lhss let lhs' = applyDType (DConT n) $ map DTANormal lhss' DTySynEqn Nothing lhs' <$> dsType rhs #endif -- | Desugar clauses to a function definition dsClauses :: DsMonad q => MatchContext -- ^ The context in which the clauses arise -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses mc rest exp' <- dsExp exp (where_decs', ip_binder) <- dsLetDecs where_decs let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' dsClauses mc clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) clause <- DClause (map DVarP arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do let failure_exp = maybeDCaseE mc scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' let match = DMatch (mkUnboxedTupleDPat pats') exp' if uni_pats then return [match] else return (match : failure_matches) -- | The context of a pattern match. This is used to produce -- @Non-exhaustive patterns in...@ messages that are tailored to specific -- situations. Compare this to GHC's @HsMatchContext@ data type -- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695), -- from which the @MatchContext@ data type takes inspiration. data MatchContext = FunRhs Name -- ^ A pattern matching on an argument of a function binding | LetDecRhs Pat -- ^ A pattern in a @let@ declaration | RecUpd -- ^ A record update | MultiWayIfAlt -- ^ Guards in a multi-way if alternative | CaseAlt -- ^ Patterns and guards in a case alternative -- | Construct an expression that throws an error when encountering a pattern -- at runtime that is not covered by pattern matching. mkErrorMatchExpr :: MatchContext -> DExp mkErrorMatchExpr mc = DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context))) where pp_context = case mc of FunRhs n -> show n LetDecRhs pat -> pprint pat RecUpd -> "record update" MultiWayIfAlt -> "multi-way if" CaseAlt -> "case" -- | Desugar a type dsType :: DsMonad q => Type -> q DType #if __GLASGOW_HASKELL__ >= 900 -- See Note [Gracefully handling linear types] dsType (MulArrowT `AppT` _) = return DArrowT dsType MulArrowT = fail "Cannot desugar exotic uses of linear types." #endif dsType (ForallT tvbs preds ty) = mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name -- The PromotedT case is identical to the ConT case above. -- See Note [Desugaring promoted types]. 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 = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit dsType EqualityT = return $ DConT ''(~) dsType (InfixT t1 n t2) = dsInfixT t1 n t2 dsType (UInfixT{}) = dsUInfixT dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #if __GLASGOW_HASKELL__ >= 801 dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) #endif #if __GLASGOW_HASKELL__ >= 807 dsType (AppKindT t k) = DAppKindT <$> dsType t <*> dsType k dsType (ImplicitParamT n t) = do t' <- dsType t return $ DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t' #endif #if __GLASGOW_HASKELL__ >= 809 dsType (ForallVisT tvbs ty) = DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty #endif #if __GLASGOW_HASKELL__ >= 903 -- The PromotedInfixT case is identical to the InfixT case above. -- See Note [Desugaring promoted types]. dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2 dsType PromotedUInfixT{} = dsUInfixT #endif #if __GLASGOW_HASKELL__ >= 900 -- | Desugar a 'TyVarBndr'. dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag) dsTvb (PlainTV n flag) = return $ DPlainTV n flag dsTvb (KindedTV n flag k) = DKindedTV n flag <$> dsType k #else -- | Desugar a 'TyVarBndr' with a particular @flag@. dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag) dsTvb flag (PlainTV n) = return $ DPlainTV n flag dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k #endif {- Note [Gracefully handling linear types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Per the README, th-desugar does not currently support linear types. Unfortunately, we cannot simply reject all occurrences of multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible for "non-linear" code to contain them when reified. For example, the type of a Haskell98 data constructor such as `Just` will be reified as a #-> Maybe a In terms of the TH AST, that is: MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a) Therefore, in order to desugar these sorts of types, we have to do *something* with MulArrowT. The approach that th-desugar takes is to pretend that all multiplicity-polymorphic function arrows are actually ordinary function arrows (->) when desugaring types. In other words, whenever th-desugar sees (MulArrowT `AppT` m), for any particular value of `m`, it will turn it into DArrowT. This approach is enough to gracefully handle most uses of MulArrowT, as TH reification always generates MulArrowT applied to some particular multiplicity (as of GHC 9.0, at least). It's conceivable that some wily user could manually construct a TH AST containing MulArrowT in a different position, but since this situation is rare, we simply throw an error in such cases. We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the types of data constructors: since th-desugar doesn't currently support linear types, we pretend as if MulArrowT does not exist. As a result, the type of `Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`. Note [Desugaring promoted types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ConT and PromotedT both contain Names as a payload, the only difference being that PromotedT is intended to refer exclusively to promoted data constructor Names, while ConT can refer to both type and data constructor Names alike. When desugaring a PromotedT, we make the assumption that the TH quoting mechanism produced the correct Name and wrap the name in a DConT. In other words, we desugar ConT and PromotedT identically. This assumption about PromotedT may not always be correct, however. Consider this example: data a :+: b = Inl a | Inr b data Exp a = ... | Exp :+: Exp How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be desugared to a DConT that contains (:+:) the data constructor, not (:+:) the type constructor. Deciding between the two is not always straightforward, however. We could use the `lookupDataName` function to try and distinguish between the two Names, but this may not necessarily work. This is because the Name passed to `lookupDataName` could have its original module attached, which may not be in scope. Long story short: we make things simple (albeit slightly wrong) by desugaring ConT and PromotedT identically. We'll wait for someone to complain about the wrongness of this approach before researching a more accurate solution. Note that the same considerations also apply to InfixT and PromotedInfixT, which are also desugared identically. -} -- | Desugar an infix 'Type'. dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 -- | We cannot desugar unresolved infix operators, so fail if we encounter one. dsUInfixT :: Fail.MonadFail m => m a dsUInfixT = fail "Cannot desugar unresolved infix operators." -- | Desugar a 'TyVarBndrSpec'. dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec #if __GLASGOW_HASKELL__ >= 900 dsTvbSpec = dsTvb #else dsTvbSpec = dsTvb SpecifiedSpec #endif -- | Desugar a 'TyVarBndrUnit'. dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit #if __GLASGOW_HASKELL__ >= 900 dsTvbUnit = dsTvb #else dsTvbUnit = dsTvb () #endif -- | Desugar a @Cxt@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred #if __GLASGOW_HASKELL__ >= 801 -- | A backwards-compatible type synonym for the thing representing a single -- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or -- @Name@ depending on the GHC version.) type DerivingClause = DerivClause -- | Desugar a @DerivingClause@. dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause (DerivClause mds cxt) = DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt #else type DerivingClause = Pred dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @DerivStrategy@. dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy dsDerivStrategy StockStrategy = pure DStockStrategy dsDerivStrategy AnyclassStrategy = pure DAnyclassStrategy dsDerivStrategy NewtypeStrategy = pure DNewtypeStrategy #if __GLASGOW_HASKELL__ >= 805 dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty #endif #endif #if __GLASGOW_HASKELL__ >= 801 -- | Desugar a @PatSynDir@. (Available only with GHC 8.2+) dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir dsPatSynDir _ ImplBidir = pure DImplBidir dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses #endif -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt dsPred t | Just ts <- splitTuple_maybe t = concatMapM dsPred ts dsPred (ForallT tvbs cxt p) = dsForallPred tvbs cxt p dsPred (AppT t1 t2) = do [p1] <- dsPred t1 -- tuples can't be applied! (:[]) <$> DAppT p1 <$> dsType t2 dsPred (SigT ty ki) = do preds <- dsPred ty case preds of [p] -> (:[]) <$> DSigT p <$> dsType ki other -> return other -- just drop the kind signature on a tuple. dsPred (VarT n) = return [DVarT n] dsPred (ConT n) = return [DConT n] dsPred t@(PromotedT _) = impossible $ "Promoted type seen as head of constraint: " ++ show t dsPred (TupleT 0) = return [DConT (tupleTypeName 0)] dsPred (TupleT _) = impossible "Internal error in th-desugar in detecting tuple constraints." dsPred t@(UnboxedTupleT _) = impossible $ "Unboxed tuple seen as head of constraint: " ++ show t dsPred ArrowT = impossible "Arrow seen as head of constraint." dsPred ListT = impossible "List seen as head of constraint." dsPred (PromotedTupleT _) = impossible "Promoted tuple seen as head of constraint." dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint." dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint." dsPred StarT = impossible "* seen as head of constraint." dsPred ConstraintT = impossible "The kind `Constraint' seen as head of constraint." dsPred t@(LitT _) = impossible $ "Type literal seen as head of constraint: " ++ show t dsPred EqualityT = return [DConT ''(~)] dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2 dsPred (UInfixT{}) = dsUInfixT dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardT] #if __GLASGOW_HASKELL__ >= 801 dsPred t@(UnboxedSumT {}) = impossible $ "Unboxed sum seen as head of constraint: " ++ show t #endif #if __GLASGOW_HASKELL__ >= 807 dsPred (AppKindT t k) = do [p] <- dsPred t (:[]) <$> (DAppKindT p <$> dsType k) dsPred (ImplicitParamT n t) = do t' <- dsType t return [DConT ''IP `DAppT` DLitT (StrTyLit n) `DAppT` t'] #endif #if __GLASGOW_HASKELL__ >= 809 dsPred t@(ForallVisT {}) = impossible $ "Visible dependent quantifier seen as head of constraint: " ++ show t #endif #if __GLASGOW_HASKELL__ >= 900 dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." #endif #if __GLASGOW_HASKELL__ >= 903 dsPred t@PromotedInfixT{} = impossible $ "Promoted infix type seen as head of constraint: " ++ show t dsPred PromotedUInfixT{} = dsUInfixT #endif -- | Desugar a quantified constraint. dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt dsForallPred tvbs cxt p = do ps' <- dsPred p case ps' of [p'] -> (:[]) <$> (mkDForallConstrainedT <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p') _ -> fail "Cannot desugar constraint tuples in the body of a quantified constraint" -- See GHC #15334. -- | Like 'reify', but safer and desugared. Uses local declarations where -- available. dsReify :: DsMonad q => Name -> q (Maybe DInfo) dsReify = traverse dsInfo <=< reifyWithLocals_maybe -- | Like 'reifyType', but safer and desugared. Uses local declarations where -- available. dsReifyType :: DsMonad q => Name -> q (Maybe DType) dsReifyType = traverse dsType <=< reifyTypeWithLocals_maybe -- Given a list of `forall`ed type variable binders and a context, construct -- a DType using DForallT and DConstrainedT as appropriate. The phrase -- "as appropriate" is used because DConstrainedT will not be used if the -- context is empty, per Note [Desugaring and sweetening ForallT]. mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType mkDForallConstrainedT tele ctxt ty = DForallT tele $ if null ctxt then ty else DConstrainedT ctxt ty -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat con_name field_decs field_pats = reorderFields' dsPat con_name field_decs field_pats (repeat DWildP) reorderFields' :: (Applicative m, Fail.MonadFail m) => (a -> m da) -> Name -- ^ The name of the constructor (used for error reporting) -> [VarStrictType] -> [(Name, a)] -> [da] -> m [da] reorderFields' ds_thing con_name field_names_types field_things deflts = check_valid_fields >> reorder field_names deflts where field_names = map (\(a, _, _) -> a) field_names_types check_valid_fields = forM_ field_things $ \(thing_name, _) -> unless (thing_name `elem` field_names) $ fail $ "Constructor ‘" ++ nameBase con_name ++ "‘ does not have field ‘" ++ nameBase thing_name ++ "‘" reorder [] _ = return [] reorder (field_name : rest) (deflt : rest_deflt) = do rest' <- reorder rest rest_deflt case find (\(thing_name, _) -> thing_name == field_name) field_things of Just (_, thing) -> (: rest') <$> ds_thing thing Nothing -> return $ deflt : rest' reorder (_ : _) [] = error "Internal error in th-desugar." -- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the -- use of 1-tuples. These are used to create auxiliary tuple values when -- desugaring pattern-matching constructs to simpler forms. -- See Note [Auxiliary tuples in pattern matching]. -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps -- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkUnboxedTupleDExp :: [DExp] -> DExp mkUnboxedTupleDExp [exp] = exp mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps -- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkTupleExp :: [Exp] -> Exp mkTupleExp [exp] = exp mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps -- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkUnboxedTupleExp :: [Exp] -> Exp mkUnboxedTupleExp [exp] = exp mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats -- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkUnboxedTupleDPat :: [DPat] -> DPat mkUnboxedTupleDPat [pat] = pat mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitP {}) = return False isUniversalPattern (DVarP {}) = return True isUniversalPattern (DConP con_name _ pats) = do data_name <- dataConNameToDataName con_name (_df, _tvbs, cons) <- getDataD "Internal error." data_name if length cons == 1 then fmap and $ mapM isUniversalPattern pats else return False isUniversalPattern (DTildeP {}) = return True isUniversalPattern (DBangP pat) = isUniversalPattern pat isUniversalPattern (DSigP pat _) = isUniversalPattern pat isUniversalPattern DWildP = return True -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp applyDExp = foldl DAppE -- | Apply one 'DType' to a list of arguments applyDType :: DType -> [DTypeArg] -> DType applyDType = foldl apply where apply :: DType -> DTypeArg -> DType apply f (DTANormal x) = f `DAppT` x apply f (DTyArg x) = f `DAppKindT` x -- | An argument to a type, either a normal type ('DTANormal') or a visible -- kind application ('DTyArg'). -- -- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is -- useful when decomposing an application of a 'DType' to its arguments. data DTypeArg = DTANormal DType | DTyArg DKind deriving (Eq, Show, Data, Generic) -- | Desugar a 'TypeArg'. dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg dsTypeArg (TANormal t) = DTANormal <$> dsType t dsTypeArg (TyArg k) = DTyArg <$> dsType k -- | Filter the normal type arguments from a list of 'DTypeArg's. filterDTANormals :: [DTypeArg] -> [DType] filterDTANormals = mapMaybe getDTANormal where getDTANormal :: DTypeArg -> Maybe DType getDTANormal (DTANormal t) = Just t getDTANormal (DTyArg {}) = Nothing -- | Convert a 'DTyVarBndr' into a 'DType' dTyVarBndrToDType :: DTyVarBndr flag -> DType dTyVarBndrToDType (DPlainTV a _) = DVarT a dTyVarBndrToDType (DKindedTV a _ k) = DVarT a `DSigT` k -- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets -- information about whether a type is a normal argument or not, so use with -- caution. probablyWrongUnDTypeArg :: DTypeArg -> DType probablyWrongUnDTypeArg (DTANormal t) = t probablyWrongUnDTypeArg (DTyArg k) = k -- Take a data type name (which does not belong to a data family) and -- apply it to its type variable binders to form a DType. nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DType nonFamilyDataReturnType con_name = applyDType (DConT con_name) . map (DTANormal . dTyVarBndrToDType) -- Take a data family name and apply it to its argument types to form a -- data family instance DType. dataFamInstReturnType :: Name -> [DTypeArg] -> DType dataFamInstReturnType fam_name = applyDType (DConT fam_name) -- Data family instance declarations did not come equipped with a list of bound -- type variables until GHC 8.8 (and even then, it's optional whether the user -- provides them or not). This means that there are situations where we must -- reverse engineer this information ourselves from the list of type -- arguments. We accomplish this by taking the free variables of the types -- and performing a reverse topological sort on them to ensure that the -- returned list is well scoped. dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit] dataFamInstTvbs = toposortTyVarsOf . map probablyWrongUnDTypeArg -- | Take a list of 'DType's, find their free variables, and sort them in -- reverse topological order to ensure that they are well scoped. In other -- words, the free variables are ordered such that: -- -- 1. Whenever an explicit kind signature of the form @(A :: K)@ is -- encountered, the free variables of @K@ will always appear to the left of -- the free variables of @A@ in the returned result. -- -- 2. The constraint in (1) notwithstanding, free variables will appear in -- left-to-right order of their original appearance. -- -- On older GHCs, this takes measures to avoid returning explicitly bound -- kind variables, which was not possible before @TypeInType@. toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit] toposortTyVarsOf tys = let freeVars :: [Name] freeVars = F.toList $ foldMap fvDType tys varKindSigs :: Map Name DKind varKindSigs = foldMap go_ty tys where go_ty :: DType -> Map Name DKind go_ty (DForallT tele t) = go_tele tele (go_ty t) go_ty (DConstrainedT ctxt t) = foldMap go_ty ctxt `mappend` go_ty t go_ty (DAppT t1 t2) = go_ty t1 `mappend` go_ty t2 go_ty (DAppKindT t k) = go_ty t `mappend` go_ty k go_ty (DSigT t k) = let kSigs = go_ty k in case t of DVarT n -> M.insert n k kSigs _ -> go_ty t `mappend` kSigs go_ty (DVarT {}) = mempty go_ty (DConT {}) = mempty go_ty DArrowT = mempty go_ty (DLitT {}) = mempty go_ty DWildCardT = mempty go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind go_tele (DForallVis tvbs) = go_tvbs tvbs go_tele (DForallInvis tvbs) = go_tvbs tvbs go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind go_tvbs tvbs m = foldr go_tvb m tvbs go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind go_tvb (DPlainTV n _) m = M.delete n m go_tvb (DKindedTV n _ k) m = M.delete n m `mappend` go_ty k -- | Do a topological sort on a list of tyvars, -- so that binders occur before occurrences -- E.g. given [ a::k, k::*, b::k ] -- it'll return a well-scoped list [ k::*, a::k, b::k ] -- -- This is a deterministic sorting operation -- (that is, doesn't depend on Uniques). -- -- It is also meant to be stable: that is, variables should not -- be reordered unnecessarily. scopedSort :: [Name] -> [Name] scopedSort = go [] [] go :: [Name] -- already sorted, in reverse order -> [Set Name] -- each set contains all the variables which must be placed -- before the tv corresponding to the set; they are accumulations -- of the fvs in the sorted tvs' kinds -- This list is in 1-to-1 correspondence with the sorted tyvars -- INVARIANT: -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) -- That is, each set in the list is a superset of all later sets. -> [Name] -- yet to be sorted -> [Name] go acc _fv_list [] = reverse acc go acc fv_list (tv:tvs) = go acc' fv_list' tvs where (acc', fv_list') = insert tv acc fv_list insert :: Name -- var to insert -> [Name] -- sorted list, in reverse order -> [Set Name] -- list of fvs, as above -> ([Name], [Set Name]) -- augmented lists insert tv [] [] = ([tv], [kindFVSet tv]) insert tv (a:as) (fvs:fvss) | tv `S.member` fvs , (as', fvss') <- insert tv as fvss = (a:as', fvs `S.union` fv_tv : fvss') | otherwise = (tv:a:as, fvs `S.union` fv_tv : fvs : fvss) where fv_tv = kindFVSet tv -- lists not in correspondence insert _ _ _ = error "scopedSort" kindFVSet n = maybe S.empty (OS.toSet . fvDType) (M.lookup n varKindSigs) ascribeWithKind n = maybe (DPlainTV n ()) (DKindedTV n ()) (M.lookup n varKindSigs) in map ascribeWithKind $ scopedSort freeVars dtvbName :: DTyVarBndr flag -> Name dtvbName (DPlainTV n _) = n dtvbName (DKindedTV n _ _) = n -- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if -- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be -- returned that uses @mod_@ as the new module prefix. This is useful for -- emulating the behavior of the @QualifiedDo@ extension, which adds module -- prefixes to functions such as ('>>=') and ('>>'). mk_qual_do_name :: Maybe ModName -> Name -> Name mk_qual_do_name mb_mod orig_name = case mb_mod of Nothing -> orig_name Just mod_ -> Name (OccName (nameBase orig_name)) (NameQ mod_) -- | Reconstruct an arrow 'DType' from its argument and result types. ravelDType :: DFunArgs -> DType -> DType ravelDType DFANil res = res ravelDType (DFAForalls tele args) res = DForallT tele (ravelDType args res) ravelDType (DFACxt cxt args) res = DConstrainedT cxt (ravelDType args res) ravelDType (DFAAnon t args) res = DAppT (DAppT DArrowT t) (ravelDType args res) -- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its -- result type (the 'DType). unravelDType :: DType -> (DFunArgs, DType) unravelDType (DForallT tele ty) = let (args, res) = unravelDType ty in (DFAForalls tele args, res) unravelDType (DConstrainedT cxt ty) = let (args, res) = unravelDType ty in (DFACxt cxt args, res) unravelDType (DAppT (DAppT DArrowT t1) t2) = let (args, res) = unravelDType t2 in (DFAAnon t1 args, res) unravelDType t = (DFANil, t) -- | The list of arguments in a function 'DType'. data DFunArgs = DFANil -- ^ No more arguments. | DFAForalls DForallTelescope DFunArgs -- ^ A series of @forall@ed type variables followed by a dot (if -- 'ForallInvis') or an arrow (if 'ForallVis'). For example, -- the type variables @a1 ... an@ in @forall a1 ... an. r@. | DFACxt DCxt DFunArgs -- ^ A series of constraint arguments followed by @=>@. For example, -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@. | DFAAnon DType DFunArgs -- ^ An anonymous argument followed by an arrow. For example, the @a@ -- in @a -> r@. deriving (Eq, Show, Data, Generic) -- | A /visible/ function argument type (i.e., one that must be supplied -- explicitly in the source code). This is in contrast to /invisible/ -- arguments (e.g., the @c@ in @c => r@), which are instantiated without -- the need for explicit user input. data DVisFunArg = DVisFADep DTyVarBndrUnit -- ^ A visible @forall@ (e.g., @forall a -> a@). | DVisFAAnon DType -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@). deriving (Eq, Show, Data, Generic) -- | Filter the visible function arguments from a list of 'DFunArgs'. filterDVisFunArgs :: DFunArgs -> [DVisFunArg] filterDVisFunArgs DFANil = [] filterDVisFunArgs (DFAForalls tele args) = case tele of DForallVis tvbs -> map DVisFADep tvbs ++ args' DForallInvis _ -> args' where args' = filterDVisFunArgs args filterDVisFunArgs (DFACxt _ args) = filterDVisFunArgs args filterDVisFunArgs (DFAAnon t args) = DVisFAAnon t:filterDVisFunArgs args -- | Decompose an applied type into its individual components. For example, this: -- -- @ -- Proxy \@Type Char -- @ -- -- would be unfolded to this: -- -- @ -- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)]) -- @ unfoldDType :: DType -> (DType, [DTypeArg]) unfoldDType = go [] where go :: [DTypeArg] -> DType -> (DType, [DTypeArg]) go acc (DForallT _ ty) = go acc ty go acc (DAppT ty1 ty2) = go (DTANormal ty2:acc) ty1 go acc (DAppKindT ty ki) = go (DTyArg ki:acc) ty go acc (DSigT ty _) = go acc ty go acc ty = (ty, acc) -- | Extract the kind from a 'DTyVarBndr', if one is present. extractTvbKind :: DTyVarBndr flag -> Maybe DKind extractTvbKind (DPlainTV _ _) = Nothing extractTvbKind (DKindedTV _ _ k) = Just k -- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts -- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to -- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound -- by a 'DDataD' in a 'DForallT', one can do the following: -- -- @ -- case x of -- 'DDataD' _ _ _ tvbs _ _ _ -> -- 'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ... -- @ changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag] changeDTVFlags new_flag = map (new_flag <$) -- | Some functions in this module only use certain arguments on particular -- versions of GHC. Other versions of GHC (that don't make use of those -- arguments) might need to conjure up those arguments out of thin air at the -- functions' call sites, so this function serves as a placeholder to use in -- those situations. (In other words, this is a slightly more informative -- version of 'undefined'.) unusedArgument :: a unusedArgument = error "Unused" {- Note [Desugaring and sweetening ForallT] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ForallT constructor from template-haskell is tremendously awkward. Because ForallT contains both a list of type variable binders and constraint arguments, ForallT expressions can be ambiguous when one of these lists is empty. For example, consider this expression with no constraints: ForallT [PlainTV a] [] (VarT a) What should this desugar to in th-desugar, which must maintain a clear separation between type variable binders and constraints? There are two possibilities: 1. DForallT DForallInvis [DPlainTV a] (DVarT a) (i.e., forall a. a) 2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a)) (i.e., forall a. () => a) Template Haskell generally drops these empty lists when splicing Template Haskell expressions, so we would like to do the same in th-desugar to mimic TH's behavior as closely as possible. However, there are some situations where dropping empty lists of `forall`ed type variable binders can change the semantics of a program. For instance, contrast `foo :: forall. a -> a` (which is an error) with `foo :: a -> a` (which is fine). Therefore, we try to preserve empty `forall`s to the best of our ability. Here is an informal specification of how th-desugar should handle different sorts of ambiguity. First, a specification for desugaring. Let `tvbs` and `ctxt` be non-empty: * `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`. * `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`. * `ForallT [] [] ty` should desugar to `DForallT DForallInvis [] ty`. * For all other cases, just straightforwardly desugar `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`. For sweetening: * `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`. * `DForallT DForallInvis [] (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`. * `DForallT DForallInvis tvbs (DConstrainedT [] ty)` should sweeten to `ForallT tvbs [] ty`. * `DForallT DForallInvis [] (DConstrainedT [] ty)` should sweeten to `ForallT [] [] ty`. * For all other cases, just straightforwardly sweeten `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`. Note [Auxiliary tuples in pattern matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ th-desugar simplifies the overall treatment of pattern matching in two notable ways: 1. Lambda expressions only bind variables and do not directly perform pattern matching. For example, this: \True False -> () Roughly desugars to: \x y -> case (x, y) of (True, False) -> () _ -> error "Non-exhaustive patterns" 2. th-desugar does not have guards, as guards are desugared into pattern matches. For example, this: f x y | True <- x , False <- y = () Roughly desugars to: f x y = case (x, y) of (True, False) -> () _ -> error "Non-exhaustive patterns" In both of these examples, there are multiple expressions being matched on simultaneously. When desugaring these examples to `case` expressions, we need a construct that allows us to group these patterns together. Auxiliary tuples are one way to accomplish this. While this use of tuples works well when the arguments have lifted types, such as Bool, it doesn't work when the arguments have unlifted types, such as Int#. Imagine desugaring this lambda expression, for instance: \27# 42# -> () The approach above would desugar this to: \x y -> case (x, y) of (27#, 42#) -> () _ -> error "Non-exhaustive patterns" This will not typecheck, however, as we are using _lifted_ tuples, which require their arguments to have lifted types. If we want to support unlifted types, we need a different approach. One idea that seems tempting at first is to create an auxiliary `let` expression, e.g., \x y -> let aux 27# 42# = () in aux x y This avoids having to use lifted tuples, but it creates a new problem: type inference. In the general case, auxiliary `let` expressions aren't enough to handle GADT pattern matches, such as in this example: data T a where MkT :: Int -> T Int g :: T a -> T a -> a g = \(MkT x1) (MkT x2) -> x1 + x2 If you desugar `g` to use an auxiliary `let` expression: g :: T a -> T a -> a g = \t1 t2 -> let aux (MkT x1) (MkT x2) = x1 + x2 in aux t1 t2 Then it will not typecheck. To make this work, you'd need to give `aux` a type signature. Doing this in general is tantamount to performing type inference, however, which is very challenging in a Template Haskell setting. Another approach, which is what th-desugar currently uses, is to use auxiliary _unboxed_ tuples. This is identical to the previous tuple approach, but with slightly different syntax: \x y -> case (# x, y #) of (# 27#, 42# #) -> () _ -> error "Non-exhaustive patterns" Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable of handling all the examples above. You might worry that this approach would require clients of th-desugar to enable the UnboxedTuples extension in non-obvious places, but fortunately, this is not the case. For one thing, all unboxed tuples produced by th-desugar would be TH-generated, so we would bypass the need to enable UnboxedTuples to lex unboxed tuple syntax. GHC's typechecker also imposes a requirement that UnboxedTuples be enabled if a variable has an unboxed tuple type, but this never happens in th-desugar by construction. It's possible that a future version of GHC might be stricter about this, but it seems unlikely. There are a couple of exceptions to the general rule that auxiliary binders should be unboxed: 1. ParallelListComp is desugared using the `mzip` function, which returns a lifted pair. As a result, the variables bound in a parallel list comprehension must be lifted. This is a restriction which is inherited from GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270. 2. Match flattening desugars lazy patterns that bind multiple variables to code that extracts fields from tuples. For instance, this: data Pair a b = MkPair a b f :: Pair a b -> Pair b a f ~(MkPair x y) = MkPair y x Desugars to this (roughly) when match-flattened: f :: Pair a b -> Pair b a f p = let tuple = case p of MkPair x y -> (x, y) x = case tuple of (x, _) -> x y = case tuple of (_, y) -> x in MkPair y x One could imagine using an unboxed tuple here instead, but since the intermediate `tuple` value would have an unboxed tuple this, this would require users of match flattening to enable UnboxedTuples. Fortunately, using unboxed tuples here isn't necessary, as GHC doesn't support binding variables with unlifted types in lazy patterns anyway. -}