content: -- $Id: ParseUtil.hs,v 1.7 2001/11/06 06:33:37 hallgren Exp $
  
  {-
  
  Utilities for the parser.
  
  Author(s): Simon Marlow 1997, 1998;
             Emir Pasalic, Bill Harrison, Andrew Moran 2001
  
  -}
  
  module ParseUtil (--setInfix,        -- HsInfixDecl -> PM ()
  		  splitTyConApp,   -- HsType -> PM (HsName, [HsType])
                    mkQuant,         -- HsQuantifier -> [HsPat] -> HsExp -> HsExp
  		  mkValDef,        -- HsExp -> SrcLoc -> HsRhs HsExp
  		                   --   -> [HsDecl] -> PM HsDecl
                    mkFunDef,        -- HsExp -> SrcLoc -> HsRhs HsExp
                                     --   -> [HsDecl] -> PM HsDecl
                    expToPat)        -- HsExp -> PM HsPat
  where
  
  import ParseMonad
  --import Rewrite
  --import HsAssoc
  import PropSyntax
  import PropSyntaxUtil(isConE)
  import PrettyPrint
  
  {-
  -- Update the infix environment with infix information from declaration.
  setInfix (HsInfixDecl sl (HsFixity prec assoc) names) = 
    mapM (addToEnv prec assoc) names
    where 
        addToEnv prec HsAssocNone  n =
  	  do { s <- getInfixEnv ;
  	       setInfixEnv $ extend s (HsInfix HsAssocNone  prec n)
  	     }
        addToEnv prec HsAssocRight n =
  	  do { s <- getInfixEnv ;
  	       setInfixEnv $ extend s (HsInfix HsAssocLeft  prec n)
  	     }
        addToEnv prec HsAssocLeft  n =
  	  do { s <- getInfixEnv ;
  	       setInfixEnv $ extend s (HsInfix HsAssocRight prec n)
  	     }
  -}
  
  splitTyConApp :: HsType -> PM (HsName, [HsType])
  splitTyConApp t = split t []
      where
      split :: HsType -> [HsType] -> PM (HsName, [HsType])
      split (Typ (HsTyApp t u)) ts = split t (u:ts)
      split (Typ (HsTyCon t))   ts = return (t, ts)
      split _                   _
          = parseError "illegal data/newtype declaration"
  
  mkQuant :: HsQuantifier -> [HsPat] -> HsExp -> HsExp
  mkQuant q ps (e @ (Exp (Prop (HsQuant q' ps' e'))))
      | q == q'   = hsQuant q (ps ++ ps') e'
      | otherwise = hsQuant q ps e
  mkQuant q ps e  = hsQuant q ps e
  
  mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> PM 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] -> PM HsDecl
  mkFunDef lhs sloc rhs wheres = 
      do { (fnamePat, ps) <- getFundefPats lhs ; 
  	 case fnamePat of 
           Pat (Base (HsPId (HsVar nm))) ->
                return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]
           _                      ->
                parseError $ "invalid function name in:\n\n" ++ pp lhs
         }
  
  
  getFundefPats :: HsExp -> PM (HsPat, [HsPat])
  getFundefPats (Exp (Base 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
      _     -> parseError $
  	     "cannot use\n\n" ++ pp pexp ++
  	     "\n\nas a function definition pattern."
  getFundefPats p =
      parseError $
      "cannot use\n\n" ++ pp p ++
      "\n\nas a function definition pattern."
  
  
  expToPat :: HsExp -> PM HsPat
  expToPat l@(Exp (Base lhexp))  = 
      case lhexp of 
        HsId (HsVar n) -> return $ hsPVar n
        HsId (HsCon n) -> return $ hsPCon n
        HsLit literal  -> return $ hsPLit literal
        HsNegApp  e    -> do { p <- expToPat e ; return $ hsPNeg p }
        HsLambda _ _   -> parseError "lambdas not allowed in patterns."
        HsList es      -> do { ps <- sequence (map expToPat es) ;
  			     return $ hsPList ps
  			   }
        HsTuple es     -> do { ps <- sequence (map expToPat es) ;
  			     return $ hsPTuple ps
  			   }
        HsWildCard     -> return hsPWildCard
        HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }
        HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}
        HsApp l r | isConE l  -> 
                          do { let { Exp (Base (HsId (HsCon n))) = l } ;
  			     rp <- expToPat r ;
  			     return $ hsPApp n [rp]
  			   }
                  | otherwise ->
                          do { lp <- expToPat l ;
                               rp <- expToPat r ;
                               case lp of 
                               Pat (Base (HsPApp n ps)) ->
  			         return $ hsPApp n (ps ++ [rp])
                               _                 ->
  			         parseError $
  			         "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 (HsCon n) rp 
  			   }
        HsParen e                -> expToPat e
        HsRecConstr con fields   ->
                          do { pfs <- mapM fieldToPat fields ;
  			     return $ hsPRec con pfs
  			   }
        HsExpTypeSig _ e c t     ->
                          do { p <- expToPat e ;
                               return $ hsPatTypeSig p c t
                             }
        _                        ->
            parseError $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"
                         ++ pp lhexp
      where --fieldToPat (HsFieldBind f)     = return $ HsPFieldPun f
  	  fieldToPat (HsFieldUpdate f e) = do { p <- expToPat e ;
  						return $ HsPFieldPat f p
  					      }
  expToPat e  =
      parseError $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"
                   ++ pp e
  