A dynamically typed DSL in Haskell

DynamicDSL.hs

{-# LANGUAGE FlexibleInstances #-}

module Main where

import Data.String (IsString, fromString)


-- language types
-- 1. integers
-- 2. string
-- 3. booleans
-- 4. functions
-- language syntax
-- f x applies x to f (f : Haskell function Dyn -> Dyn)
-- x |> f applies x to f (f : ->)
-- x + y adds x and y (x y : Integer)
-- x - y subtracts y from x (x y : Integer)
-- x * y multiplies x and y (x y : Integer)
-- -x does arithmetic negation on x (x : Integer)
-- x @& y is a conjunction between x and y (x y : Bool)
-- x @| y is a disjunction between x and y (x y : Bool)
-- nay x does logical negation on x (x : Bool)
-- x <> y concatenates string (x y : String)
-- x == y tests x and y for equality (x y : Any)
-- x /= y tests x and y for inequality (x y : Any)
-- select x y z selects y if x is true, z if false (x : Bool, y z : Any)

main :: IO ()
main = print (fac 6)

fac :: Dyn -> Dyn
fac n = select (n == 0) 1 (n * fac (n - 1))

data Dyn = DInt Integer
         | DStr String
         | DBool Bool
         | DFun (Dyn -> Dyn)
         | DErr String

class Select b where
  select :: b -> Dyn -> Dyn -> Dyn

instance Select Dyn where
  select (DBool True)  t _ = t
  select (DBool False) _ f = f
  select x _ _ = typeError $ "tried to select " ++ show x

instance Select Bool where
  select True  t _ = t
  select False _ f = f

infixl 1 |>

class Pipe f where
  (|>) :: Dyn -> f -> Dyn

instance Pipe Dyn where
  x |> (DFun f) = f x
  x |> f = typeError $ "tried to apply " ++ show x ++ " to " ++ show f

instance Pipe (Dyn -> Dyn) where
  x |> f = f x

true :: Dyn
true = DBool True

false :: Dyn
false = DBool False

typeError :: String -> Dyn
typeError s = DErr $ "TypeError: " ++ s

instance Show Dyn where
  show (DInt x)   = "DInt " ++ show x
  show (DStr x)   = "DStr " ++ show x
  show (DBool x)  = "DBool " ++ show x
  show (DFun _)   = "DFun <unknown>"
  show (DErr x)   = "DErr " ++ show x

instance Eq Dyn where
  (DInt i)   == (DInt j)   = i == j
  (DStr s)   == (DStr r)   = s == r
  (DBool b)  == (DBool c)  = b == c
  _          == _          = False

instance Num Dyn where
  fromInteger = DInt

  (DInt i) + (DInt j) = DInt (i + j)
  x        + y        = typeError
                        $ "tried to add " ++ show x ++ " and " ++ show y
  (DInt i) - (DInt j) = DInt (i - j)
  x        - y        = typeError
                        $ "tried to subtract " ++ show x ++ " and " ++ show y
  (DInt i) * (DInt j) = DInt (i * j)
  x        * y        = typeError
                        $ "tried to multiply " ++ show x ++ " and " ++ show y

  abs (DInt i) = DInt (abs i)
  abs x        = typeError $ "tried to get abstract value of " ++ show x

  signum (DInt i) = DInt (signum i)
  signum x        = typeError $ "tried to get sign of " ++ show x

instance IsString Dyn where
  fromString = DStr

infixl 3 @&

(@&) :: Dyn -> Dyn -> Dyn
(DBool False) @& _             = false
(DBool True)  @& (DBool False) = false
(DBool True)  @& (DBool True)  = true
x             @& y             = typeError
                                 $ "tried to conjunct "
                                 ++ show x
                                 ++ " and "
                                 ++ show y

infixl 3 @|

(@|) :: Dyn -> Dyn -> Dyn
(DBool True)  @| _              = true
(DBool False) @| (DBool True)   = true
(DBool False) @| (DBool False)  = false
x             @| y              = typeError
                                 $ "tried to disjunct "
                                 ++ show x
                                 ++ " and "
                                 ++ show y

nay :: Dyn -> Dyn
nay (DBool True)  = false
nay (DBool False) = true
nay x             = typeError $ "tried to negate " ++ show x

instance Semigroup Dyn where
  (DStr s) <> (DStr r) = DStr (s <> r)
  x        <> y        = typeError
                         $ "tried to append "
                         ++ show x
                         ++ " to "
                         ++ show y