RemoveIrrefPatsBaseStruct.hs

module RemoveIrrefPatsBaseStruct where

import RemoveIrrefPats 

import HasBaseStruct
import TiClasses(HasDef(..))
import HsPat
import HsExp
import HsDecl
import HsGuards
import HsModule
import HsIdent
import SrcLoc

import MUtils
import Monad(liftM)


-- replaces listOutput, to handle generic lists of declarations
getDecls o = foldOutput noDef (`consDef` noDef) appendDef o
getDDecls o = foldOutput noDef id appendDef o

procDs :: (RemIrrefPats ds (OM i ds), HasDef ds d) => ds -> M i ds
procDs ds = uncurry appendDef # getDDecls (remIrrefPats ds)

-- we translate the patterns, and output pattern bindings,
-- which essentially delay the matching

instance ( GetBaseStruct p (PI i p)
         , HasBaseStruct d (DI i e p ds t c tp) 
         , HasBaseStruct e (EI i e p ds t c)
         , HasDef ds d 
         , RemIrrefPats p (OEM i d)

        ) => RemIrrefPats (PI i p) (OEM i d) where

    remIrrefPats p = do
        p1 <- seqPI (mapPI return remIrrefPats p)
        case p1 of
            HsPIrrPat p2 -> case basestruct p2 of
                Just p3 -> case p3 of
                    HsPWildCard     -> return p3
                    HsPId (HsVar _) -> return p3
                    HsPAsPat i p    -> decl i
                    _               -> decl . head =<< updSt tail 
                    where
                    decl x = do
                        s <- getEnv
                        output $ hsPatBind s p2 (HsBody (hsEVar x)) noDef
                        return (HsPId (HsVar x))
                Nothing -> return p1

            _ -> return p1


-- PRE: e & ds have been processed
instance (RemIrrefPats p (OEM i d), HasDef ds d)
    => RemIrrefPats (HsAlt e p ds) (M i) where

    remIrrefPats (HsAlt s p rhs ds) = do
        (p',ds')   <- withEnv s $ getDecls $ remIrrefPats p
        return (HsAlt s p' rhs (ds `appendDef` ds'))


-- PRE: e & ds have been processed
instance (RemIrrefPats p (OEM i d), HasDef ds d) 
    => RemIrrefPats (HsStmt e p ds) (EM i) where

    remIrrefPats = atoms2Stmt @@ liftM concat . mapM rem  . getStmtList 
        where
        rem (HsGeneratorAtom s p e) = do
            (p',ds) <- getDecls (remIrrefPats p)
            return [HsGeneratorAtom s p' e, HsLetStmtAtom ds]
        rem x = return [x]


-- PRE: e & ds have been processed
instance (RemIrrefPats p (OEM i d), HasDef ds d)
    => RemIrrefPats (HsMatchI i e p ds) (M i) where

    remIrrefPats (HsMatch s i ps rhs ds) = do
        (ps',ds')  <- withEnv s $ getDecls $ remIrrefPats ps
        return (HsMatch s i ps' rhs (ds `appendDef` ds'))
 

-- Expressions
instance ( RemIrrefPats e (EM i)
         , RemIrrefPats p (OEM i d)
         , RemIrrefPats ds (OM i ds)
         , HasBaseStruct e (EI i e p ds t c)
         , HasDef ds d
         )

    => RemIrrefPats (EI i e p ds t c) (EM i) where
    remIrrefPats e = do
        e1 <- seqEI (mapEI return remIrrefPats return (lift . procDs) 
                                                            return return e)

        case e1 of
            HsLambda ps e   -> do
                (ps',ds) <- getDecls (remIrrefPats ps)
                return (HsLambda ps' (hsLet ds e))  -- check null ds?
            HsCase e alts   -> HsCase e # lift (remIrrefPats alts)
            HsDo stms       -> HsDo # remIrrefPats stms 
            HsListComp stms -> HsListComp # remIrrefPats stms
            _               -> return e1




-- Declarations
instance ( RemIrrefPats e (EM i)
         , RemIrrefPats p (OEM i d)
         , RemIrrefPats ds (OM i ds)
         , HasDef ds d
         ) => RemIrrefPats (DI i e p ds t c tp) (OM i ds) where

    remIrrefPats d = do
        d1 <- lift $ seqDI (mapDI return (withEnv (srcLoc d) . remIrrefPats)
                           return procDs return return return d)
        case d1 of
            HsFunBind s ms      -> lift $ HsFunBind s # remIrrefPats ms
            HsPatBind s p r ds  -> do
                (p',ds1) <- lift $ withEnv s $ getDecls $ remIrrefPats p
                output ds1
                return (HsPatBind s p' r ds) 

            _   -> return d1

  
-- Modules

-- Note the i and j !!!  It looks like some mappings over identifiers,
-- do not quite change all identifiers

instance (RemIrrefPats ds (OM j ds), HasDef ds d) 
    => RemIrrefPats (HsModuleI i ds) (M j) where
    remIrrefPats (HsModule s n es is ds) 
        = HsModule s n es is # procDs ds