{-# Language DeriveDataTypeable, StandaloneDeriving #-}
module Conjure.Cases
( Cases (..)
, Fxpr
, sumFxpr
, factFxpr
, nullFxpr
, isZeroFxpr
)
where
import Conjure.Utils
import Data.Express
import Data.Express.Express
import Data.Express.Fixtures
import Data.Dynamic
import Data.Typeable (Typeable)
type Fxpr = (Expr, Cxpr)
type Cxpr = [([Expr],Expr)]
sumFxpr :: Fxpr
sumFxpr :: Fxpr
sumFxpr = String -> ([Int] -> Int) -> Expr
forall a. Typeable a => String -> a -> Expr
var String
"sum" ([Int] -> Int
forall a. HasCallStack => a
undefined :: [Int] -> Int) Expr -> [([Expr], Expr)] -> Fxpr
forall a b. a -> b -> (a, b)
=-
[ [Expr
nil] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
zero
, [(Expr
xx Expr -> Expr -> Expr
-:- Expr
xxs)] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
xx Expr -> Expr -> Expr
-+- (String -> ([Int] -> Int) -> Expr
forall a. Typeable a => String -> a -> Expr
var String
"recurse" ([Int] -> Int
forall a. HasCallStack => a
undefined :: [Int] -> Int) Expr -> Expr -> Expr
:$ Expr
xxs)
]
where
=- :: a -> b -> (a, b)
(=-) = (,)
infixr 0 =-
factFxpr :: Fxpr
factFxpr :: Fxpr
factFxpr = String -> Fxpr
forall a. HasCallStack => String -> a
error String
"TODO: write me"
nullFxpr :: Fxpr
nullFxpr :: Fxpr
nullFxpr = String -> Expr
forall a. HasCallStack => String -> a
error String
"TODO" Expr -> [([Expr], Expr)] -> Fxpr
forall a b. a -> b -> (a, b)
=-
[ [Expr
nil] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
false
, [(Expr
xx Expr -> Expr -> Expr
-:- Expr
xxs)] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
false
]
where
=- :: a -> b -> (a, b)
(=-) = (,)
infixr 0 =-
isZeroFxpr :: Fxpr
isZeroFxpr :: Fxpr
isZeroFxpr = String -> Expr
forall a. HasCallStack => String -> a
error String
"TODO" Expr -> [([Expr], Expr)] -> Fxpr
forall a b. a -> b -> (a, b)
=-
[ [Expr
zero] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
true
, [Expr -> Expr
forall a. a
inc Expr
xx] [Expr] -> Expr -> ([Expr], Expr)
forall a b. a -> b -> (a, b)
=- Expr
false
]
where
inc :: a
inc = a
forall a. HasCallStack => a
undefined
=- :: a -> b -> (a, b)
(=-) = (,)
infixr 0 =-
fxprToDynamic :: Int -> Fxpr -> Expr -> Maybe Dynamic
fxprToDynamic :: Int -> Fxpr -> Expr -> Maybe Dynamic
fxprToDynamic = Int -> Fxpr -> Expr -> Maybe Dynamic
forall a. HasCallStack => a
undefined
class Express a => Cases a where
cases :: a -> [Expr]
instance Cases () where
cases :: () -> [Expr]
cases ()
_ = [() -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val ()]
instance Cases Bool where
cases :: Bool -> [Expr]
cases Bool
_ = [Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val Bool
False, Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val Bool
True]
instance Cases Int where
cases :: Int -> [Expr]
cases Int
x = [Int -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val (Int
0 Int -> Int -> Int
forall a. a -> a -> a
-: Int
x), Int -> Expr
forall a. Typeable a => a -> Expr
hole Int
x]
instance Cases Integer where
cases :: Integer -> [Expr]
cases Integer
x = [Integer -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val (Integer
0 Integer -> Integer -> Integer
forall a. a -> a -> a
-: Integer
x), Integer -> Expr
forall a. Typeable a => a -> Expr
hole Integer
x]
instance Cases Char where
cases :: Char -> [Expr]
cases Char
_ = []
instance Express a => Cases [a] where
cases :: [a] -> [Expr]
cases [a]
xs = [ [a] -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val ([] [a] -> [a] -> [a]
forall a. a -> a -> a
-: [a]
xs)
, String -> (a -> [a] -> [a]) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
":" ((:) (a -> [a] -> [a]) -> [a] -> a -> [a] -> [a]
forall a b c. (a -> b -> c) -> c -> a -> b -> c
->>: [a]
xs) Expr -> Expr -> Expr
:$ a -> Expr
forall a. Typeable a => a -> Expr
hole a
x Expr -> Expr -> Expr
:$ [a] -> Expr
forall a. Typeable a => a -> Expr
hole [a]
xs
]
where
x :: a
x = [a] -> a
forall a. [a] -> a
head [a]
xs
instance (Express a, Express b) => Cases (a,b) where
cases :: (a, b) -> [Expr]
cases (a, b)
xy = [String -> (a -> b -> (a, b)) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"," ((,) (a -> b -> (a, b)) -> (a, b) -> a -> b -> (a, b)
forall a b c. (a -> b -> c) -> c -> a -> b -> c
->>: (a, b)
xy) Expr -> Expr -> Expr
:$ a -> Expr
forall a. Typeable a => a -> Expr
hole a
x Expr -> Expr -> Expr
:$ b -> Expr
forall a. Typeable a => a -> Expr
hole b
y]
where
(a
x,b
y) = (a
forall a. HasCallStack => a
undefined,b
forall a. HasCallStack => a
undefined) (a, b) -> (a, b) -> (a, b)
forall a. a -> a -> a
-: (a, b)
xy
instance (Express a, Express b, Express c) => Cases (a,b,c) where
cases :: (a, b, c) -> [Expr]
cases (a, b, c)
xyz = [String -> (a -> b -> c -> (a, b, c)) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
",," ((,,) (a -> b -> c -> (a, b, c)) -> (a, b, c) -> a -> b -> c -> (a, b, c)
forall a b c d. (a -> b -> c -> d) -> d -> a -> b -> c -> d
->>>: (a, b, c)
xyz) Expr -> Expr -> Expr
:$ a -> Expr
forall a. Typeable a => a -> Expr
hole a
x Expr -> Expr -> Expr
:$ b -> Expr
forall a. Typeable a => a -> Expr
hole b
y Expr -> Expr -> Expr
:$ c -> Expr
forall a. Typeable a => a -> Expr
hole c
z]
where
(a
x,b
y,c
z) = (a
forall a. HasCallStack => a
undefined,b
forall a. HasCallStack => a
undefined,c
forall a. HasCallStack => a
undefined) (a, b, c) -> (a, b, c) -> (a, b, c)
forall a. a -> a -> a
-: (a, b, c)
xyz
instance Express a => Cases (Maybe a) where
cases :: Maybe a -> [Expr]
cases Maybe a
mx = [ String -> Maybe a -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"Nothing" (Maybe a
forall a. Maybe a
Nothing Maybe a -> Maybe a -> Maybe a
forall a. a -> a -> a
-: Maybe a
mx)
, String -> (a -> Maybe a) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"Just" (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Maybe a -> a -> Maybe a
forall a b. (a -> b) -> b -> a -> b
->: Maybe a
mx) Expr -> Expr -> Expr
:$ Maybe a -> Expr
forall a. Typeable a => a -> Expr
hole Maybe a
x
]
where
x :: Maybe a
x = a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. HasCallStack => a
undefined Maybe a -> Maybe a -> Maybe a
forall a. a -> a -> a
-: Maybe a
mx
instance (Express a, Express b) => Cases (Either a b) where
cases :: Either a b -> [Expr]
cases Either a b
exy = [ String -> (a -> Either a b) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"Left" (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Either a b -> a -> Either a b
forall a b. (a -> b) -> b -> a -> b
->: Either a b
exy) Expr -> Expr -> Expr
:$ Either a b -> Expr
forall a. Typeable a => a -> Expr
hole Either a b
x
, String -> (b -> Either a b) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"Right" (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Either a b -> b -> Either a b
forall a b. (a -> b) -> b -> a -> b
->: Either a b
exy) Expr -> Expr -> Expr
:$ Either a b -> Expr
forall a. Typeable a => a -> Expr
hole Either a b
y
]
where
x :: Either a b
x = a -> Either a b
forall a b. a -> Either a b
Left a
forall a. HasCallStack => a
undefined Either a b -> Either a b -> Either a b
forall a. a -> a -> a
-: Either a b
exy
y :: Either a b
y = b -> Either a b
forall a b. b -> Either a b
Right b
forall a. HasCallStack => a
undefined Either a b -> Either a b -> Either a b
forall a. a -> a -> a
-: Either a b
exy