content: {-# LANGUAGE CPP #-}
  module SymTab(
                SymTab(..), VarInfo(..), TypeInfo(..),
                ConInfo(..), ConTagInfo(..),
                FieldInfo(..), VarKind(..),
                getAllTypes,
                emptySymtab,
                addVars, addTypes, addCons, addFields, addClasses,
                addVarsUQ, addTypesUQ, addClassesUQ, mkDefaultQuals,
                addTypesQ, addFieldsQ,
                findVar, findCon, findConVis, findType,
                findField, findFieldVis, findSClass, mustFindClass,
                findFieldInfo,
                getMethodArgNames, getIfcFieldNames, getIfcFlatMethodNames
                ) where
  
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  
  import Data.List(find)
  import Data.Maybe(isNothing, isJust)
  import qualified Data.Map as M
  import Eval
  import PPrint
  import Id
  import Pred(Class(..))
  import Assump
  import Scheme(Scheme(..))
  import Pred(Qual(..))
  import CType
  import Type(isClock, isReset, isInout)
  import CSyntax(CClause)
  import Pragma
  import ConTagInfo
  
  import ErrorUtil(internalError)
  
  --import Debug.Trace
  
  type IdMap a = M.Map Id a
  
  data VarInfo
          -- the Maybe is whether the identifier has been deprecated, and why
          = VarInfo !VarKind !Assump !(Maybe String)
          deriving (Show)
  
  instance PPrint VarInfo where
      pPrint d p (VarInfo k a m) =
          pparen (p>0) $
              text "VarInfo" <+> pPrint d 1 k <+> pPrint d 1 a <+>
              pPrint d 1 (isJust m)
  
  data VarKind
          = VarPrim
          | VarDefn
          | VarMeth
          -- the maybe [String] is portlist for Verilog foreign funcs as modules
          -- (as "noinline" compiles to)
          | VarForg String (Maybe ([String], [String]))
          deriving (Show)
  
  instance PPrint VarKind where
      pPrint _ _ k = text (show k)
  
  data ConInfo
          = ConInfo { ci_id :: Id,
                      ci_visible :: Bool,
                      ci_assump :: Assump,    -- type
                      ci_taginfo :: ConTagInfo -- constructor number and tag metadata
                    }
          deriving (Show, Eq)
  
  -- test whether two ConInfo are identical except for the visibility
  conInfoEq :: ConInfo -> ConInfo -> Bool
  conInfoEq ci1 ci2 =
      (ci1 { ci_visible = False }) == (ci2 { ci_visible = False })
  
  -- merge two coninfo lists, overriding hidden entries with visible entries
  conInfoMerge :: [ConInfo] -> [ConInfo] -> [ConInfo]
  conInfoMerge new_cis old_cis = foldr mergeFn old_cis new_cis
      where mergeFn ci [] = [ci]
            mergeFn ci (h:rest) =
                if (conInfoEq h ci)
                then if (ci_visible h) then (h:rest) else (ci:rest)
                else (h : mergeFn ci rest)
  
  instance Hyper ConInfo where
      hyper x y = seq x y
  
  instance PPrint ConInfo where
      pPrint d p (ConInfo i vis a cti) = pparen (p>0) $ text "ConInfo" <+> pPrint d 1 i <> pVis vis <+> pPrint d 1 a <+> pPrint d 1 cti
          where pVis False = text " (invisible)"
                pVis True = text " (visible)"
  
  data TypeInfo
          = TypeInfo {
                ti_qual_id   :: (Maybe Id),  -- Nothing for numeric and string types
                ti_kind      :: Kind,
                ti_type_vars :: [Id],
                ti_sort      :: TISort
            } deriving (Show)
  
  instance PPrint TypeInfo where
      pPrint d p (TypeInfo _ k _ ti) = pparen (p>0) $ text "TypeInfo" <+> pPrint d 10 k <+> pPrint d 1 ti
  
  data FieldInfo
          = FieldInfo {
                       fi_id      :: Id ,  -- Id is the identifier of a type which has this field
                       fi_visible :: Bool, -- Bool is if the fields of that type are visible to user
                       fi_arity   :: Int,  -- Int is the arity of the type
                       fi_assump  :: Assump,
                       fi_pragmas :: [IfcPragma],
                       fi_default :: [CClause],
                       fi_orig_type :: Maybe CType -- original field type for wrapped fields
                      }
          deriving (Show)
  
  -- test whether two FieldInfo are identical except for the visibility
  fieldInfoEq :: FieldInfo -> FieldInfo -> Bool
  fieldInfoEq fi1 fi2 =
      ((fi_id fi1) == (fi_id fi2)) &&
      -- ignore fi_visible
      ((fi_arity fi1) == (fi_arity fi2)) &&
      ((fi_assump fi1) == (fi_assump fi2)) &&
      ((fi_pragmas fi1) == (fi_pragmas fi2)) &&
      -- ignore fi_default
      ((fi_orig_type fi1) == (fi_orig_type fi2))
  
  -- merge two coninfo lists, overriding hidden entries with visible entries
  fieldInfoMerge :: [FieldInfo] -> [FieldInfo] -> [FieldInfo]
  fieldInfoMerge new_fis old_fis = foldr mergeFn old_fis new_fis
      where mergeFn fi [] = [fi]
            mergeFn fi (h:rest) =
                if (fieldInfoEq h fi)
                then if (fi_visible h) then (h:rest) else (fi:rest)
                else (h : mergeFn fi rest)
  
  instance PPrint FieldInfo where
      pPrint d p (FieldInfo i _ n a ps def_cs mot) =
          pparen (p>0) $
            text "FieldInfo" <+>
            pPrint d 1 i <+>
            pPrint d 1 n <+>
            pPrint d 1 a $+$
            text ( "Fields:" ) <> pPrint d 2 ps <>
            (case (def_cs) of
                 [] -> empty
                 cs -> text ( "Default: ") <> pPrint d 0 cs) <>
            (case (mot) of
                 Nothing -> empty
                 Just t -> text ("Original type: ") <> pPrint d 0 t)
  
  instance Hyper FieldInfo where
      hyper (FieldInfo a b c d e f g) y = hyper7 a b c d e f g y
  
  
  -- The symbol table is composed of several other tables
  data SymTab =
          S (IdMap VarInfo) (IdMap [ConInfo]) (IdMap TypeInfo) (IdMap [FieldInfo]) (IdMap Class)
            -- The TypeInfo is indexed by type and returns the info for that type
            --   (indexed generally by both qualified and unqualified name)
            -- The FieldInfo is indexed by field id (e.g., "_write" returns the fields of Reg)
            --   or by superclass (e.g. Literal returns the superclasses of "Arith")
  
  instance Eq SymTab where -- just because we need one for forcing evaluation
      _ == _ = False
  
  showsPrecList :: Show a => Int -> [a] -> String -> String
  showsPrecList wid (thing@[_]) z =
      concat ( sps wid thing ) ++ z
  
  showsPrecList wid (thing@(_)) z =
       (showsPrec wid thing . showString "\n") z
  
  sps :: Show a => Int -> [a] -> [String]
  sps wid islist =
      [ show thing ++ "\n" | thing <- islist ]
  
  instance Show SymTab where
      showsPrec _ (S v c t f cl) =
          showString "Vars: " . showsPrecList 0 (M.toList v) . showString "\n" .
          showString "Cons: " . showsPrecList 0 (M.toList c) . showString "\n" .
          showString "Types: " . showsPrecList 0 (M.toList t) . showString "\n" .
          showString "Fields: " . showsPrecList 0 (M.toList f) . showString "\n" .
          showString "Classes: " . showsPrecList 0 (M.toList cl) . showString "\n"
  
  instance PPrint SymTab where
      pPrint d _ (S v c t f cl) =
          (text "Vars:" <+> pPrint d 0 (M.toList v) ) $+$
          (text "Cons:" <+> pPrint d 0 (M.toList c) ) $+$
          (text "Types:" <+> pPrint d 0 (M.toList t) ) $+$
          (text "Fields:" <+> pPrint d 0 (M.toList f) ) $+$
          (text "Classes:" <+> pPrint d 0 (M.toList cl) )
  
  instance Hyper SymTab where
      hyper x y = y                -- XXX
  
  emptySymtab :: SymTab
  emptySymtab = S M.empty M.empty M.empty M.empty M.empty
  
  -- ---------------
  
  -- mkQuals applied to identifier returns a list of forms of that identifier
  -- which should be added to the symbol table (qual, unqual, re-qual)
  addVars :: (Id -> [Id]) -> SymTab -> [(Id, VarInfo)] -> SymTab
  addVars mkQuals (S v c t f cl) ivs =
      S (foldr (uncurry M.insert) v (addQuals mkQuals ivs)) c t f cl
  
  -- mkQuals applied to identifier returns a list of forms of that identifier
  -- which should be added to the symbol table (qual, unqual, re-qual)
  addTypes :: (Id -> [Id]) -> SymTab -> [(Id, TypeInfo)] -> SymTab
  addTypes mkQuals (S v c t f cl) its =
      S v c (foldr (uncurry (M.insertWith pickBetter)) t (addQuals mkQuals its)) f cl
    where
      -- replace an abstract export with a full export
      pickBetter it1 it2 =
          case (ti_sort it1, ti_sort it2) of
            -- are these needed?
            (TIabstract, TIabstract) -> it1
            (TIabstract, _)          -> it2
            -- abstract typeclasses have hidden methods, but might still
            -- have superclasses (so the list is not necessarily null)
            (TIstruct SClass fs1, TIstruct SClass fs2)
              | length fs2 > length fs1 -> it2
            _ -> it1
  
  -- mkQuals applied to identifier returns a list of forms of that identifier
  -- which should be added to the symbol table (qual, unqual, re-qual)
  addCons :: (Id -> [Id]) -> SymTab -> [(Id, ConInfo)] -> SymTab
  addCons mkQuals (S v c t f cl) ics =
      let
          insertFn (i,c) = M.insertWith conInfoMerge i [c]
          c' = foldr insertFn c (addQuals mkQuals ics)
      in
          S v c' t f cl
  
  -- mkQuals applied to identifier returns a list of forms of that identifier
  -- which should be added to the symbol table (qual, unqual, re-qual)
  addFields :: (Id -> [Id]) -> SymTab -> [(Id, FieldInfo)] -> SymTab
  addFields mkQuals (S v c t f cl) ifs =
      let
          insertFn (i,f) = M.insertWith fieldInfoMerge i [f]
          f' = foldr insertFn f (addQuals mkQuals ifs)
      in
          S v c t f' cl
  
  -- mkQuals applied to identifier returns a list of forms of that identifier
  -- which should be added to the symbol table (qual, unqual, re-qual)
  addClasses :: (Id -> [Id]) -> SymTab -> [Class] -> SymTab
  addClasses mkQuals (S v c t f cl) cls =
      S v c t f
            (foldr (uncurry M.insert) cl (addQuals mkQuals (map (\c -> (typeclassId $ name c, c)) cls)))
  
  -- -----
  
  -- given:
  --  * a pairing of an Id with its symbol info
  --  * mkQuals, a function which makes a list of the Ids under which this
  --    entry should be recorded (usually just the original qual Id, possibly
  --    the unqual Id, and maybe a re-qualified Id if its a re-export)
  -- returns:
  --  a list of pairings of the Ids with the symbol info
  addQuals :: (Id -> [Id]) -> [(Id, a)] -> [(Id, a)]
  addQuals mkQuals ixs = concatMap addQuals' ixs
      where addQuals' pair@(name, value) =
                [ (i, value) | i <- mkQuals name ]
  
  -- ---------------
  
  -- versions which add both qual and unqual names
  addTypesUQ :: SymTab -> [(Id, TypeInfo)] -> SymTab
  addTypesUQ   = addTypes mkDefaultQuals
  
  addVarsUQ :: SymTab -> [(Id, VarInfo)] -> SymTab
  addVarsUQ  = addVars mkDefaultQuals
  
  addClassesUQ :: SymTab -> [Class] -> SymTab
  addClassesUQ = addClasses mkDefaultQuals
  
  -- For Ids which should be entered as both qualified and unqualified
  mkDefaultQuals :: Id -> [Id]
  mkDefaultQuals name =
      -- if the Id is already unqualified, don't duplicate it
      if (isNothing (getIdQFString name))
      then [name]
      else [unQualId name, name]
  
  -- -----
  
  -- versions which only add the name as it is (qualified)
  addTypesQ :: SymTab -> [(Id, TypeInfo)] -> SymTab
  addTypesQ  = addTypes mkSameQual
  addFieldsQ :: SymTab -> [(Id, FieldInfo)] -> SymTab
  addFieldsQ = addFields mkSameQual
  
  -- For Ids which should be entered as-is
  mkSameQual :: Id -> [Id]
  mkSameQual name = [name]
  
  -- ---------------
  
  findVar :: SymTab -> Id -> Maybe VarInfo
  findVar (S v _ _ _ _) i = --trace (ppReadable (show i, show (map fst (M.toList v)))) $
          M.lookup i v
  
  findCon :: SymTab -> Id -> Maybe [ConInfo]
  findCon (S _ c _ _ _) i = M.lookup i c
  
  findConVis :: SymTab -> Id -> Maybe [ConInfo]
  findConVis s i = fmap (filter ci_visible) (findCon s i)
  
  findType :: SymTab -> Id -> Maybe TypeInfo
  findType (S _ _ t _ _) i = M.lookup i t
  
  findField :: SymTab -> Id -> Maybe [FieldInfo]
  findField (S _ _ _ f _) i = M.lookup i f
  
  findFieldVis :: SymTab -> Id -> Maybe [FieldInfo]
  findFieldVis s i = fmap (filter fi_visible) (findField s i)
  
  findSClass :: SymTab -> CTypeclass -> Maybe Class
  findSClass (S _ _ _ _ cl) (CTypeclass i) = M.lookup i cl
  
  mustFindClass :: SymTab -> CTypeclass -> Class
  mustFindClass r i =
      case findSClass r i of
       Just cl -> cl
       Nothing -> internalError ("mustFindClass " ++ show i)
  
  getAllTypes :: SymTab -> [(Id, TypeInfo)]
  getAllTypes (S _ _ t _ _) = M.toList t
  
  -- a double key lookup into the symbol table to get field names of an interface method
  -- The first key is the interface name, the second the method name.
  findFieldInfo :: SymTab -> Id -> Id -> Maybe FieldInfo
  findFieldInfo symtable ifcName methodName =
        -- There may be multiple types with the same field, and the types
        -- may even have the same name, so we need to do the lookup using
        -- the qualified type name
        if (isUnqualId ifcName)
        then internalError ("findFieldInfo: unqualified ifcName: " ++
                            ppReadable ifcName)
        else fieldInfo
      where
        -- extra field info from symbol table for matching names
        fields    = findField symtable methodName
        fieldInfo = case fields of
                    Just fieldInfos -> find matches fieldInfos
                    _               -> Nothing
        -- find function equality test for in ifcName lookup
        matches (FieldInfo {fi_id = ifcId }) = (ifcId == ifcName)
  
  
  getMethodArgNames :: SymTab -> Id -> Id -> [Id]
  getMethodArgNames symtable ifcId methId =
      case (findFieldInfo symtable ifcId methId) of
          Nothing -> []
          Just finfo -> filterIArgNames (fi_pragmas finfo)
  
  getIfcFieldNames :: SymTab -> Id -> [Id]
  getIfcFieldNames symbolTable ifcId = fields
      where
      fields = case findType symbolTable ifcId of
               Nothing ->  []
               Just (TypeInfo (Just ti) _ _ (TIstruct ss fs)) | isIfc ss -> fs
               Just x -> []
  
  -- generate just the method names, following subinterfaces
  getIfcFlatMethodNames :: SymTab -> Id -> [Id]
  getIfcFlatMethodNames symt topIfcId =
    let
        fields :: Id -> Maybe [Id]
        fields conId =
            case findType symt conId of
              Nothing -> internalError ("getIfcFlatMethodNames: findType: " ++
                                        ppReadable conId)
              Just (TypeInfo (Just ti) _ _ (TIstruct ss fs))
                  | isIfc ss -> Just fs
              Just x         -> Nothing
  
        recurseFn :: [Id] -> Id -> Id -> [Id]
        recurseFn pfx ifcId fieldId =
          let pfx' = pfx ++ [fieldId]
              meth_res = [flattenUSId pfx']
          in  case findFieldInfo symt ifcId fieldId of
                Nothing -> internalError ("getIfcFlatMethodNames: " ++
                                          ppReadable fieldId)
                Just (FieldInfo { fi_assump = (_ :>: Forall _ (_ :=> t)) }) ->
                    case (getArrows t) of
                      -- fields always have the ifc as the first argument
                      ([], _) -> internalError
                                     ("getIfcFlatMethodNames: type: " ++
                                      ppReadable (fieldId, t))
                      -- ignore non-method fields
                      ([_], res) | (isClock res || isReset res || isInout res)
                              -> []
                      -- if it's an ifc, recurse;
                      -- if it's a method, return its name
                      ([_], res) ->
                          case (leftCon res) of
                            Nothing -> meth_res
                            Just conId ->
                                case (fields conId) of
                                  Nothing -> meth_res
                                  Just fs -> concatMap (recurseFn pfx' conId) fs
                      -- if it has more arguments, it's just a method
                      (_, _) -> meth_res
  
        topFields =
            case (fields topIfcId) of
              Just fs -> fs
              Nothing -> internalError ("getIfcFlatMethodNames: not ifc: "
                                        ++ ppReadable topIfcId)
    in
        concatMap (recurseFn [] topIfcId) topFields
  