{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Dhall.Bash (
dhallToExpression
, dhallToStatement
, ExpressionError(..)
, StatementError(..)
) where
import Control.Exception (Exception)
import Data.Bifunctor (first)
import Data.ByteString
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import Dhall.Core (Expr(..), Chunks(..))
import qualified Data.Foldable
import qualified Data.Text
import qualified Data.Text.Encoding
import qualified Dhall.Core
import qualified Dhall.Map
import qualified NeatInterpolation
import qualified Text.ShellEscape
_ERROR :: Data.Text.Text
_ERROR = "\ESC[1;31mError\ESC[0m"
data StatementError
= UnsupportedStatement (Expr Void Void)
| UnsupportedSubexpression (Expr Void Void)
deriving (Typeable)
instance Show StatementError where
show (UnsupportedStatement e) =
Data.Text.unpack [NeatInterpolation.text|
$_ERROR: Cannot translate to a Bash statement
Explanation: Only primitive values, records, ❰List❱s, and ❰Optional❱ values can
be translated from Dhall to a Bash statement
The following Dhall expression could not be translated to a Bash statement:
↳ $txt
|]
where
txt = Dhall.Core.pretty e
show (UnsupportedSubexpression e) =
Data.Text.unpack [NeatInterpolation.text|
$_ERROR: Cannot translate to a Bash expression
Explanation: Only primitive values can be translated from Dhall to a Bash
expression
The following Dhall expression could not be translated to a Bash expression:
↳ $txt
|]
where
txt = Dhall.Core.pretty e
instance Exception StatementError
data ExpressionError = UnsupportedExpression (Expr Void Void) deriving (Typeable)
instance Show ExpressionError where
show (UnsupportedExpression e) =
Data.Text.unpack [NeatInterpolation.text|
$_ERROR: Cannot translate to a Bash expression
Explanation: Only primitive values can be translated from Dhall to a Bash
expression
The following Dhall expression could not be translated to a Bash expression:
↳ $txt$tip
|]
where
txt = Dhall.Core.pretty e
tip = case e of
Some _ -> "\n\n" <> [NeatInterpolation.text|
Tip: You can convert an ❰Optional❱ value to a Bash statement using the --declare
flag
|]
ListLit _ _ -> "\n\n" <> [NeatInterpolation.text|
Tip: You can convert a ❰List❱ to a Bash statement using the --declare flag
|]
RecordLit _ -> "\n\n" <> [NeatInterpolation.text|
Tip: You can convert a record to a Bash statement using the --declare flag
|]
_ -> ""
instance Exception ExpressionError
dhallToStatement
:: Expr s Void
-> ByteString
-> Either StatementError ByteString
dhallToStatement expr0 var0 = go (Dhall.Core.normalize expr0)
where
var = Text.ShellEscape.bytes (Text.ShellEscape.bash var0)
adapt (UnsupportedExpression e) = UnsupportedSubexpression e
go (BoolLit a) = do
go (TextLit (if a then "true" else "false"))
go (NaturalLit a) = do
go (IntegerLit (fromIntegral a))
go (IntegerLit a) = do
e <- first adapt (dhallToExpression (IntegerLit a))
let bytes = "declare -r -i " <> var <> "=" <> e
return bytes
go (TextLit a) = do
e <- first adapt (dhallToExpression (TextLit a))
let bytes = "declare -r " <> var <> "=" <> e
return bytes
go (ListLit _ bs) = do
bs' <- first adapt (mapM dhallToExpression bs)
let bytes
= "declare -r -a "
<> var
<> "=("
<> Data.ByteString.intercalate " " (Data.Foldable.toList bs')
<> ")"
return bytes
go (Some b) = go b
go (App None _) = return ("unset " <> var)
go (RecordLit a) = do
let process (k, v) = do
v' <- dhallToExpression v
let bytes = Data.Text.Encoding.encodeUtf8 k
let k' = Text.ShellEscape.bytes (Text.ShellEscape.bash bytes)
return ("[" <> k' <> "]=" <> v')
kvs' <- first adapt (traverse process (Dhall.Map.toList a))
let bytes
= "declare -r -A "
<> var
<> "=("
<> Data.ByteString.intercalate " " kvs'
<> ")"
return bytes
go (Field (Union m) k) = do
e <- first adapt (dhallToExpression (Field (Union m) k))
let bytes = "declare -r " <> var <> "=" <> e
return bytes
go (Embed x) = do
absurd x
go (Note _ e) = do
go e
go e@(Const {}) = Left (UnsupportedStatement e)
go e@(Var {}) = Left (UnsupportedStatement e)
go e@(Lam {}) = Left (UnsupportedStatement e)
go e@(Pi {}) = Left (UnsupportedStatement e)
go e@(App {}) = Left (UnsupportedStatement e)
go e@(Let {}) = Left (UnsupportedStatement e)
go e@(Annot {}) = Left (UnsupportedStatement e)
go e@(Bool {}) = Left (UnsupportedStatement e)
go e@(BoolAnd {}) = Left (UnsupportedStatement e)
go e@(BoolOr {}) = Left (UnsupportedStatement e)
go e@(BoolEQ {}) = Left (UnsupportedStatement e)
go e@(BoolNE {}) = Left (UnsupportedStatement e)
go e@(BoolIf {}) = Left (UnsupportedStatement e)
go e@(Natural ) = Left (UnsupportedStatement e)
go e@(NaturalFold ) = Left (UnsupportedStatement e)
go e@(NaturalBuild ) = Left (UnsupportedStatement e)
go e@(NaturalIsZero ) = Left (UnsupportedStatement e)
go e@(NaturalEven ) = Left (UnsupportedStatement e)
go e@(NaturalOdd ) = Left (UnsupportedStatement e)
go e@(NaturalToInteger ) = Left (UnsupportedStatement e)
go e@(NaturalShow ) = Left (UnsupportedStatement e)
go e@(NaturalSubtract ) = Left (UnsupportedStatement e)
go e@(NaturalPlus {}) = Left (UnsupportedStatement e)
go e@(NaturalTimes {}) = Left (UnsupportedStatement e)
go e@(Integer ) = Left (UnsupportedStatement e)
go e@(IntegerClamp ) = Left (UnsupportedStatement e)
go e@(IntegerNegate ) = Left (UnsupportedStatement e)
go e@(IntegerShow ) = Left (UnsupportedStatement e)
go e@(IntegerToDouble ) = Left (UnsupportedStatement e)
go e@(Double ) = Left (UnsupportedStatement e)
go e@(DoubleLit {}) = Left (UnsupportedStatement e)
go e@(DoubleShow ) = Left (UnsupportedStatement e)
go e@(Text ) = Left (UnsupportedStatement e)
go e@(TextAppend {}) = Left (UnsupportedStatement e)
go e@(TextShow {}) = Left (UnsupportedStatement e)
go e@(List ) = Left (UnsupportedStatement e)
go e@(ListAppend {}) = Left (UnsupportedStatement e)
go e@(ListBuild ) = Left (UnsupportedStatement e)
go e@(ListFold ) = Left (UnsupportedStatement e)
go e@(ListLength ) = Left (UnsupportedStatement e)
go e@(ListHead ) = Left (UnsupportedStatement e)
go e@(ListLast ) = Left (UnsupportedStatement e)
go e@(ListIndexed ) = Left (UnsupportedStatement e)
go e@(ListReverse ) = Left (UnsupportedStatement e)
go e@(Optional ) = Left (UnsupportedStatement e)
go e@(None ) = Left (UnsupportedStatement e)
go e@(OptionalFold ) = Left (UnsupportedStatement e)
go e@(OptionalBuild ) = Left (UnsupportedStatement e)
go e@(Record {}) = Left (UnsupportedStatement e)
go e@(Union {}) = Left (UnsupportedStatement e)
go e@(Combine {}) = Left (UnsupportedStatement e)
go e@(CombineTypes {}) = Left (UnsupportedStatement e)
go e@(Prefer {}) = Left (UnsupportedStatement e)
go e@(RecordCompletion {}) = Left (UnsupportedStatement e)
go e@(Merge {}) = Left (UnsupportedStatement e)
go e@(ToMap {}) = Left (UnsupportedStatement e)
go e@(Field {}) = Left (UnsupportedStatement e)
go e@(Project {}) = Left (UnsupportedStatement e)
go e@(Assert {}) = Left (UnsupportedStatement e)
go e@(Equivalent {}) = Left (UnsupportedStatement e)
go e@(With {}) = Left (UnsupportedStatement e)
go e@(ImportAlt {}) = Left (UnsupportedStatement e)
dhallToExpression
:: Expr s Void
-> Either ExpressionError ByteString
dhallToExpression expr0 = go (Dhall.Core.normalize expr0)
where
go (BoolLit a) = do
go (TextLit (if a then "true" else "false"))
go (NaturalLit a) = do
go (IntegerLit (fromIntegral a))
go (IntegerLit a) = do
go (TextLit (Chunks [] (Data.Text.pack (show a))))
go (TextLit (Chunks [] a)) = do
let bytes = Data.Text.Encoding.encodeUtf8 a
return (Text.ShellEscape.bytes (Text.ShellEscape.bash bytes))
go e@(Field (Union m) k) =
case Dhall.Map.lookup k m of
Just Nothing -> go (TextLit (Chunks [] k))
_ -> Left (UnsupportedExpression e)
go e = Left (UnsupportedExpression e)