mirror of
https://github.com/thma/LtuPatternFactory.git
synced 2024-12-03 03:55:08 +03:00
bringing idiom brackets to the masses...
This commit is contained in:
parent
aa6cffe708
commit
84052deff9
21
src/IdiomBrackets.hs
Normal file
21
src/IdiomBrackets.hs
Normal file
@ -0,0 +1,21 @@
|
|||||||
|
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
|
||||||
|
module IdiomBrackets where
|
||||||
|
|
||||||
|
-- This module provides the Idiom Bracket syntax suggested by Conor McBride
|
||||||
|
-- 'iI f a b ... Ii' stands for '[[f a b ...]]' which denotes 'pure f <*> a <*> b <*> ...'
|
||||||
|
-- See also https://wiki.haskell.org/Idiom_brackets
|
||||||
|
|
||||||
|
class Applicative i => Idiomatic i f g | g -> f i where
|
||||||
|
idiomatic :: i f -> g
|
||||||
|
|
||||||
|
iI :: Idiomatic i f g => f -> g
|
||||||
|
iI = idiomatic . pure
|
||||||
|
|
||||||
|
data Ii = Ii
|
||||||
|
|
||||||
|
instance Applicative i => Idiomatic i x (Ii -> i x) where
|
||||||
|
idiomatic xi Ii = xi
|
||||||
|
|
||||||
|
instance Idiomatic i f g => Idiomatic i (s -> f) (i s -> g) where
|
||||||
|
idiomatic sfi si = idiomatic (sfi <*> si)
|
@ -1,4 +1,5 @@
|
|||||||
module Singleton where
|
module Singleton where
|
||||||
|
import IdiomBrackets
|
||||||
|
|
||||||
data Exp a =
|
data Exp a =
|
||||||
Var String
|
Var String
|
||||||
@ -45,6 +46,14 @@ eval2 (Val i) = pure i
|
|||||||
eval2 (Add p q) = pure (+) <*> eval2 p <*> eval2 q
|
eval2 (Add p q) = pure (+) <*> eval2 p <*> eval2 q
|
||||||
eval2 (Mul p q) = pure (*) <*> eval2 p <*> eval2 q
|
eval2 (Mul p q) = pure (*) <*> eval2 p <*> eval2 q
|
||||||
|
|
||||||
|
-- using the Idiom Bracket syntax suggested by Conor McBride
|
||||||
|
-- 'iI f a b ... Ii' stands for '[[f a b ...]]' which denotes 'pure f <*> a <*> b <*> ...'
|
||||||
|
eval3 :: (Num a) => Exp a -> Env a -> a
|
||||||
|
eval3 (Var x) = fetch x
|
||||||
|
eval3 (Val i) = iI i Ii
|
||||||
|
eval3 (Add p q) = iI (+) (eval3 p) (eval3 q) Ii
|
||||||
|
eval3 (Mul p q) = iI (*) (eval3 p) (eval3 q) Ii
|
||||||
|
|
||||||
-- simple environment lookup
|
-- simple environment lookup
|
||||||
fetch :: String -> Env a -> a
|
fetch :: String -> Env a -> a
|
||||||
fetch x [] = error $ "variable " ++ x ++ " is not defined"
|
fetch x [] = error $ "variable " ++ x ++ " is not defined"
|
||||||
@ -61,4 +70,5 @@ singletonDemo = do
|
|||||||
print $ eval exp env
|
print $ eval exp env
|
||||||
print $ eval1 exp env
|
print $ eval1 exp env
|
||||||
print $ eval2 exp env
|
print $ eval2 exp env
|
||||||
|
print $ eval3 exp env
|
||||||
putStrLn ""
|
putStrLn ""
|
Loading…
Reference in New Issue
Block a user