-- |
-- Module      : Conjure.Constructors
-- Copyright   : (c) 2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of 'Conjure'.
--
-- This module defines the 'Constructors' typeclass
-- that allows listing constructors of a type
-- encoded as 'Expr's
--
-- You are probably better off importing "Conjure".
{-# Language DeriveDataTypeable, StandaloneDeriving #-} -- for GHC < 7.10
module Conjure.Constructors
  ( Constructors (..)
  , Fxpr
  , Fxpress (..)
  , sumFxpr
  , factFxpr
  , nullFxpr
  , isZeroFxpr
  )
where

import Conjure.Utils
import Data.Express
import Data.Express.Express
import Data.Express.Fixtures
import Data.Typeable (Typeable)

type Fxpr  =  [([Expr],Expr)]

sumFxpr :: Fxpr
sumFxpr :: Fxpr
sumFxpr  =
  [ [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  =  Fxpr
forall a. HasCallStack => a
undefined

nullFxpr :: Fxpr
nullFxpr :: Fxpr
nullFxpr  =
  [ [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  =
  [ [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 -- TODO: define me
  =- :: a -> b -> (a, b)
(=-) = (,)
  infixr 0 =-


class Typeable a => Fxpress a where
  fvl :: Fxpr -> a
  fvl (([],Expr
e):Fxpr
_)  =  Expr -> a
forall a. Typeable a => Expr -> a
evl Expr
e
  fvl Fxpr
_           =  String -> a
forall a. HasCallStack => String -> a
error String
"fvl: incomplete pattern match"

instance Fxpress ()
instance Fxpress Int
instance Fxpress Bool
instance Fxpress Char
instance Fxpress a => Fxpress [a]
instance Fxpress a => Fxpress (Maybe a)
instance (Fxpress a, Fxpress b) => Fxpress (Either a b)

instance (Constructors a, Fxpress b) => Fxpress (a -> b) where
  fvl :: Fxpr -> a -> b
fvl Fxpr
cs a
x  =  Fxpr -> b
forall a. Fxpress a => Fxpr -> a
fvl [ ([Expr]
ps,Expr
exp Expr -> [(Expr, Expr)] -> Expr
//- [(Expr, Expr)]
bs)
                   | (Expr
p:[Expr]
ps,Expr
exp) <- Fxpr
cs
                   , [(Expr, Expr)]
bs <- Maybe [(Expr, Expr)] -> [[(Expr, Expr)]]
forall a. Maybe a -> [a]
maybeToList (Expr -> Expr -> Maybe [(Expr, Expr)]
match (a -> Expr
forall a. Constructors a => a -> Expr
expr1 a
x) Expr
p)
                   ]
-- TODO: add support for recursion


class Express a => Constructors a where
  expr1 :: a -> Expr
  constructors :: a -> [Expr]

instance Constructors () where
  expr1 :: () -> Expr
expr1  =  () -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val
  constructors :: () -> [Expr]
constructors ()
_  =  [() -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val ()]

instance Constructors Bool where
  expr1 :: Bool -> Expr
expr1  =  Bool -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val
  constructors :: Bool -> [Expr]
constructors 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]

constructorsNum :: (Num a, Express a) => a -> [Expr]
constructorsNum :: a -> [Expr]
constructorsNum a
x  =  [ a -> Expr
forall a. Typeable a => a -> Expr
hole a
x -- <= 0 -- val (0 -: x)
                      , String -> (a -> a) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"inc" ((a -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a -> a) -> a -> a -> a
forall a b. (a -> b) -> b -> a -> b
->: a
x) Expr -> Expr -> Expr
:$ a -> Expr
forall a. Typeable a => a -> Expr
hole a
x
                      ]

expr1Num :: (Ord a, Num a, Express a) => a -> Expr
expr1Num :: a -> Expr
expr1Num a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0     =  a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val a
x
  | Bool
otherwise  =  String -> (a -> a) -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"inc" ((a -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a -> a) -> a -> a -> a
forall a b. (a -> b) -> b -> a -> b
->: a
x) Expr -> Expr -> Expr
:$ a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val (a
xa -> a -> a
forall a. Num a => a -> a -> a
-a
1)

instance Constructors Int where
  expr1 :: Int -> Expr
expr1  =  Int -> Expr
forall a. (Ord a, Num a, Express a) => a -> Expr
expr1Num
  constructors :: Int -> [Expr]
constructors  =  Int -> [Expr]
forall a. (Num a, Express a) => a -> [Expr]
constructorsNum

instance Constructors Integer where
  expr1 :: Integer -> Expr
expr1  =  Integer -> Expr
forall a. (Ord a, Num a, Express a) => a -> Expr
expr1Num
  constructors :: Integer -> [Expr]
constructors  =  Integer -> [Expr]
forall a. (Num a, Express a) => a -> [Expr]
constructorsNum

instance Constructors Char where
  expr1 :: Char -> Expr
expr1  =  Char -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val
  constructors :: Char -> [Expr]
constructors Char
_  =  []

instance Express a => Constructors [a] where
  expr1 :: [a] -> Expr
expr1 [a]
xs  =  case [a]
xs of
               [] -> [a] -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val [a]
xs
               (a
y:[a]
ys) -> 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, Show a) => a -> Expr
val a
y Expr -> Expr -> Expr
:$ [a] -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val [a]
ys
  constructors :: [a] -> [Expr]
constructors [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) => Constructors (a,b) where
  expr1 :: (a, b) -> Expr
expr1 (a
x,b
y)  =  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
x,b
y))
               Expr -> Expr -> Expr
:$ a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val a
x Expr -> Expr -> Expr
:$ b -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val b
y
  constructors :: (a, b) -> [Expr]
constructors (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) => Constructors (a,b,c) where
  expr1 :: (a, b, c) -> Expr
expr1 (a
x,b
y,c
z)  =  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
x,b
y,c
z))
                 Expr -> Expr -> Expr
:$ a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val a
x Expr -> Expr -> Expr
:$ b -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val b
y Expr -> Expr -> Expr
:$ c -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val c
z

  constructors :: (a, b, c) -> [Expr]
constructors (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 => Constructors (Maybe a) where
  expr1 :: Maybe a -> Expr
expr1 mx :: Maybe a
mx@Maybe a
Nothing   =  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)
  expr1 mx :: Maybe a
mx@(Just a
x)  =  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
:$ a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val a
x
  constructors :: Maybe a -> [Expr]
constructors 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) => Constructors (Either a b) where
  expr1 :: Either a b -> Expr
expr1 lx :: Either a b
lx@(Left a
x)   =  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
lx) Expr -> Expr -> Expr
:$ a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val a
x
  expr1 ry :: Either a b
ry@(Right b
y)  =  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
ry) Expr -> Expr -> Expr
:$ b -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val b
y
  constructors :: Either a b -> [Expr]
constructors 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