module Haxible.Codegen (renderScript) where

import Data.Aeson (encode)
import Data.Text qualified as Text
import Haxible.Normalize
import Haxible.Prelude

renderScript :: FilePath -> FilePath -> [Definition] -> Text
renderScript :: [Char] -> [Char] -> [Definition] -> Text
renderScript [Char]
inventory [Char]
playPath [Definition]
defs =
  [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
"#!/usr/bin/env cabal",
      Text
"-- Generated with haxible",
      Text
"{-# LANGUAGE QuasiQuotes, ApplicativeDo, OverloadedStrings #-}",
      Text
"{- cabal:",
      Text
"build-depends: base, haxible",
      Text
"ghc-options: -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T",
      Text
"-}",
      Text
"module Main (main) where\n",
      Text
"import Haxible.Eval\n",
      Text
"main :: IO ()",
      Text
"main = runHaxible " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote ([Char] -> Text
forall source target. From source target => source -> target
from [Char]
inventory) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote ([Char] -> Text
forall source target. From source target => source -> target
from [Char]
playPath) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (playbook [] [] [])\n"
    ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Definition -> [Text]) -> [Definition] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Definition -> [Text]
renderDefinition [Definition]
defs

renderDefinition :: Definition -> [Text]
renderDefinition :: Definition -> [Text]
renderDefinition Definition
def =
  [ Definition
def.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: Vars -> Vars -> Vars -> AnsibleHaxl [Value]",
    Definition
def.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" parentPlayAttrs taskAttrs taskVars = do",
    Text
"  let playAttrs = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
concatList [Text
playAttrs, Text
"parentPlayAttrs"]
  ]
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"  " (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Text) -> [Expr] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Text
renderExpr Definition
def.exprs)
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"  pure $ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outputList, Text
""]
  where
    playAttrs :: Text
