content: module HsDeclUtil where
  
  import HsDeclStruct
  import HsDeclMaps
  --import MUtils
  --import HsGuardsMaps
  import SrcLoc1
  import SrcLocPretty
  import PrettyPrint(pp)
  
  -- Finds all of the free variables in a D structure.
  
  freeVarsD fvd fve d = 
      accD (++) (++) (++) (++) (++) (++) 
           (mapDI id fve (const [])
  	           (concatMap fvd)
  	           (const [])
  	           (const [])
  	           (const [])
  	  d)
  	 []
  
  
  -- Rewrite expressions inside declarations given fixity information.
  
  rewriteD rwe env d = mapDI id (rwe env) id id id id id d
  
  -- New version: rewrite expressions and patterns,
  -- and also recurse into nested declarations.
  rewriteAllD rwe rwp rwds = mapDI id rwe rwp rwds id id id
  
  fixitiesD ds =[(n,fixity) | HsInfixDecl _ fixity ns<-ds, n<-ns]
  
  
  instance HasSrcLoc (DI i e p ds t c tp) where
    srcLoc d =
      case d of
        HsTypeDecl s tps t                 -> s
        HsNewTypeDecl s cntxt tps cd names -> s
        HsDataDecl s cntxt tps cds names   -> s
        HsClassDecl s c tp fd ds           -> s
        HsInstDecl s optn c tp ds          -> s
        HsDefaultDecl s t                  -> s
        HsTypeSig s nms c tp               -> s
        HsFunBind s matches                -> s
        HsPatBind s p rhs ds               -> s
        HsInfixDecl s fixity names         -> s
  
        HsPrimitiveBind s nm t             -> s
        HsPrimitiveTypeDecl s cntxt nm     -> s
  
  
  instance HasSrcLoc (HsMatchI i e p ds) where
      srcLoc (HsMatch s _ _ _ _) = s
  
  unbang bt = accBangType const bt ()
  
  conargcnt con =
    case con of
      HsConDecl s _ _ c args -> length args
      HsRecDecl s _ _ c fields -> sum (map (length.fst) fields)
  
  conctx con =
    case con of
      HsConDecl s _ ctx c args -> ctx
      HsRecDecl s _ ctx c fields -> ctx
  
  instance HasSrcLoc (HsConDeclI i t c) where
    srcLoc con =
      case con of
        HsConDecl s _ _ c argrs -> s
        HsRecDecl s _ _ c fields -> s
  
  chkNewtype con =
    if conargcnt con==1
    then if null (conctx con)
         then return ()
         else fail $ pp (srcLoc con)++
                     ": existential newtype constructors can't have a context"
    else fail $ pp (srcLoc con)++
  	      ": a newtype constructor must have exactly one argument"
  