-- |
-- Module      : Slab.Generate.Haskell
-- Description : Translate from the Slab syntax to Haskell
--
-- @Slab.Generate.Haskell@ is an attempt to translate Slab to Haskell. This
-- could make it possible to use Slab within Haskell projects without needing
-- to interpret Slab templates at runtime. If this proves useful, other
-- languages could also be supported.
module Slab.Generate.Haskell
  ( renderHs
  ) where

import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Prettyprinter
import Prettyprinter.Render.Text
import Slab.Error qualified as Error
import Slab.PreProcess qualified as PreProcess
import Slab.Syntax qualified as Syntax

--------------------------------------------------------------------------------
renderHs :: FilePath -> IO ()
renderHs :: FilePath -> IO ()
renderHs FilePath
path = do
  [Block]
blocks <- FilePath -> IO (Either Error [Block])
PreProcess.preprocessFile FilePath
path IO (Either Error [Block])
-> (Either Error [Block] -> IO [Block]) -> IO [Block]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error [Block] -> IO [Block]
forall a. Either Error a -> IO a
Error.unwrap
  Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Block] -> Text
renderModule [Block]
blocks

renderModule :: [Syntax.Block] -> Text
renderModule :: [Block] -> Text
renderModule = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text)
-> ([Block] -> SimpleDocStream Any) -> [Block] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> ([Block] -> Doc Any) -> [Block] -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> Doc Any
forall ann. [Block] -> Doc ann
prettyModule

renderBlocks :: [Syntax.Block] -> Text
renderBlocks :: [Block] -> Text
renderBlocks = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text)
-> ([Block] -> SimpleDocStream Any) -> [Block] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> ([Block] -> Doc Any) -> [Block] -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> Doc Any
forall ann. [Block] -> Doc ann
prettyBlocks

--------------------------------------------------------------------------------
prettyModule :: [Syntax.Block] -> Doc ann
prettyModule :: forall ann. [Block] -> Doc ann
prettyModule [Block]
blocks =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ann
forall ann. Doc ann
moduleHeader
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Block] -> Doc ann
forall ann. [Block] -> Doc ann
prettyBlocks [Block]
blocks
    ]

moduleHeader :: Doc ann
moduleHeader :: forall ann. Doc ann
moduleHeader =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ann
"module Main where"
    , Doc ann
forall a. Monoid a => a
mempty
    , Doc ann
"import Data.Text (Text)"
    , Doc ann
"import Text.Blaze.Html5 (Html, (!))"
    , Doc ann
"import Text.Blaze.Html5 qualified as H"
    , Doc ann
"import Text.Blaze.Html5.Attributes qualified as A"
    , Doc ann
"import Text.Blaze.Html.Renderer.Pretty (renderHtml)"
    , Doc ann
forall a. Monoid a => a
mempty
    , Doc ann
"main :: IO ()"
    , Doc ann
"main = putStrLn . renderHtml $"
    ]

--------------------------------------------------------------------------------
prettyBlocks :: [Syntax.Block] -> Doc ann
prettyBlocks :: forall ann. [Block] -> Doc ann
prettyBlocks = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([Block] -> [Doc ann]) -> [Block] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Doc ann) -> [Block] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Doc ann
forall ann. Block -> Doc ann
prettyBlock

prettyBlock :: Syntax.Block -> Doc ann
prettyBlock :: forall ann. Block -> Doc ann
prettyBlock (Syntax.BlockElem Elem
name TrailingSym
_ [Attr]
attrs [Block]
children) = (Elem, [Attr], [Block]) -> Doc ann
forall ann. (Elem, [Attr], [Block]) -> Doc ann
prettyBlockElem (Elem
name, [Attr]
attrs', [Block]
children)
 where
  attrs' :: [Attr]
attrs' = [Attr] -> [Attr]
Syntax.groupAttrs [Attr]
attrs

-- | Render an element, aligning the @!@ character:
--
-- @
--   elem ! a
--        ! b $ do
--     child0
--     child1
-- @
prettyBlockElem :: (Syntax.Elem, [Syntax.Attr], [Syntax.Block]) -> Doc ann
prettyBlockElem :: forall ann. (Elem, [Attr], [Block]) -> Doc ann
prettyBlockElem (Elem
t1, [Attr]
ts_, [Block]
as) =
  case [Attr]
ts_ of
    [] ->
      let header :: Doc ann
header = Doc ann
forall ann. Doc ann
prettyT1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
dollar
       in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
header, Doc ann
forall ann. Doc ann
footer]
    [Attr
t] ->
      let header :: Doc ann
header = Doc ann
forall ann. Doc ann
prettyT1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"!" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Attr -> Doc ann
forall ann. Attr -> Doc ann
prettyAttr Attr
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
dollar
       in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
header, Doc ann
forall ann. Doc ann
footer]
    Attr
t : [Attr]
ts ->
      let header :: Doc ann
header = Doc ann
forall ann. Doc ann
prettyT1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"!" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Attr -> Doc ann
forall ann. Attr -> Doc ann
prettyAttr Attr
t
          body :: Doc ann
body = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
lengthT1 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((Attr -> Doc ann) -> [Attr] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
"!" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (Attr -> Doc ann) -> Attr -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Doc ann
forall ann. Attr -> Doc ann
prettyAttr) [Attr]
ts) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
dollar
       in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
forall ann. Doc ann
header, Doc ann
body, Doc ann
forall ann. Doc ann
footer]
 where
  prettyT1 :: Doc ann
prettyT1 = Elem -> Doc ann
forall ann. Elem -> Doc ann
prettyElem Elem
t1
  lengthT1 :: Int
lengthT1 = Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int)
-> (SimpleDocStream Any -> Int) -> SimpleDocStream Any -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int)
-> (SimpleDocStream Any -> Text) -> SimpleDocStream Any -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Int) -> SimpleDocStream Any -> Int
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc Any
forall ann. Doc ann
prettyT1
  dollar :: Doc ann
dollar = if [Block] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block]
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Doc ann
"$ do" else Doc ann
"$"
  footer :: Doc ann
footer = case [Block]
as of
    [] -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ann
"mempty"
    [Block]
_ -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Block -> Doc ann) -> [Block] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> (Block -> Doc ann) -> Block -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Doc ann
forall ann. Block -> Doc ann
prettyBlock) [Block]
as

prettyElem :: Syntax.Elem -> Doc ann
prettyElem :: forall ann. Elem -> Doc ann
prettyElem = \case
  Elem
Syntax.Html -> Doc ann
"H.html"
  Elem
Syntax.Body -> Doc ann
"H.body"
  Elem
Syntax.Div -> Doc ann
"H.div"

prettyAttr :: Syntax.Attr -> Doc ann
prettyAttr :: forall ann. Attr -> Doc ann
prettyAttr (Syntax.Id Text
t) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text
"A.id (H.toValue (\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" :: Text))"
prettyAttr (Syntax.Class Text
t) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text
"A.class_ (H.toValue (\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" :: Text))"
prettyAttr (Syntax.Attr Text
a Maybe Expr
b) =
  Doc ann
"H.customAttribute" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> (Expr -> Doc ann) -> Maybe Expr -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
a) Expr -> Doc ann
forall ann. Expr -> Doc ann
prettyExpr Maybe Expr
b

prettyExpr :: Syntax.Expr -> Doc ann
prettyExpr :: forall ann. Expr -> Doc ann
prettyExpr Expr
_ = Doc ann
"TODO"