Pin down types better in julius

yesodweb · Sep 21, 2012 · 69d3a57 · 69d3a57
1 parent 35f3203
commit 69d3a57
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 9 deletions.
diff --git a/shakespeare-js/Text/Julius.hs b/shakespeare-js/Text/Julius.hs
@@ -69,6 +69,9 @@ newtype Javascript = Javascript { unJavascript :: Builder }
 -- | Return type of template-reading functions.
 type JavascriptUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript
 
+asJavascriptUrl :: JavascriptUrl url -> JavascriptUrl url
+asJavascriptUrl = id
+
 -- | A typeclass for types that can be interpolated in CoffeeScript templates.
 class ToJavascript a where
     toJavascript :: a -> Builder
@@ -81,9 +84,11 @@ javascriptSettings = do
   toJExp <- [|toJavascript|]
   wrapExp <- [|Javascript|]
   unWrapExp <- [|unJavascript|]
+  asJavascriptUrl' <- [|asJavascriptUrl|]
   return $ defaultShakespeareSettings { toBuilder = toJExp
   , wrap = wrapExp
   , unwrap = unWrapExp
+  , modifyFinalValue = Just asJavascriptUrl'
   }
 
 js, julius :: QuasiQuoter

diff --git a/shakespeare-js/shakespeare-js.cabal b/shakespeare-js/shakespeare-js.cabal
@@ -1,5 +1,5 @@
 name:            shakespeare-js
-version:         1.0.0.5
+version:         1.0.0.6
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -29,7 +29,7 @@ homepage:        http://www.yesodweb.com/book/shakespearean-templates
 
 library
     build-depends:   base             >= 4       && < 5
-                   , shakespeare      >= 1.0.0.3 && < 1.1
+                   , shakespeare      >= 1.0.1.4 && < 1.1
                    , template-haskell
                    , text             >= 0.7     && < 0.12
 

diff --git a/shakespeare/Text/Shakespeare.hs b/shakespeare/Text/Shakespeare.hs
@@ -25,6 +25,7 @@ module Text.Shakespeare
 
 import Text.ParserCombinators.Parsec hiding (Line)
 import Language.Haskell.TH.Quote (QuasiQuoter (..))
+import Language.Haskell.TH (appE)
 import Language.Haskell.TH.Syntax
 #if !MIN_VERSION_template_haskell(2,8,0)
 import Language.Haskell.TH.Syntax.Internals
@@ -86,6 +87,10 @@ data ShakespeareSettings = ShakespeareSettings
     , unwrap :: Exp
     , justVarInterpolation :: Bool
     , preConversion :: Maybe PreConvert
+    , modifyFinalValue :: Maybe Exp
+    -- ^ A transformation applied to the final expression. Most often, this
+    -- would be used to force the type of the expression to help make more
+    -- meaningful error messages.
     }
 
 defaultShakespeareSettings :: ShakespeareSettings
@@ -95,6 +100,7 @@ defaultShakespeareSettings = ShakespeareSettings {
   , intChar = '^'
   , justVarInterpolation = False
   , preConversion = Nothing
+  , modifyFinalValue = Nothing
 }
 
 instance Lift PreConvert where
@@ -107,14 +113,16 @@ instance Lift PreConversion where
     lift Id = [|Id|]
 
 instance Lift ShakespeareSettings where
-    lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8) =
+    lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) =
         [|ShakespeareSettings
             $(lift x1) $(lift x2) $(lift x3)
-            $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8)|]
+            $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|]
       where
         liftExp (VarE n) = [|VarE $(liftName n)|]
         liftExp (ConE n) = [|ConE $(liftName n)|]
         liftExp _ = error "liftExp only supports VarE and ConE"
+        liftMExp Nothing = [|Nothing|]
+        liftMExp (Just e) = [|Just|] `appE` liftExp e
         liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
         liftFlavour NameS = [|NameS|]
         liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
@@ -222,14 +230,17 @@ contentsToShakespeare rs a = do
     r <- newName "_render"
     c <- mapM (contentToBuilder r) a
     compiledTemplate <- case c of
-        []  -> [|mempty|]
+        -- Make sure we convert this mempty using toBuilder to pin down the
+        -- type appropriately
+        []  -> fmap (AppE $ wrap rs) [|mempty|]
         [x] -> return x
         _   -> do
               mc <- [|mconcat|]
               return $ mc `AppE` ListE c
-    if justVarInterpolation rs
-      then return compiledTemplate
-      else return $ LamE [VarP r] compiledTemplate
+    fmap (maybe id AppE $ modifyFinalValue rs) $
+        if justVarInterpolation rs
+            then return compiledTemplate
+            else return $ LamE [VarP r] compiledTemplate
       where
         contentToBuilder :: Name -> Content -> Q Exp
         contentToBuilder _ (ContentRaw s') = do

diff --git a/shakespeare/shakespeare.cabal b/shakespeare/shakespeare.cabal
@@ -1,5 +1,5 @@
 name:            shakespeare
-version:         1.0.1.3
+version:         1.0.1.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>