+ 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