playAttrs = [Text] -> Text
textList ((Text, Value) -> Text
mkJsonArg ((Text, Value) -> Text) -> [(Text, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Definition
def.playAttrs)
    outputList :: Text
outputList = Text -> [Text] -> Text
Text.intercalate Text
" <> " (Expr -> Text
forall {r} {source} {a}.
(HasField "binder" r source, HasField "term" r Term, From source a,
 IsString a, Semigroup a) =>
r -> a
toOutput (Expr -> Text) -> [Expr] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Definition
def.exprs)
    toOutput :: r -> a
toOutput r
expr = case r
expr.term of
      -- Module call produces a single value
      ModuleCall CallModule
_ -> a
"[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> source -> a
forall source target. From source target => source -> target
from r
expr.binder a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"]"
      -- Otherwise we got a list of values
      Term
_ -> source -> a
forall source target. From source target => source -> target
from r
expr.binder

renderExpr :: Expr -> Text
renderExpr :: Expr -> Text
renderExpr Expr
e = Binder -> Text
forall source target. From source target => source -> target
from Expr
e.binder Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
finalExpr
  where
    requirements :: Text
requirements = [Text] -> Text
textList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (\Requirement
req -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Requirement
req.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Origin -> Text
mkOrigin Requirement
req.origin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") (Requirement -> Text) -> [Requirement] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr
e.requirements
    mkOrigin :: Origin -> Text
mkOrigin = \case
      Direct Binder
n -> Binder -> Text
forall source target. From source target => source -> target
from Binder
n
      Nested Binder
n Int
i -> Binder -> Text
forall source target. From source target => source -> target
from Binder
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" !! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall source target. From source target => source -> target
from (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
      Origin
LoopVar -> Text
"__haxible_loop_item"

    finalExpr :: [Text]
finalExpr = case Expr
e.loop of
      Just (Array Array
xs) -> Text -> [Text]
mkTraverse (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
textList (Value -> Text
embedJSON (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
xs)
      Just (String Text
v) -> Text -> [Text]
mkTraverse (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
"(envLoop " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
paren (Text
requirements Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <> baseEnv") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      Just Value
_ -> [Char] -> [Text]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Text]) -> [Char] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid loop expression: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe Value -> [Char]
forall a. Show a => a -> [Char]
show Expr
e.loop
      Maybe Value
Nothing
        | Bool
extractFact -> [Text
"extractFact", Text
"<$>"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
callExpr
        | Bool
otherwise -> [Text]
callExpr
      where
        traverser :: Text
traverser = case Expr
e.term of
          ModuleCall CallModule
_ -> Text
"traverseLoop"
          DefinitionCall CallDefinition
_ -> Text
"traverseInclude"
          BlockRescueCall CallDefinition
_ -> Text
"traverseInclude"
        mkTraverse :: Text -> [Text]
mkTraverse Text
arg = [Text
traverser, Text
"(\\__haxible_loop_item -> "] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
callExpr [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
") ", Text
arg]

    (Bool
extractFact, [Text]
callExpr) = case Expr
e.term of
      ModuleCall CallModule {Text
$sel:module_:CallModule :: CallModule -> Text
module_ :: Text
module_, Value
$sel:params:CallModule :: CallModule -> Value
params :: Value
params, [(Text, Value)]
$sel:taskAttrs:CallModule :: CallModule -> [(Text, Value)]
taskAttrs :: [(Text, Value)]
taskAttrs} ->
        ( Text
module_ Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"set_fact",
          [ Text
"runTask",
            Text
"playAttrs",
            Text -> Text
quote Text
module_,
            Value -> Text
embedJSON ([(Text, Value)] -> Value
mkObj ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ [(Text
module_, Value
params)] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)]
taskAttrs),
            Text
"taskAttrs",
            Text -> Text
paren ([Text] -> Text
concatList [Text
requirements, Text
"taskVars"])
          ]
        )
      DefinitionCall CallDefinition {Text
$sel:name:CallDefinition :: CallDefinition -> Text
name :: Text
name, [(Text, Value)]
$sel:taskAttrs:CallDefinition :: CallDefinition -> [(Text, Value)]
taskAttrs :: [(Text, Value)]
taskAttrs, [(Text, Value)]
$sel:taskVars:CallDefinition :: CallDefinition -> [(Text, Value)]
taskVars :: [(Text, Value)]
taskVars} ->
        (Bool
False, [Text
name, Text
"playAttrs"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)] -> [(Text, Value)] -> [Text]
cdExpr [(Text, Value)]
taskAttrs [(Text, Value)]
taskVars)
      BlockRescueCall CallDefinition {Text
name :: Text
$sel:name:CallDefinition :: CallDefinition -> Text
name, [(Text, Value)]
taskAttrs :: [(Text, Value)]
$sel:taskAttrs:CallDefinition :: CallDefinition -> [(Text, Value)]
taskAttrs, [(Text, Value)]
taskVars :: [(Text, Value)]
$sel:taskVars:CallDefinition :: CallDefinition -> [(Text, Value)]
taskVars} ->
        ( Bool
False,
          [ Text
"tryRescue",
            Text -> Text
paren (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Main playAttrs"),
            Text -> Text
paren (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Rescue playAttrs")
          ]
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)] -> [(Text, Value)] -> [Text]
cdExpr [(Text, Value)]
taskAttrs [(Text, Value)]
taskVars
        )

    cdExpr :: [(Text, Value)] -> [(Text, Value)] -> [Text]
cdExpr [(Text, Value)]
taskAttrs [(Text, Value)]
taskVars =
      [ Text -> Text
paren ([Text] -> Text
concatList [[Text] -> Text
textList ((Text, Value) -> Text
mkJsonArg ((Text, Value) -> Text) -> [(Text, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
taskAttrs), Text
"taskAttrs"]),
        Text -> Text
paren ([Text] -> Text
concatList [Text
requirements, [Text] -> Text
textList ((Text, Value) -> Text
mkJsonArg ((Text, Value) -> Text) -> [(Text, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
taskVars), Text
"taskVars"])
      ]

-- | Add parenthesis
-- >>> paren "toto"
-- "(toto)"
paren :: Text -> Text
paren :: Text -> Text
paren = Char -> Text -> Text
Text.cons Char
'(' (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Char -> Text) -> Char -> Text -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
Text.snoc Char
')'

-- | Create json quasi quote
-- >>> embedJSON Null
-- "[json|null|]"
embedJSON :: Value -> Text
embedJSON :: Value -> Text
embedJSON Value
v = Text
"[json|" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode Value
v) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|]"

-- | Create task arguments
-- >>> mkJsonArg (("test", Null))
-- "(\"test\", [json|null|])"
mkJsonArg :: (Text, Value) -> Text
mkJsonArg :: (Text, Value) -> Text
mkJsonArg (Text
n, Value
v) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
embedJSON Value
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Format a text list
-- >>> textList ["a", "b"]
-- "[a, b]"
textList :: [Text] -> Text
textList :: [Text] -> Text
textList [Text]
xs = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

concatList :: [Text] -> Text
concatList :: [Text] -> Text
concatList = Text -> [Text] -> Text
Text.intercalate Text
" <> " ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"[]")