content: {-
  Utilities for the parser.
  
  Author(s): Simon Marlow 1997, 1998;
             Emir Pasalic, Bill Harrison, Andrew Moran 2001
             Thomas Hallgren 2001, 2002, 2003
  -}
  
  module PropParseUtil(
      chkTypeLhs,        -- ([HsType],HsType) -> m ([HsType],HsType)
      splitTyConApp,     -- HsType -> m (HsName, [HsType])
      mkValDef,          -- HsExp -> SrcLoc -> HsRhs HsExp
                         --   -> [HsDecl] -> m HsDecl
      mkFunDef,          -- HsExp -> SrcLoc -> HsRhs HsExp
                         --   -> [HsDecl] -> m HsDecl
      mkFunDef',
      expToPat,          -- HsExp -> m HsPat
      hsName2modName)    -- HsName -> ModuleName
  
                         -- Monad m => ...
  		       -- The monad is used for error handling only
  where
  
  --import HsAssoc
  import PropSyntax
  --import HsConstants(plus_name)
  import SourceNames(fakeSN)
  import HsName
  import SourceNames
  --import PropSyntaxUtil(isConE)
  import PrettyPrint
  import MUtils
  
  -- The LHSs of data/newtype/class declaration is parsed like a ctype (c=>t),
  -- so this additional check is needed to ensure that they are well formed.
  chkTypeLhs ct@(ctx,t) =
    do (c,as) <- splitTyConApp t
       if all isTyVar as
         then return ct
         else fail "bad lhs in data/newtype/class declaration"
    where
      isTyVar (Typ (HsTyVar _)) = True
      isTyVar _ = False
  
  --splitTyConApp :: HsType -> m (HsName, [HsType])
  splitTyConApp t = split t []
      where
      --split :: HsType -> [HsType] -> m (HsName, [HsType])
      split (Typ (HsTyApp t u)) ts = split t (u:ts)
      split (Typ (HsTyCon t))   ts = return (t, ts)
      split _                   _
          = fail "illegal data/newtype declaration"
  
  --mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl
  mkValDef lhs sloc (HsBody b) wheres = 
      do { lpat <- expToPat lhs ;
  	 return $ hsPatBind sloc lpat (HsBody b) wheres
         }
  mkValDef lhs sloc (HsGuard gds) wheres = 
      do { lpat <- expToPat lhs ;
  	 return $ hsPatBind sloc lpat (HsGuard gds) wheres
         }
  
  --mkFunDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl
  mkFunDef lhs sloc rhs wheres = 
      do { (fnamePat, ps) <- getFundefPats lhs ; 
  	 case fnamePat of 
           Pat (HsPId (HsVar nm)) ->
                return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]
           _                      ->
                fail $ "invalid function name in:\n\n" ++ pp lhs
         }
  
  mkFunDef' (nm,ps) sloc rhs wheres =
      hsFunBind sloc [HsMatch sloc nm ps rhs wheres]
  
  --getFundefPats :: HsExp -> m (HsPat, [HsPat])
  getFundefPats (Exp pexp) = 
   case pexp of 
     HsId (HsVar nm) -> return (hsPVar nm, [])
     HsApp l r ->  
       do { (pv, ps) <- getFundefPats l ;
            p        <- expToPat r ;
            return (pv, ps ++ [p])
  	}
     HsInfixApp l (HsVar n) r -> 
       do { lp  <- expToPat l ;
            rp  <- expToPat r ;
            return (hsPVar n, [lp, rp])
  	}
     HsInfixApp l (HsCon n) r -> 
       do { lp  <- expToPat l ;
            rp  <- expToPat r ;
            return (hsPCon n, [lp, rp])
  	}
     HsParen e -> getFundefPats e
     _     -> fail $
  	    "cannot use\n\n" ++ pp pexp ++
  	   "\n\nas a function definition pattern."
  
  expToPat l@(Exp lhexp)  = 
      case lhexp of 
        HsId (HsVar n) -> return $ hsPVar n
        HsId (HsCon n) -> return $ hsPCon n
        HsLit s literal -> return $ hsPLit s literal
        HsNegApp s e   -> do p <- expToPat e
  			   case p of
  			     Pat (HsPLit s l) -> return (hsPNeg s l)
  			     _ -> fail "only literals can be negated in patterns"
        HsLambda _ _   -> fail "lambdas not allowed in patterns."
        HsList es      -> do { ps <- sequence (map expToPat es) ;
  			     return $ hsPList loc0 ps -- !! loc0
  			   }
        HsTuple es     -> do { ps <- sequence (map expToPat es) ;
  			     return $ hsPTuple loc0 ps -- !! loc0
  			   }
        HsWildCard     -> return hsPWildCard
        HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }
        HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}
        HsApp (Exp (HsId (HsCon n))) r -> 
                        do { rp <- expToPat r ;
  			   return $ hsPApp n [rp]
  			 }
        HsApp l r -> 
                        do { lp <- expToPat l ;
                             rp <- expToPat r ;
                             case lp of 
                             Pat (HsPApp n ps) ->
  			        return $ hsPApp n (ps ++ [rp])
                             _                 ->
  			        fail $
  			        "Cannot use:\n\n" ++
  			        pp lhexp ++
  			        "\n\n as a pattern."
                            }
        HsInfixApp l (HsCon n) r -> 
                         do { lp <- expToPat l ;
                              rp <- expToPat r ;
                              return $ hsPInfixApp lp n rp 
  			  }
        HsInfixApp ne (HsVar (SN op _)) ke | op==UnQual "+" -> -- n+k patterns!!!
  		       do np <- expToPat ne
  			  kp <- expToPat ke
  			  case (np,kp) of
  			    (Pat (HsPId (HsVar n)),Pat (HsPLit s l)) ->
                                 return $ hsPSucc s n l
  			    _ -> fail$ pp $ "Mailformed n+k pattern:"<+>lhexp
        HsParen e      -> hsPParen # expToPat e
        HsRecConstr s con fields ->
                         do { pfs <- mapM fieldToPat fields ;
  			    return $ hsPRec con pfs
  			  }
        HsExpTypeSig s e c t -> expToPat e -- warning: type signature ignored!
        _              ->
            fail $ pp $
  	    sep [ppi "PropParseUtil.expToPat: not a valid/supported pattern:",
                   nest 4 lhexp]
      where fieldToPat (HsField f e) = HsField f # expToPat e
  