From f500a9e447912e68c12f011fe97b62e6a6c5c3ce Mon Sep 17 00:00:00 2001 From: Joey Hess 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