{- 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 TemplateHaskell, 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 (match, clause, cxt) import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Syntax hiding (lift) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad hiding (forM_, mapM) import qualified Control.Monad.Fail as Fail import Control.Monad.Zip import Control.Monad.Writer hiding (forM_, mapM) import Data.Data (Data, Typeable) 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 (mapMaybe) import qualified Data.Set as S import Data.Set (Set) import Data.Traversable #if __GLASGOW_HASKELL__ > 710 import Data.Maybe (isJust) #endif #if __GLASGOW_HASKELL__ >= 800 import qualified Control.Monad.Fail as MonadFail #endif #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif #if __GLASGOW_HASKELL__ >= 807 import GHC.Classes (IP(..)) #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 [ Match (ConP 'True []) (NormalB e2) [] , Match (ConP 'False []) (NormalB e3) [] ]) dsExp (MultiIfE guarded_exps) = let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) 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 #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields fields #endif 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 #if __GLASGOW_HASKELL__ > 710 VarI _name ty _m_dec -> extract_first_arg ty #else VarI _name ty _m_dec _fixity -> extract_first_arg ty #endif _ -> 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 #if __GLASGOW_HASKELL__ >= 800 has_names (RecGadtC _con_name args _ret_ty) = args_contain_names args #endif 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 #if __GLASGOW_HASKELL__ >= 800 -- 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 #endif con_to_dmatch (ForallC _ _ c) = con_to_dmatch c 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 #if __GLASGOW_HASKELL__ >= 709 dsExp (StaticE exp) = DStaticE <$> dsExp exp #endif #if __GLASGOW_HASKELL__ > 710 dsExp (UnboundVarE n) = return (DVarE n) #endif #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__ >= 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 = mkTupleDExp (map DVarE arg_names) match = DMatch (mkTupleDPat pats) exp return $ DLamE arg_names (DCaseE scrutinee [match]) where stripDVarP_maybe :: DPat -> Maybe Name stripDVarP_maybe (DVarP n) = Just n stripDVarP_maybe _ = Nothing -- | 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 = DCaseE (DVarE scr) rest' -- this might be an empty case. 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 :: String -> DExp -> [DMatch] -> DExp maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err)) 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 #elif __GLASGOW_HASKELL__ >= 800 mk_fail_name = do mfd <- qIsExtEnabled MonadFailDesugaring return $ if mfd then fail_MonadFail_name else fail_Prelude_name #else mk_fail_name = return fail_Prelude_name #endif #if __GLASGOW_HASKELL__ >= 800 fail_MonadFail_name = mk_qual_do_name mb_mod 'MonadFail.fail #endif #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 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 <- 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 #if __GLASGOW_HASKELL__ >= 800 GadtC _names fields _ret_ty -> non_record fields RecGadtC _names fields _ret_ty -> reorder_fields_pat fields #endif 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 pats) = foldl DAppE (DConE name) (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 pats) = DConP con_name <$> 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) #if __GLASGOW_HASKELL__ > 710 dsInfo (ClassOpI name ty parent) = #else dsInfo (ClassOpI name ty parent _fixity) = #endif 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 #if __GLASGOW_HASKELL__ > 710 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 #else dsInfo (DataConI name ty parent _fixity) = DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing _fixity) = DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _) _) = impossible $ "Declaration supplied with variable: " ++ show name #endif 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 #if __GLASGOW_HASKELL__ > 710 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 #else dsDec (DataD cxt n tvbs cons derivings) = dsDataDec Data cxt n tvbs Nothing cons derivings dsDec (NewtypeD cxt n tvbs con derivings) = dsDataDec Newtype cxt n tvbs Nothing [con] derivings #endif 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) #if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) = (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #else dsDec (InstanceD cxt ty decs) = (:[]) <$> (DInstanceD Nothing Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs) #endif dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = dsTopLevelLetDec d dsDec d@(PragmaD {}) = dsTopLevelLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) = (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) #else dsDec (FamilyD TypeFam n tvbs m_k) = do (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k) dsDec (FamilyD DataFam n tvbs m_k) = (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k) #endif #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 #elif __GLASGOW_HASKELL__ > 710 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 #else dsDec (DataInstD cxt n tys cons derivings) = dsDataInstDec Data cxt n Nothing (map TANormal tys) Nothing cons derivings dsDec (NewtypeInstD cxt n tys con derivings) = dsDataInstDec Newtype cxt n Nothing (map TANormal tys) Nothing [con] derivings #endif #if __GLASGOW_HASKELL__ >= 807 dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) #endif #if __GLASGOW_HASKELL__ > 710 dsDec (ClosedTypeFamilyD tfHead eqns) = (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns) #else dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k <*> mapM (dsTySynEqn n) eqns) #endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #if __GLASGOW_HASKELL__ >= 709 #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) #endif #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 -- | Desugar a 'DataD' or 'NewtypeD'. dsDataDec :: DsMonad q => NewOrData -> 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 => NewOrData -> 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) #if __GLASGOW_HASKELL__ > 710 -- | 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 #else -- | Desugar bits and pieces into a 'DTypeFamilyHead' dsTypeFamilyHead :: DsMonad q => Name -> [TyVarBndrUnit] -> Maybe Kind -> q DTypeFamilyHead dsTypeFamilyHead n tvbs m_kind = do result_sig <- case m_kind of Nothing -> return DNoSig Just k -> DKindSig <$> dsType k DTypeFamilyHead n <$> mapM dsTvbUnit tvbs <*> pure result_sig <*> pure Nothing #endif -- | 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 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 = DAppE (DVarE 'error) (DLitE (StringL $ "Non-exhaustive patterns for " ++ pprint 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) #if __GLASGOW_HASKELL__ > 710 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) #endif #if __GLASGOW_HASKELL__ > 710 -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty #else -- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned) dsBangType :: DsMonad q => StrictType -> q DBangType dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty -- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned) dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty #endif -- | 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 #if __GLASGOW_HASKELL__ >= 709 dsPragma (LineP n str) = return $ DLineP n str #endif #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty) = return $ DCompleteP cls mty #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 => Name -- ^ Name of the function -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. rest' <- dsClauses n 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 n clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "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 :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n)) 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 (mkTupleDPat pats') exp' if uni_pats then return [match] else return (match : failure_matches) -- | 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 only difference between ConT and PromotedT is the name lookup. Here, we assume -- that the TH quote mechanism figured out the right name. Note that lookupDataName name -- does not necessarily work, because `name` has its original module attached, which -- may not be in scope. 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 #if __GLASGOW_HASKELL__ >= 709 dsType EqualityT = return $ DConT ''(~) #endif #if __GLASGOW_HASKELL__ > 710 dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2 dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #endif #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__ >= 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`. -} -- | 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 #elif __GLASGOW_HASKELL__ >= 711 type DerivingClause = Pred dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p #else type DerivingClause = Name dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause n = pure $ DDerivClause Nothing [DConT n] #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 n clauses #endif -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709 dsPred (ClassP n tys) = do ts' <- mapM dsType tys return [foldl DAppT (DConT n) ts'] dsPred (EqualP t1 t2) = do ts' <- mapM dsType [t1, t2] return [foldl DAppT (DConT ''(~)) ts'] #else 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 ''(~)] #if __GLASGOW_HASKELL__ > 710 dsPred (InfixT t1 n t2) = (:[]) <$> (DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2) dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators." dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardT] #endif #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 -- | 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. #endif -- | 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." -- | 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 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 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 -- | 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 (_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, Typeable, 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 -- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just -- the identity operation in GHC 8.x, which has no 'Strict'. -- (This is included in GHC 8.x only for good Haddocking.) #if __GLASGOW_HASKELL__ <= 710 strictToBang :: Strict -> Bang strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness strictToBang Unpacked = Bang SourceUnpack SourceStrict #else strictToBang :: Bang -> Bang strictToBang = id #endif -- 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) -- An annoying wrinkle: GHCs before 8.0 don't support explicitly -- quantifying kinds, so something like @forall k (a :: k)@ would be -- rejected. To work around this, we filter out any binders whose names -- also appear in a kind on old GHCs. isKindBinderOnOldGHCs #if __GLASGOW_HASKELL__ >= 800 = const False #else = (`elem` kindVars) where kindVars = foldMap fvDType $ M.elems varKindSigs #endif in map ascribeWithKind $ filter (not . isKindBinderOnOldGHCs) $ 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, Typeable, 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, Typeable, 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`. -}