module Language.Haskell.ER.MiscRewrite ( dictionary , inlineTrivialVar , inlineTrivialVarDCE , multiBetaReduction , quote , quoteCode , quoteModule , defn , equationFor ) where import Language.Haskell.ER.Ppr as Ppr import Language.Haskell.TH.Syntax import Language.Haskell.ER.Syntax import Language.Haskell.ER.HaskellRewrite hiding (dictionary) import Debug.Trace import GHC.Err dictionary :: [ UniHaskellRewrite ] dictionary = map HaskellRewriteExp [ caseToLet , caseOfKnownConstructor , cleanup , inlineTrivialVar , inlineTrivialVarDCE , multiBetaReduction , pmCompiler , doToBind2 , inlineFunDVar2 , inlineFunction ] ++ map HaskellRewriteCode [ simplifyNames ] multiBetaReduction :: HaskellRewrite Exp multiBetaReduction = nameRewrite "/Evaluation/(Multi Argument) Beta Reduction" $ examineRewrite $ cut . multiBeta where multiBeta :: Exp -> HaskellRewrite Exp multiBeta (AppE (LamE {}) _) = betaReduce multiBeta (AppE e@(AppE {}) _) = substPath [0] rec >&> rec multiBeta (AppE e@(LetE {}) _) = appDescent >&> rec multiBeta (LetE _ (AppE {})) = substPath [1] rec multiBeta _ = failRewrite rec = examineRewrite multiBeta -- perhaps use *many*, to get chains inlineTrivialVar = nameRewrite "/inline/Inline Trivial Vars (and repeat)" $ many $ examineRewrite $ const $ cut (inlineValDVar >&> examineRewrite (\ exp -> case exp of VarE {} -> idRewrite _ -> failRewrite)) inlineTrivialVarDCE = nameRewrite "/inline/Inline Trivial Vars with DCE" $ inlineTrivialVar >+> deadCodeElim inlineSpecificVar :: Name -> HaskellRewrite Exp inlineSpecificVar nm = substUsing Postfix $ examineRewrite $ \ e -> case e of VarE nm' | nm == nm' -> inlineValDVar _ -> idRewrite pmCompiler :: HaskellRewrite Exp pmCompiler = nameRewrite "/Case/Pattern Match Compiler" $ examineRewrite $ \ e -> case e of CaseE (VarE v) _ -> pmCompiler2 CaseE {} -> case_rule_a >+> substPath [0,1] pmCompiler2 >+> betaReduce _ -> idRewrite pmCompiler2 :: HaskellRewrite Exp pmCompiler2 = (case_rule_b >+> pmCompiler3) -- get all the cannonical cases from (b), and apply (c). pmCompiler3 = (examineRewrite $ \ e -> case e of -- should all be of this form (CaseE (VarE {}) [Match {},Match WildP (NormalB e) []]) -> -- trace "got it" $ substPath [1,1,1,0] (pmCompiler3) >+> pmCompiler4 _ -> idRewrite) pmCompiler4 = ((case_rule_c >?> (substPath [1,0,1,0] pmCompiler5,pmCompiler5)) >+> caseToLet) -- rules (d) .. (j) pmCompiler5 :: HaskellRewrite Exp pmCompiler5 = baa "pmCompiler5" (examineRewrite $ \ e -> case e of CaseE (VarE v) ( Match (TupP pats) _ _ : _) -> (baa "case_rule_g" case_rule_g >&> (substPath [1,0,1,0,1,0,1,0] (pmCompiler_rule_g_sweep (length pats)) >+> substPath [1,0,1,0] pmCompiler6 >+> caseToLet)) CaseE (VarE v) ( Match (VarP {}) _ _ : _) -> caseToLet CaseE {} -> pmCompiler6 _ -> idRewrite) {- find the cases in rule, and call pmCompiler5 for each -} pmCompiler_rule_g_sweep :: Int -> HaskellRewrite Exp pmCompiler_rule_g_sweep 0 = idRewrite pmCompiler_rule_g_sweep n = examineRewrite $ \ e -> -- trace ("pm_rule_g_sweep: \n" ++ pprint e ++ "\n") $ substPath [1,0,1,0] (pmCompiler_rule_g_sweep (n-1)) >+> pmCompiler5 -- handle (k) .. (r) pmCompiler6 :: HaskellRewrite Exp pmCompiler6 = examineRewrite $ \ e -> -- trace ("pmCompiler6:" ++ (pprint e) ++ "\n") $ case e of CaseE (VarE v) ( Match (TupP pats) _ _ : _) -> (substPath [0] (inlineSpecificVar v) >&> (case_rule_q >|> failRewrite)) _ -> idRewrite -- -> -- _ -> caseToLet -- split into 2 functions (or two HO instances) -- because this does more that caseToLet, it also does DCE. caseToLet :: HaskellRewrite Exp caseToLet = nameRewrite "/Case/Trivial Case to Let + inline" $ examineRewrite $ \ e -> -- trace (show ("caseToLet",e)) $ case e of CaseE (VarE {}) (Match (VarP y) (NormalB e2) []:_) -> (case_rule_i >+> case_rule_j) >&> betaReduce >&> examineRewrite (\ e' -> -- trace (show ("bla:",e')) $ case e' of LetE [ValD (VarP y') _ _] _ | y == y' -> inlineSpecificVar y >&> deadCodeElim _ -> idRewrite) CaseE e1 (Match (VarP y) (NormalB e2) []:_) -> case_rule_a >&> substPath [0,1] caseToLet >&> betaReduce _ -> idRewrite caseOfKnownConstructor :: HaskellRewrite Exp caseOfKnownConstructor = nameRewrite "/Case/Case of Known Constructor" $ cut -- always works $ examineRewrite $ \ e -> (case_rule_q >|> case e of CaseE (VarE v) _ -> (substPath [0] (many $ inlineValDVar) >&> (case_rule_q >|> failRewrite) ) _ -> idRewrite) >&> multiBetaReduction >&> inlineTrivialVarDCE burp :: (Ppr.Ppr a) => String -> HaskellRewrite a burp str = traceRewrite (\ a -> str ++ ":\n" ++ pprint a) baa :: (Ppr.Ppr a) => String -> HaskellRewrite a -> HaskellRewrite a baa str rr = burp ("before " ++ str) >+> rr >+> burp ("after " ++ str) cleanup = nameRewrite "/ Clean up!" $ many (inlineTrivialVar >+> caseOfKnownConstructor >+> multiBetaReduction >+> deadCodeElim) ------------------------------------------------------------------------------ simplifyNames :: HaskellRewrite Code simplifyNames = nameRewrite "/Eureka/Alpha Convert (clean up local names)" (substUsing Postfix simplifyNamesCode >+> substUsing Postfix simplifyNamesExp >+> substUsing Postfix simplifyNamesDec) ------------------------------------------------------------------------------ -- | Takes a piece of AST, and lifts it into the -- AST that represents this AST. The concept is that -- return $(quote [| .. exp .. |]) == runQ [| .. exp .. |] -- an we use it when we do not have a Q or IO monad handy. -- same as simplifyNames, but over *any* term. alphaConvert :: (Subst exp) => HaskellRewrite exp alphaConvert = substUsing Postfix simplifyNamesExp >+> substUsing Postfix simplifyNamesDec >+> substUsing Postfix simplifyNamesCode -- TODO: overload quote. quote :: Q Exp -> Q Exp quote qExp = do exp <- qExp (exp',_,[]) <- runRewrite alphaConvert [] exp lift exp' quoteCode :: Q [Dec] -> Q Exp quoteCode qExp = do exp <- qExp (exp',_,[]) <- runRewrite alphaConvert []exp lift (Code exp') -- This fixes top level names to defined in terms of inside a specific module. -- The reason is simple; we a fragment to know that its a specific defn. of -- a prelude function, not just one with the same name. quoteModule :: String -> String -> Q [Dec] -> Q Exp quoteModule pkg mod qExp = do runIO $ print "quoteModule" exp0 <- qExp runIO $ print "quoteModule" (exp1,_,[]) <- runRewrite alphaConvert [] exp0 runIO $ print "quoteModule" code2 <- fixSimpleTopLevelNames pkg mod (Code exp1) runIO $ print "quoteModule" lift code2 ------------------------------------------------------------------------------ -- builds a simple rewrite out of a definition defn :: Name -> Code -> HaskellRewrite Exp defn name (Code decs) = equation ("/Definitions/" ++ mod ++ "/" ++ base ++ " (definition)") (VarE name) (LetE defns $ VarE tmp_name) Nothing -- for now where tmp_name = Name (mkOccName base) NameS Just mod = nameModule name base = nameBase name defns = [ FunD tmp_name clauses | dec@(FunD (Name name' (NameQ _)) clauses) <- decs , occString name' == base ] equationFor :: Exp -> HaskellRewrite Exp -> HaskellRewrite Exp equationFor exp rr = undefined ------------------------------------------------------------------------------ doToBind2 :: HaskellRewrite Exp doToBind2 = nameRewrite "/Syntax/Do To Bind (macro)" $ cut $ (doToBind >&> examineRewrite fixupBind) where -- fixupBind _ = fixupBind (LetE [ FunD ok clauses ] (AppE (AppE (VarE bind) e) (VarE ok'))) = substPath [0,0] funDtoValD >&> substPath [0,0,1,0,1] caseToLet >+> substPath [1,1] inlineValDVar >&> (deadCodeElim >&> traceRewrite (\ e -> show ("fixupBind",e))) fixupBind _ = idRewrite -- fine, another combination ------------------------------------------------------------------------------ inlineFunDVar2 = nameRewrite "@/inline/Inline Definition (as expression)" $ cut $ (inlineValDVar >|> (inlineFunDVar >&> (examineRewrite $ \ e -> case e of LetE [_] (VarE {}) -> substPath [0,0] funDtoValD >&> substPath [1] inlineValDVar >&> deadCodeElim _ -> failRewrite))) ------------------------------------------------------------------------------ inlineFunction = nameRewrite "@/inline/Inline function" $ cut $ examineRewrite $ \ e -> case e of AppE fn exp -> substPath [0] inlineFunction' >&> multiBetaReduction >&> -- basic cleanup (hacked) substUsing Postfix caseToLet >+> many (substUsing (Prefix True) cleanup) _ -> failRewrite inlineFunction' = examineRewrite $ \ e -> case e of AppE {} -> inlineFunction other -> inlineFunDVar2 ------------------------------------------------------------------------------ -- adding typing the the rewriting of App. substAppE :: HaskellRewrite Exp -> HaskellRewrite Exp -> HaskellRewrite Exp substAppE re1 re2 = examineRewrite $ \ e -> case e of AppE {} -> substPath [0] re1 >+> substPath [1] re2 _ -> failRewrite {- multiBeta :: Exp -> HaskellRewrite Exp multiBeta (AppE e1 _) = multiBeta_AppE e1 multiBeta (LetE {}) = substLetE idRewrite rec multiBeta _ = failRewrite multiBeta_AppE (LamE {}) = betaReduce multiBeta_AppE (AppE {}) = substAppE rec idRewrite >&> rec multiBeta_AppE (LetE {}) = appDescent >&> rec -}