ParseUtil.hs

{-

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])
		  mkValDef,          -- HsExp -> SrcLoc -> HsRhs HsExp
		                     --   -> [HsDecl] -> PM HsDecl
                  mkFunDef,          -- HsExp -> SrcLoc -> HsRhs HsExp
                                     --   -> [HsDecl] -> PM HsDecl
                  mkFunDef',
                  expToPat)          -- HsExp -> PM HsPat
where

--import ParseMonad
--import Rewrite
import HsAssoc
import Syntax
import SyntaxUtil(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 _                   _
        = fail "illegal data/newtype declaration"

--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 (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 -> PM (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 :: HsExp -> PM HsPat
expToPat l@(Exp 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 _ _   -> fail "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 (HsId (HsCon n)) = l } ;
			   rp <- expToPat r ;
			   return $ hsPApp n [rp]
			 }
                | otherwise ->
                      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 (HsCon n) rp 
			  }
      HsParen e      -> expToPat e
      HsRecConstr con fields ->
                       do { pfs <- mapM fieldToPat fields ;
			    return $ hsPRec con pfs
			  }
      _              ->
          fail $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"
                       ++ pp lhexp
    where fieldToPat (HsFieldUpdate f e) = do { p <- expToPat e ;
						return $ HsPFieldPat f p
					      }