summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Hs/Binds.hs69
-rw-r--r--compiler/GHC/Hs/Lit.hs44
-rw-r--r--compiler/GHC/Hs/Pat.hs20
-rw-r--r--compiler/GHC/Hs/Type.hs106
-rw-r--r--compiler/GHC/HsToCore/Match.hs2
-rw-r--r--compiler/GHC/HsToCore/Quote.hs6
-rw-r--r--compiler/GHC/HsToCore/Utils.hs1
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs10
-rw-r--r--compiler/GHC/Parser.y10
-rw-r--r--compiler/GHC/Rename/Bind.hs30
-rw-r--r--compiler/GHC/Rename/HsType.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs4
-rw-r--r--compiler/GHC/Tc/Instance/Typeable.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs4
-rw-r--r--compiler/GHC/ThToHs.hs4
-rw-r--r--compiler/GHC/Types/Basic.hs27
20 files changed, 267 insertions, 84 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 686d9e6b25..c08031c223 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -600,6 +600,10 @@ pprTicks pp_no_debug pp_when_debug
then pp_when_debug
else pp_no_debug
+instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where
+ ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
+
+
{-
************************************************************************
* *
@@ -651,20 +655,28 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
type instance XTypeSig (GhcPass p) = EpAnn AnnSig
type instance XPatSynSig (GhcPass p) = EpAnn AnnSig
type instance XClassOpSig (GhcPass p) = EpAnn AnnSig
-type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated
type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn]
type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn]
type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn]
-type instance XSpecInstSig (GhcPass p) = EpAnn [AddEpAnn]
-type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn]
-type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn]
-type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn]
-
-type instance XXSig (GhcPass p) = DataConCantHappen
+type instance XSpecInstSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XMinimalSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XSCCFunSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)
+ -- SourceText: Note [Pragma source text] in GHC.Types.SourceText
+type instance XXSig GhcPs = DataConCantHappen
+type instance XXSig GhcRn = IdSig
+type instance XXSig GhcTc = IdSig
type instance XFixitySig (GhcPass p) = NoExtField
type instance XXFixitySig (GhcPass p) = DataConCantHappen
+-- | A type signature in generated code, notably the code
+-- generated for record selectors. We simply record the desired Id
+-- itself, replete with its name, type and IdDetails. Otherwise it's
+-- just like a type signature: there should be an accompanying binding
+newtype IdSig = IdSig { unIdSig :: Id }
+ deriving Data
+
data AnnSig
= AnnSig {
asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option
@@ -714,7 +726,6 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id))
ppr_sig (FixSig _ fix_sig) = ppr fix_sig
ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
= pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)
@@ -729,20 +740,20 @@ ppr_sig (InlineSig _ var inl)
ppr_pfx = case inlinePragmaSource inl of
SourceText src -> text src
NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl)
-ppr_sig (SpecInstSig _ src ty)
+ppr_sig (SpecInstSig (_, src) ty)
= pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
-ppr_sig (MinimalSig _ src bf)
+ppr_sig (MinimalSig (_, src) bf)
= pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
ppr_sig (PatSynSig _ names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
-ppr_sig (SCCFunSig _ src fn mlabel)
+ppr_sig (SCCFunSig (_, src) fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )
where
ppr_fn = case ghcPass @p of
GhcPs -> ppr fn
GhcRn -> ppr fn
GhcTc -> ppr fn
-ppr_sig (CompleteMatchSig _ src cs mty)
+ppr_sig (CompleteMatchSig (_, src) cs mty)
= pragSrcBrackets src "{-# COMPLETE"
((hsep (punctuate comma (map ppr_n (unLoc cs))))
<+> opt_sig)
@@ -752,6 +763,40 @@ ppr_sig (CompleteMatchSig _ src cs mty)
GhcPs -> ppr n
GhcRn -> ppr n
GhcTc -> ppr n
+ppr_sig (XSig x) = case ghcPass @p of
+ GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id))
+ GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id))
+
+hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc
+hsSigDoc (TypeSig {}) = text "type signature"
+hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
+hsSigDoc (ClassOpSig _ is_deflt _ _)
+ | is_deflt = text "default type signature"
+ | otherwise = text "class method signature"
+hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
+hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"
+-- Using the 'inlinePragmaName' function ensures that the pragma name for any
+-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted
+-- from the InlineSpec field of the pragma.
+hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma"
+hsSigDoc (FixSig {}) = text "fixity declaration"
+hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
+hsSigDoc (SCCFunSig {}) = text "SCC pragma"
+hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
+hsSigDoc (XSig _) = case ghcPass @p of
+ GhcRn -> text "id signature"
+ GhcTc -> text "id signature"
+
+-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src
+-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE
+-- instance pragma of the form: "SourceText {-# SPECIALIZE"
+--
+-- Extraction ensures that all variants of the pragma name (with a 'Z' or an
+-- 'S') are output exactly as used in the pragma.
+extractSpecPragName :: SourceText -> String
+extractSpecPragName srcTxt = case (words $ show srcTxt) of
+ (_:_:pragName:_) -> filter (/= '\"') pragName
+ _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt)
instance OutputableBndrId p
=> Outputable (FixitySig (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index 3b9b6948c6..838e3348dd 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -25,14 +25,15 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Hs.Expr( pprExpr )
-import Language.Haskell.Syntax.Lit
-
+import GHC.Types.Basic (PprPrec(..), topPrec )
+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Utils.Outputable
+import GHC.Hs.Extension
import Language.Haskell.Syntax.Expr ( HsExpr )
import Language.Haskell.Syntax.Extension
-import GHC.Hs.Extension
+import Language.Haskell.Syntax.Lit
{-
************************************************************************
@@ -103,6 +104,37 @@ type instance XXOverLit (GhcPass _) = DataConCantHappen
overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty
+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
+-- @ol@ needs to be parenthesized under precedence @p@.
+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
+ where
+ go :: OverLitVal -> Bool
+ go (HsIntegral x) = p > topPrec && il_neg x
+ go (HsFractional x) = p > topPrec && fl_neg x
+ go (HsIsString {}) = False
+hsOverLitNeedsParens _ (XOverLit { }) = False
+
+-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
+-- to be parenthesized under precedence @p@.
+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens p = go
+ where
+ go (HsChar {}) = False
+ go (HsCharPrim {}) = False
+ go (HsString {}) = False
+ go (HsStringPrim {}) = False
+ go (HsInt _ x) = p > topPrec && il_neg x
+ go (HsIntPrim _ x) = p > topPrec && x < 0
+ go (HsWordPrim {}) = False
+ go (HsInt64Prim _ x) = p > topPrec && x < 0
+ go (HsWord64Prim {}) = False
+ go (HsInteger _ x _) = p > topPrec && x < 0
+ go (HsRat _ x _) = p > topPrec && fl_neg x
+ go (HsFloatPrim _ x) = p > topPrec && fl_neg x
+ go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+ go (XLit _) = False
+
-- | Convert a literal from one index type to another
convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit (HsChar a x) = HsChar a x
@@ -161,6 +193,11 @@ instance OutputableBndrId p
ppr (OverLit {ol_val=val, ol_ext=ext})
= ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext)))
+instance Outputable OverLitVal where
+ ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
+ ppr (HsFractional f) = ppr f
+ ppr (HsIsString st s) = pprWithSourceText st (pprHsString s)
+
-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
-- match warnings. All are printed the same (i.e., without hashes if they are
-- primitive and not wrapped in constructors if they are boxed). This happens
@@ -181,3 +218,4 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
+
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 102587026e..2b8eb269bb 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -260,6 +261,24 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
************************************************************************
-}
+instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where
+ ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty
+
+instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)
+ => Outputable (HsRecFields p arg) where
+ ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
+ = braces (fsep (punctuate comma (map ppr flds)))
+ ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })
+ = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
+ where
+ dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
+
+instance (Outputable p, OutputableBndr p, Outputable arg)
+ => Outputable (HsFieldBind p arg) where
+ ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,
+ hfbPun = pun })
+ = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
+
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
@@ -734,3 +753,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns
type instance Anno ConLike = SrcSpanAnnN
type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
+type instance Anno RecFieldsDotDot = SrcSpan
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 1635019dbe..73709e2849 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -112,8 +113,10 @@ import GHC.Hs.Doc
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
+import GHC.Utils.Misc (count)
import Data.Maybe
+import Data.Data (Data)
import qualified Data.Semigroup as S
@@ -207,6 +210,14 @@ type instance XHsPS GhcPs = EpAnnCO
type instance XHsPS GhcRn = HsPSRn
type instance XHsPS GhcTc = HsPSRn
+-- | The extension field for 'HsPatSigType', which is only used in the
+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.
+data HsPSRn = HsPSRn
+ { hsps_nwcs :: [Name] -- ^ Wildcard names
+ , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names
+ }
+ deriving Data
+
type instance XXHsPatSigType (GhcPass _) = DataConCantHappen
type instance XHsSig (GhcPass _) = NoExtField
@@ -533,6 +544,66 @@ lhsTypeArgSrcSpan arg = case arg of
--------------------------------
+numVisibleArgs :: [HsArg tm ty] -> Arity
+numVisibleArgs = count is_vis
+ where is_vis (HsValArg _) = True
+ is_vis _ = False
+
+--------------------------------
+
+-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@
+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix
+-- or infix. Examples:
+--
+-- @
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering
+-- @
+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)
+ => id -> LexicalFixity -> [HsArg tm ty] -> SDoc
+pprHsArgsApp thing fixity (argl:argr:args)
+ | Infix <- fixity
+ = let pp_op_app = hsep [ ppr_single_hs_arg argl
+ , pprInfixOcc thing
+ , ppr_single_hs_arg argr ] in
+ case args of
+ [] -> pp_op_app
+ _ -> ppr_hs_args_prefix_app (parens pp_op_app) args
+
+pprHsArgsApp thing _fixity args
+ = ppr_hs_args_prefix_app (pprPrefixOcc thing) args
+
+-- | Pretty-print a prefix identifier to a list of 'HsArg's.
+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)
+ => SDoc -> [HsArg tm ty] -> SDoc
+ppr_hs_args_prefix_app acc [] = acc
+ppr_hs_args_prefix_app acc (arg:args) =
+ case arg of
+ HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+ HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+ HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args
+
+-- | Pretty-print an 'HsArg' in isolation.
+ppr_single_hs_arg :: (Outputable tm, Outputable ty)
+ => HsArg tm ty -> SDoc
+ppr_single_hs_arg (HsValArg tm) = ppr tm
+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty
+-- GHC shouldn't be constructing ASTs such that this case is ever reached.
+-- Still, it's possible some wily user might construct their own AST that
+-- allows this to be reachable, so don't fail here.
+ppr_single_hs_arg (HsArgPar{}) = empty
+
+-- | This instance is meant for debug-printing purposes. If you wish to
+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.
+instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
+ ppr (HsValArg tm) = text "HsValArg" <+> ppr tm
+ ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty
+ ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp
+
+--------------------------------
+
-- | Decompose a pattern synonym type signature into its constituent parts.
--
-- Note that this function looks through parentheses, so it will work on types
@@ -919,6 +990,41 @@ instance (OutputableBndrId p)
=> Outputable (HsPatSigType (GhcPass p)) where
ppr (HsPS { hsps_body = ty }) = ppr ty
+
+instance Outputable HsTyLit where
+ ppr = ppr_tylit
+
+instance Outputable HsIPName where
+ ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters
+
+instance OutputableBndr HsIPName where
+ pprBndr _ n = ppr n -- Simple for now
+ pprInfixOcc n = ppr n
+ pprPrefixOcc n = ppr n
+
+instance (Outputable tyarg, Outputable arg, Outputable rec)
+ => Outputable (HsConDetails tyarg arg rec) where
+ ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args
+ ppr (RecCon rec) = text "RecCon:" <+> ppr rec
+ ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
+
+instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where
+ ppr = ppr . foLabel
+
+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where
+ pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel
+ pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel
+
+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where
+ pprInfixOcc = pprInfixOcc . unLoc
+ pprPrefixOcc = pprPrefixOcc . unLoc
+
+
+ppr_tylit :: HsTyLit -> SDoc
+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)
+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))
+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))
+
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 0cc5907c2b..86b6347e09 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -27,7 +27,7 @@ import GHC.Platform
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
+import GHC.Types.Basic ( Origin(..), isGenerated )
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Hs
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 015ecb56f6..57292e47f2 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -989,16 +989,16 @@ rep_sig (L loc (PatSynSig _ nms ty))
rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms
| otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms
-rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
-rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc)
+rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas
-rep_sig (L loc (CompleteMatchSig _ _st cls mty))
+rep_sig (L loc (CompleteMatchSig _ cls mty))
= rep_complete_sig cls mty (locA loc)
+rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d)
-- Desugar the explicit type variable binders in an 'LHsSigType', making
-- sure not to gensym them.
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index e3c6ef1333..083c59b3cf 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -66,7 +66,6 @@ import GHC.Core.PatSyn
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Builtin.Types
-import GHC.Types.Basic
import GHC.Core.ConLike
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index dab2a7e7ad..c1465bf0bc 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1698,7 +1698,6 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
_ -> toHie $ map (C $ TyDecl) names
, toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
]
- IdSig _ _ -> []
FixSig _ fsig ->
[ toHie $ L sp fsig
]
@@ -1709,21 +1708,22 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
[ toHie $ (C Use) name
, toHie $ map (TS (ResolvedScopes [])) typs
]
- SpecInstSig _ _ typ ->
+ SpecInstSig _ typ ->
[ toHie $ TS (ResolvedScopes []) typ
]
- MinimalSig _ _ form ->
+ MinimalSig _ form ->
[ toHie form
]
- SCCFunSig _ _ name mtxt ->
+ SCCFunSig _ name mtxt ->
[ toHie $ (C Use) name
, maybe (pure []) (locOnly . getLocA) mtxt
]
- CompleteMatchSig _ _ (L ispan names) typ ->
+ CompleteMatchSig _ (L ispan names) typ ->
[ locOnly ispan
, toHie $ map (C Use) names
, toHie $ fmap (C Use) typ
]
+ XSig _ -> []
instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where
toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span :
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index be897a1d14..2731c6abd2 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2580,7 +2580,7 @@ sigdecl :: { LHsDecl GhcPs }
{% let (dcolon, tc) = $3
in acsA
(\cs -> sLL $1 $>
- (SigD noExtField (CompleteMatchSig (EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) }
+ (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvarcon '#-}'
@@ -2591,12 +2591,12 @@ sigdecl :: { LHsDecl GhcPs }
{% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2
(mkOpaquePragma (getOPAQUE_PRAGs $1))))) }
| '{-# SCC' qvar '#-}'
- {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }
+ {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
- ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1a $3 str_lit))))) }}
+ ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% acsA (\cs ->
@@ -2611,11 +2611,11 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% acsA (\cs -> sLL $1 $>
- $ SigD noExtField (SpecInstSig (EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) }
+ $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (EpAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) }
+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) }
activation :: { ([AddEpAnn],Maybe Activation) }
-- See Note [%shift: activation -> {- empty -}]
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 70489c0048..5ade2db117 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -970,9 +970,6 @@ renameSigs ctxt sigs
-- Doesn't seem worth much trouble to sort this.
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
-renameSig _ (IdSig _ x)
- = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs
-
renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
@@ -992,7 +989,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
ty_ctxt = GenericCtx (text "a class method signature for"
<+> quotes (ppr v1))
-renameSig _ (SpecInstSig _ src ty)
+renameSig _ (SpecInstSig (_, src) ty)
= do { checkInferredVars doc inf_msg ty
; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty
-- Check if there are any nested `forall`s or contexts, which are
@@ -1001,7 +998,7 @@ renameSig _ (SpecInstSig _ src ty)
-- GHC.Hs.Type).
; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type")
(getLHsInstDeclHead new_ty)
- ; return (SpecInstSig noAnn src new_ty,fvs) }
+ ; return (SpecInstSig (noAnn, src) new_ty,fvs) }
where
doc = SpecInstSigCtx
inf_msg = Just (text "Inferred type variables are not allowed")
@@ -1031,9 +1028,9 @@ renameSig ctxt (FixSig _ fsig)
= do { new_fsig <- rnSrcFixityDecl ctxt fsig
; return (FixSig noAnn new_fsig, emptyFVs) }
-renameSig ctxt sig@(MinimalSig _ s (L l bf))
+renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
= do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf
- return (MinimalSig noAnn s (L l new_bf), emptyFVs)
+ return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
@@ -1043,13 +1040,13 @@ renameSig ctxt sig@(PatSynSig _ vs ty)
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
<+> ppr_sig_bndrs vs)
-renameSig ctxt sig@(SCCFunSig _ st v s)
+renameSig ctxt sig@(SCCFunSig (_, st) v s)
= do { new_v <- lookupSigOccRnN ctxt sig v
- ; return (SCCFunSig noAnn st new_v s, emptyFVs) }
+ ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) }
-- COMPLETE Sigs can refer to imported IDs which is why we use
-- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
+renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty)
= do new_bf <- traverse lookupLocatedOccRn bf
new_mty <- traverse lookupLocatedOccRn mty
@@ -1058,7 +1055,7 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
-- Why 'any'? See Note [Orphan COMPLETE pragmas]
addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
- return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)
+ return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs)
where
orphanError :: TcRnMessage
orphanError = TcRnUnknownMessage $ mkPlainError noHints $
@@ -1108,10 +1105,6 @@ okHsSig ctxt (L _ sig)
(FixSig {}, InstDeclCtxt {}) -> False
(FixSig {}, _) -> True
- (IdSig {}, TopSigCtxt {}) -> True
- (IdSig {}, InstDeclCtxt {}) -> True
- (IdSig {}, _) -> False
-
(InlineSig {}, HsBootCtxt {}) -> False
(InlineSig {}, _) -> True
@@ -1132,6 +1125,11 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, TopSigCtxt {} ) -> True
(CompleteMatchSig {}, _) -> False
+ (XSig {}, TopSigCtxt {}) -> True
+ (XSig {}, InstDeclCtxt {}) -> True
+ (XSig {}, _) -> False
+
+
-------------------
findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
-- Check for duplicates on RdrName version,
@@ -1151,7 +1149,7 @@ findDupSigs sigs
expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns]
expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns]
expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]
- expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)]
+ expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)]
expand_sig _ = []
matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index bbcd5244af..eacfe233dc 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -71,7 +71,7 @@ import GHC.Types.Error
import GHC.Utils.Misc
import GHC.Types.Fixity ( compareFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..) )
-import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) )
+import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 08c4ca664c..3db286e3e5 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -208,7 +208,7 @@ tcCompleteSigs sigs =
-- combinations are invalid it will be found so at match sites.
-- There it is also where we consider if the type of the pattern match is
-- compatible with the result type constructor 'mb_tc'.
- doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm))
+ doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm))
= fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do
cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns
mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
@@ -658,7 +658,7 @@ tcPolyCheck _prag_fn sig bind
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [CoreTickish]
funBindTicks loc fun_id mod sigs
- | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
+ | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
-- this can only be a singleton list, as duplicate pragmas are rejected
-- by the renamer
, let cc_str
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index e26fee1f98..cb7f5cfb56 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -1376,7 +1376,7 @@ desugarRecordUpd record_expr rbnds res_ty
upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs)
| (_, (id, rhs)) <- upd_ids ]
mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
- mk_idSig (_, (id, _)) = L gen $ IdSig noExtField id
+ mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id
-- We let-bind variables using 'IdSig' in order to accept
-- record updates involving higher-rank types.
-- See Wrinkle [Using IdSig] in Note [Record Updates].
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 69e65ce2d1..ce5e3bd394 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -189,7 +189,7 @@ tcTySigs hs_sigs
; return (poly_ids, lookupNameEnv env) }
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
-tcTySig (L _ (IdSig _ id))
+tcTySig (L _ (XSig (IdSig id)))
= do { let ctxt = FunSigCtxt (idName id) NoRRC
-- NoRRC: do not report redundant constraints
-- The user has no control over the signature!
@@ -581,7 +581,7 @@ mkPragEnv sigs binds
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)
- get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig)
+ get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)
get_sig _ = Nothing
add_arity n sig -- Adjust inl_sat field to match visible arity of function
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
index 3dc6154c84..f1a576dcbc 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ b/compiler/GHC/Tc/Instance/Typeable.hs
@@ -13,7 +13,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
import GHC.Prelude
import GHC.Platform
-import GHC.Types.Basic ( Boxity(..), neverInlinePragma )
+import GHC.Types.Basic ( neverInlinePragma )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Iface.Env( newGlobalBinder )
import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index ee41b3e0aa..dee46e9189 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -403,7 +403,7 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
- toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
+ toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
toMinimalDef _ = Nothing
{-
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 160d8ceae9..c99beb861e 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2346,7 +2346,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
------------------------------
tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
-tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
+tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index e102507d63..a77d6be317 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -853,14 +853,14 @@ when typechecking the [d| .. |] quote, and typecheck them later.
tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds sel_bind_prs
- = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $
+ = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $
do { (rec_sel_binds, tcg_env) <- discardWarnings $
-- See Note [Impredicative record selectors]
setXOptM LangExt.ImpredicativeTypes $
tcValBinds TopLevel binds sigs getGblEnv
; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
where
- sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id)
+ sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
| (sel_id, _) <- sel_bind_prs
, let loc = getSrcSpan sel_id ]
binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 441c84bad7..0432de43fa 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -857,7 +857,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtSigType ty
; returnJustLA $ Hs.SigD noExtField $
- SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' }
+ SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' }
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -906,7 +906,7 @@ cvtPragmaD (CompleteP cls mty)
= do { cls' <- wrapL $ mapM cNameN cls
; mty' <- traverse tconNameN mty
; returnJustLA $ Hs.SigD noExtField
- $ CompleteMatchSig noAnn NoSourceText cls' mty' }
+ $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index a2decc2ba4..d5eba8c4ad 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -122,6 +122,8 @@ import GHC.Types.SourceText
import qualified GHC.LanguageExtensions as LangExt
import Data.Data
import qualified Data.Semigroup as Semi
+import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted)
+import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag)
{-
************************************************************************
@@ -195,12 +197,6 @@ type FullArgCount = Int
************************************************************************
-}
--- | A *one-index* constructor tag
---
--- Type of the tags associated with each constructor possibility or superclass
--- selector
-type ConTag = Int
-
-- | A *zero-indexed* constructor tag
type ConTagZ = Int
@@ -401,16 +397,6 @@ unSwap IsSwapped f a b = f b a
* *
********************************************************************* -}
--- | Is a TyCon a promoted data constructor or just a normal type constructor?
-data PromotionFlag
- = NotPromoted
- | IsPromoted
- deriving ( Eq, Data )
-
-isPromoted :: PromotionFlag -> Bool
-isPromoted IsPromoted = True
-isPromoted NotPromoted = False
-
instance Outputable PromotionFlag where
ppr NotPromoted = text "NotPromoted"
ppr IsPromoted = text "IsPromoted"
@@ -498,15 +484,6 @@ instance Outputable TopLevelFlag where
************************************************************************
-}
-data Boxity
- = Boxed
- | Unboxed
- deriving( Eq, Data )
-
-isBoxed :: Boxity -> Bool
-isBoxed Boxed = True
-isBoxed Unboxed = False
-
instance Outputable Boxity where
ppr Boxed = text "Boxed"
ppr Unboxed = text "Unboxed"
View Lorry Controller Status