Unfoldable Dispatcher

[Lucu.git] / ImplantFile.hs

diff --git a/ImplantFile.hs b/ImplantFile.hs
index 67633f763e3db855c6b4d4f6c39eeb62bb56aa1b..60f9b54755911f631c693a053129867bb836f687 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -1,34 +1,22 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    OverloadedStrings
-  , UnicodeSyntax
+    UnicodeSyntax

   #-}
   #-}

-module Main where
-import Codec.Compression.GZip
+module Main (main) where

 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A
 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A

-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as Strict
-import qualified Data.ByteString.Lazy as Lazy

 import Data.Char
 import Data.Char

-import Data.Digest.Pure.SHA
-import Data.Int

 import Data.Maybe
 import Data.Maybe

-import Data.Time
-import Data.Time.Clock.POSIX
-import Language.Haskell.Exts.Build
-import Language.Haskell.Exts.Extension
-import Language.Haskell.Exts.Pretty
-import Language.Haskell.Exts.Syntax
+import Language.Haskell.TH.PprLib
+import Language.Haskell.TH.Syntax

 import Network.HTTP.Lucu.ETag
 import Network.HTTP.Lucu.ETag

+import Network.HTTP.Lucu.Implant
+import Network.HTTP.Lucu.Implant.PrettyPrint

 import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.MIMEType

-import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
-import Network.HTTP.Lucu.MIMEType.Guess

 import Prelude.Unicode
 import System.Console.GetOpt
 import System.Environment
 import System.Exit
 import Prelude.Unicode
 import System.Console.GetOpt
 import System.Environment
 import System.Exit

-import System.Posix.Files

 import System.IO
 
 data CmdOpt
 import System.IO
 
 data CmdOpt


@@ -41,27 +29,27 @@ data CmdOpt
     deriving (Eq, Show)
 
 options ∷ [OptDescr CmdOpt]
     deriving (Eq, Show)
 
 options ∷ [OptDescr CmdOpt]

-options = [ Option ['o'] ["output"]
+options = [ Option "o" ["output"]

                        (ReqArg OptOutput "FILE")
                        "Output to the FILE."
 
                        (ReqArg OptOutput "FILE")
                        "Output to the FILE."
 

-          , Option ['m'] ["module"]
+          , Option "m" ["module"]

                        (ReqArg OptModName "MODULE")
                        "Specify the resulting module name. (required)"
 
                        (ReqArg OptModName "MODULE")
                        "Specify the resulting module name. (required)"
 

-          , Option ['s'] ["symbol"]
+          , Option "s" ["symbol"]

                        (ReqArg OptSymName "SYMBOL")
                        "Specify the resulting symbol name."
 
                        (ReqArg OptSymName "SYMBOL")
                        "Specify the resulting symbol name."
 

-          , Option ['t'] ["mime-type"]
+          , Option "t" ["mime-type"]

                        (ReqArg OptMIMEType "TYPE")
                        "Specify the MIME Type of the file."
 
                        (ReqArg OptMIMEType "TYPE")
                        "Specify the MIME Type of the file."
 

-          , Option ['e'] ["etag"]
+          , Option "e" ["etag"]

                        (ReqArg OptETag "TAG")
                        "Specify the ETag of the file."
 
                        (ReqArg OptETag "TAG")
                        "Specify the ETag of the file."
 

-          , Option ['h'] ["help"]
+          , Option "h" ["help"]

                        (NoArg OptHelp)
                        "Print this message."
           ]
                        (NoArg OptHelp)
                        "Print this message."
           ]


@@ -73,7 +61,7 @@ printUsage = do mapM_ putStrLn msg
     where
       msg = [ ""
             , "Description:"
     where
       msg = [ ""
             , "Description:"

-            , concat [ "  lucu-implant-file is an utility that generates " 
+            , concat [ "  lucu-implant-file is an utility that generates "

                      , "Haskell code containing an arbitrary file to "
                      , "compile it directly into programs and serve it "
                      , "statically with the Lucu HTTP server."
                      , "Haskell code containing an arbitrary file to "
                      , "compile it directly into programs and serve it "
                      , "statically with the Lucu HTTP server."


@@ -104,373 +92,15 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
 
           generateHaskellSource opts (head sources)
 
 
           generateHaskellSource opts (head sources)
 

-generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
-generateHaskellSource opts srcFile
-    = do modName  ← getModuleName opts
-         symName  ← getSymbolName opts modName
-         mimeType ← getMIMEType opts srcFile
-         lastMod  ← getLastModified srcFile
-         input    ← openInput srcFile
-         output   ← openOutput opts
-         eTag     ← getETag opts input
-
-         let compParams  = defaultCompressParams { compressLevel = bestCompression }
-             gzippedData = compressWith compParams input
-             originalLen = Lazy.length input
-             gzippedLen  = Lazy.length gzippedData
-             useGZip     = originalLen > gzippedLen
-             rawB64      = B64.encode <$> Lazy.toChunks input
-             gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData
-
-         header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-
-         let hsModule = mkModule modName symName imports decls
-             imports  = mkImports useGZip
-             decls    = concat ([ resourceDecl symName useGZip
-                                , entityTagDecl eTag
-                                , lastModifiedDecl lastMod
-                                , contentTypeDecl mimeType
-                                ]
-                                ⧺
-                                if useGZip then
-                                    [ gunzipAndPutChunkDecl
-                                    , dataDecl (name "gzippedData") gzippedB64
-                                    ]
-                                else
-                                    [ dataDecl (name "rawData") rawB64 ]
-                               )
-
-         hPutStrLn output header
-         hPutStrLn output (prettyPrint hsModule)
-         hClose output
-
-mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module
-mkModule modName symName imports decls
-    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
-          exports   = [ EVar (UnQual symName) ]
-      in
-        Module (⊥) modName modPragma Nothing (Just exports) imports decls
-
-mkImports ∷ Bool → [ImportDecl]
-mkImports useGZip
-    = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
-                   True False Nothing (Just (ModuleName "B64")) Nothing
-      , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
-                   True False Nothing (Just (ModuleName "Lazy")) Nothing
-      , ImportDecl (⊥) (ModuleName "Data.Time")
-                   False False Nothing Nothing Nothing
-      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
-                   False False Nothing Nothing Nothing
-      ]
-      ⧺
-      if useGZip then
-          [ ImportDecl (⊥) (ModuleName "Blaze.ByteString.Builder.ByteString")
-                       True False Nothing (Just (ModuleName "BB")) Nothing
-          , ImportDecl (⊥) (ModuleName "Codec.Compression.Zlib.Internal")
-                       False False Nothing Nothing Nothing
-          , ImportDecl (⊥) (ModuleName "Data.Text")
-                       True False Nothing (Just (ModuleName "T")) Nothing
-          ]
-      else
-          []
-
-resourceDecl ∷ Name → Bool → [Decl]
-resourceDecl symName useGZip
-    = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
-      , nameBind (⊥) symName valExp
-      ]
-    where
-      valExp ∷ Exp
-      valExp = RecUpdate (function "emptyResource")
-               [ FieldUpdate (UnQual (name "resGet" )) resGet
-               , FieldUpdate (UnQual (name "resHead")) resHead
-               ]
-
-      resGet ∷ Exp
-      resGet | useGZip   = resGetGZipped
-             | otherwise = resGetRaw
-
-resHead ∷ Exp
-resHead
-    = function "Just" `app`
-      paren (doE [ foundEntityStmt
-                 , setContentTypeStmt
-                 ])
-
-resGetGZipped ∷ Exp
-resGetGZipped
-    = function "Just" `app`
-      paren (doE [ foundEntityStmt
-                 , setContentTypeStmt
-                 , bindGZipStmt
-                 , conditionalOutputStmt
-                 ])
-    where
-      condVarName ∷ Name
-      condVarName = name "gzipAllowed"
-
-      dataVarName ∷ Name
-      dataVarName = name "gzippedData"
-
-      bindGZipStmt ∷ Stmt
-      bindGZipStmt
-          = genStmt (⊥)
-            (pvar condVarName)
-            (function "isEncodingAcceptable" `app` strE "gzip")
-
-      conditionalOutputStmt ∷ Stmt
-      conditionalOutputStmt
-          = qualStmt $
-            If (var condVarName)
-               (doE [ setContentEncodingGZipStmt
-                    , outputStmt (var dataVarName)
-                    ])
-               (function "gunzipAndPutChunk" `app` var dataVarName)
-
-resGetRaw ∷ Exp
-resGetRaw
-    = function "Just" `app`
-      paren (doE [ foundEntityStmt
-                 , setContentTypeStmt
-                 , outputStmt (function "rawData")
-                 ])
-
-setContentEncodingGZipStmt ∷ Stmt
-setContentEncodingGZipStmt
-    = qualStmt
-      ( function "setContentEncoding"
-        `app`
-        listE [ strE "gzip" ]
-      )
-
-foundEntityStmt ∷ Stmt
-foundEntityStmt
-    = qualStmt $
-      metaFunction "foundEntity"
-                       [ var (name "entityTag")
-                       , var (name "lastModified")
-                       ]
-
-setContentTypeStmt ∷ Stmt
-setContentTypeStmt
-    = qualStmt
-      ( function "setContentType"
-        `app`
-        function "contentType"
-      )
-
-outputStmt ∷ Exp → Stmt
-outputStmt e
-    = qualStmt $ function "putChunk" `app` e
-
-entityTagDecl ∷ ETag → [Decl]
-entityTagDecl eTag
-    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "entityTag"
-
-      valExp ∷ Exp
-      valExp = function "parseETag" `app` strE (eTagToString eTag)
-
-lastModifiedDecl ∷ UTCTime → [Decl]
-lastModifiedDecl lastMod
-    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "lastModified"
-
-      valExp ∷ Exp
-      valExp = function "read" `app` strE (show lastMod)
-
-contentTypeDecl ∷ MIMEType → [Decl]
-contentTypeDecl mime
-    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      varName ∷ Name
-      varName = name "contentType"
-
-      valExp ∷ Exp
-      valExp = function "parseMIMEType" `app` strE (mimeToString mime)
-
-      mimeToString ∷ MIMEType → String
-      mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
-
-gunzipAndPutChunkDecl ∷ [Decl]
-gunzipAndPutChunkDecl
-    = [ TypeSig (⊥) [funName]
-                    (TyFun (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
-                           tyResourceUnit)
-      , sfun (⊥) funName [] (UnGuardedRhs funExp) (binds goDecl)
-      ]
-    where
-      funName ∷ Name
-      funName = name "gunzipAndPutChunk"
-
-      goName ∷ Name
-      goName = name "go"
-
-      tyResourceUnit ∷ Type
-      tyResourceUnit
-          = TyApp (TyCon (UnQual (name "Resource")))
-                  (TyTuple Boxed [])
-
-      funExp ∷ Exp
-      funExp = var goName
-               `app`
-               function "."
-               `app`
-               metaFunction "decompressWithErrors"
-                                [ function "gzipFormat"
-                                , function "defaultDecompressParams"
-                                ]
-
-      goDecl ∷ [Decl]
-      goDecl = [ TypeSig (⊥) [goName]
-                             (TyFun (TyCon (UnQual (name "DecompressStream")))
-                                    tyResourceUnit)
-               , FunBind [ Match (⊥) goName [pvar (name "StreamEnd")]
-                                 Nothing (UnGuardedRhs endExp) (binds [])
-                         , Match (⊥) goName [pApp (name "StreamChunk")
-                                                  [ pvar (name "x")
-                                                  , pvar (name "xs") ]]
-                                 Nothing (UnGuardedRhs chunkExp) (binds [])
-                         , Match (⊥) goName [pApp (name "StreamError")
-                                                   [ wildcard
-                                                   , pvar (name "msg") ]]
-                                 Nothing (UnGuardedRhs errorExp) (binds [])
-                         ]
-               ]
-
-      endExp ∷ Exp
-      endExp = function "return" `app` tuple []
-
-      chunkExp ∷ Exp
-      chunkExp = function "putBuilder"
-                 `app`
-                 paren ( qvar (ModuleName "BB") (name "fromByteString")
-                         `app`
-                         var (name "x")
-                       )
-                 `app`
-                 function ">>"
-                 `app`
-                 function "go" `app` var (name "xs")
-
-      errorExp ∷ Exp
-      errorExp = metaFunction "abort"
-                 [ var (name "InternalServerError")
-                 , listE []
-                 , function "Just"
-                   `app`
-                   paren ( qvar (ModuleName "T") (name "pack")
-                           `app`
-                           paren ( strE "gunzip: "
-                                   `app`
-                                   function "++"
-                                   `app`
-                                   var (name "msg")
-                                 )
-                         )
-                 ]
-
-dataDecl ∷ Name → [Strict.ByteString] → [Decl]
-dataDecl varName chunks
-    = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
-      , nameBind (⊥) varName valExp
-      ]
-    where
-      valExp ∷ Exp
-      valExp = qvar (ModuleName "Lazy") (name "fromChunks")
-               `app`
-               listE (chunkToExp <$> chunks)
-
-      chunkToExp ∷ Strict.ByteString → Exp
-      chunkToExp chunk
-          = qvar (ModuleName "B64") (name "decodeLenient")
-            `app`
-            strE (Strict.unpack chunk)
-
-mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
-mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-    = do localLastMod ← utcToLocalZonedTime lastMod
-         return $ concat
-                    [ "{- DO NOT EDIT THIS FILE.\n"
-                    , "   This file is automatically generated by the lucu-implant-file program.\n"
-                    , "\n"
-                    , "              Source: ", if srcFile ≡ "-" then
-                                                    "(stdin)"
-                                                else
-                                                    srcFile
-                    , "\n"
-                    , "     Original Length: ", show originalLen, " bytes\n"
-                    , if useGZip then
-                          "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
-                          "         Compression: gzip\n"
-                      else
-                          "         Compression: disabled\n"
-                    , "           MIME Type: ", mimeTypeToString mimeType, "\n"
-                    , "                ETag: ", eTagToString eTag, "\n"
-                    , "       Last Modified: ", show localLastMod, "\n"
-                    , " -}"
-                    ]
-
-eTagToString ∷ ETag → String
-eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
-
-mimeTypeToString ∷ MIMEType → String
-mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
-
-getModuleName ∷ [CmdOpt] → IO ModuleName
-getModuleName opts
-    = case modNameOpts of
-        []                    → fail "a module name must be given."
-        OptModName modName:[] → return $ ModuleName modName
-        _                     → fail "too many --module options."
-    where
-      modNameOpts ∷ [CmdOpt]
-      modNameOpts = filter (\ x → case x of
-                                     OptModName _ → True
-                                     _            → False) opts
-
-getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
-getSymbolName opts (ModuleName modName)
-    = case symNameOpts of
-        []                    → return defaultSymName
-        OptSymName symName:[] → return $ name symName
-        _                     → fail "too many --symbol options."
-    where
-      symNameOpts ∷ [CmdOpt]
-      symNameOpts = filter (\ x → case x of
-                                     OptSymName _ → True
-                                     _            → False) opts
-
-      defaultSymName ∷ Name
-      defaultSymName
-          = name $ headToLower $ getLastComp modName
-
-      headToLower ∷ String → String
-      headToLower []     = error "module name must not be empty"
-      headToLower (x:xs) = toLower x : xs
-
-      getLastComp ∷ String → String
-      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
-
-getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
-getMIMEType opts srcFile
+getMIMEType ∷ [CmdOpt] → Maybe MIMEType
+getMIMEType opts

     = case mimeTypeOpts of
     = case mimeTypeOpts of

-        []  → return defaultType
+        []  → Nothing

         OptMIMEType ty:[]
             → case A.fromChars ty of
         OptMIMEType ty:[]
             → case A.fromChars ty of

-                 Just a  → return $ parseMIMEType a
-                 Nothing → fail "MIME type must not contain any non-ASCII letters."
-        _   → fail "too many --mime-type options."
+                 Just a  → Just $ parseMIMEType a
+                 Nothing → error "MIME types must not contain any non-ASCII letters."
+        _   → error "too many --mime-type options."

     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts
     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts


@@ -478,50 +108,31 @@ getMIMEType opts srcFile
                              OptMIMEType _ → True
                              _             → False) opts
 
                              OptMIMEType _ → True
                              _             → False) opts
 

-      octetStream ∷ MIMEType
-      octetStream = parseMIMEType "application/octet-stream"
-
-      defaultType ∷ MIMEType
-      defaultType = fromMaybe octetStream
-                    $ guessTypeByFileName defaultExtensionMap srcFile
-
-getLastModified ∷ FilePath → IO UTCTime
-getLastModified "-"   = getCurrentTime
-getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
-                        <$>
-                        getFileStatus fpath
-
-getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
-getETag opts input
+getETag ∷ [CmdOpt] → Maybe ETag
+getETag opts

     = case eTagOpts of
     = case eTagOpts of

-        []             → return mkETagFromInput
-        OptETag str:[] → return $ strToETag str
-        _              → fail "too many --etag options."
+        []             → Nothing
+        OptETag str:[] → Just $ strToETag str
+        _              → error "too many --etag options."

     where
       eTagOpts ∷ [CmdOpt]
       eTagOpts = filter (\ x → case x of
                                   OptETag _ → True
                                   _         → False) opts
 
     where
       eTagOpts ∷ [CmdOpt]
       eTagOpts = filter (\ x → case x of
                                   OptETag _ → True
                                   _         → False) opts
 

-      mkETagFromInput ∷ ETag
-      mkETagFromInput
-          = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)
-

       strToETag ∷ String → ETag
       strToETag str
           = case A.fromChars str of
               Just a  → strongETag a
               Nothing → error "ETag must not contain any non-ASCII letters."
 
       strToETag ∷ String → ETag
       strToETag str
           = case A.fromChars str of
               Just a  → strongETag a
               Nothing → error "ETag must not contain any non-ASCII letters."
 

-openInput ∷ FilePath → IO Lazy.ByteString
-openInput "-"   = Lazy.getContents
-openInput fpath = Lazy.readFile fpath
-

 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts
     = case outputOpts of
         []                 → return stdout
 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts
     = case outputOpts of
         []                 → return stdout

-        OptOutput fpath:[] → openFile fpath WriteMode
+        OptOutput fpath:[] → do h ← openFile fpath WriteMode
+                                hSetEncoding h utf8
+                                return h

         _                  → fail "two many --output options."
     where
       outputOpts ∷ [CmdOpt]
         _                  → fail "two many --output options."
     where
       outputOpts ∷ [CmdOpt]


@@ -529,103 +140,51 @@ openOutput opts
                                     OptOutput _ → True
                                     _           → False) opts
 
                                     OptOutput _ → True
                                     _           → False) opts
 

-{-
-  作られるファイルの例 (壓縮されない場合):
-  ------------------------------------------------------------------------------
-  {- DO NOT EDIT THIS FILE.
-     This file is automatically generated by the lucu-implant-file program.
-     
-                Source: baz.png
-       Original Length: 302 bytes
-     Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
-           Compression: disabled
-             MIME Type: image/png
-                  ETag: "d41d8cd98f00b204e9800998ecf8427e"
-         Last Modified: 2007-11-05 13:53:42.231882 JST
-   -}
-  {-# LANGUAGE OverloadedStrings #-}
-  module Foo.Bar.Baz (baz) where
-  import qualified Data.ByteString.Base64 as B64
-  import qualified Data.ByteString.Lazy as Lazy
-  import Data.Time
-  import Network.HTTP.Lucu
-
-  baz ∷ ResourceDef
-  baz = ResourceDef {
-          resUsesNativeThread = False
-        , resIsGreedy         = False
-        , resGet
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-                        putChunk rawData
-        , resHead
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-        , resPost   = Nothing
-        , resPut    = Nothing
-        , resDelete = Nothing
-        }
-
-  entityTag ∷ ETag
-  entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
-
-  lastModified ∷ UTCTime
-  lastModified = read "2007-11-05 04:47:56.008366 UTC"
-
-  contentType ∷ MIMEType
-  contentType = parseMIMEType "image/png"
+getModuleName ∷ [CmdOpt] → ModName
+getModuleName opts
+    = case modNameOpts of
+        []                 → error "a module name must be given."
+        OptModName name:[] → mkModName name
+        _                  → error "too many --module options."
+    where
+      modNameOpts ∷ [CmdOpt]
+      modNameOpts = filter (\ x → case x of
+                                     OptModName _ → True
+                                     _            → False) opts

 
 

-  rawData ∷ Lazy.ByteString
-  rawData = Lazy.fromChunks
-            [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
-            , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
-            ]
-  ------------------------------------------------------------------------------
+getSymbolName ∷ [CmdOpt] → Maybe Name
+getSymbolName opts
+    = case symNameOpts of
+        []                 → Nothing
+        OptSymName name:[] → Just $ mkName name
+        _                  → fail "too many --symbol options."
+    where
+      symNameOpts ∷ [CmdOpt]
+      symNameOpts = filter (\ x → case x of
+                                     OptSymName _ → True
+                                     _            → False) opts

 
 

-  壓縮される場合は次のやうに變はる:
-  ------------------------------------------------------------------------------
-  -- import に追加
-  import qualified Blaze.ByteString.Builder.ByteString as BB
-  import Codec.Compression.Zlib.Internal
-  import qualified Data.Text as T
+defaultSymName ∷ ModName → Name
+defaultSymName = headToLower ∘ getLastComp
+    where
+      headToLower ∷ String → Name
+      headToLower []     = error "module name must not be empty"
+      headToLower (x:xs) = mkName (toLower x:xs)

 
 

-  -- ResourceDef は次のやうに變化
-  baz ∷ ResourceDef
-  baz = ResourceDef {
-          resUsesNativeThread = False
-        , resIsGreedy         = False
-        , resGet
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
+      getLastComp ∷ ModName → String
+      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString

 
 

-                        gzipAllowed ← isEncodingAcceptable "gzip"
-                        if gzipAllowed then
-                            do setContentEncoding ["gzip"]
-                               putChunk gzippedData
-                        else
-                            gunzipAndPutChunk gzippedData
-        , resHead
-            = Just $ do foundEntity entityTag lastModified
-                        setContentType contentType
-        , resPost   = Nothing
-        , resPut    = Nothing
-        , resDelete = Nothing
-        }
+generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
+generateHaskellSource opts srcFile
+    = do i   ← openInput srcFile (getMIMEType opts) (getETag opts)
+         o   ← openOutput opts
+         doc ← pprInput i modName symName
+         hPutStrLn o ∘ show $ to_HPJ_Doc doc
+         hClose o
+    where
+      modName ∷ ModName
+      modName = getModuleName opts

 
 

-  -- 追加
-  gunzipAndPutChunk :: Lazy.ByteString -> Resource ()
-  gunzipAndPutChunk = go . decompressWithErrors gzipFormat defaultDecompressParams
-      where
-        go :: DecompressStream -> Resource ()
-        go StreamEnd = return ()
-        go (StreamChunk x xs) = putBuilder (BB.fromByteString x) >> go xs
-        go (StreamError _ msg) = abort InternalServerError [] (Just (T.pack ("gunzip: " ++ msg)))
-  
-  -- rawData の代はりに gzippedData
-  gzippedData ∷ Lazy.ByteString
-  gzippedData = Lazy.fromChunks
-                [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
-                , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
-                ]
-  ------------------------------------------------------------------------------
- -}
+      symName ∷ Name
+      symName = fromMaybe (defaultSymName modName)
+                $ getSymbolName opts