{-# LANGUAGE CPP #-}
-- |
-- Module        : Data.NonEmpty.TH
-- Copyright     : Gautier DI FOLCO
-- License       : ISC
--
-- Maintainer    : Gautier DI FOLCO <foss@difolco.dev>
-- Stability     : Unstable
-- Portability   : GHC
--
-- Create NonEmpty values from TemplateHaskell instead of unsafe functions.
--
-- Since @0.1.1.0@
module Data.NonEmpty.TH
  ( makeNonEmpty,

    -- * Re-export
    trustedNonEmpty,
  )
where

import Control.Monad (when)
import Data.NonEmpty
import Language.Haskell.TH

-- | Build a NonEmpty safely.
--
-- Since @0.1.1.0@
--
--  > $(makeNonEmpty [|"Hello"|])
--  > $(makeNonEmpty [|[1, 2]|])
makeNonEmpty :: Q Exp -> Q Exp
makeNonEmpty :: Q Exp -> Q Exp
makeNonEmpty Q Exp
eExp = do
  Exp
e <- Q Exp
eExp
  let ensureNonEmpty :: Exp -> Q ()
ensureNonEmpty =
        \case
          LitE (StringL String
s) ->
            Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
              String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot build a non-enpty value from an empty string"
          ListE [Exp]
es ->
            Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
              String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot build a non-enpty value from an empty list"
          SigE Exp
e' Type
_ -> Exp -> Q ()
ensureNonEmpty Exp
e'
#if MIN_VERSION_base(4,19,0)
          TypedBracketE Exp
e' -> Exp -> Q ()
ensureNonEmpty Exp
e'
          TypedSpliceE Exp
e' -> Exp -> Q ()
ensureNonEmpty Exp
e'
#endif
          Exp
e' -> String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported expression type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Exp -> String
forall a. Show a => a -> String
show Exp
e'

  Exp -> Q ()
ensureNonEmpty Exp
e
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"trustedNonEmpty") Exp
e