heist-aeson 0.3 → 0.4

raw patch · 9 files changed

+147/−127 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• heist-aeson.cabal +3/−1
• src/Text/Templating/Heist/Aeson.hs +91/−95
• tests/access.expected +7/−1
• tests/access.tpl +12/−6
• tests/loop.expected +9/−3
• tests/loop.tpl +7/−5
• tests/scope.expected +4/−3
• tests/scope.tpl +7/−6
• tests/section.tpl +7/−7

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.3+Version:             0.4  -- A short (one-line) description of the package. Synopsis:            Use JSON directly from Heist templates.@@ -59,6 +59,8 @@   Build-depends:       base >= 4 && < 5, aeson, monads-fd, text, xmlhtml,                        bytestring, vector, containers, blaze-builder, heist   +  ghc-options:         -fwarn-unused-binds -fwarn-unused-imports+   -- Modules not exported by this package.   -- Other-modules:          

@@ -13,53 +13,78 @@ import Data.Aeson                            ( Value(..), Array ) import Text.Templating.Heist                 ( TemplateState, TemplateMonad                                              , Splice, getParamNode, MIMEType-                                             , modifyTS, renderTemplate-                                             , runNodeList, bindSplices )+                                             , renderTemplate, bindSplices+                                             , runChildren ) import Blaze.ByteString.Builder              ( Builder )-import qualified Data.Map as Map             ( lookup, toList )+import qualified Data.Map as Map             ( lookup ) import qualified Data.Vector as V            ( forM, toList )  import qualified Data.ByteString as Strict   ( ByteString ) -import qualified Text.XmlHtml as X           ( Node(..), childNodes-                                             , getAttribute )-import qualified Data.Text as T              ( Text, append, pack, splitOn-                                             , intercalate )+import qualified Text.XmlHtml as X           ( Node(..), elementAttrs )+import qualified Data.Text as T              ( Text, append, pack, splitOn )  import Control.Monad.Reader                  ( ReaderT, ask, local, runReaderT )  -type JsonT m = ReaderT Value m+data JsonInput = JsonInput { jsonRoot    :: Value+                           , jsonCurrent :: Value+                           , jsonHistory :: [Value] }++mkJsonInput value+    = JsonInput { jsonRoot = value+                , jsonCurrent = value+                , jsonHistory = [] }++type JsonT m = ReaderT JsonInput m type JsonTemplate m a = TemplateMonad (JsonT m) a type JsonState m = TemplateState (JsonT m) type JsonSpliceT m = Splice (JsonT m) type JsonSplice = JsonSpliceT IO -section :: Monad m => JsonSpliceT m-section = do-    node <- getParamNode-    withRequiredAttribute "key" $ \nodeIdentifier -> do-    withAnyValue nodeIdentifier $ \json -> do-    openJson json $ do-    runNodeList $ X.childNodes node+withValue :: Monad m => Value -> JsonSpliceT m -> JsonSpliceT m+withValue value+    = local $ \input -> input{jsonCurrent = value, jsonHistory = value : jsonHistory input} -noSection :: Monad m => JsonSpliceT m-noSection = do-    node <- getParamNode-    withRequiredAttribute "key" $ \nodeIdentifier -> do-    json <- ask-    case findWithIdentifier nodeIdentifier json of-      Just{}  -> return []-      Nothing -> runNodeList $ X.childNodes node +jsonSplice :: Monad m => JsonSpliceT m+jsonSplice+    = do node <-getParamNode+         let attrs = X.elementAttrs node+             methods = [ ("value", jsonValue)+                       , ("section", jsonSection)+                       , ("no-section", jsonNoSection)+                       , ("for-each", jsonForEach) ]+         case [ action val | (key, val) <- attrs, (mKey, action) <- methods, key == mKey ] of+           [x] -> x+           []  -> error "No method invoked."+           _   -> error "More than one method invoked." -repeated :: Monad m => JsonSpliceT m-repeated = do-    node <- getParamNode-    withRequiredAttribute "key" $ \nodeIdentifier -> do-    withArrayValue nodeIdentifier $ \array -> do-    result <- V.forM array $ \entry -> openJson entry $ runNodeList $ X.childNodes node-    return $ concat (V.toList result)+jsonValue :: Monad m => T.Text -> JsonSpliceT m+jsonValue identifier+    = withTextValue identifier $ \txt ->+      return [X.TextNode txt] +jsonSection :: Monad m => T.Text -> JsonSpliceT m+jsonSection identifier+    = withAnyValue identifier $ \json ->+      withValue json $+      runChildren++jsonNoSection :: Monad m => T.Text -> JsonSpliceT m+jsonNoSection identifier+    = do input <- ask+         case findWithIdentifier identifier input of+           Just{}  -> return []+           Nothing -> runChildren++jsonForEach :: Monad m => T.Text -> JsonSpliceT m+jsonForEach identifier+    = withArrayValue identifier $ \array ->+      do result <- V.forM array $ \entry -> withValue entry runChildren+         return $ concat (V.toList result)+++ withArrayValue ::Monad m => T.Text -> (Array -> JsonSpliceT m) -> JsonSpliceT m withArrayValue nodeIdentifier action     = withAnyValue nodeIdentifier $ \json ->@@ -67,85 +92,56 @@         Array array -> action array         _           -> return [X.TextNode $ "Json value expected to be an array: " `T.append` nodeIdentifier] +withTextValue ::Monad m => T.Text -> (T.Text -> JsonSpliceT m) -> JsonSpliceT m+withTextValue nodeIdentifier action+    = withAnyValue nodeIdentifier $ \json ->+      case json of+        Object object -> action "object"+        Array{}       -> action "array"+        String string -> action string+        Number num    -> action (T.pack $ show num)+        Bool bool     -> action (T.pack $ show bool)+        Null          -> action "null"+ withAnyValue :: Monad m => T.Text -> (Value -> JsonSpliceT m) -> JsonSpliceT m withAnyValue nodeIdentifier action-    = do json <- ask-         case findWithIdentifier nodeIdentifier json of+    = do input <- ask+         case findWithIdentifier nodeIdentifier input of            Nothing    -> return []            Just value -> action value- {-   Return corresponding json values for identifiers such as:-    "@"+    "."     "key"-    "object.key"+    "object/key"+    "../object/./key" -}-findWithIdentifier :: T.Text -> Value -> Maybe Value-findWithIdentifier "@" currentJsonScope = Just currentJsonScope-findWithIdentifier identifier currentJsonScope-    = worker (T.splitOn "." identifier) currentJsonScope-    where worker [] json = Just json-          worker (key:keys) json-              = case json of+findWithIdentifier :: T.Text -> JsonInput -> Maybe Value+findWithIdentifier identifier input+    = case T.splitOn "/" identifier of+        "":rest -> worker (jsonRoot input) [] rest+        rest    -> worker (jsonCurrent input) (jsonHistory input) rest+    where worker current history []+              = Just current+          worker current history (".":xs)+              = worker current history xs+          worker current [] ("..":xs)+              = error "Asked to access parent node of the top-level."+          worker current (now:later) ("..":xs)+              = worker now later xs+          worker current history (key:xs)+              = case current of                   Object object | Just value <- Map.lookup key object-                    -> worker keys value+                    -> worker value (current:history) xs                   _ -> Nothing--withRequiredAttribute :: Monad m => T.Text -> (T.Text -> JsonSpliceT m) -> JsonSpliceT m-withRequiredAttribute attribute action-    = do node <- getParamNode-         case X.getAttribute attribute node of-           Nothing  -> return [X.TextNode ("Missing attribute: " `T.append` attribute)]-           Just val -> action val---- Set a new json value as the current scope.--- I'm not quite happy with the way it works. 2011-03-30-openJson :: Monad m => Value -> JsonTemplate m a -> JsonTemplate m a-openJson json splice-    = ask >>= \originalJsonScope ->-      local (const json) $-      do modifyTS $ closeJsonTS originalJsonScope-         modifyTS $ openJsonTS json-         tpl <- splice-         modifyTS $ closeJsonTS json-         return tpl--openJsonTS :: Monad m => Value -> TemplateState m -> TemplateState m-openJsonTS json-    = bindSplices [ ("val:" `T.append` key, return [X.TextNode val])-                    | (key, val) <- jsonToBinds json ]---- Undo the binds created with 'openJsonTS'.-closeJsonTS :: Monad m => Value -> TemplateState m -> TemplateState m-closeJsonTS json-    = bindSplices [ ("val:" `T.append` key, generateOriginal)-                    | (key, _val) <- jsonToBinds json ]-    where generateOriginal = do node <- getParamNode-                                return [node]--jsonToBinds :: Value -> [(T.Text, T.Text)]-jsonToBinds = worker []-    where worker hierarchy json-              = case json of-                  Object object -> concat [ worker (key:hierarchy) val | (key, val) <- Map.toList object ]-                  Array{}       -> []-                  String string -> [(mkIndex hierarchy, string)]-                  Number num    -> [(mkIndex hierarchy, T.pack $ show num)]-                  Bool bool     -> [(mkIndex hierarchy, T.pack $ show bool)]-                  Null          -> [(mkIndex hierarchy, "Null")]-          mkIndex [] = "self"-          mkIndex hierarchy = T.intercalate "." (reverse hierarchy)-+                               addHeistAeson :: Monad m => JsonState m -> JsonState m-addHeistAeson-    = bindSplices [ ("json:section", section)-                  , ("json:no-section", noSection)-                  , ("json:repeated", repeated) ]+addHeistAeson = bindSplices [ ("json", jsonSplice)]  renderJsonTemplate :: Monad m => JsonState m -> Strict.ByteString -> Value -> m (Maybe (Builder, MIMEType)) renderJsonTemplate state tplName json-    = runReaderT (renderTemplate (openJsonTS json state) tplName) json+    = runReaderT (renderTemplate state tplName) (mkJsonInput json)  runJsonT :: Monad m => JsonT m a -> Value -> m a runJsonT action json-    = runReaderT action json+    = runReaderT action (mkJsonInput json)

