Types.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
module Text.Mustache.Internal.Types
  ( Array
  , ASTree
  , Context (..)
  , DataIdentifier (..)
  , Key
  , Node (..)
  , Object
  , Pair
  , STree
  , SubM (..)
  , SubstitutionError (..)
  , Template (..)
  , TemplateCache
  , ToMustache (..)
  , Value (..)
  , innerSearch
  , integralToMustache
  , runSubM
  , search
  , shiftContext
  , tellError
  , tellSuccess
  ) where


import           Control.Arrow ( Arrow (..) )
import           Control.Monad.RWS
                   ( MonadReader (..), MonadWriter (..), RWS, RWST (..), asks
                   , evalRWS
                   )
import qualified Data.Aeson as Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM
#endif
import           Data.Foldable ( toList )
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import           Data.Int ( Int8, Int16, Int32, Int64 )
import qualified Data.Map as Map
import           Data.Scientific ( Scientific, fromFloatDigits )
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import           Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Vector as V
import           Data.Word ( Word8, Word16, Word32, Word64 )
import           Language.Haskell.TH.Lift (deriveLift)
#if !MIN_VERSION_unordered_containers(0,2,17) || !MIN_VERSION_text(1,2,4)
import           Language.Haskell.TH.Syntax ( Lift (..) )
#endif
import           Numeric.Natural ( Natural )


-- | Type of errors we may encounter during substitution.
data SubstitutionError
  = VariableNotFound [Key]
    -- ^ The template contained a variable for which there was no data
    -- counterpart in the current context
  | InvalidImplicitSectionContextType String
    -- ^ When substituting an implicit section the current context had an
    -- unsubstitutable type
  | InvertedImplicitSection
    -- ^ Inverted implicit sections should never occur
  | SectionTargetNotFound [Key]
    -- ^ The template contained a section for which there was no data
    -- counterpart in the current context
  | PartialNotFound FilePath
    -- ^ The template contained a partial for which there was no data
    -- counterpart in the current context
  | DirectlyRenderedValue Value
    -- ^ A complex value such as an Object or Array was directly rendered into
    -- the template (warning)
  deriving (Show)


tellError :: SubstitutionError -> SubM ()
tellError e = SubM $ tell ([e], [])


tellSuccess :: Text -> SubM ()
tellSuccess s = SubM $ tell ([], [s])


newtype SubM a = SubM
  { runSubM' :: RWS (Context Value, TemplateCache) ([SubstitutionError], [Text]) () a
  }
  deriving (Monad, Functor, Applicative, MonadReader (Context Value, TemplateCache))


