never executed always true always false

    1 {-
    2 (c) The University of Glasgow 2006
    3 (c) The AQUA Project, Glasgow University, 1993-1998
    4 
    5 -}
    6 {-# LANGUAGE TypeFamilies #-}
    7 
    8 -- | Typechecking @default@ declarations
    9 module GHC.Tc.Gen.Default ( tcDefaults ) where
   10 
   11 import GHC.Prelude
   12 
   13 import GHC.Hs
   14 import GHC.Core.Class
   15 import GHC.Core.Type ( typeKind )
   16 import GHC.Types.Var( tyVarKind )
   17 import GHC.Tc.Errors.Types
   18 import GHC.Tc.Utils.Monad
   19 import GHC.Tc.Utils.Env
   20 import GHC.Tc.Gen.HsType
   21 import GHC.Tc.Utils.Zonk
   22 import GHC.Tc.Solver
   23 import GHC.Tc.Validity
   24 import GHC.Tc.Utils.TcType
   25 import GHC.Builtin.Names
   26 import GHC.Types.Error
   27 import GHC.Types.SrcLoc
   28 import GHC.Utils.Outputable
   29 import GHC.Utils.Panic
   30 import qualified GHC.LanguageExtensions as LangExt
   31 
   32 tcDefaults :: [LDefaultDecl GhcRn]
   33            -> TcM (Maybe [Type])    -- Defaulting types to heave
   34                                     -- into Tc monad for later use
   35                                     -- in Disambig.
   36 
   37 tcDefaults []
   38   = getDeclaredDefaultTys       -- No default declaration, so get the
   39                                 -- default types from the envt;
   40                                 -- i.e. use the current ones
   41                                 -- (the caller will put them back there)
   42         -- It's important not to return defaultDefaultTys here (which
   43         -- we used to do) because in a TH program, tcDefaults [] is called
   44         -- repeatedly, once for each group of declarations between top-level
   45         -- splices.  We don't want to carefully set the default types in
   46         -- one group, only for the next group to ignore them and install
   47         -- defaultDefaultTys
   48 
   49 tcDefaults [L _ (DefaultDecl _ [])]
   50   = return (Just [])            -- Default declaration specifying no types
   51 
   52 tcDefaults [L locn (DefaultDecl _ mono_tys)]
   53   = setSrcSpan (locA locn)              $
   54     addErrCtxt defaultDeclCtxt          $
   55     do  { ovl_str   <- xoptM LangExt.OverloadedStrings
   56         ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
   57         ; num_class    <- tcLookupClass numClassName
   58         ; deflt_str <- if ovl_str
   59                        then mapM tcLookupClass [isStringClassName]
   60                        else return []
   61         ; deflt_interactive <- if ext_deflt
   62                                then mapM tcLookupClass interactiveClassNames
   63                                else return []
   64         ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
   65 
   66         ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
   67 
   68         ; return (Just tau_tys) }
   69 
   70 tcDefaults decls@(L locn (DefaultDecl _ _) : _)
   71   = setSrcSpan (locA locn) $
   72     failWithTc (dupDefaultDeclErr decls)
   73 
   74 
   75 tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
   76 tc_default_ty deflt_clss hs_ty
   77  = do   { ty <- solveEqualities "tc_default_ty" $
   78                 tcInferLHsType hs_ty
   79         ; ty <- zonkTcTypeToType ty   -- establish Type invariants
   80         ; checkValidType DefaultDeclCtxt ty
   81 
   82         -- Check that the type is an instance of at least one of the deflt_clss
   83         ; oks <- mapM (check_instance ty) deflt_clss
   84         ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)
   85         ; return ty }
   86 
   87 check_instance :: Type -> Class -> TcM Bool
   88 -- Check that ty is an instance of cls
   89 -- We only care about whether it worked or not; return a boolean
   90 -- This checks that  cls :: k -> Constraint
   91 -- with just one argument and no polymorphism; if we need to add
   92 -- polymorphism we can make it more complicated.  For now we are
   93 -- concerned with classes like
   94 --    Num      :: Type -> Constraint
   95 --    Foldable :: (Type->Type) -> Constraint
   96 check_instance ty cls
   97   | [cls_tv] <- classTyVars cls
   98   , tyVarKind cls_tv `tcEqType` typeKind ty
   99   = simplifyDefault [mkClassPred cls [ty]]
  100   | otherwise
  101   = return False
  102 
  103 defaultDeclCtxt :: SDoc
  104 defaultDeclCtxt = text "When checking the types in a default declaration"
  105 
  106 dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage
  107 dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
  108   = TcRnMultipleDefaultDeclarations dup_things
  109 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"