path: root/standalone/no-th/haskell-patches/hamlet_remove-TH.patch

From f500a9e447912e68c12f011fe97b62e6a6c5c3ce Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 17 Dec 2013 16:16:32 +0000
Subject: [PATCH] remove TH

---
 Text/Hamlet.hs | 310 ++++-----------------------------------------------------
 1 file changed, 17 insertions(+), 293 deletions(-)

diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index 4f873f4..10d8ba6 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -11,34 +11,34 @@
 module Text.Hamlet
     ( -- * Plain HTML
       Html
-    , shamlet
-    , shamletFile
-    , xshamlet
-    , xshamletFile
+    --, shamlet
+    --, shamletFile
+    --, xshamlet
+    --, xshamletFile
       -- * Hamlet
     , HtmlUrl
-    , hamlet
-    , hamletFile
-    , xhamlet
-    , xhamletFile
+    --, hamlet
+    --, hamletFile
+    --, xhamlet
+    --, xhamletFile
       -- * I18N Hamlet
     , HtmlUrlI18n
-    , ihamlet
-    , ihamletFile
+    --, ihamlet
+    --, ihamletFile
       -- * Type classes
     , ToAttributes (..)
       -- * Internal, for making more
     , HamletSettings (..)
     , NewlineStyle (..)
-    , hamletWithSettings
-    , hamletFileWithSettings
+    --, hamletWithSettings
+    --, hamletFileWithSettings
     , defaultHamletSettings
     , xhtmlHamletSettings
-    , Env (..)
-    , HamletRules (..)
-    , hamletRules
-    , ihamletRules
-    , htmlRules
+    --, Env (..)
+    --, HamletRules (..)
+    --, hamletRules
+    --, ihamletRules
+    --, htmlRules
     , CloseStyle (..)
       -- * Used by generated code
     , condH
@@ -100,47 +100,9 @@ type HtmlUrl url = Render url -> Html
 -- | A function generating an 'Html' given a message translator and a URL rendering function.
 type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
 
-docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
-docsToExp env hr scope docs = do
-    exps <- mapM (docToExp env hr scope) docs
-    case exps of
-        [] -> [|return ()|]
-        [x] -> return x
-        _ -> return $ DoE $ map NoBindS exps
-
 unIdent :: Ident -> String
 unIdent (Ident s) = s
 
-bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
-bindingPattern (BindAs i@(Ident s) b) = do
-    name <- newName s
-    (pattern, scope) <- bindingPattern b
-    return (AsP name pattern, (i, VarE name):scope)
-bindingPattern (BindVar i@(Ident s))
-    | all isDigit s = do
-        return (LitP $ IntegerL $ read s, [])
-    | otherwise = do
-        name <- newName s
-        return (VarP name, [(i, VarE name)])
-bindingPattern (BindTuple is) = do
-    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
-    return (TupP patterns, concat scopes)
-bindingPattern (BindList is) = do
-    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
-    return (ListP patterns, concat scopes)
-bindingPattern (BindConstr con is) = do
-    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
-    return (ConP (mkConName con) patterns, concat scopes)
-bindingPattern (BindRecord con fields wild) = do
-    let f (Ident field,b) =
-           do (p,s) <- bindingPattern b
-              return ((mkName field,p),s)
-    (patterns, scopes) <- fmap unzip $ mapM f fields
-    (patterns1, scopes1) <- if wild
-       then bindWildFields con $ map fst fields
-       else return ([],[])
-    return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)
-
 mkConName :: DataConstr -> Name
 mkConName = mkName . conToStr
 
@@ -148,248 +110,10 @@ conToStr :: DataConstr -> String
 conToStr (DCUnqualified (Ident x)) = x
 conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
 