runSubM :: SubM a -> Context Value -> TemplateCache -> ([SubstitutionError], [Text])
runSubM comp ctx cache = snd $ evalRWS (runSubM' comp) (ctx, cache) ()


shiftContext :: Context Value -> SubM a -> SubM a
shiftContext = local . first . const


-- | Search for a key in the current context.
--
-- The search is conducted inside out mening the current focus
-- is searched first. If the key is not found the outer scopes are recursively
-- searched until the key is found, then 'innerSearch' is called on the result.
search :: [Key] -> SubM (Maybe Value)
search [] = pure Nothing
search (key:nextKeys) = (>>= innerSearch nextKeys) <$> go
  where
    go = asks fst >>= \case
      Context parents focus -> do
        let searchParents = case parents of
              (newFocus: newParents) -> shiftContext (Context newParents newFocus) go
              _ -> pure Nothing
        case focus of
          Object o ->
            case HM.lookup key o of
              Just res -> pure $ Just res
              _ -> searchParents
          _ -> searchParents


-- | Searches nested scopes navigating inward. Fails if it encunters something
-- other than an object before the key is expended.
innerSearch :: [Key] -> Value -> Maybe Value
innerSearch []     v          = Just v
innerSearch (y:ys) (Object o) = HM.lookup y o >>= innerSearch ys
innerSearch _      _          = Nothing


-- | Syntax tree for a mustache template
type STree = ASTree Text


type ASTree α = [Node α]


-- | Basic values composing the STree
data Node α
  = TextBlock α
  | Section DataIdentifier (ASTree α)
  | InvertedSection DataIdentifier (ASTree α)
  | Variable Bool DataIdentifier
  | Partial (Maybe α) FilePath
  deriving (Show, Eq)


-- | Kinds of identifiers for Variables and sections
data DataIdentifier
  = NamedData [Key]
  | Implicit
  deriving (Show, Eq)


-- | A list-like structure used in 'Value'
type Array  = V.Vector Value
-- | A map-like structure used in 'Value'
type Object = HM.HashMap Text Value
-- | Source type for constructing 'Object's
type Pair   = (Text, Value)


-- | Representation of stateful context for the substitution process
data Context α = Context { ctxtParents :: [α], ctxtFocus :: α }
  deriving (Eq, Show, Ord)


-- | Internal value representation
data Value
  = Object !Object
  | Array  !Array
  | Number !Scientific
  | String !Text
  | Lambda (STree -> SubM STree)
  | Bool   !Bool
  | Null


instance Show Value where
  show (Lambda _) = "Lambda function"
  show (Object o) = show o
  show (Array  a) = show a
  show (String s) = show s
  show (Number n) = show n
  show (Bool   b) = show b
  show Null       = "null"


listToMustache' :: ToMustache ω => [ω] -> Value
listToMustache' = Array . V.fromList . fmap toMustache


integralToMustache :: Integral ω => ω -> Value
integralToMustache = toMustache . toInteger


-- | Conversion class
class ToMustache ω where
  toMustache :: ω -> Value
  listToMustache :: [ω] -> Value
  listToMustache = listToMustache'

instance ToMustache Float where
  toMustache = Number . fromFloatDigits

instance ToMustache Double where
  toMustache = Number . fromFloatDigits

instance ToMustache Integer where
  toMustache = Number . fromInteger

instance ToMustache Natural where
  toMustache = integralToMustache

instance ToMustache Int where
  toMustache = integralToMustache

instance ToMustache Word where
  toMustache = integralToMustache

instance ToMustache Int8 where
  toMustache = integralToMustache

instance ToMustache Int16 where
  toMustache = integralToMustache

instance ToMustache Int32 where
  toMustache = integralToMustache

instance ToMustache Int64 where
  toMustache = integralToMustache

instance ToMustache Word8 where
  toMustache = integralToMustache

instance ToMustache Word16 where
  toMustache = integralToMustache

instance ToMustache Word32 where
  toMustache = integralToMustache

instance ToMustache Word64 where
  toMustache = integralToMustache

instance ToMustache Char where
  toMustache = toMustache . (:[])
  listToMustache = String . T.pack

instance ToMustache Value where
  toMustache = id

instance ToMustache Bool where
  toMustache = Bool

instance ToMustache () where
  toMustache = const Null

instance ToMustache ω => ToMustache (Maybe ω) where
  toMustache (Just w) = toMustache w
  toMustache Nothing  = Null

instance ToMustache Text where
  toMustache = String

instance ToMustache LT.Text where
  toMustache = String . LT.toStrict

instance ToMustache Scientific where
  toMustache = Number

instance ToMustache α => ToMustache [α] where
  toMustache = listToMustache

instance ToMustache ω => ToMustache (Seq.Seq ω) where
  toMustache = listToMustache' . toList

instance ToMustache ω => ToMustache (V.Vector ω) where
  toMustache = Array . fmap toMustache

instance (ToMustache ω) => ToMustache (Map.Map Text ω) where
  toMustache = mapInstanceHelper id

instance (ToMustache ω) => ToMustache (Map.Map LT.Text ω) where
  toMustache = mapInstanceHelper LT.toStrict

instance (ToMustache ω) => ToMustache (Map.Map String ω) where
  toMustache = mapInstanceHelper T.pack


mapInstanceHelper :: ToMustache v => (a -> Text) -> Map.Map a v -> Value
mapInstanceHelper conv =
  toMustache
  . Map.foldrWithKey
    (\k -> HM.insert (conv k) . toMustache)
    HM.empty


instance ToMustache ω => ToMustache (HM.HashMap Text ω) where
  toMustache = Object . fmap toMustache

instance ToMustache ω => ToMustache (HM.HashMap LT.Text ω) where
  toMustache = hashMapInstanceHelper LT.toStrict

instance ToMustache ω => ToMustache (HM.HashMap String ω) where
  toMustache = hashMapInstanceHelper T.pack


hashMapInstanceHelper :: ToMustache v => (a -> Text) -> HM.HashMap a v -> Value
hashMapInstanceHelper conv =
  toMustache
  . HM.foldrWithKey
    (\k -> HM.insert (conv k) . toMustache)
    HM.empty


instance ToMustache (STree -> SubM STree) where
    toMustache = Lambda

instance ToMustache Aeson.Value where
  toMustache (Aeson.Object o) = Object $ fmap toMustache
#if MIN_VERSION_aeson(2,0,0)
    (KM.toHashMapText o)
#else
    o
#endif
  toMustache (Aeson.Array  a) = Array $ fmap toMustache a
  toMustache (Aeson.Number n) = Number n
  toMustache (Aeson.String s) = String s
  toMustache (Aeson.Bool   b) = Bool b
  toMustache Aeson.Null       = Null

instance ToMustache ω => ToMustache (HS.HashSet ω) where
  toMustache = listToMustache' . HS.toList

instance ToMustache ω => ToMustache (Set.Set ω) where
  toMustache = listToMustache' . Set.toList

instance (ToMustache α, ToMustache β) => ToMustache (α, β) where
  toMustache (a, b) = toMustache [toMustache a, toMustache b]

instance (ToMustache α, ToMustache β, ToMustache γ)
         => ToMustache (α, β, γ) where
  toMustache (a, b, c) = toMustache [toMustache a, toMustache b, toMustache c]

instance (ToMustache α, ToMustache β, ToMustache γ, ToMustache δ)
         => ToMustache (α, β, γ, δ) where
  toMustache (a, b, c, d) = toMustache
    [ toMustache a
    , toMustache b
    , toMustache c
    , toMustache d
    ]

instance ( ToMustache α
         , ToMustache β
         , ToMustache γ
         , ToMustache δ
         , ToMustache ε
         ) => ToMustache (α, β, γ, δ, ε) where
  toMustache (a, b, c, d, e) = toMustache
    [ toMustache a
    , toMustache b
    , toMustache c
    , toMustache d
    , toMustache e
    ]

instance ( ToMustache α
         , ToMustache β
         , ToMustache γ
         , ToMustache δ
         , ToMustache ε
         , ToMustache ζ
         ) => ToMustache (α, β, γ, δ, ε, ζ) where
  toMustache (a, b, c, d, e, f) = toMustache
    [ toMustache a
    , toMustache b
    , toMustache c
    , toMustache d
    , toMustache e
    , toMustache f
    ]

instance ( ToMustache α
         , ToMustache β
         , ToMustache γ
         , ToMustache δ
         , ToMustache ε
         , ToMustache ζ
         , ToMustache η
         ) => ToMustache (α, β, γ, δ, ε, ζ, η) where
  toMustache (a, b, c, d, e, f, g) = toMustache
    [ toMustache a
    , toMustache b
    , toMustache c
    , toMustache d
    , toMustache e
    , toMustache f
    , toMustache g
    ]

instance ( ToMustache α
         , ToMustache β
         , ToMustache γ
         , ToMustache δ
         , ToMustache ε
         , ToMustache ζ
         , ToMustache η
         , ToMustache θ
         ) => ToMustache (α, β, γ, δ, ε, ζ, η, θ) where
  toMustache (a, b, c, d, e, f, g, h) = toMustache
    [ toMustache a
    , toMustache b
    , toMustache c
    , toMustache d
    , toMustache e
    , toMustache f
    , toMustache g
    , toMustache h
    ]


-- | A collection of templates with quick access via their hashed names
type TemplateCache = HM.HashMap String Template


-- | Type of key used for retrieving data from 'Value's
type Key = Text


{-|
  A compiled Template with metadata.
-}
data Template = Template
  { name     :: String
  , ast      :: STree
  , partials :: TemplateCache
  } deriving (Show)


deriveLift ''DataIdentifier
deriveLift ''Node
deriveLift ''Template


-- Data.HashMap 0.2.17.0 introduces its own Lift instance
#if !MIN_VERSION_unordered_containers(0,2,17)
instance Lift TemplateCache where
#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped m = [|| HM.fromList $$(liftTyped $ HM.toList m) ||]
#else
  lift m = [| HM.fromList $(lift $ HM.toList m) |]
#endif
#endif


--Data.Text 1.2.4.0 introduces its own Lift Text instance
#if !MIN_VERSION_text(1,2,4)
instance Lift Text where
  lift = lift . T.unpack
#endif