module Database.DSH.Externals where
import Database.DSH.Internals
import Database.DSH.Impossible
import Database.DSH.TH
import Prelude ( Eq, Ord, Num(..), Fractional(..), Show(..)
, Bool(..), Char, Integer, Double, String, Maybe(..), Either(..)
, id, undefined, ($), (.))
import qualified Prelude as P
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
instance QA () where
type Rep () = ()
toExp () = UnitE
frExp UnitE = ()
frExp _ = $impossible
instance QA Bool where
type Rep Bool = Bool
toExp = BoolE
frExp (BoolE b) = b
frExp _ = $impossible
instance QA Char where
type Rep Char = Char
toExp = CharE
frExp (CharE c) = c
frExp _ = $impossible
instance QA Integer where
type Rep Integer = Integer
toExp = IntegerE
frExp (IntegerE i) = i
frExp _ = $impossible
instance QA Double where
type Rep Double = Double
toExp = DoubleE
frExp (DoubleE d) = d
frExp _ = $impossible
instance QA Text where
type Rep Text = Text
toExp = TextE
frExp (TextE t) = t
frExp _ = $impossible
instance (QA a,QA b) => QA (a,b) where
type Rep (a,b) = (Rep a,Rep b)
toExp (a,b) = PairE (toExp a) (toExp b)
frExp (PairE a b) = (frExp a,frExp b)
frExp _ = $impossible
instance (QA a,QA b,QA c) => QA (a,b,c) where
type Rep (a,b,c) = (Rep a,(Rep b,Rep c))
toExp (a,b,c) = PairE (toExp a) (PairE (toExp b) (toExp c))
frExp (PairE a (PairE b c)) = (frExp a,frExp b,frExp c)
frExp _ = $impossible
instance (QA a) => QA [a] where
type Rep [a] = [Rep a]
toExp as = ListE (P.map toExp as)
frExp (ListE as) = P.map frExp as
frExp _ = $impossible
instance (QA a) => QA (Maybe a) where
type Rep (Maybe a) = [Rep a]
toExp Nothing = ListE []
toExp (Just a) = ListE [toExp a]
frExp (ListE []) = Nothing
frExp (ListE (a : _)) = Just (frExp a)
frExp _ = $impossible
instance (QA a,QA b) => QA (Either a b) where
type Rep (Either a b) = ([Rep a],[Rep b])
toExp (Left a) = PairE (ListE [toExp a]) (ListE [])
toExp (Right b) = PairE (ListE []) (ListE [toExp b])
frExp (PairE (ListE (a : _)) _) = Left (frExp a)
frExp (PairE _ (ListE (a : _))) = Right (frExp a)
frExp _ = $impossible
instance (QA r) => Elim () r where
type Eliminator () r = Q r -> Q r
elim _ r = r
instance (QA r) => Elim Bool r where
type Eliminator Bool r = Q r -> Q r -> Q r
elim (Q e) (Q e1) (Q e2) = Q (AppE Cond (PairE e (PairE e1 e2)))
instance (QA r) => Elim Char r where
type Eliminator Char r = (Q Char -> Q r) -> Q r
elim q f = f q
instance (QA r) => Elim Integer r where
type Eliminator Integer r = (Q Integer -> Q r) -> Q r
elim q f = f q
instance (QA r) => Elim Double r where
type Eliminator Double r = (Q Double -> Q r) -> Q r
elim q f = f q
instance (QA r) => Elim Text r where
type Eliminator Text r = (Q Text -> Q r) -> Q r
elim q f = f q
instance (QA a,QA b,QA r) => Elim (a,b) r where
type Eliminator (a,b) r = (Q a -> Q b -> Q r) -> Q r
elim q f = f (fst q) (snd q)
instance (QA a,QA r) => Elim (Maybe a) r where
type Eliminator (Maybe a) r = Q r -> (Q a -> Q r) -> Q r
elim q r f = maybe r f q
instance (QA a,QA b,QA r) => Elim (Either a b) r where
type Eliminator (Either a b) r = (Q a -> Q r) -> (Q b -> Q r) -> Q r
elim q f g = either f g q
instance BasicType () where
instance BasicType Bool where
instance BasicType Char where
instance BasicType Integer where
instance BasicType Double where
instance BasicType Text where
instance TA () where
instance TA Bool where
instance TA Char where
instance TA Integer where
instance TA Double where
instance TA Text where
instance (BasicType a, BasicType b) => TA (a,b) where
instance Num (Exp Integer) where
(+) e1 e2 = AppE Add (PairE e1 e2)
(*) e1 e2 = AppE Mul (PairE e1 e2)
() e1 e2 = AppE Sub (PairE e1 e2)
fromInteger = IntegerE
abs e = let c = AppE Lt (PairE e 0)
in AppE Cond (PairE c (PairE (negate e) e))
signum e = let c1 = AppE Lt (PairE e 0)
c2 = AppE Equ (PairE e 0)
e' = AppE Cond (PairE c2 (PairE 0 1))
in AppE Cond (PairE c1 (PairE (1) e'))
instance Num (Exp Double) where
(+) e1 e2 = AppE Add (PairE e1 e2)
(*) e1 e2 = AppE Mul (PairE e1 e2)
() e1 e2 = AppE Sub (PairE e1 e2)
fromInteger = DoubleE . fromInteger
abs e = let c = AppE Lt (PairE e 0)
in AppE Cond (PairE c (PairE (negate e) e))
signum e = let c1 = AppE Lt (PairE e 0.0)
c2 = AppE Equ (PairE e 0.0)
e' = AppE Cond (PairE c2 (PairE 0 1))
in AppE Cond (PairE c1 (PairE (1) e'))
instance Fractional (Exp Double) where
(/) e1 e2 = AppE Div (PairE e1 e2)
fromRational = DoubleE . fromRational
instance Num (Q Integer) where
(+) (Q e1) (Q e2) = Q (e1 + e2)
(*) (Q e1) (Q e2) = Q (e1 * e2)
() (Q e1) (Q e2) = Q (e1 e2)
fromInteger = Q . IntegerE
abs (Q e) = Q (abs e)
signum (Q e) = Q (signum e)
instance Num (Q Double) where
(+) (Q e1) (Q e2) = Q (e1 + e2)
(*) (Q e1) (Q e2) = Q (e1 * e2)
() (Q e1) (Q e2) = Q (e1 e2)
fromInteger = Q . DoubleE . fromInteger
abs (Q e) = Q (abs e)
signum (Q e) = Q (signum e)
instance Fractional (Q Double) where
(/) (Q e1) (Q e2) = Q (e1 / e2)
fromRational = Q . DoubleE . fromRational
instance View (Q ()) where
type ToView (Q ()) = Q ()
view = id
instance View (Q Bool) where
type ToView (Q Bool) = Q Bool
view = id
instance View (Q Char) where
type ToView (Q Char) = Q Char
view = id
instance View (Q Integer) where
type ToView (Q Integer) = Q Integer
view = id
instance View (Q Double) where
type ToView (Q Double) = Q Double
view = id
instance View (Q Text) where
type ToView (Q Text) = Q Text
view = id
instance (QA a, QA b) => View (Q (a,b)) where
type ToView (Q (a,b)) = (Q a,Q b)
view (Q e) = (Q (AppE Fst e),Q (AppE Snd e))
instance (QA a,QA b,QA c) => View (Q (a,b,c)) where
type ToView (Q (a,b,c)) = (Q a,Q b,Q c)
view (Q e) = (Q (AppE Fst e),Q (AppE Fst (AppE Snd e)),Q (AppE Snd (AppE Snd e)))
instance IsString (Q Text) where
fromString = Q . TextE . T.pack
table :: (QA a, TA a) => String -> Q [a]
table name = Q (TableE (TableDB name []))
tableDB :: (QA a, TA a) => String -> Q [a]
tableDB name = Q (TableE (TableDB name []))
tableWithKeys :: (QA a, TA a) => String -> [[String]] -> Q [a]
tableWithKeys name keys = Q (TableE (TableDB name keys))
tableCSV :: (QA a, TA a) => String -> Q [a]
tableCSV filename = Q (TableE (TableCSV filename))
toQ :: (QA a) => a -> Q a
toQ = Q . toExp
unit :: Q ()
unit = Q UnitE
false :: Q Bool
false = Q (BoolE False)
true :: Q Bool
true = Q (BoolE True)
not :: Q Bool -> Q Bool
not (Q e) = Q (AppE Not e)
(&&) :: Q Bool -> Q Bool -> Q Bool
(&&) (Q a) (Q b) = Q (AppE Conj (PairE a b))
(||) :: Q Bool -> Q Bool -> Q Bool
(||) (Q a) (Q b) = Q (AppE Disj (PairE a b))
eq :: (QA a,Eq a) => Q a -> Q a -> Q Bool
eq (Q a) (Q b) = Q (AppE Equ (PairE a b))
(==) :: (QA a,Eq a) => Q a -> Q a -> Q Bool
(==) = eq
neq :: (QA a,Eq a) => Q a -> Q a -> Q Bool
neq a b = not (eq a b)
(/=) :: (QA a,Eq a) => Q a -> Q a -> Q Bool
(/=) = neq
lt :: (QA a,Ord a) => Q a -> Q a -> Q Bool
lt (Q a) (Q b) = Q (AppE Lt (PairE a b))
(<) :: (QA a,Ord a) => Q a -> Q a -> Q Bool
(<) = lt
lte :: (QA a,Ord a) => Q a -> Q a -> Q Bool
lte (Q a) (Q b) = Q (AppE Lte (PairE a b))
(<=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool
(<=) = lte
gte :: (QA a,Ord a) => Q a -> Q a -> Q Bool
gte (Q a) (Q b) = Q (AppE Gte (PairE a b))
(>=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool
(>=) = gte
gt :: (QA a,Ord a) => Q a -> Q a -> Q Bool
gt (Q a) (Q b) = Q (AppE Gt (PairE a b))
(>) :: (QA a,Ord a) => Q a -> Q a -> Q Bool
(>) = gt
min :: (QA a,Ord a) => Q a -> Q a -> Q a
min (Q a) (Q b) = Q (AppE Min (PairE a b))
max :: (QA a,Ord a) => Q a -> Q a -> Q a
max (Q a) (Q b) = Q (AppE Max (PairE a b))
bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a
bool f t b = cond b t f
cond :: (QA a) => Q Bool -> Q a -> Q a -> Q a
cond (Q c) (Q a) (Q b) = Q (AppE Cond (PairE c (PairE a b)))
ifThenElse :: (QA a) => Q Bool -> Q a -> Q a -> Q a
ifThenElse = cond
(?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a
(?) c (a,b) = cond c a b
listToMaybe :: (QA a) => Q [a] -> Q (Maybe a)
listToMaybe (Q as) = Q as
maybeToList :: (QA a) => Q (Maybe a) -> Q [a]
maybeToList (Q ma) = Q ma
nothing :: (QA a) => Q (Maybe a)
nothing = listToMaybe nil
just :: (QA a) => Q a -> Q (Maybe a)
just a = listToMaybe (singleton a)
isNothing :: (QA a) => Q (Maybe a) -> Q Bool
isNothing ma = null (maybeToList ma)
isJust :: (QA a) => Q (Maybe a) -> Q Bool
isJust ma = not (isNothing ma)
fromJust :: (QA a) => Q (Maybe a) -> Q a
fromJust ma = head (maybeToList ma)
maybe :: (QA a,QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b
maybe b f ma = isNothing ma ? (b,f (fromJust ma))
fromMaybe :: (QA a) => Q a -> Q (Maybe a) -> Q a
fromMaybe a ma = isNothing ma ? (a,fromJust ma)
catMaybes :: (QA a) => Q [Maybe a] -> Q [a]
catMaybes = concatMap maybeToList
mapMaybe :: (QA a,QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b]
mapMaybe f = concatMap (maybeToList . f)
pairToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b)
pairToEither (Q a) = Q a
eitherToPair :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b])
eitherToPair (Q a) = Q a
left :: (QA a,QA b) => Q a -> Q (Either a b)
left a = pairToEither (pair (singleton a) nil)
right :: (QA a,QA b) => Q b -> Q (Either a b)
right a = pairToEither (pair nil (singleton a))
isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool
isLeft = null . snd . eitherToPair
isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool
isRight = null . fst . eitherToPair
either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c
either lf rf e =
let p = eitherToPair e
in head (map lf (fst p) ++ map rf (snd p))
lefts :: (QA a,QA b) => Q [Either a b] -> Q [a]
lefts = concatMap (fst . eitherToPair)
rights :: (QA a,QA b) => Q [Either a b] -> Q [b]
rights = concatMap (snd . eitherToPair)
partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b])
partitionEithers es = pair (lefts es) (rights es)
nil :: (QA a) => Q [a]
nil = Q (ListE [])
empty :: (QA a) => Q [a]
empty = nil
cons :: (QA a) => Q a -> Q [a] -> Q [a]
cons (Q a) (Q as) = Q (AppE Cons (PairE a as))
(<|) :: (QA a) => Q a -> Q [a] -> Q [a]
(<|) = cons
snoc :: (QA a) => Q [a] -> Q a -> Q [a]
snoc as a = append as (singleton a)
(|>) :: (QA a) => Q [a] -> Q a -> Q [a]
(|>) = snoc
singleton :: (QA a) => Q a -> Q [a]
singleton (Q e) = cons (Q e) nil
head :: (QA a) => Q [a] -> Q a
head (Q as) = Q (AppE Head as)
tail :: (QA a) => Q [a] -> Q [a]
tail (Q as) = Q (AppE Tail as)
take :: (QA a) => Q Integer -> Q [a] -> Q [a]
take (Q i) (Q as) = Q (AppE Take (PairE i as))
drop :: (QA a) => Q Integer -> Q [a] -> Q [a]
drop (Q i) (Q as) = Q (AppE Drop (PairE i as))
map :: (QA a,QA b) => (Q a -> Q b) -> Q [a] -> Q [b]
map f (Q as) = Q (AppE Map (PairE (LamE (toLam f)) as))
append :: (QA a) => Q [a] -> Q [a] -> Q [a]
append (Q as) (Q bs) = Q (AppE Concat (ListE [as,bs]))
(++) :: (QA a) => Q [a] -> Q [a] -> Q [a]
(++) = append
filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]
filter f (Q as) = Q (AppE Filter (PairE (LamE (toLam f)) as))
groupWithKey :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [(b,[a])]
groupWithKey f (Q as) = Q (AppE GroupWithKey (PairE (LamE (toLam f)) as))
groupWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [[a]]
groupWith f as = map snd (groupWithKey f as)
sortWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [a]
sortWith f (Q as) = Q (AppE SortWith (PairE (LamE (toLam f)) as))
last :: (QA a) => Q [a] -> Q a
last (Q as) = Q (AppE Last as)
init :: (QA a) => Q [a] -> Q [a]
init (Q as) = Q (AppE Init as)
null :: (QA a) => Q [a] -> Q Bool
null (Q as) = Q (AppE Null as)
length :: (QA a) => Q [a] -> Q Integer
length (Q as) = Q (AppE Length as)
index :: (QA a) => Q [a] -> Q Integer -> Q a
index (Q as) (Q i) = Q (AppE Index (PairE as i))
(!!) :: (QA a) => Q [a] -> Q Integer -> Q a
(!!) = index
reverse :: (QA a) => Q [a] -> Q [a]
reverse (Q as) = Q (AppE Reverse as)
and :: Q [Bool] -> Q Bool
and (Q bs) = Q (AppE And bs)
or :: Q [Bool] -> Q Bool
or (Q bs) = Q (AppE Or bs)
any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool
any f = or . map f
all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool
all f = and . map f
sum :: (QA a,Num a) => Q [a] -> Q a
sum (Q as) = Q (AppE Sum as)
concat :: (QA a) => Q [[a]] -> Q [a]
concat (Q ass) = Q (AppE Concat ass)
concatMap :: (QA a,QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b]
concatMap f as = concat (map f as)
maximum :: (QA a,Ord a) => Q [a] -> Q a
maximum (Q as) = Q (AppE Maximum as)
minimum :: (QA a,Ord a) => Q [a] -> Q a
minimum (Q as) = Q (AppE Minimum as)
splitAt :: (QA a) => Q Integer -> Q [a] -> Q ([a],[a])
splitAt (Q i) (Q as) = Q (AppE SplitAt (PairE i as))
takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]
takeWhile f (Q as) = Q (AppE TakeWhile (PairE (LamE (toLam f)) as))
dropWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]
dropWhile f (Q as) = Q (AppE DropWhile (PairE (LamE (toLam f)) as))
span :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a])
span f as = pair (takeWhile f as) (dropWhile f as)
break :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a])
break f = span (not . f)
elem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool
elem a as = null (filter (a ==) as) ? (false,true)
notElem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool
notElem a as = not (a `elem` as)
lookup :: (QA a,QA b,Eq a) => Q a -> Q [(a, b)] -> Q (Maybe b)
lookup a = listToMaybe . map snd . filter ((a ==) . fst)
zip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)]
zip (Q as) (Q bs) = Q (AppE Zip (PairE as bs))
zipWith :: (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c]
zipWith f as bs = map (\e -> f (fst e) (snd e)) (zip as bs)
unzip :: (QA a,QA b) => Q [(a,b)] -> Q ([a],[b])
unzip as = pair (map fst as) (map snd as)
zip3 :: (QA a,QA b,QA c) => Q [a] -> Q [b] -> Q [c] -> Q [(a,b,c)]
zip3 as bs cs = map (\abc -> triple (fst abc) (fst (snd abc)) (snd (snd abc))) (zip as (zip bs cs))
zipWith3 :: (QA a,QA b,QA c,QA d) => (Q a -> Q b -> Q c -> Q d) -> Q [a] -> Q [b] -> Q [c] -> Q [d]
zipWith3 f as bs cs = map (\e -> (case view e of (a,b,c) -> f a b c))
(zip3 as bs cs)
unzip3 :: (QA a,QA b,QA c) => Q [(a,b,c)] -> Q ([a],[b],[c])
unzip3 abcs = triple (map (\e -> (case view e of (a,_,_) -> a)) abcs)
(map (\e -> (case view e of (_,b,_) -> b)) abcs)
(map (\e -> (case view e of (_,_,c) -> c)) abcs)
nub :: (QA a,Eq a) => Q [a] -> Q [a]
nub (Q as) = Q (AppE Nub as)
fst :: (QA a,QA b) => Q (a,b) -> Q a
fst (Q e) = Q (AppE Fst e)
snd :: (QA a,QA b) => Q (a,b) -> Q b
snd (Q e) = Q (AppE Snd e)
integerToDouble :: Q Integer -> Q Double
integerToDouble (Q i) = Q (AppE IntegerToDouble i)
return :: (QA a) => Q a -> Q [a]
return = singleton
(>>=) :: (QA a,QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b]
(>>=) ma f = concatMap f ma
(>>) :: (QA a,QA b) => Q [a] -> Q [b] -> Q [b]
(>>) ma mb = concatMap (\_ -> mb) ma
mzip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)]
mzip = zip
guard :: Q Bool -> Q [()]
guard c = cond c (singleton unit) nil
pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b)
pair (Q a) (Q b) = Q (PairE a b)
triple :: (QA a,QA b,QA c) => Q a -> Q b -> Q c -> Q (a,b,c)
triple (Q a) (Q b) (Q c)= Q (PairE a (PairE b c))
infixl 9 !!
infixr 5 ++, <|, |>
infix 4 ==, /=, <, <=, >=, >
infixr 3 &&
infixr 2 ||
infix 0 ?
deriveTupleRangeQA 4 7
deriveTupleRangeView 4 7
deriveTupleRangeSmartConstructors 2 7