Exporter.hs

module Language.Sifflet.Export.Exporter 
    (Exporter
    , simplifyExpr
    , commonRuleHigherPrec
    , commonRuleAtomic
    , commonRuleLeftToRight
    , commonRuleAssocRight
    , commonRuleFuncOp
    , commonRulesForSimplifyingExprs
    , ruleIfRight
    , ruleRightToLeft
    , applyFirstMatch
    , findFixed
    ) 

where

import Language.Sifflet.Expr

-- | The type of a function to export (user) functions to a file.
type Exporter = Functions -> FilePath -> IO ()

-- | Simplify an expression by applying rules 
-- top-down throughout the expression
-- tree and repeatedly until there is no change.
-- This is intended for removing extra parentheses,
-- but could be used for other forms of simplification.
-- 
-- Should each rule also know the level in the original expr tree,
-- with 0 = top level (root)?
-- That would require additional arguments.

simplifyExpr :: [Expr -> Expr] -> Expr -> Expr
simplifyExpr rules expr = 
    findFixed (topDown (applyFirstMatch rules)) expr

-- | Repeatedly apply a function to an object until there is no change,
-- that is, until reaching a fixed point of the function, a point 
-- where f x == x.

findFixed :: (Eq a) => (a -> a) -> a -> a
findFixed f x =
    let x' = f x
    in if x' == x then x else findFixed f x'


-- | Common rules for simplifying parentheses.

-- | Remove ()'s around a higher precedence operator: e.g., 
-- (a * b) + c ==> a * b + c
-- a + (b * c) ==> a + b * c

commonRuleHigherPrec :: Expr -> Expr
commonRuleHigherPrec e =
    case e of
      EOp op1 (EGroup (EOp op2 subleft subright)) right ->
          -- left side
          if opPrec op2 > opPrec op1
          then EOp op1 (EOp op2 subleft subright) right
          else e
      EOp op1 left (EGroup (EOp op2 subleft subright)) ->
          -- right side
          if opPrec op2 > opPrec op1
          then EOp op1 left (EOp op2 subleft subright)
          else e
      _ -> e

-- | Remove ()'s around an atomic expression -- a variable,
-- literal, or list

commonRuleAtomic :: Expr -> Expr
commonRuleAtomic e =
    case e of
      EGroup e' ->
          if exprIsAtomic e' 
          then e'
          else e
      _ -> e

-- | Remove ()'s in the case of (a op1 b) op2 c,
-- if op1 and op2 have the same precedence, and
-- both group left to right, since
-- left to right evaluation makes them unnecessary.

commonRuleLeftToRight :: Expr -> Expr
commonRuleLeftToRight e =
    case e of
      EOp op2 (EGroup (EOp op1 a b)) c ->
          if opPrec op1 == opPrec op2 && 
             opGrouping op1 == GroupLtoR &&
             opGrouping op2 == GroupLtoR
          then EOp op2 (EOp op1 a b) c
          else e
      _ -> e

-- | Remove ()'s in the case of a op (b op c)
-- if op groups right to left, and note that
-- it is the same operator op in both places
-- (though I don't know if that restriction is necessary).
-- This applies to (:) in Haskell, for example:
-- x : y : zs == x : (y : zs)

ruleRightToLeft :: Expr -> Expr
ruleRightToLeft e =
    case e of
      EOp op1 a (EGroup (EOp op2 b c)) ->
          if op1 == op2 && opGrouping op1 == GroupRtoL
          then EOp op1 a (EOp op2 b c)
          else e
      _ -> e

-- Associativity on the right
-- x + (y + z) --> x + y + z
-- for + and all other associative operators.
-- We could add, the left-hand rule
-- (x + y) + z --> x + y + z
-- but do not need it,
-- because it is already covered by the left to right rule
-- for operators of equal precedence.
-- It must be the SAME operator on both sides, of course!

commonRuleAssocRight :: Expr -> Expr
commonRuleAssocRight e =
    case e of
      EOp op1 a (EGroup (EOp op2 b c)) -> 
          if op1 == op2 && opAssoc op1
          then EOp op1 a (EOp op2 b c)
          else e
      _ -> e

-- An if expression as the right operand can be unparenthesized.
-- but not so on the left (at least in Haskell):
-- x + (if ...) --> x + if ...
-- but NOT
-- (if ...) + x --> if ... + x (NOT!)

ruleIfRight :: Expr -> Expr
ruleIfRight e =
    case e of
      EOp op a (EGroup i@(EIf _ _ _)) -> EOp op a i
      _ -> e

-- In Haskell, a function application has precedence over all
-- operators.  This applies in both the left and right operands.

commonRuleFuncOp :: Expr -> Expr
commonRuleFuncOp e =
    case e of
      EOp op a (EGroup c@(ECall _ _)) -> EOp op a c
      EOp op (EGroup c@(ECall _ _)) b -> EOp op c b
      _ -> e

-- | A list of common rules for simplifying expressions.
-- Does *not* include ruleIfRight, since that works
-- for Haskell but not Python.

commonRulesForSimplifyingExprs :: [Expr -> Expr]
commonRulesForSimplifyingExprs =
    [commonRuleHigherPrec
    , commonRuleAtomic
    , commonRuleLeftToRight
    , commonRuleAssocRight
    , commonRuleFuncOp]

-- | Try the first rule in a list to see if it changes an expression,
-- returning the new expression if it does; otherwise, try the next rule,
-- and so on; if no rule changes the expression, then return the expression.
-- (Note that (applyFirstMatch rules) is itself a rule.)

applyFirstMatch :: [Expr -> Expr] -> Expr -> Expr
applyFirstMatch [] e = e
applyFirstMatch (r:rs) e = 
    let e' = r e
    in if e' /= e
       then e'
       else applyFirstMatch rs e

-- | Apply a rule top-down to all levels of an expression.
-- Normally, the "rule" would be a value of (applyFirstMatch rules).
topDown :: (Expr -> Expr) -> Expr -> Expr
topDown f e =
    let tdf = topDown f
        e' = f e
    in case e' of
         EIf c a b -> EIf (tdf c) (tdf a) (tdf b)
         EList xs -> EList (map tdf xs)
         ELambda x body -> ELambda x (tdf body)
         ECall fsym args -> ECall fsym (map tdf args)
         EOp op left right -> EOp op (tdf left) (tdf right)
         EGroup e'' -> EGroup (tdf e'')
         _ -> e'