git.haldean.org del / 30e5126 src / Language / Del / Constants.hs
30e5126

Tree @30e5126 (Download .tar.gz)

Constants.hs @30e5126 — raw · history · blame 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
module Language.Del.Constants (propConstants, foldConstantExprs) where

import Language.Del.AST
import Language.Del.AstUtils
import Language.Del.CompileDefs
import Control.Monad

import qualified Data.Map.Strict as Map

-- Replace references to constants with the constants themselves
propConstants' :: Expr -> Expr
propConstants' (Let n v@(Number _) b) = mapexpr (replaceNames $ Map.singleton n v) b
propConstants' (Let n v@(Id _) b) = mapexpr (replaceNames $ Map.singleton n v) b
propConstants' e = e

propConstants :: Def -> Artifact Def
propConstants (Def n ret a b) = return . Def n ret a $ mapexpr propConstants' b

isNumber :: Expr -> Bool
isNumber (Number _) = True
isNumber _ = False

getNumbers :: [Expr] -> [DelNum]
getNumbers = map extract . filter isNumber
    where extract (Number nt) = nt
          extract _ = undefined

-- Only safe to call on expressions that are definitely constant numbers
extractNumber :: Expr -> DelNum
extractNumber (Number n) = n
extractNumber _ = undefined

liftConstExprOp :: (DelNum -> DelNum -> DelNum) -> Expr -> Expr -> Expr -> Expr
liftConstExprOp f e e1 e2 =
    if isNumber e1 && isNumber e2
       then Number $ f (extractNumber e1) (extractNumber e2)
       else e

-- Replace arithmetic operations on constants with the result of the operation
-- itself.
collapseConstExprs' :: Expr -> Expr
-- These two partition the list into constant numbers and not-constant-numbers,
-- sum/product the constant numbers, promoting them in the meantime if
-- necessary, and then prepend that constant onto the the list of
-- non-constants.
collapseConstExprs' (Add xs) =
    Add . (flip (:)) (filter (not . isNumber) xs) . Number . sum . promote . getNumbers $ xs
collapseConstExprs' (Mul xs) =
    Mul . (flip (:)) (filter (not . isNumber) xs) . Number . product . promote . getNumbers $ xs
collapseConstExprs' e@(Sub e1 e2) = liftConstExprOp (-) e e1 e2
collapseConstExprs' e@(Div e1 e2) = liftConstExprOp (/) e e1 e2
collapseConstExprs' e@(Pow e1 e2) = liftConstExprOp pow e e1 e2
collapseConstExprs' e = e

collapseConstExprs :: Def -> Artifact Def
collapseConstExprs (Def n ret a b) = return . Def n ret a $ mapexpr collapseConstExprs' b

-- Remove unnecessary arithmetic
remIdent :: Integer -> ([Expr] -> Expr) -> [Expr] -> Expr
remIdent ident ctor exprs =
    case (filter (\e -> case e of
                             Number (DelInt x) -> x /= ident
                             Number (DelFloat x) -> x /= fromIntegral ident
                             _ -> True) exprs) of
    [] -> Number $ DelInt ident
    [x] -> x
    xs -> ctor xs

removeIdentities' :: Expr -> Expr
removeIdentities' (Add xs) = remIdent 0 Add xs
removeIdentities' (Mul xs) = remIdent 1 Mul xs
removeIdentities' (Pow _ (Number (DelInt 0))) = Number (DelInt 1)
removeIdentities' (Pow _ (Number (DelFloat 0))) = Number (DelFloat 1)
removeIdentities' e = e

removeIdentities :: Def -> Artifact Def
removeIdentities (Def n ret a b) = return . Def n ret a $ mapexpr removeIdentities' b

foldConstantExprs :: Def -> Artifact Def
-- this is not the correct way to do this; some kind of
-- iteration-until-finished is the way to go here.
foldConstantExprs = collapseConstExprs
                    >=> removeIdentities
                    >=> collapseConstExprs
                    >=> removeIdentities