module Data.Express.Fixtures
(
module Data.Express
, b_, pp, qq, rr, pp'
, false
, true
, notE
, orE
, andE
, implies
, not'
, (-||-)
, (-&&-)
, (-==>-)
, (-==-)
, (-/=-)
, (-<=-)
, (-<-)
, compare'
, i_, xx, yy, zz, xx'
, ii, jj, kk, ii'
, zero, one, two, three, minusOne, minusTwo
, idE, negateE, absE
, idInt
, idBool
, idChar
, idInts
, idBools
, idString
, id', const', negate', abs'
, plus, times
, (-+-), (-*-)
, ff, ffE
, gg, ggE
, (-?-)
, (-$-)
, odd'
, even'
, c_
, cc, dd, ccs
, ae, bee, cee, dee
, space, lineBreak
, ord'
, ordE
, is_
, xxs
, yys
, nil
, emptyString
, nilInt
, nilBool
, nilChar
, cons
, consInt
, consBool
, consChar
, (-:-)
, unit
, (-++-)
, head'
, tail'
, length'
, elem'
, sort'
, insert'
, nothing
, nothingInt
, nothingBool
, just
, justInt
, justBool
, comma
, pair
, (-|-)
, triple
, quadruple
, quintuple
, sixtuple
)
where
import Data.Express
import Data.Maybe
import Data.Typeable (Typeable, typeOf)
import Data.Char
import Data.List
int :: Int
int = undefined
bool :: Bool
bool = undefined
char :: Char
char = undefined
string :: String
string = undefined
b_ :: Expr
b_ = hole bool
pp :: Expr
pp = var "p" bool
qq :: Expr
qq = var "q" bool
rr :: Expr
rr = var "r" bool
pp' :: Expr
pp' = var "p'" bool
false :: Expr
false = val False
true :: Expr
true = val True
notE :: Expr
notE = value "not" not
andE :: Expr
andE = value "&&" (&&)
orE :: Expr
orE = value "||" (||)
(-==>-) :: Expr -> Expr -> Expr
e1 -==>- e2 = implies :$ e1 :$ e2
implies :: Expr
implies = value "==>" (==>)
where
False ==> _ = True
True ==> p = p
not' :: Expr -> Expr
not' pp = notE :$ pp
(-&&-) :: Expr -> Expr -> Expr
pp -&&- qq = andE :$ pp :$ qq
(-||-) :: Expr -> Expr -> Expr
pp -||- qq = orE :$ pp :$ qq
i_ :: Expr
i_ = hole int
xx :: Expr
xx = var "x" int
yy :: Expr
yy = var "y" int
zz :: Expr
zz = var "z" int
xx' :: Expr
xx' = var "x'" int
ii :: Expr
ii = var "i" int
jj :: Expr
jj = var "j" int
kk :: Expr
kk = var "k" int
ii' :: Expr
ii' = var "i'" int
zero :: Expr
zero = val (0 :: Int)
one :: Expr
one = val (1 :: Int)
two :: Expr
two = val (2 :: Int)
three :: Expr
three = val (3 :: Int)
minusOne :: Expr
minusOne = val (-1 :: Int)
minusTwo :: Expr
minusTwo = val (-2 :: Int)
ff :: Expr -> Expr
ff = (ffE :$)
ffE :: Expr
ffE = var "f" (undefined :: Int -> Int)
gg :: Expr -> Expr
gg = (ggE :$)
(-?-) :: Expr -> Expr -> Expr
ex -?- ey = fromMaybe err $ ($$ ey) $ headOr err $ mapMaybe ($$ ex)
[ var "?" (undefined :: Int -> Int -> Int)
, var "?" (undefined :: Bool -> Bool -> Bool)
, var "?" (undefined :: Char -> Char -> Char)
, var "?" (undefined :: [Int] -> [Int] -> [Int])
, var "?" (undefined :: String -> String -> String)
]
where
err = error $ "(-?-): cannot apply `(?) :: * -> * -> *` to `"
++ show ex ++ "' and `" ++ show ey ++ "'. Unhandled types?"
ggE :: Expr
ggE = var "g" (undefined :: Int -> Int)
(-+-) :: Expr -> Expr -> Expr
e1 -+- e2 = plus :$ e1 :$ e2
infixl 6 -+-
plus :: Expr
plus = value "+" ((+) :: Int -> Int -> Int)
(-*-) :: Expr -> Expr -> Expr
e1 -*- e2 = times :$ e1 :$ e2
times :: Expr
times = value "*" ((*) :: Int -> Int -> Int)
minus :: Expr
minus = value "-" ((-) :: Int -> Int -> Int)
id' :: Expr -> Expr
id' e = headOr err $ mapMaybe ($$ e)
[ idInt
, idBool
, idChar
, idInts
, idBools
, idString
]
where
err = error $ "id': unhandled type " ++ show (typ e)
idE :: Expr
idE = idInt
idInt,idBool,idChar,idInts,idBools,idString :: Expr
idInt = value "id" (id :: Id Int)
idBool = value "id" (id :: Id Bool)
idChar = value "id" (id :: Id Char)
idInts = value "id" (id :: Id [Int])
idBools = value "id" (id :: Id [Bool])
idString = value "id" (id :: Id String)
type Id a = a -> a
const' :: Expr -> Expr -> Expr
const' e1 e2 = (:$ e2) . headOr err $ mapMaybe ($$ e1)
[ value "const" (const :: Int -> Int -> Int)
, value "const" (const :: Bool -> Bool -> Bool)
, value "const" (const :: Char -> Char -> Char)
, value "const" (const :: [Int] -> [Int] -> [Int])
, value "const" (const :: [Bool] -> [Bool] -> [Bool])
, value "const" (const :: String -> String -> String)
]
where
err = error $ "const': unhandled type " ++ show (typ e1)
negate' :: Expr -> Expr
negate' e = negateE :$ e
negateE :: Expr
negateE = value "negate" (negate :: Int -> Int)
abs' :: Expr -> Expr
abs' e = absE :$ e
absE :: Expr
absE = value "abs" (abs :: Int -> Int)
odd' :: Expr -> Expr
odd' = (oddE :$) where oddE = value "odd" (odd :: Int -> Bool)
even' :: Expr -> Expr
even' = (evenE :$) where evenE = value "even" (even :: Int -> Bool)
c_ :: Expr
c_ = hole char
cc :: Expr
cc = var "c" char
dd :: Expr
dd = var "d" char
ccs :: Expr
ccs = var "cs" [char]
ae :: Expr
ae = val 'a'
bee :: Expr
bee = val 'b'
cee :: Expr
cee = val 'c'
dee :: Expr
dee = val 'd'
space :: Expr
space = val ' '
lineBreak :: Expr
lineBreak = val '\n'
ord' :: Expr -> Expr
ord' = (ordE :$)
ordE :: Expr
ordE = value "ord" ord
is_ :: Expr
is_ = hole [int]
xxs :: Expr
xxs = var "xs" [int]
yys :: Expr
yys = var "ys" [int]
nil :: Expr
nil = nilInt
emptyString :: Expr
emptyString = val ""
nilInt, nilBool, nilChar :: Expr
nilInt = val ([] :: [Int])
nilBool = val ([] :: [Bool])
nilChar = value "[]" ([] :: [Char])
cons :: Expr
cons = consInt
consInt, consBool, consChar :: Expr
consInt = value ":" ((:) :: Cons Int)
consBool = value ":" ((:) :: Cons Bool)
consChar = value ":" ((:) :: Cons Char)
type Cons a = a -> [a] -> [a]
unit :: Expr -> Expr
unit e = e -:- nil'
where
nil' | typ e == typ i_ = nil
| typ e == typ c_ = emptyString
| typ e == typ b_ = nilBool
(-:-) :: Expr -> Expr -> Expr
e1 -:- e2 = (:$ e2) . headOr err $ mapMaybe ($$ e1)
[ consInt
, consBool
, consChar
, value ":" ((:) :: Cons (Maybe Int))
]
where
err = error $ "(-:-): unhandled type " ++ show (typ e1)
infixr 5 -:-
(-++-) :: Expr -> Expr -> Expr
e1 -++- e2 = (:$ e2) . headOr err $ mapMaybe ($$ e1)
[ value "++" ((++) :: [Int] -> [Int] -> [Int])
, value "++" ((++) :: String -> String -> String)
, value "++" ((++) :: [Bool] -> [Bool] -> [Bool])
]
where
err = error $ "(-++-): unhandled type " ++ show (typ e1)
infixr 5 -++-
head' :: Expr -> Expr
head' exs = headOr err $ mapMaybe ($$ exs)
[ value "head" (head :: [Int] -> Int)
, value "head" (head :: [Char] -> Char)
, value "head" (head :: [Bool] -> Bool)
]
where
err = error $ "head': cannot apply `head :: [a] -> a` to `" ++ show exs ++ "'."
tail' :: Expr -> Expr
tail' exs = headOr err $ mapMaybe ($$ exs)
[ value "tail" (tail :: [Int] -> [Int])
, value "tail" (tail :: [Char] -> [Char])
, value "tail" (tail :: [Bool] -> [Bool])
]
where
err = error $ "tail': unhandled type " ++ show (typ exs)
length' :: Expr -> Expr
length' exs = headOr err $ mapMaybe ($$ exs)
[ value "length" (length :: [Int] -> Int)
, value "length" (length :: [Char] -> Int)
, value "length" (length :: [Bool] -> Int)
]
where
err = error $ "length': cannot apply `length :: [a] -> a` to `" ++ show exs ++ "'."
sort' :: Expr -> Expr
sort' exs = headOr err $ mapMaybe ($$ exs)
[ value "sort" (sort :: [Int] -> [Int])
, value "sort" (sort :: [Char] -> [Char])
, value "sort" (sort :: [Bool] -> [Bool])
]
where
err = error $ "sort': unhandled type " ++ show (typ exs)
insert' :: Expr -> Expr -> Expr
insert' ex exs = (:$ exs) . headOr err $ mapMaybe ($$ ex)
[ value "insert" (insert :: Int -> [Int] -> [Int])
, value "insert" (insert :: Bool -> [Bool] -> [Bool])
, value "insert" (insert :: Char -> String -> String)
]
where
err = error $ "insert': unhandled type " ++ show (typ ex)
elem' :: Expr -> Expr -> Expr
elem' ex exs = (:$ exs) . headOr err $ mapMaybe ($$ ex)
[ value "elem" (elem :: Int -> [Int] -> Bool)
, value "elem" (elem :: Bool -> [Bool] -> Bool)
, value "elem" (elem :: Char -> String -> Bool)
]
where
err = error $ "elem': unhandled type " ++ show (typ ex)
(-$-) :: Expr -> Expr -> Expr
ef -$- ex = (:$ ex) . headOr err $ mapMaybe ($$ ef)
[ value "$" (($) :: Apply Int)
, value "$" (($) :: Apply Bool)
, value "$" (($) :: Apply Char)
, value "$" (($) :: Apply [Int])
, value "$" (($) :: Apply [Bool])
, value "$" (($) :: Apply [Char])
]
where
err = error $ "(-$-): unhandled type " ++ show (typ ef)
infixl 6 -$-
type Apply a = (a -> a) -> a -> a
(-==-) :: Expr -> Expr -> Expr
ex -==- ey = (:$ ey) . headOr err $ mapMaybe ($$ ex)
[ value "==" ((==) :: Comparison ())
, value "==" ((==) :: Comparison Int)
, value "==" ((==) :: Comparison Bool)
, value "==" ((==) :: Comparison Char)
, value "==" ((==) :: Comparison [Int])
, value "==" ((==) :: Comparison [Bool])
, value "==" ((==) :: Comparison [Char])
]
where
err = error $ "(-==-): unhandled type " ++ show (typ ex)
infix 4 -==-
type Comparison a = a -> a -> Bool
(-/=-) :: Expr -> Expr -> Expr
ex -/=- ey = (:$ ey) . headOr err $ mapMaybe ($$ ex)
[ value "/=" ((/=) :: Comparison ())
, value "/=" ((/=) :: Comparison Int)
, value "/=" ((/=) :: Comparison Bool)
, value "/=" ((/=) :: Comparison Char)
, value "/=" ((/=) :: Comparison [Int])
, value "/=" ((/=) :: Comparison [Bool])
, value "/=" ((/=) :: Comparison [Char])
]
where
err = error $ "(-/=-): unhandled type " ++ show (typ ex)
infix 4 -/=-
(-<=-) :: Expr -> Expr -> Expr
ex -<=- ey = (:$ ey) . headOr err $ mapMaybe ($$ ex)
[ value "<=" ((<=) :: Comparison ())
, value "<=" ((<=) :: Comparison Int)
, value "<=" ((<=) :: Comparison Bool)
, value "<=" ((<=) :: Comparison Char)
, value "<=" ((<=) :: Comparison [Int])
, value "<=" ((<=) :: Comparison [Bool])
, value "<=" ((<=) :: Comparison [Char])
]
where
err = error $ "(-<=-): unhandled type " ++ show (typ ex)
infix 4 -<=-
(-<-) :: Expr -> Expr -> Expr
ex -<- ey = (:$ ey) . headOr err $ mapMaybe ($$ ex)
[ value "<" ((<) :: Comparison ())
, value "<" ((<) :: Comparison Int)
, value "<" ((<) :: Comparison Bool)
, value "<" ((<) :: Comparison Char)
, value "<" ((<) :: Comparison [Int])
, value "<" ((<) :: Comparison [Bool])
, value "<" ((<) :: Comparison [Char])
]
where
err = error $ "(-<-): unhandled type " ++ show (typ ex)
infix 4 -<-
compare' :: Expr -> Expr -> Expr
compare' ex ey = (:$ ey) . headOr err $ mapMaybe ($$ ex)
[ value "compare" (compare :: Compare ())
, value "compare" (compare :: Compare Int)
, value "compare" (compare :: Compare Bool)
, value "compare" (compare :: Compare Char)
, value "compare" (compare :: Compare [Int])
, value "compare" (compare :: Compare [Bool])
, value "compare" (compare :: Compare [Char])
]
where
err = error $ "(-<-): unhandled type " ++ show (typ ex)
type Compare a = a -> a -> Ordering
nothing :: Expr
nothing = nothingInt
nothingInt, nothingBool :: Expr
nothingInt = val (Nothing :: Maybe Int)
nothingBool = val (Nothing :: Maybe Bool)
justInt, justBool :: Expr
justInt = value "Just" (Just :: Just Int)
justBool = value "Just" (Just :: Just Bool)
type Just a = a -> Maybe a
just :: Expr -> Expr
just ex = headOr err $ mapMaybe ($$ ex)
[ justInt
, justBool
]
where
err = error $ "just: unhandled type " ++ show (typ ex)
(-|-) :: Expr -> Expr -> Expr
(-|-) = pair
pair :: Expr -> Expr -> Expr
pair x y = comma :$ x :$ y
where
comma = case (show $ typ x, show $ typ y) of
("Int", "Int") -> value "," ((,) :: Pair Int Int)
("Int", "Bool") -> value "," ((,) :: Pair Int Bool)
("Bool","Int") -> value "," ((,) :: Pair Bool Int)
("Bool","Bool") -> value "," ((,) :: Pair Bool Bool)
(t,t') -> error $ "(-:-): unhandled types " ++ t ++ " " ++ t'
type Pair a b = a -> b -> (a,b)
comma :: Expr
comma = value "," ((,) :: Pair Int Int)
triple :: Expr -> Expr -> Expr -> Expr
triple e1 e2 e3 = ccE :$ e1 :$ e2 :$ e3
where
ccE = value ",," ((,,) :: Int -> Int -> Int -> (Int,Int,Int))
quadruple :: Expr -> Expr -> Expr -> Expr -> Expr
quadruple e1 e2 e3 e4 = cccE :$ e1 :$ e2 :$ e3 :$ e4
where
cccE = value ",,," ((,,,) :: Int -> Int -> Int -> Int -> (Int,Int,Int,Int))
quintuple :: Expr -> Expr -> Expr -> Expr -> Expr -> Expr
quintuple e1 e2 e3 e4 e5 = ccccE :$ e1 :$ e2 :$ e3 :$ e4 :$ e5
where
ccccE = value ",,,," ((,,,,) :: Int -> Int -> Int -> Int -> Int -> (Int,Int,Int,Int,Int))
sixtuple :: Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Expr
sixtuple e1 e2 e3 e4 e5 e6 = cccccE :$ e1 :$ e2 :$ e3 :$ e4 :$ e5 :$ e6
where
cccccE = value ",,,,," ((,,,,,) :: Int -> Int -> Int -> Int -> Int -> Int -> (Int,Int,Int,Int,Int,Int))
headOr :: a -> [a] -> a
headOr x [] = x
headOr _ (x:_) = x