--- Wildcards bind all of the unbound fields to variables whose name
--- matches the field name.
---
--- For example: data R = C { f1, f2 :: Int }
--- C {..}           is equivalent to   C {f1=f1, f2=f2}
--- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
--- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
-bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
-bindWildFields conName fields = do
-  fieldNames <- recordToFieldNames conName
-  let available n     = nameBase n `notElem` map unIdent fields
-  let remainingFields = filter available fieldNames
-  let mkPat n = do
-        e <- newName (nameBase n)
-        return ((n,VarP e), (Ident (nameBase n), VarE e))
-  fmap unzip $ mapM mkPat remainingFields
-
--- Important note! reify will fail if the record type is defined in the
--- same module as the reify is used. This means quasi-quoted Hamlet
--- literals will not be able to use wildcards to match record types
--- defined in the same module.
-recordToFieldNames :: DataConstr -> Q [Name]
-recordToFieldNames conStr = do
-  -- use 'lookupValueName' instead of just using 'mkName' so we reify the
-  -- data constructor and not the type constructor if their names match.
-  Just conName                <- lookupValueName $ conToStr conStr
-  DataConI _ _ typeName _     <- reify conName
-  TyConI (DataD _ _ _ cons _) <- reify typeName
-  [fields] <- return [fields | RecC name fields <- cons, name == conName]
-  return [fieldName | (fieldName, _, _) <- fields]
-
-docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
-docToExp env hr scope (DocForall list idents inside) = do
-    let list' = derefToExp scope list
-    (pat, extraScope) <- bindingPattern idents
-    let scope' = extraScope ++ scope
-    mh <- [|F.mapM_|]
-    inside' <- docsToExp env hr scope' inside
-    let lam = LamE [pat] inside'
-    return $ mh `AppE` lam `AppE` list'
-docToExp env hr scope (DocWith [] inside) = do
-    inside' <- docsToExp env hr scope inside
-    return $ inside'
-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do
-    let deref' = derefToExp scope deref
-    (pat, extraScope) <- bindingPattern idents
-    let scope' = extraScope ++ scope
-    inside' <- docToExp env hr scope' (DocWith dis inside)
-    let lam = LamE [pat] inside'
-    return $ lam `AppE` deref'
-docToExp env hr scope (DocMaybe val idents inside mno) = do
-    let val' = derefToExp scope val
-    (pat, extraScope) <- bindingPattern idents
-    let scope' = extraScope ++ scope
-    inside' <- docsToExp env hr scope' inside
-    let inside'' = LamE [pat] inside'
-    ninside' <- case mno of
-                    Nothing -> [|Nothing|]
-                    Just no -> do
-                        no' <- docsToExp env hr scope no
-                        j <- [|Just|]
-                        return $ j `AppE` no'
-    mh <- [|maybeH|]
-    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
-docToExp env hr scope (DocCond conds final) = do
-    conds' <- mapM go conds
-    final' <- case final of
-                Nothing -> [|Nothing|]
-                Just f -> do
-                    f' <- docsToExp env hr scope f
-                    j <- [|Just|]
-                    return $ j `AppE` f'
-    ch <- [|condH|]
-    return $ ch `AppE` ListE conds' `AppE` final'
-  where
-    go :: (Deref, [Doc]) -> Q Exp
-    go (d, docs) = do
-        let d' = derefToExp ((specialOrIdent, VarE 'or):scope) d
-        docs' <- docsToExp env hr scope docs
-        return $ TupE [d', docs']
-docToExp env hr scope (DocCase deref cases) = do
-    let exp_ = derefToExp scope deref
-    matches <- mapM toMatch cases
-    return $ CaseE exp_ matches
-  where
-    readMay s =
-        case reads s of
-            (x, ""):_ -> Just x
-            _ -> Nothing
-    toMatch :: (Binding, [Doc]) -> Q Match
-    toMatch (idents, inside) = do
-        (pat, extraScope) <- bindingPattern idents
-        let scope' = extraScope ++ scope
-        insideExp <- docsToExp env hr scope' inside
-        return $ Match pat (NormalB insideExp) []
-docToExp env hr v (DocContent c) = contentToExp env hr v c
-
-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
-contentToExp _ hr _ (ContentRaw s) = do
-    os <- [|preEscapedText . pack|]
-    let s' = LitE $ StringL s
-    return $ hrFromHtml hr `AppE` (os `AppE` s')
-contentToExp _ hr scope (ContentVar d) = do
-    str <- [|toHtml|]
-    return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
-contentToExp env hr scope (ContentUrl hasParams d) =
-    case urlRender env of
-        Nothing -> error "URL interpolation used, but no URL renderer provided"
-        Just wrender -> wrender $ \render -> do
-            let render' = return render
-            ou <- if hasParams
-                    then [|\(u, p) -> $(render') u p|]
-                    else [|\u -> $(render') u []|]
-            let d' = derefToExp scope d
-            pet <- [|toHtml|]
-            return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
-contentToExp env hr scope (ContentMsg d) =
-    case msgRender env of
-        Nothing -> error "Message interpolation used, but no message renderer provided"
-        Just wrender -> wrender $ \render ->
-            return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
-contentToExp _ hr scope (ContentAttrs d) = do
-    html <- [|attrsToHtml . toAttributes|]
-    return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)
-
-shamlet :: QuasiQuoter
-shamlet = hamletWithSettings htmlRules defaultHamletSettings
-
-xshamlet :: QuasiQuoter
-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings
-
-htmlRules :: Q HamletRules
-htmlRules = do
-    i <- [|id|]
-    return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)
-
-hamlet :: QuasiQuoter
-hamlet = hamletWithSettings hamletRules defaultHamletSettings
-
-xhamlet :: QuasiQuoter
-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
 
 asHtmlUrl :: HtmlUrl url -> HtmlUrl url
 asHtmlUrl = id
 
-hamletRules :: Q HamletRules
-hamletRules = do
-    i <- [|id|]
-    let ur f = do
-            r <- newName "_render"
-            let env = Env
-                    { urlRender = Just ($ (VarE r))
-                    , msgRender = Nothing
-                    }
-            h <- f env
-            return $ LamE [VarP r] h
-    return $ HamletRules i ur em
-  where
-    em (Env (Just urender) Nothing) e = do
-        asHtmlUrl' <- [|asHtmlUrl|]
-        urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')
-    em _ _ = error "bad Env"
-
-ihamlet :: QuasiQuoter
-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings
-
-ihamletRules :: Q HamletRules
-ihamletRules = do
-    i <- [|id|]
-    let ur f = do
-            u <- newName "_urender"
-            m <- newName "_mrender"
-            let env = Env
-                    { urlRender = Just ($ (VarE u))
-                    , msgRender = Just ($ (VarE m))
-                    }
-            h <- f env
-            return $ LamE [VarP m, VarP u] h
-    return $ HamletRules i ur em
-  where
-    em (Env (Just urender) (Just mrender)) e =
-          urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')
-    em _ _ = error "bad Env"
-
-hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
-hamletWithSettings hr set =
-    QuasiQuoter
-        { quoteExp = hamletFromString hr set
-        }
-
-data HamletRules = HamletRules
-    { hrFromHtml :: Exp
-    , hrWithEnv :: (Env -> Q Exp) -> Q Exp
-    , hrEmbed :: Env -> Exp -> Q Exp
-    }
-
-data Env = Env
-    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
-    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
-    }
-
-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
-hamletFromString qhr set s = do
-    hr <- qhr
-    case parseDoc set s of
-        Error s' -> error s'
-        Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d
-
-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
-hamletFileWithSettings qhr set fp = do
-#ifdef GHC_7_4
-    qAddDependentFile fp
-#endif
-    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
-    hamletFromString qhr set contents
-
-hamletFile :: FilePath -> Q Exp
-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
-
-xhamletFile :: FilePath -> Q Exp
-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
-
-shamletFile :: FilePath -> Q Exp
-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
-
-xshamletFile :: FilePath -> Q Exp
-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
-
-ihamletFile :: FilePath -> Q Exp
-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
-
-varName :: Scope -> String -> Exp
-varName _ "" = error "Illegal empty varName"
-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
-
-strToExp :: String -> Exp
-strToExp s@(c:_)
-    | all isDigit s = LitE $ IntegerL $ read s
-    | isUpper c = ConE $ mkName s
-    | otherwise = VarE $ mkName s
-strToExp "" = error "strToExp on empty string"
 
 -- | Checks for truth in the left value in each pair in the first argument. If
 -- a true exists, then the corresponding right action is performed. Only the
-- 
1.8.5.1