diff options
Diffstat (limited to 'standalone/no-th/haskell-patches/hamlet_remove-TH.patch')
| -rw-r--r-- | standalone/no-th/haskell-patches/hamlet_remove-TH.patch | 365 |
1 files changed, 365 insertions, 0 deletions
diff --git a/standalone/no-th/haskell-patches/hamlet_remove-TH.patch b/standalone/no-th/haskell-patches/hamlet_remove-TH.patch new file mode 100644 index 000000000..c5c352fe4 --- /dev/null +++ b/standalone/no-th/haskell-patches/hamlet_remove-TH.patch @@ -0,0 +1,365 @@ +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 + |