Skip to content

Instantly share code, notes, and snippets.

@sordina
Last active August 29, 2015 13:58
Show Gist options
  • Save sordina/10094977 to your computer and use it in GitHub Desktop.
Save sordina/10094977 to your computer and use it in GitHub Desktop.
{-# 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) ' '
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment