FreeBash.hs

{-# LANGUAGE GADTs
           , FlexibleInstances
           , RebindableSyntax
           , DeriveFunctor
           , RebindableSyntax
           , OverloadedStrings #-}

import Control.Monad.Free
import Control.Monad
import Data.Monoid
import Data.String
import Prelude hiding ((++))

type UniqueID = Integer

newtype VStr = VStr UniqueID
newtype VInt = VInt UniqueID

data Expr a where
  StrL   :: String  -> Expr String  -- String  literal
  IntL   :: Integer -> Expr Integer -- Integer literal
  StrV   :: VStr    -> Expr String  -- String  variable
  IntV   :: VInt    -> Expr Integer -- Integer variable
  Plus   :: Expr Integer -> Expr Integer -> Expr Integer
  Concat :: Expr String  -> Expr String  -> Expr String
  Shown  :: Expr Integer -> Expr String
  BOOL   :: Bool -> Expr Bool
  Cmp    :: Eq a => Expr a -> Expr a -> Expr Bool

instance Num (Expr Integer) where
    fromInteger = IntL
    (+)         = Plus
    (*)    = undefined
    abs    = undefined
    signum = undefined

instance IsString (Expr String) where
    fromString = StrL

data ScriptF next
    = NewInt (Expr Integer) (VInt -> next)
    | NewStr (Expr String ) (VStr -> next)
    | SetStr VStr (Expr String ) next
    | SetInt VInt (Expr Integer) next
    | Echo (Expr String) next
    | IF (Expr Bool) (Script ()) (Script ()) next
    | Exit (Expr Integer)
  deriving (Functor)

instance Num (Script VInt) where
  fromInteger = newInt . IntL
  (+)    = undefined
  (*)    = undefined
  abs    = undefined
  signum = undefined

(++) :: Expr String -> Expr String -> Expr String
(++) = Concat

type Script = Free ScriptF

newInt :: Expr Integer -> Script VInt
newInt n = liftF $ NewInt n id

newStr :: Expr String -> Script VStr
newStr str = liftF $ NewStr str id

setStr :: VStr -> Expr String -> Script ()
setStr v expr = liftF $ SetStr v expr ()

setInt :: VInt -> Expr Integer -> Script ()
setInt v expr = liftF $ SetInt v expr ()

echo :: Expr String -> Script ()
echo expr = liftF $ Echo expr ()

exit :: Expr Integer -> Script r
exit expr = liftF $ Exit expr

-- Also using RebindableSyntax to subsume 'if' syntax
ifThenElse :: Expr Bool -> Script () -> Script () -> Script ()
ifThenElse b s1 s2 = liftF $ IF b s1 s2 ()

script :: Script ()
script = do
    hello <- newStr "Hello, "
    world <- newStr "World!"
    setStr hello (StrV hello ++ StrV world)
    echo ("hello: " ++ StrV hello)
    echo ("world: " ++ StrV world)
    x <- newInt 4
    y <- newInt 5
    exit (IntV x + IntV y)

script2 :: Script ()
script2 = forM_ [1..5] $ \i -> do
    x <- newInt (IntL i)
    setInt x (IntV x + 5)
    echo (Shown (IntV x))

script3 :: Script ()
script3 = do
  if BOOL True
  then echo "1"
  else echo "2"

script4 :: Script ()
script4 = do
  if BOOL True
  then do
    x <- 3
    setInt x (IntV x + 1)
  else do
    x <- 5
    setInt x (IntV x + 1)

script5 :: Script ()
script5 = do
  if (Cmp "hello" ("world" :: Expr String))
  then echo "1"
  else do
    if (Cmp 1 (2 :: Expr Integer))
    then echo "yay"
    else echo "oops"

bashExpr :: Expr a -> String
bashExpr expr = case expr of
    StrL str           -> str
    IntL int           -> show int
    StrV (VStr nID)    -> "${S" <> show nID <> "}"
    IntV (VInt nID)    -> "${I" <> show nID <> "}"
    Plus exp1 expr2    -> concat ["$((", bashExpr exp1, "+", bashExpr expr2, "))"]
    Concat exp1 expr2  -> bashExpr exp1 <> bashExpr expr2
    Shown  expr'       -> bashExpr expr'
    BOOL True          -> "1 == 1"
    BOOL False         -> "0 == 1"
    Cmp  x y           -> bashExpr x <> " == " <> bashExpr y

bashBackend :: Script r -> String
bashBackend scriptArg = go 0 0 0 scriptArg where
  go :: Int -> Integer -> Integer -> Script a -> String
  go indent nStrs nInts scriptArg2 =
      case scriptArg2 of
          Free f -> case f of
              NewInt e k ->
                  space <> "I" <> show nInts <> "=" <> bashExpr e <> "\n" <> 
                      go indent nStrs (nInts + 1) (k (VInt nInts))
              NewStr e k ->
                  space <> "S" <> show nStrs <> "=" <> bashExpr e <> "\n" <>
                      go indent (nStrs + 1) nInts (k (VStr nStrs))
              SetStr (VStr nID) e script' ->
                  space <> "S" <> show nID <> "=" <> bashExpr e <> "\n" <>
                      go indent nStrs nInts script'
              SetInt (VInt nID) e script' ->
                  space <> "I" <> show nID <> "=" <> bashExpr e <> "\n" <>
                      go indent nStrs nInts script'
              Echo e script' ->
                  space <> "echo " <> bashExpr e <> "\n" <>
                      go indent nStrs nInts script'
              Exit e ->
                  space <> "exit " <> bashExpr e <> "\n"
              IF b tt ff k ->
                  space <> "if [ " <> bashExpr b <> " ]\n"
                    <> space <> "then\n"
                    <> go (succ indent) nStrs nInts tt
                    <> space <> "else\n"
                    <> go (succ indent) nStrs nInts ff
                    <> space <> "fi\n"
                    <> go indent nStrs nInts k
          Pure _ -> ""
    where
    space = replicate (4 * indent) ' '