{-# LANGUAGE TemplateHaskell #-}

-- | @since 0.1.2.0
module Language.Dickinson.TH ( dickinson
                             , run
                             ) where

import           Control.Exception.Value    (eitherThrow)
import           Data.Data                  (Data)
import           Data.Foldable              (traverse_)
import qualified Data.Text                  as T
import           Data.Typeable              (cast)
import           Language.Dickinson.Eval
import           Language.Dickinson.File
import           Language.Dickinson.Lexer
import           Language.Dickinson.Type
import           Language.Haskell.TH        (Exp, Q)
import           Language.Haskell.TH.Syntax (Exp (AppE, VarE))
import qualified Language.Haskell.TH.Syntax as TH

run :: [Declaration AlexPosn] -> IO T.Text
run :: [Declaration AlexPosn] -> IO Text
run = (Either (DickinsonError AlexPosn) Text -> Text)
-> IO (Either (DickinsonError AlexPosn) Text) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (DickinsonError AlexPosn) Text -> Text
forall e x. Exception e => Either e x -> x
eitherThrow (IO (Either (DickinsonError AlexPosn) Text) -> IO Text)
-> ([Declaration AlexPosn]
    -> IO (Either (DickinsonError AlexPosn) Text))
-> [Declaration AlexPosn]
-> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllM Text -> IO (Either (DickinsonError AlexPosn) Text)
forall x. AllM x -> IO (Either (DickinsonError AlexPosn) x)
evalIO (AllM Text -> IO (Either (DickinsonError AlexPosn) Text))
-> ([Declaration AlexPosn] -> AllM Text)
-> [Declaration AlexPosn]
-> IO (Either (DickinsonError AlexPosn) Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration AlexPosn] -> AllM Text
forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
[Declaration a] -> m Text
evalDickinsonAsMain

dickinson :: [FilePath] -> FilePath -> Q Exp
dickinson :: [FilePath] -> FilePath -> Q Exp
dickinson [FilePath]
is FilePath
fp = do
    (FilePath -> Q ()) -> [FilePath] -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> Q ()
TH.addDependentFile [FilePath
fp] -- TODO: resolve dependencies
    [Declaration AlexPosn]
ds <- IO [Declaration AlexPosn] -> Q [Declaration AlexPosn]
forall a. IO a -> Q a
TH.runIO ([FilePath] -> FilePath -> IO [Declaration AlexPosn]
validateAmalgamate [FilePath]
is FilePath
fp)
    [Declaration AlexPosn] -> Q Exp
forall a. Data a => a -> Q Exp
liftDataWithText [Declaration AlexPosn]
ds

liftText :: T.Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift (Text -> FilePath
T.unpack Text
txt)

-- see this mess: https://stackoverflow.com/a/38182444
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText :: a -> Q Exp
liftDataWithText = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
TH.dataToExpQ ((Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText (Maybe Text -> Maybe (Q Exp))
-> (b -> Maybe Text) -> b -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast)