From cc074d0ce3f7df2544bc2baddca4e7730ecdf0a0 Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 11 Nov 2011 14:30:27 +0900 Subject: [PATCH] Better name-rewriting engine Ditz-issue: 123424c3b4a0d83452e26403cd79676f319d4295 --- ImplantFile.hs | 2 +- Lucu.cabal | 60 ++-- Network/HTTP/Lucu.hs | 2 + Network/HTTP/Lucu/Authentication.hs | 2 +- Network/HTTP/Lucu/ETag.hs | 2 +- Network/HTTP/Lucu/HandleLike.hs | 1 + Network/HTTP/Lucu/Headers.hs | 1 + Network/HTTP/Lucu/HttpVersion.hs | 2 +- .../Lucu/{Implant/Input.hs => Implant.hs} | 4 +- Network/HTTP/Lucu/Implant/PrettyPrint.hs | 140 +++++--- Network/HTTP/Lucu/Implant/Rewrite.hs | 306 +++++++++++------- Network/HTTP/Lucu/MultipartForm.hs | 2 - Network/HTTP/Lucu/Parser.hs | 3 +- Network/HTTP/Lucu/SocketLike.hs | 1 + Network/HTTP/Lucu/Utils.hs | 28 +- ...424c3b4a0d83452e26403cd79676f319d4295.yaml | 8 +- cabal-package.mk | 3 +- examples/Makefile | 2 +- 18 files changed, 343 insertions(+), 226 deletions(-) rename Network/HTTP/Lucu/{Implant/Input.hs => Implant.hs} (95%) diff --git a/ImplantFile.hs b/ImplantFile.hs index b6545a8..bd01923 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -10,7 +10,7 @@ import Data.Maybe import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.Implant.Input +import Network.HTTP.Lucu.Implant import Network.HTTP.Lucu.Implant.PrettyPrint import Network.HTTP.Lucu.MIMEType import Prelude.Unicode diff --git a/Lucu.cabal b/Lucu.cabal index 7ceb6c2..604fc27 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -1,26 +1,30 @@ -Name: Lucu -Synopsis: Embedded HTTP Server +Name: Lucu +Synopsis: Embedded HTTP Server Description: - - Lucu is an embedded HTTP server library. - - It's not a replacement for Apache nor lighttpd. It is intended - to be used to build an efficient web-based RESTful application - which runs behind a reverse-proxy so it doesn't have some - functionalities like logging, client filtering and such. - -Version: 1.0 -License: PublicDomain -License-File: COPYING -Author: PHO -Maintainer: PHO -Stability: experimental -Homepage: http://cielonegro.org/Lucu.html -Bug-Reports: http://static.cielonegro.org/ditz/Lucu/ -Category: Network -Tested-With: GHC == 7.0.3 + . + Lucu is an embedded HTTP server library. + . + This isn't a replacement for Apache nor lighttpd. It is intended + to be used to build an efficient web-based RESTful application + which runs behind a reverse-proxy so it doesn't have some + functionalities like logging, client filtering and such. + . + The library has indeed so many exposed modules, but in general + you don't need to import any modules other than + "Network.HTTP.Lucu". + . +Version: 1.0 +License: PublicDomain +License-File: COPYING +Author: PHO +Maintainer: PHO +Stability: experimental +Homepage: http://cielonegro.org/Lucu.html +Bug-Reports: http://static.cielonegro.org/ditz/Lucu/ +Category: Network +Tested-With: GHC == 7.0.3 Cabal-Version: >= 1.6 -Build-Type: Simple +Build-Type: Simple Extra-Source-Files: NEWS examples/HelloWorld.hs @@ -72,8 +76,13 @@ Library Network.HTTP.Lucu.Authentication Network.HTTP.Lucu.Config Network.HTTP.Lucu.ETag + Network.HTTP.Lucu.HandleLike + Network.HTTP.Lucu.Headers Network.HTTP.Lucu.HttpVersion Network.HTTP.Lucu.Httpd + Network.HTTP.Lucu.Implant + Network.HTTP.Lucu.Implant.PrettyPrint + Network.HTTP.Lucu.Implant.Rewrite Network.HTTP.Lucu.MIMEParams Network.HTTP.Lucu.MIMEType Network.HTTP.Lucu.MIMEType.DefaultExtensionMap @@ -86,6 +95,7 @@ Library Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Resource.Tree Network.HTTP.Lucu.Response + Network.HTTP.Lucu.SocketLike Network.HTTP.Lucu.StaticFile Network.HTTP.Lucu.StatusCode Network.HTTP.Lucu.Utils @@ -95,15 +105,12 @@ Library Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage - Network.HTTP.Lucu.HandleLike - Network.HTTP.Lucu.Headers Network.HTTP.Lucu.Interaction Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader Network.HTTP.Lucu.Resource.Internal Network.HTTP.Lucu.ResponseWriter - Network.HTTP.Lucu.SocketLike Network.HTTP.Lucu.StatusCode.Internal ghc-options: @@ -117,11 +124,6 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs - Other-Modules: - Network.HTTP.Lucu.Implant.Input - Network.HTTP.Lucu.Implant.PrettyPrint - Network.HTTP.Lucu.Implant.Rewrite - Build-Depends: SHA == 1.5.*, syb == 0.3.*, diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 79ae061..b2c7895 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -57,6 +57,7 @@ module Network.HTTP.Lucu -- *** MIME Type , MIMEType(..) + , MIMEParams(..) , parseMIMEType , mimeType @@ -74,6 +75,7 @@ import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd +import Network.HTTP.Lucu.MIMEParams import Network.HTTP.Lucu.MIMEType hiding (mimeType) import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Resource diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs index 753af6e..495c931 100644 --- a/Network/HTTP/Lucu/Authentication.hs +++ b/Network/HTTP/Lucu/Authentication.hs @@ -2,7 +2,7 @@ OverloadedStrings , UnicodeSyntax #-} --- |HTTP Authentication +-- |An internal module for HTTP authentication. module Network.HTTP.Lucu.Authentication ( AuthChallenge(..) , AuthCredential(..) diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index b8191a3..1335738 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -5,7 +5,7 @@ , TemplateHaskell , UnicodeSyntax #-} --- |Entity tags +-- |An internal module for entity tags. module Network.HTTP.Lucu.ETag ( ETag(..) , parseETag diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs index c4a4c62..a45ce6c 100644 --- a/Network/HTTP/Lucu/HandleLike.hs +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -2,6 +2,7 @@ DoAndIfThenElse , UnicodeSyntax #-} +-- |Type class for things behaves like a 'I.Handle'. module Network.HTTP.Lucu.HandleLike ( HandleLike(..) , hPutBuilder diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index a47f2ac..80b9b13 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -3,6 +3,7 @@ , OverloadedStrings , UnicodeSyntax #-} +-- |An internal module for HTTP headers. module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 36b6c49..4466f1e 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -2,7 +2,7 @@ OverloadedStrings , UnicodeSyntax #-} --- |HTTP version number +-- |An internal module for HTTP version numbers. module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) , printHttpVersion diff --git a/Network/HTTP/Lucu/Implant/Input.hs b/Network/HTTP/Lucu/Implant.hs similarity index 95% rename from Network/HTTP/Lucu/Implant/Input.hs rename to Network/HTTP/Lucu/Implant.hs index 4b462e3..f80ac99 100644 --- a/Network/HTTP/Lucu/Implant/Input.hs +++ b/Network/HTTP/Lucu/Implant.hs @@ -3,7 +3,9 @@ , RecordWildCards , UnicodeSyntax #-} -module Network.HTTP.Lucu.Implant.Input +-- |An internal module for generating Haskell modules eith an +-- arbitrary file implanted. +module Network.HTTP.Lucu.Implant ( Input(..) , originalLen diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index 027003d..ecdb4fe 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -4,7 +4,10 @@ , RecordWildCards , TemplateHaskell , UnicodeSyntax + , ViewPatterns #-} +-- |An internal module for generating Haskell modules eith an +-- arbitrary file implanted. module Network.HTTP.Lucu.Implant.PrettyPrint ( pprInput ) @@ -14,15 +17,17 @@ import Control.Monad import Data.Ascii (CIAscii) import qualified Data.Ascii as A import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Foldable import Data.List -import qualified Data.Map as M +import Data.Ratio import Data.Time import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.Implant.Input +import Network.HTTP.Lucu.Implant import Network.HTTP.Lucu.Implant.Rewrite import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Resource @@ -68,27 +73,50 @@ header i@(Input {..}) moduleDecl ∷ ModName → Name → Doc moduleDecl modName symName - = hsep [ text "module" - , text (modString modName) - , lparen - , ppr symName - , rparen - , text "where" - ] + = text "module" <+> text (modString modName) $+$ + nest 4 (vcat [ lparen <+> ppr symName + , rparen + , text "where" + ]) + +importDecls ∷ Imports ImportOp → Doc +importDecls = vcat ∘ map pprImport ∘ toList -importDecls ∷ ModMap → Doc -importDecls = vcat ∘ map f ∘ M.toAscList +pprImport ∷ ImportOp → Doc +pprImport (QualifiedImp {..}) + = hsep [ text "import" + , text "qualified" + , text (modString impModule) + , text "as" + , text (modString impAlias) + ] +pprImport (UnqualifiedImp {impNames = Nothing, ..}) + = hsep [ text "import" + , text (modString impModule) + ] +pprImport (UnqualifiedImp {impNames = Just ns, ..}) + = hsep [ text "import" + , text (modString impModule) + , hcat [ lparen + , sep $ punctuate comma + $ map (uncurry pprImpName) + $ toList ns + , rparen + ] + ] where - f ∷ (ModName, Maybe ModName) → Doc - f (m, Nothing) = hsep [ text "import" - , text (modString m) - ] - f (m, Just m') = hsep [ text "import" - , text "qualified" - , text (modString m) - , text "as" - , text (modString m') - ] + pprImpName ∷ NameSpace → OccName → Doc + pprImpName TcClsName (occString → o) + = hcat [text o, text "(..)"] + pprImpName _ (occString → o) + | needParen o = hcat [lparen, text o, rparen] + | otherwise = text o + + needParen ∷ String → Bool + needParen (head → c) + | isPunctuation c = True + | isSymbol c = True + | otherwise = False entityTag ∷ Name entityTag = mkName "entityTag" @@ -132,39 +160,38 @@ resourceE i = [| emptyResource { resGetE ∷ Input → Q Exp resGetE i | useGZip i - = [| Just $ - do foundEntity $(varE entityTag) $(varE lastModified) - setContentType $(varE contentType) - - gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) - if gzipAllowed then - do setContentEncoding [$(varE gzipEncoding)] - putChunks $(varE gzippedData) - else - putChunks (decompress $(varE gzippedData)) + = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + + gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) + if gzipAllowed then + do setContentEncoding [$(varE gzipEncoding)] + putChunks $(varE gzippedData) + else + putChunks (decompress $(varE gzippedData)) + ) |] | otherwise - = [| Just $ - do foundEntity $(varE entityTag) $(varE lastModified) - setContentType $(varE contentType) - putChunks $(varE rawData) + = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + putChunks $(varE rawData) + ) |] resHeadE ∷ Input → Q Exp resHeadE i | useGZip i - = [| Just $ - do foundEntity $(varE entityTag) $(varE lastModified) - setContentType $(varE contentType) + = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) - gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) - when gzipAllowed (setContentEncoding [$(varE gzipEncoding)]) + gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding) + when gzipAllowed (setContentEncoding [$(varE gzipEncoding)]) + ) |] | otherwise - = [| Just $ - do foundEntity $(varE entityTag) - $(varE lastModified) - setContentType $(varE contentType) + = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified) + setContentType $(varE contentType) + ) |] eTagDecl ∷ Input → Q [Dec] @@ -196,6 +223,29 @@ binDecl i@(Input {..}) , valD (varP rawData) (normalB (liftLazyByteString iRawData)) [] ] +rules ∷ Rules +rules = [ qualifyAll "Codec.Compression.GZip" "G" + , unqualify ''CIAscii "Data.Ascii" + , qualifyAll "Data.Ascii" "A" + , qualifyAll "Data.ByteString.Char8" "B" + , qualifyAll "Data.ByteString.Lazy.Internal" "L" + , qualifyAll "Data.Map" "M" + , qualifyAll "Data.Text" "T" + , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu" + , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu" + , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu" + , unqualifyAll "Network.HTTP.Lucu.MIMEParams" "Network.HTTP.Lucu" + , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu" + , unqualify 'when "Control.Monad" + , unqualify '(%) "Data.Ratio" + , unqualify ''DiffTime "Data.Time" + , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time" + , unqualifyIn 'UTCTime ''UTCTime "Data.Time" + , unqualifyIn 'False ''Bool "Prelude" + , unqualifyIn 'Just ''Maybe "Prelude" + , unqualify 'fromRational "Prelude" + ] + pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc pprInput i modName symName = do decls ← runQ $ sequence [ resourceDecl i symName @@ -204,7 +254,7 @@ pprInput i modName symName , contTypeDecl i , binDecl i ] - let (decls', mods) = rewriteNames decls + let (decls', mods) = rewriteNames rules decls return $ vcat [ header i , moduleDecl modName symName , importDecls mods diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs index 37fbfbb..e4ec832 100644 --- a/Network/HTTP/Lucu/Implant/Rewrite.hs +++ b/Network/HTTP/Lucu/Implant/Rewrite.hs @@ -1,129 +1,205 @@ {-# LANGUAGE - UnicodeSyntax + FlexibleInstances + , GeneralizedNewtypeDeriving + , RecordWildCards + , UnicodeSyntax #-} +-- |An internal module for rewriting 'Name's in Template Haskell AST. module Network.HTTP.Lucu.Implant.Rewrite - ( ModMap + ( NamePat(..) + , RewriteOp(..) + + , Imports + , ImportOp(..) + + , Rules + , RewriteRule(..) + , qualifyAll + , unqualify + , unqualifyIn + , unqualifyAll + , rewriteNames ) where import Control.Applicative import Control.Monad.State import Data.Data -import Data.Generics.Aliases +import Data.Foldable +import Data.Generics.Aliases hiding (GT) import Data.Generics.Schemes -import Data.Map (Map) -import qualified Data.Map as M +import Data.Monoid import Data.Monoid.Unicode +import Data.Set (Set) +import qualified Data.Set as S import Language.Haskell.TH.Syntax +import Prelude import Prelude.Unicode --- FIXME: Document at least these data types. -type ModMap = Map ModName (Maybe ModName) -data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName) - -rewriteNames ∷ Data d ⇒ d → (d, ModMap) -rewriteNames - = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName)) - -rewriteName ∷ (Functor m, Monad m) - ⇒ Name - → StateT ModMap m Name -rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl - -rewriteNameFlavour ∷ (Functor m, Monad m) - ⇒ NameFlavour - → StateT ModMap m NameFlavour -rewriteNameFlavour fl - = case getModName fl of - Nothing → return fl - Just m → do let r = M.lookup m modules - insertIntoModMap m r - return $ setModName r fl - -insertIntoModMap ∷ Monad m - ⇒ ModName - → Maybe RewriteTo - → StateT ModMap m () -insertIntoModMap _ (Just (Qual (Just m) m')) = modify $ M.insert m (Just m') -insertIntoModMap m (Just (Qual Nothing m')) = modify $ M.insert m (Just m') -insertIntoModMap _ (Just (UnQual (Just m) )) = modify $ M.insert m Nothing -insertIntoModMap _ (Just (UnQual Nothing )) = return () -insertIntoModMap m Nothing = modify $ M.insert m Nothing - -getModName ∷ NameFlavour → Maybe ModName -getModName (NameQ m) = Just m -getModName (NameG _ _ m) = Just m -getModName _ = Nothing - -setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour -setModName (Just (Qual _ m)) (NameQ _ ) = NameQ m -setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m -setModName (Just (UnQual _)) (NameQ _ ) = NameS -setModName (Just (UnQual _)) (NameG _ _ _) = NameS -setModName Nothing (NameQ _ ) = NameS -setModName Nothing (NameG _ _ _) = NameS -setModName _ _ = error "setModName: internal error" - -modules ∷ Map ModName RewriteTo -modules - = M.fromList - [ ( mkModName "Codec.Compression.GZip" - , Qual Nothing $ mkModName "G" - ) - , ( mkModName "Data.Ascii" - , Qual Nothing $ mkModName "A" - ) - , ( mkModName "Data.ByteString.Char8" - , Qual Nothing $ mkModName "B" - ) - , ( mkModName "Data.ByteString.Lazy.Internal" - , Qual Nothing $ mkModName "L" - ) - , ( mkModName "Data.ByteString.Unsafe" - , Qual Nothing $ mkModName "B" - ) - , ( mkModName "Data.Map" - , Qual Nothing $ mkModName "M" - ) - , ( mkModName "Data.Maybe" - , UnQual Nothing - ) - , ( mkModName "Data.Text" - , Qual Nothing $ mkModName "T" - ) - , ( mkModName "Data.Time.Calendar.Days" - , UnQual $ Just $ mkModName "Data.Time" - ) - , ( mkModName "Data.Time.Clock.Scale" - , UnQual $ Just $ mkModName "Data.Time" - ) - , ( mkModName "Data.Time.Clock.UTC" - , UnQual $ Just $ mkModName "Data.Time" - ) - , ( mkModName "GHC.Base" - , UnQual Nothing - ) - , ( mkModName "GHC.Bool" - , UnQual Nothing - ) - , ( mkModName "GHC.IO" - -- for 'unsafePerformIO', but rather problematic... - , UnQual $ Just $ mkModName "System.IO.Unsafe" - ) - , ( mkModName "GHC.Real" - -- for '%', but rather problematic... - , UnQual $ Just $ mkModName "Data.Ratio" - ) - , ( mkModName "Network.HTTP.Lucu.ETag" - , UnQual $ Just $ mkModName "Network.HTTP.Lucu" - ) - , ( mkModName "Network.HTTP.Lucu.MIMEType" - , UnQual $ Just $ mkModName "Network.HTTP.Lucu" - ) - , ( mkModName "Network.HTTP.Lucu.Resource" - , UnQual $ Just $ mkModName "Network.HTTP.Lucu" - ) - , ( mkModName "Network.HTTP.Lucu.Resource.Internal" - , UnQual $ Just $ mkModName "Network.HTTP.Lucu" - ) - ] +-- |Pattern for 'Name's. 'Just' represents a perfect matching pattern, +-- and 'Nothing' represensts a wildcard. +data NamePat + = NamePat !(Maybe ModName) !(Maybe OccName) + +-- |Instruction for rewriting 'Name's. +data RewriteOp + = Identity + | Unqualify + | Qualify !ModName + +-- |A 'Set' of modules and names to be imported. +newtype Imports α = Imports (Set α) + deriving Foldable + +-- |Instruction for declaring module imports. +data ImportOp + = -- |> import qualified M as A + QualifiedImp { + impModule ∷ !ModName + , impAlias ∷ !ModName + } + -- |> import M + -- + -- or + -- + -- > import M (a, b, c, ...) + | UnqualifiedImp { + impModule ∷ !ModName + , impNames ∷ !(Maybe (Set (NameSpace, OccName))) + } + deriving Eq + +-- |List of 'RewriteRule's. +type Rules = [RewriteRule] + +-- |Instruction for rewriting 'Name's and declaring module imports. +data RewriteRule + = RewriteRule { + rrPat ∷ !NamePat + , rrOp ∷ !RewriteOp + , rrImps ∷ !(Imports ImportOp) + } + +instance Ord ImportOp where + α `compare` β + | impModule α < impModule β = LT + | impModule α > impModule β = GT + | otherwise + = case (α, β) of + (QualifiedImp {}, QualifiedImp {}) + → impAlias α `compare` impAlias β + (QualifiedImp {}, _ ) + → GT + (UnqualifiedImp {}, UnqualifiedImp {}) + → impNames α `compare` impNames β + (UnqualifiedImp {}, _ ) + → LT + +instance Monoid (Imports ImportOp) where + mempty + = Imports (∅) + mappend (Imports α) (Imports β) + = Imports (foldl' insertImp α β) + +insertImp ∷ Set ImportOp → ImportOp → Set ImportOp +insertImp α qi@(QualifiedImp {}) = S.insert qi α +insertImp α ui@(UnqualifiedImp {}) + = case find sameMod α of + Nothing → S.insert ui α + Just ui' → S.insert (merge ui') (S.delete ui' α) + where + sameMod ∷ ImportOp → Bool + sameMod ui'@(UnqualifiedImp {}) + = impModule ui ≡ impModule ui' + sameMod _ + = False + + merge ∷ ImportOp → ImportOp + merge ui' + = case (impNames ui, impNames ui') of + (Nothing, _ ) → ui + (_ , Nothing) → ui' + (Just s , Just s') → ui { impNames = Just (s ⊕ s') } + +-- |@'qualifyAll' module alias@: qualify every symbols defined in +-- @module@ with @alias@. +qualifyAll ∷ String → String → RewriteRule +qualifyAll m a + = let pat = NamePat (Just (mkModName m)) Nothing + rop = Qualify (mkModName a) + iop = QualifiedImp (mkModName m) (mkModName a) + in + RewriteRule pat rop (Imports (S.singleton iop)) + +-- |@'unqualify' name module@: unqualify the symbol @name@ with +-- importing @module@. +unqualify ∷ Name → String → RewriteRule +unqualify (Name o _) m + = let pat = NamePat Nothing (Just o) + iop = UnqualifiedImp (mkModName m) + $ Just + $ S.singleton (VarName, o) + in + RewriteRule pat Unqualify (Imports (S.singleton iop)) + +-- |@'unqualifyIn' name tycl module@: unqualify a constructor, field +-- name, or whatever resides in the type or class @tycl@ with +-- importing @module@. +unqualifyIn ∷ Name → Name → String → RewriteRule +unqualifyIn (Name name _) (Name tycl _) m + = let pat = NamePat Nothing (Just name) + iop = UnqualifiedImp (mkModName m) + $ Just + $ S.singleton (TcClsName, tycl) + in + RewriteRule pat Unqualify (Imports (S.singleton iop)) + +-- |@'unqualifyAll' origMod impMod@: unqualify every symbols +-- defined in @origMod@ with importing @impMod@. +unqualifyAll ∷ String → String → RewriteRule +unqualifyAll origMod impMod + = let pat = NamePat (Just (mkModName origMod)) Nothing + iop = UnqualifiedImp (mkModName impMod) Nothing + in + RewriteRule pat Unqualify (Imports (S.singleton iop)) + +-- |@'rewriteNames' rules d@ rewrites each and every 'Name's included +-- in @d@ according to the name-rewriting @rules@ while at the same +-- time building a set of modules to be imported. +rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp) +rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f)) + where + f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name + f n = case findRule rules n of + Nothing → fail $ "No rules matches to name: " ⧺ showName n + Just r → applyRule r n + +findRule ∷ Rules → Name → Maybe RewriteRule +findRule _ (Name _ NameS ) = Just identityRule +findRule rs (Name o (NameQ m)) = find (matchPat m o ∘ rrPat) rs +findRule _ (Name _ (NameU _ )) = Just identityRule +findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs +findRule _ _ = Nothing + +identityRule ∷ RewriteRule +identityRule = RewriteRule { + rrPat = NamePat Nothing Nothing + , rrOp = Identity + , rrImps = (∅) + } + +matchPat ∷ ModName → OccName → NamePat → Bool +matchPat m o (NamePat mp op) + = maybe True (≡ m) mp ∧ maybe True (≡ o) op + +applyRule ∷ (Functor m, Monad m) + ⇒ RewriteRule + → Name + → StateT (Imports ImportOp) m Name +applyRule (RewriteRule {..}) n + = modify (⊕ rrImps) *> pure (rewrite rrOp n) + +rewrite ∷ RewriteOp → Name → Name +rewrite Identity n = n +rewrite Unqualify (Name o _) = Name o NameS +rewrite (Qualify m) (Name o _) = Name o (NameQ m) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index a28a804..1550030 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -10,8 +10,6 @@ #-} -- |Parse \"multipart/form-data\" based on RFC 2388: -- --- --- You usually don't have to use this module directly. module Network.HTTP.Lucu.MultipartForm ( FormData(..) , parseMultipartFormData diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 660f550..db83b9c 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,8 +1,7 @@ {-# LANGUAGE UnicodeSyntax #-} --- |This is an auxiliary parser utilities. You usually don't have to --- use this module directly. +-- |A set of auxiliary parser utilities. module Network.HTTP.Lucu.Parser ( atMost , finishOff diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs index dd9c34b..b9668e0 100644 --- a/Network/HTTP/Lucu/SocketLike.hs +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -4,6 +4,7 @@ , TypeFamilies , UnicodeSyntax #-} +-- |Type class for things behaves like a 'So.Socket'. module Network.HTTP.Lucu.SocketLike ( SocketLike(..) ) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 55acf0a..18370fa 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -4,8 +4,7 @@ , TemplateHaskell , UnicodeSyntax #-} --- |Utility functions used internally in the Lucu httpd. These --- functions may be useful too for something else. +-- |Utility functions used internally in this package. module Network.HTTP.Lucu.Utils ( splitBy , quoteStr @@ -26,7 +25,6 @@ import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Strict -import qualified Data.ByteString.Unsafe as Strict import qualified Data.ByteString.Lazy.Internal as Lazy import Data.Char import Data.List hiding (last) @@ -42,7 +40,6 @@ import Language.Haskell.TH.Syntax import Network.URI import Prelude hiding (last) import Prelude.Unicode -import System.IO.Unsafe -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] @@ -129,17 +126,7 @@ liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |] -- |Convert an 'Ascii' to an 'Exp' representing it as a literal. liftAscii ∷ Ascii → Q Exp -liftAscii a = [| A.unsafeFromByteString - $ unsafePerformIO - $ Strict.unsafePackAddressLen $len $ptr - |] - where - bs ∷ Strict.ByteString - bs = A.toByteString a - - len, ptr ∷ Q Exp - len = lift $ Strict.length bs - ptr = litE $ stringPrimL $ Strict.unpack bs +liftAscii a = [| A.unsafeFromByteString $(liftByteString $ A.toByteString a) |] -- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. liftCIAscii ∷ CIAscii → Q Exp @@ -162,18 +149,11 @@ liftMap liftK liftV m -- |Convert an 'UTCTime' to an 'Exp' representing it as a literal. liftUTCTime ∷ UTCTime → Q Exp liftUTCTime (UTCTime {..}) - = [| UTCTime { - utctDay = $(liftDay utctDay) - , utctDayTime = $(liftDiffTime utctDayTime) - } - |] + = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |] liftDay ∷ Day → Q Exp liftDay (ModifiedJulianDay {..}) - = [| ModifiedJulianDay { - toModifiedJulianDay = $(lift toModifiedJulianDay) - } - |] + = [| ModifiedJulianDay $(lift toModifiedJulianDay) |] liftDiffTime ∷ DiffTime → Q Exp liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |] diff --git a/bugs/issue-123424c3b4a0d83452e26403cd79676f319d4295.yaml b/bugs/issue-123424c3b4a0d83452e26403cd79676f319d4295.yaml index 959fcd4..4b7c9e6 100644 --- a/bugs/issue-123424c3b4a0d83452e26403cd79676f319d4295.yaml +++ b/bugs/issue-123424c3b4a0d83452e26403cd79676f319d4295.yaml @@ -5,8 +5,8 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted -disposition: +status: :closed +disposition: :fixed creation_time: 2011-11-07 15:28:34.417982 Z references: [] @@ -16,4 +16,8 @@ log_events: - PHO - created - "" +- - 2011-11-11 05:29:34.851297 Z + - PHO + - closed with disposition fixed + - It has now cleaner code than before, but not simple at all. I'm done anyway. git_branch: template-haskell diff --git a/cabal-package.mk b/cabal-package.mk index cc534f4..9e8e549 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -18,6 +18,7 @@ HPC ?= hpc DITZ ?= ditz CONFIGURE_ARGS ?= --disable-optimization +HADDOCK_OPTS ?= --hyperlink-source HLINT_OPTS ?= --cross --report=dist/report.html SETUP_FILE := $(wildcard Setup.*hs) @@ -81,7 +82,7 @@ clean: clean-hook clean-hook: doc: setup-config - ./Setup haddock + ./Setup haddock $(HADDOCK_OPTS) install: build $(SUDO) ./Setup install diff --git a/examples/Makefile b/examples/Makefile index 0902512..37c59cb 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -27,6 +27,6 @@ dist/MiseRafturai.hs: mise-rafturai.html $(IMPLANT) ImplantedSmall.hs: dist/SmallFile.hs dist/SmallFile.hs: small-file.txt $(IMPLANT) mkdir -p dist - $(IMPLANT) -m SmallFile -o $@ $< + $(IMPLANT) -m SmallFile -t "text/plain; charset=\"UTF-8\"" -o $@ $< .PHONY: build run clean -- 2.40.0