Skip to content

Instantly share code, notes, and snippets.

View deque-blog's full-sized avatar

deque-blog

4 followers · 5 following
View GitHub Profile
@deque-blog
deque-blog / dsl_arithmetic_2_expr_fixed.hs
Last active January 18, 2017 20:52
newtype Fix f = Fix { unFix :: f (Fix f) }
-- Analog to Expr = ExprR Expr
type Expr = Fix ExprR
@deque-blog
deque-blog / dsl_arithmetic_2_expr_ctor.hs
Created January 18, 2017 20:54
cst = Fix . Cst
var = Fix . Var
add = Fix . Op Add
mul = Fix . Op Mul
@deque-blog
deque-blog / dsl_arithmetic_2_expr_example.hs
Created January 18, 2017 20:57
> let e = add [ cst(1)
, cst(2)
, mul [cst(0), var("x"), var("y")]
, mul [cst(1), var("y"), cst(2)]
, add [cst(0), var("x") ]]
@deque-blog
deque-blog / dsl_arithmetic_2_functor.hs
Created January 20, 2017 20:08
instance Functor ExprR where
fmap _ (Cst c) = Cst c
fmap _ (Var v) = Var v
fmap f (Op opType xs) = Op opType (map f xs)
@deque-blog
deque-blog / dsl_arithmetic_2_cataExpr.hs
Created January 20, 2017 20:12
cataExpr :: (ExprR a -> a) -> Expr -> a
cataExpr algebra =
algebra
. fmap (cataExpr algebra)
. unFix
@deque-blog
deque-blog / dsl_arithmetic_2_cata.hs
Created January 20, 2017 20:16
cata :: Functor f => (f a -> a) -> Fix f -> a
cata algebra =
algebra
. fmap (cata algebra)
. unFix
@deque-blog
deque-blog / dsl_arithmetic_2_prn.hs
Created January 20, 2017 20:18
prn :: Expr -> String
prn = cata algebra where
algebra (Cst n) = show n
algebra (Var x) = x
algebra (Op Add xs) = "(+ " ++ unwords xs ++ ")"
algebra (Op Mul xs) = "(* " ++ unwords xs ++ ")"
@deque-blog
deque-blog / dsl_arithmetic_2_eval.hs
Created January 20, 2017 20:25
eval :: Env -> Expr -> Int
eval env = cata algebra where
algebra (Cst n) = n
algebra (Var x) = env Map.! x
algebra (Op Add xs) = sum xs
algebra (Op Mul xs) = product xs
@deque-blog
deque-blog / dsl_arithmetic_2_dependencies.hs
Last active January 20, 2017 20:34
dependencies :: Expr -> Set.Set Id
dependencies = cata algebra where
algebra (Cst _) = Set.empty
algebra (Var x) = Set.singleton x
algebra (Op _ xs) = Set.unions xs
@deque-blog
deque-blog / dsl_arithmetic_2_optimized_operations.hs
Last active January 21, 2017 21:09
optimizeAdd :: ExprR Expr -> Expr
optimizeAdd op@(Op Add _) = optimizeOp op 0 (+)
optimizeAdd e = Fix e
optimizeMul :: ExprR Expr -> Expr
optimizeMul op@(Op Mul xs)
| not (null (dropWhile (/= cst 0) xs)) = cst 0
| otherwise = optimizeOp op 1 (*)
optimizeMul e = Fix e