DSL.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Charcuterie.DSL () where

import           Control.Applicative
import           Data.Coerce
import           Data.Function
import           Data.Map            (Map)
import qualified Data.Map.Strict     as M
import           Data.Proxy
import           Data.String
import           GHC.TypeLits

data Status
  = Substituted
  | Free

data Calc (status :: Status)
  = Add (Calc status) (Calc status)
  | Mul (Calc status) (Calc status)
  | Div (Calc status) (Calc status)
  | Sub (Calc status) (Calc status)
  | Abs (Calc status)
  | Signum (Calc status)
  | Number Rational
  | Var String
  deriving (Eq, Show)

type Env = Map String Rational

instance IsString (Calc Free) where
  fromString = Var

-- | semantic equivalence
(===) :: Calc Substituted -> Calc Substituted -> Bool
(===) = (==) `on` interpret

instance Num (Calc Free) where
  (+) = Add
  (*) = Mul
  (-) = flip Sub
  fromInteger x = Number (fromIntegral x)
  abs = Abs
  signum = Signum

instance Fractional (Calc Free) where
  fromRational x = Number x
  (/) = Div

bottomUpM
  :: Applicative f
  => (Calc Free -> f (Calc Substituted))
  -> Calc Free
  -> f (Calc Substituted)
bottomUpM f = \case
  Add x y ->
    liftA2 Add (bottomUpM f x) (bottomUpM f y)
  Mul x y ->
    liftA2 Mul (bottomUpM f x) (bottomUpM f y)
  Sub x y ->
    liftA2 Sub (bottomUpM f x) (bottomUpM f y)
  Div x y ->
    liftA2 Div (bottomUpM f x) (bottomUpM f y)
  Abs x ->
    Abs <$> bottomUpM f x
  Signum x ->
    Signum <$> bottomUpM f x
  Number x ->
    f (Number x)
  Var x ->
    f (Var x)

substitute :: Env -> Calc Free -> Either String (Calc Substituted)
substitute env =
  bottomUpM $ \case
    Var x ->
      case M.lookup x env of
        Nothing -> Left ("Variable \"" <> x <> "\" is unbound")
        Just y -> pure (Number y)
    x -> pure (coerce x)

interpret :: Calc Substituted -> Rational
interpret (Add x y)  = on (+) interpret x y
interpret (Mul x y)  = on (*) interpret x y
interpret (Div x y)  = on (/) interpret x y
interpret (Sub x y)  = on (-) interpret x y
interpret (Signum x) = signum (interpret x)
interpret (Abs x)    = abs (interpret x)
interpret (Number x) = x
interpret (Var x)    = error ("impossible state: " <> x)

profitFree :: Calc Free
profitFree = ("revenue" - "expenses") * 1 / 1

profit :: Either String (Calc Substituted)
profit = substitute env profitFree
    where
      env
        = M.fromList -- this can become a type safe Map
        [ ("revenue", 10)
        , ("expenses", 12)
        ]

run :: IO ()
run = do
  putStrLn (pretty profitFree)
  print (pretty <$> profit)
  print (realToFrac . interpret <$> profit)

prettyAST :: String
prettyAST = pretty profitFree

pretty :: Calc a -> String
pretty (Add x y) = parens (pretty x <> " + " <> pretty y)
pretty (Mul x y) = parens (pretty x <> " * " <> pretty y)
pretty (Div x y) = parens (pretty x <> " / " <> pretty y)
pretty (Sub x y) = parens (pretty x <> " - " <> pretty y)
pretty (Abs x) = "abs" <> parens (show x)
pretty (Signum x) = "signum" <> parens (show x)
pretty (Number x) = show (realToFrac x :: Double)
pretty (Var x) = x

parens :: (Semigroup a, IsString a) => a -> a
parens s = "(" <> s <> ")"

DSL2.hs

{-# LANGUAGE GADTs #-}                                                                                                                                  
{-# LANGUAGE PolyKinds #-}                                                                                                                              
{-# LANGUAGE TypeFamilies #-}                                                                                                                           
{-# LANGUAGE TypeOperators #-}                                                                                                                          
{-# LANGUAGE KindSignatures #-}                                                                                                                         
                                                                                                                                                        
import Data.Proxy                                                                                                                                       
import GHC.TypeLits                                                                                                                                     
                                                                                                                                                        
type family xs ++ ys where                                                                                                                              
  '[] ++ xs = xs                                                                                                                                        
  (x ': xs) ++ ys = x ': (xs ++ ys)                                                                                                                     
                                                                                                                                                        
data Calc (xs :: [Symbol]) where                                                                                                                        
  Var :: KnownSymbol x => Proxy x -> Calc (x ': xs)                                                                                                     
  Add :: Calc xs -> Calc ys -> Calc (xs ++ ys)                                                                                                          
  Number :: Rational -> Calc xs