module UHC.Light.Compiler.NameAspect
( IdDefOcc (..), emptyIdDefOcc, mkIdDefOcc
, IdAspect (..)
, iaspIsFun, iaspIsPat, iaspIsValSig, iaspIsValVar, iaspIsValFix
, mbUseAspOfIdOccKind
, iaspIsTypeVar
, iaspIsValCon, iaspIsTypeDef, iaspIsValFld
, iaspIsTypeSig
, iaspIsValForeign
, iaspIsClassDef
, idDefOccLCmb
, doccStrip )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.HsName.Builtin
import qualified UHC.Light.Compiler.EH as EH
import UHC.Util.Pretty
import qualified Data.Set as Set
import UHC.Util.Utils



{-# LINE 32 "src/ehc/NameAspect.chs" #-}
data IdAspect
  = IdAsp_Val_Var
  | IdAsp_Val_Pat       	{iaspDecl   ::  EH.Decl                         }
  | IdAsp_Val_Fun       	{iaspPatL   :: [EH.PatExpr], iaspBody :: EH.Expr, iaspUniq :: !UID}
  | IdAsp_Val_Sig       	{iaspDecl   ::  EH.Decl                         }
  | IdAsp_Val_Fix
  | IdAsp_Val_Con
  | IdAsp_Val_Fld       	{iaspDataNm :: !HsName, iaspConNm :: !HsName    }
  | IdAsp_Val_Fusion	  	{iaspDecl   ::  EH.Decl                         }
  | IdAsp_Fusion_Conv  		{iaspDecl   ::  EH.Decl                         }
  | IdAsp_Type_Con
  | IdAsp_Type_Var
  | IdAsp_Type_Def      	{iaspDecl   ::  EH.Decl                         }
  | IdAsp_Type_Sig      	{iaspDecl   :: !EH.Decl                         }
  | IdAsp_Kind_Con
  | IdAsp_Kind_Var
  | IdAsp_Val_Foreign   	{iaspDecl   :: !EH.Decl                         }
  | IdAsp_Class_Class
  | IdAsp_Class_Def     	{iaspDecl   ::  EH.Decl, iaspDeclInst ::  EH.Decl}
  | IdAsp_Inst_Inst
  | IdAsp_Inst_Def      	{iaspDecl   ::  EH.Decl, iaspClassNm  :: !HsName}
  | IdAsp_Dflt_Def     		-- for now defaults without explicit class name are ignored
                       	 	{iaspDecl   :: !EH.Decl, iaspIgnore   :: !Bool  }
  | IdAsp_Any

{-# LINE 73 "src/ehc/NameAspect.chs" #-}
iaspIsFun :: IdAspect -> Bool
iaspIsFun (IdAsp_Val_Fun _ _ _) = True
iaspIsFun _                     = False

iaspIsPat :: IdAspect -> Bool
iaspIsPat (IdAsp_Val_Pat _) = True
iaspIsPat _                 = False

iaspIsValSig :: IdAspect -> Bool
iaspIsValSig (IdAsp_Val_Sig _) = True
iaspIsValSig _                 = False

iaspIsValVar :: IdAspect -> Bool
iaspIsValVar IdAsp_Val_Var = True
iaspIsValVar _             = False

iaspIsValFix :: IdAspect -> Bool
iaspIsValFix IdAsp_Val_Fix = True
iaspIsValFix _             = False

{-# LINE 95 "src/ehc/NameAspect.chs" #-}
iaspIsTypeVar :: IdAspect -> Bool
iaspIsTypeVar IdAsp_Type_Var = True
iaspIsTypeVar _              = False

{-# LINE 101 "src/ehc/NameAspect.chs" #-}
iaspIsValCon :: IdAspect -> Bool
iaspIsValCon IdAsp_Val_Con = True
iaspIsValCon _             = False

iaspIsValFld :: IdAspect -> Bool
iaspIsValFld (IdAsp_Val_Fld _ _) = True
iaspIsValFld _                   = False

iaspIsTypeDef :: IdAspect -> Bool
iaspIsTypeDef (IdAsp_Type_Def _) = True
iaspIsTypeDef _                  = False

{-# LINE 115 "src/ehc/NameAspect.chs" #-}
iaspIsTypeSig :: IdAspect -> Bool
iaspIsTypeSig (IdAsp_Type_Sig _) = True
iaspIsTypeSig _                  = False

{-# LINE 121 "src/ehc/NameAspect.chs" #-}
iaspIsValForeign :: IdAspect -> Bool
iaspIsValForeign (IdAsp_Val_Foreign _) = True
iaspIsValForeign _                     = False

{-# LINE 127 "src/ehc/NameAspect.chs" #-}
iaspIsClassDef :: IdAspect -> Bool
iaspIsClassDef (IdAsp_Class_Def _ _) = True
iaspIsClassDef _                     = False

{-# LINE 133 "src/ehc/NameAspect.chs" #-}
instance Show IdAspect where
  show _ = "IdAspect"

{-# LINE 138 "src/ehc/NameAspect.chs" #-}
instance PP IdAspect where
  pp  IdAsp_Val_Var         = pp "value"
  pp (IdAsp_Val_Pat _    )  = pp "pattern"
  pp (IdAsp_Val_Fun _ _ _)  = pp "function"
  pp (IdAsp_Val_Sig _    )  = pp "type signature"
  pp  IdAsp_Val_Fix         = pp "fixity"
  pp  IdAsp_Val_Con         = pp "data constructor"
  pp (IdAsp_Val_Fld _ _  )  = pp "data field"
  pp (IdAsp_Val_Fusion  _)  = pp "fuse"
  pp (IdAsp_Fusion_Conv _)  = pp "convert"
  pp  IdAsp_Type_Con        = pp "type constructor"
  pp  IdAsp_Type_Var        = pp "type variable"
  pp (IdAsp_Type_Def _   )  = pp "type"
  pp (IdAsp_Type_Sig _   )  = pp "kind signature"
  pp  IdAsp_Kind_Con        = pp "kind constructor"
  pp  IdAsp_Kind_Var        = pp "kind variable"
  pp (IdAsp_Val_Foreign _)  = pp "foreign"
  pp  IdAsp_Class_Class     = pp "class"
  pp (IdAsp_Class_Def _ _)  = pp "class"
  pp  IdAsp_Inst_Inst       = pp "instance"
  pp (IdAsp_Inst_Def  _ _)  = pp "instance"
  pp (IdAsp_Dflt_Def  _ _)  = pp "default"
  pp  IdAsp_Any             = pp "ANY"

{-# LINE 182 "src/ehc/NameAspect.chs" #-}
-- | Default use aspect of occurrence kind, only if a sensible choice exists
mbUseAspOfIdOccKind :: IdOccKind -> Maybe IdAspect
mbUseAspOfIdOccKind ok = case ok of
    IdOcc_Val		-> Just IdAsp_Val_Var
    -- IdOcc_Pat
    IdOcc_Type		-> Just IdAsp_Type_Con
    IdOcc_Kind		-> Just IdAsp_Kind_Con
    -- IdOcc_Fld
    IdOcc_Class		-> Just IdAsp_Class_Class
    -- IdOcc_Inst
    -- IdOcc_Dflt
    -- IdOcc_Any
    -- IdOcc_Data
    -- IdOcc_Fusion
    _ 				-> Nothing

{-# LINE 214 "src/ehc/NameAspect.chs" #-}
data IdDefOcc
  = IdDefOcc
      { doccOcc     :: !IdOcc
      , doccAsp     :: !IdAspect
      , doccLev     :: !NmLev
      , doccRange   :: !Range
      , doccNmAlts  :: !(Set.Set HsName) -- !(Maybe [HsName])
      }
  deriving (Show)

emptyIdDefOcc :: IdDefOcc
emptyIdDefOcc = mkIdDefOcc (IdOcc hsnUnknown IdOcc_Any) IdAsp_Any nmLevAbsent emptyRange

{-# LINE 236 "src/ehc/NameAspect.chs" #-}
mkIdDefOcc :: IdOcc -> IdAspect -> NmLev -> Range -> IdDefOcc
mkIdDefOcc o a l r = IdDefOcc o a l r Set.empty

{-# LINE 241 "src/ehc/NameAspect.chs" #-}
instance PP IdDefOcc where
  pp o = doccOcc o >|< "/" >|< doccAsp o >|< "/" >|< doccLev o
         >|< (ppBracketsCommas $ Set.toList $ doccNmAlts o)

{-# LINE 249 "src/ehc/NameAspect.chs" #-}
-- | Collapse multiple 'IdDefOcc', remembering duplicates in doccNmAlts
idDefOccLCmb :: IdDefOcc -> [IdDefOcc] -> [IdDefOcc]
idDefOccLCmb l1 l2 =
  [ d {doccNmAlts = Set.unions [Set.insert (ioccNm o) a | (IdDefOcc {doccOcc = o, doccNmAlts = a}) <- g]}
  | g@(d:_) <- groupSortOn (\d -> (ioccKind $ doccOcc d {-, doccLev d -})) $ l1 : l2
  ]

{-# LINE 258 "src/ehc/NameAspect.chs" #-}
-- | Strip positional info
doccStrip :: IdDefOcc -> IdDefOcc
doccStrip o = o {doccRange = emptyRange}

{-# LINE 315 "src/ehc/NameAspect.chs" #-}
instance PP IdOcc where
  pp o = ppCurlysCommas [pp (ioccNm o),pp (ioccKind o)]