@@ -1,6 +1,12 @@ value Third level-<attr attribute='Third level'></attr> ++<attribute attribute='   Third level+'></attribute>+++  Third level+  value 

@@ -1,6 +1,12 @@-<val:key/>-<val:level1.level2.level3/>-<attr attribute="$(val:level1.level2.level3)"/>-<json:section key="level1.level2">-  <val:level3/>-</json:section>+<json value="key"/>+<json value="level1/level2/level3"/>++<bind tag="attr">+  <json value="level1/level2/level3"/>+</bind>+<attribute attribute="$(attr)"/>++<json section="level1/level2">+  <json value="level3"/>+  <json value="/key"/>+</json>

@@ -2,11 +2,17 @@    <ul>     -      <li>One</li>+      <li>+        One+      </li>     -      <li>Two</li>+      <li>+        Two+      </li>     -      <li>Three</li>+      <li>+        Three+      </li>        </ul> 

@@ -1,9 +1,11 @@ <html>-<json:section key="loop">+<json section="loop">   <ul>-    <json:repeated key="@">-      <li><val:self/></li>-    </json:repeated>+    <json for-each=".">+      <li>+        <json value="."/>+      </li>+    </json>   </ul>-</json:section>+</json> </html>

@@ -1,6 +1,7 @@ value -  value-  <val:outer.inner></val:outer.inner>+  inner: value+  outer/inner: +  /outer/inner: value -<val:inner></val:inner>+

@@ -1,6 +1,7 @@-<val:outer.inner/>-<json:section key="outer">-  <val:inner/>-  <val:outer.inner/>-</json:section>-<val:inner/>+<json value="outer/inner"/>+<json section="outer">+  inner: <json value="inner"/>+  outer/inner: <json value="outer/inner"/>+  /outer/inner: <json value="/outer/inner"/>+</json>+<json value="inner"/>

@@ -1,11 +1,11 @@ <div>-  <json:no-section key="songs">+  <json no-section="songs">     No songs available.-  </json:no-section>-  <json:section key="user">-    Username: <val:name/>-  </json:section>-  <json:no-section key="user">+  </json>+  <json section="user">+    Username: <json value="name"/>+  </json>+  <json no-section="user">     No user info available.-  </json:no-section>+  </json> </div>