packages feed

hsmin (empty) → 0.1.0

raw patch · 13 files changed

+1447/−0 lines, 13 filesdep +basedep +directorydep +filepath

Dependencies added: base, directory, filepath, ghc-lib-parser, hsmin, optparse-applicative, process, tasty, tasty-hunit, temporary

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Jappie Klooster++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import System.IO (hPutStrLn, stderr)+import Options.Applicative++import HsMin (minifySource, MinifyOpts(..))++-- | CLI options+data Opts = Opts+  { optNoBraces    :: Bool+  , optNoRename    :: Bool+  , optNoPointfree :: Bool+  , optFile        :: Maybe FilePath+  } deriving (Show)++optsParser :: Parser Opts+optsParser = Opts+  <$> switch (long "no-braces" <> help "Don't convert layout to {;} syntax")+  <*> switch (long "no-rename" <> help "Don't rename local identifiers")+  <*> switch (long "no-pointfree" <> help "Don't apply eta reduction")+  <*> optional (argument str (metavar "FILE" <> help "Haskell source file (reads stdin if omitted)"))++optsInfo :: ParserInfo Opts+optsInfo = info (optsParser <**> helper)+  ( fullDesc+  <> progDesc "Minify Haskell source code for LLM token reduction"+  <> header "hsmin - Haskell source minifier"+  )++main :: IO ()+main = do+  opts <- execParser optsInfo+  let mopts = MinifyOpts+        { moUseBraces   = not (optNoBraces opts)+        , moRename      = not (optNoRename opts)+        , moPointfree   = not (optNoPointfree opts)+        }+  (filename, src) <- case optFile opts of+    Nothing -> do+      contents <- getContents+      pure ("<stdin>", contents)+    Just fp -> do+      contents <- readFile fp+      pure (fp, contents)+  case minifySource mopts filename src of+    Left err -> do+      hPutStrLn stderr $ "hsmin: " ++ err+    Right result -> do+      putStr result+      putStrLn ""
+ hsmin.cabal view
@@ -0,0 +1,112 @@+cabal-version:      3.0+name:               hsmin+version:            0.1.0+license:            MIT+license-file:       LICENSE+author:             Jappie Klooster+maintainer:         jappieklooster@hotmail.com+build-type:         Simple+synopsis:           Haskell source code minifier for LLM token reduction+description:+    A Haskell source code minifier that uses ghc-lib-parser to parse+    Haskell source and produce a compact output with comments and+    whitespace stripped, layout converted to explicit brace syntax,+    and other size reductions. Useful for reducing LLM token usage+    when including Haskell source in prompts.+category:           Development++source-repository head+    type:     git+    location: https://github.com/jappeace-sloth/haskell-minifier.git++flag werror+    description: Enable -Werror during development+    manual:      True+    default:     False++common warnings+    ghc-options:+      -Wall+      -Wincomplete-uni-patterns+      -Wincomplete-record-updates+      -Widentities+      -Wredundant-constraints+      -Wcpp-undef+      -fwarn-tabs+      -Wpartial-fields+      -Wunused-packages+      -fno-omit-yields++    if flag(werror)+      ghc-options: -Werror++    default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      LambdaCase+      MultiWayIf+      NamedFieldPuns+      TupleSections+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      StandaloneDeriving+      OverloadedStrings+      TypeApplications+      NumericUnderscores+      ImportQualifiedPost+      ScopedTypeVariables++library+    import:           warnings+    exposed-modules:+      HsMin+      HsMin.Parse+      HsMin.Print+      HsMin.Transform+      HsMin.Util+    build-depends:+      base >= 4.16 && < 5+      , ghc-lib-parser >= 9.12 && < 9.14+    hs-source-dirs:   src+    default-language: Haskell2010++executable hsmin+    import:           warnings+    main-is:          Main.hs+    build-depends:+      base >= 4.16 && < 5+      , hsmin+      , optparse-applicative >= 0.16 && < 0.19+    hs-source-dirs:   app+    default-language: Haskell2010+    ghc-options:      -threaded -rtsopts "-with-rtsopts=-N"++test-suite unit+    import:           warnings+    type:             exitcode-stdio-1.0+    main-is:          Test.hs+    other-modules:+      Test.Parse+      Test.Print+      Test.Integration+      Test.E2E+    build-depends:+      base >= 4.16 && < 5+      , hsmin+      , tasty >= 1.4 && < 1.6+      , tasty-hunit >= 0.10 && < 0.11+      , temporary >= 1.3 && < 1.5+      , directory >= 1.3 && < 1.5+      , filepath >= 1.4 && < 1.6+      , process >= 1.6 && < 1.8+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -threaded -rtsopts "-with-rtsopts=-N"
+ src/HsMin.hs view
@@ -0,0 +1,20 @@+module HsMin+  ( minify+  , minifySource+  , MinifyOpts(..)+  , defaultMinifyOpts+  , parseModule+  , ParseError(..)+  , printModule+  , PrintOpts(..)+  , defaultPrintOpts+  ) where++import HsMin.Parse (parseModule, ParseError(..))+import HsMin.Print (printModule, PrintOpts(..), defaultPrintOpts)+import HsMin.Transform (minifySource, MinifyOpts(..), defaultMinifyOpts)++-- | Minify Haskell source with default options.+--   Convenience wrapper around 'minifySource'.+minify :: FilePath -> String -> Either String String+minify = minifySource defaultMinifyOpts
+ src/HsMin/Parse.hs view
@@ -0,0 +1,54 @@+module HsMin.Parse+  ( parseModule+  , ParseError(..)+  ) where++import GHC.Data.EnumSet qualified as EnumSet+import GHC.Data.FastString (mkFastString)+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Hs (HsModule, GhcPs)+import GHC.Parser qualified as Parser+import GHC.Parser.Lexer+  ( P(..)+  , ParserOpts+  , PState+  , ParseResult(..)+  , initParserState+  , mkParserOpts+  )+import GHC.Types.SrcLoc+  ( Located+  , mkRealSrcLoc+  )+import GHC.Utils.Error (emptyDiagOpts)++-- | Errors that can occur during parsing+data ParseError+  = ParseFailed PState++instance Show ParseError where+  show (ParseFailed _) = "ParseFailed"++-- | Parse a Haskell module from source text.+--   The filename is used for error messages.+parseModule :: FilePath -> String -> Either ParseError (Located (HsModule GhcPs))+parseModule filename src =+  case unP Parser.parseModule pstate of+    POk _ result -> Right result+    PFailed ps   -> Left (ParseFailed ps)+  where+    pstate :: PState+    pstate = initParserState parserOpts buf startLoc++    buf = stringToStringBuffer src+    startLoc = mkRealSrcLoc (mkFastString filename) 1 1++    parserOpts :: ParserOpts+    parserOpts = mkParserOpts+      EnumSet.empty  -- no extensions enabled by default (source pragmas will be parsed)+      emptyDiagOpts  -- diagnostic options+      []             -- supported extensions (for LANGUAGE pragmas)+      False          -- safe imports+      True           -- allow Haddock comments+      True           -- keep comments+      False          -- keep block comments as tokens
+ src/HsMin/Print.hs view
@@ -0,0 +1,663 @@+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}+module HsMin.Print+  ( printModule+  , PrintOpts(..)+  , defaultPrintOpts+  ) where++import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Hs+import GHC.Types.Basic (OverlapMode(..))+import GHC.Types.Name.Reader (rdrNameOcc)+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.SrcLoc (Located, GenLocated(..), unLoc)+import GHC.Types.SourceText (IntegralLit(..))+import GHC.Utils.Outputable (Outputable, showPprUnsafe)+import Language.Haskell.Syntax.Basic (Boxity(..))++-- | Options controlling compact printing+data PrintOpts = PrintOpts+  { poUseBraces :: Bool  -- ^ Use {;} syntax instead of layout+  } deriving (Show, Eq)++-- | Default print options: use braces+defaultPrintOpts :: PrintOpts+defaultPrintOpts = PrintOpts+  { poUseBraces = True+  }++-- | Print a parsed module in compact form+printModule :: PrintOpts -> Located (HsModule GhcPs) -> String+printModule opts (L _ modl) = case modl of+  HsModule _ext mname mexports imports decls ->+    header ++ body+    where+      header :: String+      header = printModuleHeader opts mname mexports+      bodyItems :: [String]+      bodyItems = filter (not . null)+        ( map (printImport opts) imports+       ++ map (printDecl opts) decls+        )+      body :: String+      body+        | null bodyItems = ""+        | poUseBraces opts = "{" ++ intercalate ";" bodyItems ++ "}"+        | otherwise = intercalate ";" bodyItems+  XModule x -> absurd' x++-- | Print module header: module Name (exports) where+printModuleHeader :: PrintOpts -> Maybe (XRec GhcPs ModuleName) -> Maybe (XRec GhcPs [LIE GhcPs]) -> String+printModuleHeader _opts Nothing _ = ""+printModuleHeader opts (Just (L _ mname)) mexports =+  "module " ++ moduleNameString mname ++ exportList ++ " where"+  where+    exportList = case mexports of+      Nothing -> ""+      Just (L _ ies) -> "(" ++ intercalate "," (map (printIE opts) ies) ++ ")"++-- | Print an import/export item+printIE :: PrintOpts -> LIE GhcPs -> String+printIE _opts (L _ ie) = case ie of+  IEVar _ lname _ -> ppr lname+  IEThingAbs _ lname _ -> ppr lname+  IEThingAll _ lname _ -> ppr lname ++ "(..)"+  IEThingWith _ lname _ pieces _ ->+    ppr lname ++ "(" ++ intercalate "," (map ppr pieces) ++ ")"+  IEModuleContents _ (L _ mn) -> "module " ++ moduleNameString mn+  IEGroup {} -> ""+  IEDoc {} -> ""+  IEDocNamed {} -> ""++-- | Print a single import declaration+printImport :: PrintOpts -> LImportDecl GhcPs -> String+printImport _opts (L _ decl) =+  "import " ++ qual ++ src ++ moduleNameString (unLoc (ideclName decl)) ++ alias ++ hiding ++ impList+  where+    qual = if ideclQualified decl /= NotQualified then "qualified " else ""+    src = case ideclSource decl of+      IsBoot -> "{-# SOURCE #-} "+      NotBoot -> ""+    alias = case ideclAs decl of+      Nothing -> ""+      Just (L _ mn) -> " as " ++ moduleNameString mn+    (hiding, impList) = case ideclImportList decl of+      Nothing -> ("", "")+      Just (EverythingBut, L _ ies) ->+        (" hiding", "(" ++ intercalate "," (map (printIE defaultPrintOpts) ies) ++ ")")+      Just (Exactly, L _ ies) ->+        ("", "(" ++ intercalate "," (map (printIE defaultPrintOpts) ies) ++ ")")++-- | Print a single declaration+printDecl :: PrintOpts -> LHsDecl GhcPs -> String+printDecl opts (L _ decl) = case decl of+  TyClD _ tycl   -> printTyClDecl opts tycl+  InstD _ inst    -> printInstDecl opts inst+  ValD _ bind     -> printBind opts bind+  SigD _ sig      -> printSig opts sig+  WarningD {} -> ""+  DocD {} -> ""+  _ -> ppr decl++-- | Print type class and data declarations+printTyClDecl :: PrintOpts -> TyClDecl GhcPs -> String+printTyClDecl opts decl = case decl of+  SynDecl _ lname tvs _fix rhs ->+    "type " ++ pn lname ++ printTyVarBndrs opts tvs ++ "=" ++ printType opts (unLoc rhs)+  DataDecl _ lname tvs _fix defn ->+    printDataDefn opts (pn lname ++ printTyVarBndrs opts tvs) defn+  ClassDecl _ ctx lname tvs _fix _fds sigs meths ats atdefs _ ->+    "class " ++ printContext opts ctx ++ pn lname ++ printTyVarBndrs opts tvs ++ " where"+    ++ braceBlock opts (+         map (printSig opts . unLoc) sigs+      ++ map (printBind opts . unLoc) meths+      ++ map (ppr . unLoc) ats+      ++ map ppr atdefs+    )+  _ -> ppr decl++-- | Print a data/newtype definition+printDataDefn :: PrintOpts -> String -> HsDataDefn GhcPs -> String+printDataDefn opts header defn =+  keyword ++ header ++ ctx ++ eqOrWhere ++ consPart ++ derivs+  where+    keyword = case dd_cons defn of+      NewTypeCon _ -> "newtype "+      DataTypeCons False _ -> "data "+      DataTypeCons True _ -> "type data "+    ctx = printContext opts (dd_ctxt defn)+    cons = case dd_cons defn of+      NewTypeCon con -> [printConDecl opts (unLoc con)]+      DataTypeCons _ cs -> map (printConDecl opts . unLoc) cs+    (eqOrWhere, consPart) = case cons of+      [] -> ("", "")+      _  -> ("=", intercalate "|" cons)+    derivs = concatMap (printDerivingClause opts . unLoc) (dd_derivs defn)++-- | Print a constructor declaration+printConDecl :: PrintOpts -> ConDecl GhcPs -> String+printConDecl opts con = case con of+  ConDeclGADT _ names _bndrs _ctx _args res _ ->+    intercalate "," (map pn (toList' names)) ++ "::" ++ printType opts (unLoc res)+  ConDeclH98 _ lname _forall _tvs _ctx details _ ->+    pn lname ++ printConDeclDetails opts details+  XConDecl x -> absurd' x++-- | Print constructor details (arguments)+printConDeclDetails :: PrintOpts -> HsConDeclH98Details GhcPs -> String+printConDeclDetails opts details = case details of+  PrefixCon _ args -> concatMap (\a -> " " ++ printType opts (unLoc (hsScaledThing a))) args+  RecCon (L _ fields) ->+    "{" ++ intercalate "," (map (printConDeclField opts . unLoc) fields) ++ "}"+  InfixCon a1 a2 ->+    " " ++ printType opts (unLoc (hsScaledThing a1)) ++ " " ++ printType opts (unLoc (hsScaledThing a2))++-- | Print a record field+printConDeclField :: PrintOpts -> ConDeclField GhcPs -> String+printConDeclField opts (ConDeclField _ names ty _) =+  intercalate "," (map pn names) ++ "::" ++ printType opts (unLoc ty)++-- | Print instance declarations+printInstDecl :: PrintOpts -> InstDecl GhcPs -> String+printInstDecl opts inst = case inst of+  ClsInstD _ cid -> printClsInstDecl opts cid+  _ -> ppr inst++-- | Print class instance declaration+printClsInstDecl :: PrintOpts -> ClsInstDecl GhcPs -> String+printClsInstDecl opts cid =+  "instance " ++ printOverlapPragma (cid_overlap_mode cid)+  ++ printSigType opts (unLoc (cid_poly_ty cid))+  ++ " where" ++ braceBlock opts (+       map (printBind opts . unLoc) (cid_binds cid)+    ++ map (printSig opts . unLoc) (cid_sigs cid)+  )++-- | Print overlap pragma+printOverlapPragma :: Maybe (XRec GhcPs OverlapMode) -> String+printOverlapPragma Nothing = ""+printOverlapPragma (Just (L _ mode)) = case mode of+  NoOverlap _    -> ""+  Overlappable _ -> "{-# OVERLAPPABLE #-} "+  Overlapping _  -> "{-# OVERLAPPING #-} "+  Overlaps _     -> "{-# OVERLAPS #-} "+  Incoherent _   -> "{-# INCOHERENT #-} "+  NonCanonical _ -> "{-# NONCANONICAL #-} "++-- | Print a deriving clause+printDerivingClause :: PrintOpts -> HsDerivingClause GhcPs -> String+printDerivingClause opts (HsDerivingClause _ strat dcs) =+  " deriving " ++ stratBefore ++ printDerivClauseTys dcs ++ stratAfter+  where+    (stratBefore, stratAfter) = case strat of+      Nothing -> ("", "")+      Just (L _ s) -> case s of+        StockStrategy _ -> ("stock ", "")+        AnyclassStrategy _ -> ("anyclass ", "")+        NewtypeStrategy _ -> ("newtype ", "")+        ViaStrategy (XViaStrategyPs _ sigTy) -> ("", " via " ++ printSigType opts (unLoc sigTy))+    printDerivClauseTys :: LDerivClauseTys GhcPs -> String+    printDerivClauseTys (L _ dct) = case dct of+      DctSingle _ ty -> printSigType opts (unLoc ty)+      DctMulti _ tys -> "(" ++ intercalate "," (map (printSigType opts . unLoc) tys) ++ ")"+      XDerivClauseTys x -> absurd' x++-- | Print a context (class constraints)+printContext :: PrintOpts -> Maybe (LHsContext GhcPs) -> String+printContext _opts Nothing = ""+printContext _opts (Just (L _ [])) = ""+printContext opts (Just (L _ [ct])) = printType opts (unLoc ct) ++ "=>"+printContext opts (Just (L _ cts)) =+  "(" ++ intercalate "," (map (printType opts . unLoc) cts) ++ ")=>"++-- | Print a binding (function definition, pattern binding, etc.)+printBind :: PrintOpts -> HsBindLR GhcPs GhcPs -> String+printBind opts bind = case bind of+  FunBind _ lid matches ->+    printMatchGroup opts (pn lid) matches+  PatBind _ pat _mult rhs ->+    printPat opts (unLoc pat) ++ printGRHSs opts "=" rhs+  _ -> ppr bind++-- | Print a signature+printSig :: PrintOpts -> Sig GhcPs -> String+printSig opts sig = case sig of+  TypeSig _ names ty ->+    intercalate "," (map pn names) ++ "::" ++ printSigType opts (unLoc (hswc_body ty))+  PatSynSig _ names ty ->+    "pattern " ++ intercalate "," (map pn names) ++ "::" ++ printSigType opts (unLoc ty)+  ClassOpSig _ deflt names ty ->+    (if deflt then "default " else "") ++ intercalate "," (map pn names) ++ "::" ++ printSigType opts (unLoc ty)+  FixSig _ (FixitySig _ names fixity) ->+    ppr fixity ++ " " ++ intercalate "," (map pn names)+  _ -> ppr sig++-- | Print match groups (for function definitions)+printMatchGroup :: PrintOpts -> String -> MatchGroup GhcPs (LHsExpr GhcPs) -> String+printMatchGroup opts fname (MG _ (L _ matches)) =+  intercalate ";" (map (printMatch opts fname) matches)++-- | Print a single match (one equation)+printMatch :: PrintOpts -> String -> LMatch GhcPs (LHsExpr GhcPs) -> String+printMatch opts fname (L _ (Match _ ctx lpats rhs)) = case ctx of+  FunRhs {} ->+    fname ++ concatMap (\p -> " " ++ printPatPrec opts (unLoc p)) pats ++ printGRHSs opts "=" rhs+  CaseAlt ->+    intercalate " " (map (printPatTop opts . unLoc) pats) ++ printGRHSs opts "->" rhs+  LamAlt _ ->+    intercalate " " (map (printPatPrec opts . unLoc) pats) ++ printGRHSs opts "->" rhs+  _ -> ppr (Match noExtField ctx lpats rhs)+  where+    pats :: [LPat GhcPs]+    pats = unLoc lpats++-- | Print GRHSs (guarded right-hand sides + where clause)+printGRHSs :: PrintOpts -> String -> GRHSs GhcPs (LHsExpr GhcPs) -> String+printGRHSs opts sep (GRHSs _ grhss binds) =+  concatMap (printGRHS opts sep) grhss ++ printLocalBinds opts binds++-- | Print a single GRHS+printGRHS :: PrintOpts -> String -> LGRHS GhcPs (LHsExpr GhcPs) -> String+printGRHS opts sep (L _ (GRHS _ guards body)) = case guards of+  [] -> sep ++ " " ++ printExpr opts (unLoc body)+  gs -> "|" ++ intercalate "," (map (printStmt opts . unLoc) gs) ++ sep ++ " " ++ printExpr opts (unLoc body)++-- | Print local bindings (where clause)+printLocalBinds :: PrintOpts -> HsLocalBinds GhcPs -> String+printLocalBinds opts binds = case binds of+  EmptyLocalBinds _ -> ""+  HsValBinds _ vbs -> case vbs of+    ValBinds _ bs sigs ->+      " where" ++ braceBlock opts (+           map (printSig opts . unLoc) sigs+        ++ map (printBind opts . unLoc) bs+      )+    XValBindsLR _ -> ""+  HsIPBinds {} -> ppr binds++-- | Print an expression+printExpr :: PrintOpts -> HsExpr GhcPs -> String+printExpr opts expr = case expr of+  HsVar _ lid -> pn lid+  HsUnboundVar _ rn -> pn rn+  HsOverLit _ olit -> printOverLit olit+  HsLit _ lit -> printLit lit+  HsLam _ variant mg -> printLamExpr opts variant mg+  HsApp _ f x -> printExpr opts (unLoc f) ++ " " ++ printExprPrec opts (unLoc x)+  OpApp _ l op r ->+    printExpr opts (unLoc l) ++ opStr ++ printExpr opts (unLoc r)+    where+      opStr :: String+      opStr = case unLoc op of+        HsVar _ (L _ rn) ->+          let s = occNameString (rdrNameOcc rn)+          in if isOp s then s else "`" ++ s ++ "`"+        _ -> " " ++ printExpr opts (unLoc op) ++ " "+  NegApp _ e _ -> "-" ++ printExprPrec opts (unLoc e)+  HsPar _ e -> "(" ++ printExpr opts (unLoc e) ++ ")"+  SectionL _ e op -> "(" ++ printExpr opts (unLoc e) ++ " " ++ printExpr opts (unLoc op) ++ ")"+  SectionR _ op e -> "(" ++ printExpr opts (unLoc op) ++ " " ++ printExpr opts (unLoc e) ++ ")"+  ExplicitTuple _ args boxity ->+    let (open, close) = case boxity of+          Boxed -> ("(", ")")+          Unboxed -> ("(#", "#)")+    in open ++ intercalate "," (map (printTupArg opts) args) ++ close+  HsCase _ scrut mg ->+    "case " ++ printExpr opts (unLoc scrut) ++ " of" ++ braceBlock opts (printCaseAlts opts mg)+  HsIf _ cond t f ->+    "if " ++ printExpr opts (unLoc cond) ++ " then " ++ printExpr opts (unLoc t) ++ " else " ++ printExpr opts (unLoc f)+  HsMultiIf _ grhss ->+    "if" ++ braceBlock opts (map (printGRHS opts "->") grhss)+  HsLet _ lbinds body ->+    "let" ++ printLetBinds opts lbinds ++ " in " ++ printExpr opts (unLoc body)+  HsDo _ flavour (L _ stmts) ->+    printDoExpr opts flavour stmts+  ExplicitList _ exprs ->+    "[" ++ intercalate "," (map (printExpr opts . unLoc) exprs) ++ "]"+  RecordCon _ con fields ->+    pn con ++ printRecFields opts fields+  ExprWithTySig _ e ty ->+    printExpr opts (unLoc e) ++ "::" ++ printSigType opts (unLoc (hswc_body ty))+  ArithSeq _ _ info -> printArithSeq opts info+  HsTypedBracket _ e -> "[||" ++ printExpr opts (unLoc e) ++ "||]"+  HsTypedSplice _ e -> "$$(" ++ printExpr opts (unLoc e) ++ ")"+  HsStatic _ e -> "static " ++ printExpr opts (unLoc e)+  HsGetField _ e (L _ fld) -> printExpr opts (unLoc e) ++ "." ++ ppr fld+  HsPragE _ _ e -> printExpr opts (unLoc e)+  XExpr x -> absurd' x+  _ -> ppr expr++-- | Print expression with parentheses if it's a complex expression+printExprPrec :: PrintOpts -> HsExpr GhcPs -> String+printExprPrec opts e = case e of+  HsApp {} -> "(" ++ printExpr opts e ++ ")"+  OpApp {} -> "(" ++ printExpr opts e ++ ")"+  NegApp {} -> "(" ++ printExpr opts e ++ ")"+  HsLam {} -> "(" ++ printExpr opts e ++ ")"+  HsCase {} -> "(" ++ printExpr opts e ++ ")"+  HsIf {} -> "(" ++ printExpr opts e ++ ")"+  HsLet {} -> "(" ++ printExpr opts e ++ ")"+  HsDo {} -> "(" ++ printExpr opts e ++ ")"+  ExprWithTySig {} -> "(" ++ printExpr opts e ++ ")"+  _ -> printExpr opts e++-- | Print lambda expressions+printLamExpr :: PrintOpts -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> String+printLamExpr opts variant mg@(MG _ (L _ matches)) = case variant of+  LamSingle -> "\\" ++ concatMap printLamMatch matches+  LamCase -> "\\case" ++ braceBlock opts (printCaseAlts opts mg)+  LamCases -> "\\cases" ++ braceBlock opts (printCaseAlts opts mg)+  where+    printLamMatch :: LMatch GhcPs (LHsExpr GhcPs) -> String+    printLamMatch (L _ (Match _ _ lpats2 rhs)) =+      intercalate " " (map (printPatPrec opts . unLoc) (unLoc lpats2)) ++ printGRHSs opts " ->" rhs++-- | Print case alternatives from a MatchGroup+printCaseAlts :: PrintOpts -> MatchGroup GhcPs (LHsExpr GhcPs) -> [String]+printCaseAlts opts (MG _ (L _ matches)) =+  map printAlt matches+  where+    printAlt :: LMatch GhcPs (LHsExpr GhcPs) -> String+    printAlt (L _ (Match _ _ lpats2 rhs)) =+      intercalate " " (map (printPatTop opts . unLoc) (unLoc lpats2)) ++ printGRHSs opts "->" rhs++-- | Print do-expression+printDoExpr :: PrintOpts -> HsDoFlavour -> [ExprLStmt GhcPs] -> String+printDoExpr opts flavour stmts = case flavour of+  ListComp -> printListComp opts stmts+  MonadComp -> printListComp opts stmts+  DoExpr Nothing -> "do" ++ braceBlock opts (map (printStmt opts . unLoc) stmts)+  DoExpr (Just m) -> moduleNameString m ++ ".do" ++ braceBlock opts (map (printStmt opts . unLoc) stmts)+  MDoExpr Nothing -> "mdo" ++ braceBlock opts (map (printStmt opts . unLoc) stmts)+  MDoExpr (Just m) -> moduleNameString m ++ ".mdo" ++ braceBlock opts (map (printStmt opts . unLoc) stmts)+  GhciStmtCtxt -> "do" ++ braceBlock opts (map (printStmt opts . unLoc) stmts)++-- | Print a list comprehension: [body | quals]+printListComp :: PrintOpts -> [ExprLStmt GhcPs] -> String+printListComp opts stmts =+  case splitLast stmts of+    Nothing -> "[]"+    Just (quals, lastStmt) ->+      "[" ++ printStmt opts (unLoc lastStmt)+      ++ "|" ++ intercalate "," (map (printCompStmt opts . unLoc) quals)+      ++ "]"+  where+    splitLast :: [a] -> Maybe ([a], a)+    splitLast [] = Nothing+    splitLast [x] = Just ([], x)+    splitLast (x:xs) = case splitLast xs of+      Nothing -> Nothing+      Just (rest, l) -> Just (x:rest, l)++-- | Print a comprehension qualifier (bind, body guard)+printCompStmt :: PrintOpts -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> String+printCompStmt opts stmt = case stmt of+  BindStmt _ pat body -> printPat opts (unLoc pat) ++ "<-" ++ printExpr opts (unLoc body)+  BodyStmt _ body _ _ -> printExpr opts (unLoc body)+  LetStmt _ lbinds -> "let " ++ printLocalBindsInline opts lbinds+  _ -> ppr stmt++-- | Print a statement+printStmt :: PrintOpts -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> String+printStmt opts stmt = case stmt of+  LastStmt _ body _ _ -> printExpr opts (unLoc body)+  BindStmt _ pat body -> printPat opts (unLoc pat) ++ "<-" ++ printExpr opts (unLoc body)+  BodyStmt _ body _ _ -> printExpr opts (unLoc body)+  LetStmt _ lbinds -> "let" ++ printLocalBindsInline opts lbinds+  _ -> ppr stmt++-- | Print local bindings inline (for let in do blocks)+printLocalBindsInline :: PrintOpts -> HsLocalBinds GhcPs -> String+printLocalBindsInline opts lbinds = case lbinds of+  EmptyLocalBinds _ -> ""+  HsValBinds _ vbs -> case vbs of+    ValBinds _ bs sigs ->+      braceBlock opts (+           map (printSig opts . unLoc) sigs+        ++ map (printBind opts . unLoc) bs+      )+    XValBindsLR _ -> ""+  HsIPBinds {} -> ppr lbinds++-- | Print let bindings+printLetBinds :: PrintOpts -> HsLocalBinds GhcPs -> String+printLetBinds = printLocalBindsInline++-- | Print record fields (for RecordCon expressions)+printRecFields :: PrintOpts -> HsRecordBinds GhcPs -> String+printRecFields opts (HsRecFields _ fields dotdot) =+  "{" ++ intercalate "," (map printField fields ++ dotPart) ++ "}"+  where+    printField :: LHsRecField GhcPs (LHsExpr GhcPs) -> String+    printField (L _ (HsFieldBind _ lbl arg _pun)) =+      ppr lbl ++ "=" ++ printExpr opts (unLoc arg)+    dotPart :: [String]+    dotPart = case dotdot of+      Nothing -> []+      Just _ -> [".."]++-- | Print record fields (for constructor patterns)+printRecPatFields :: PrintOpts -> HsRecFields GhcPs (LPat GhcPs) -> String+printRecPatFields opts (HsRecFields _ fields dotdot) =+  "{" ++ intercalate "," (map printField fields ++ dotPart) ++ "}"+  where+    printField :: LHsRecField GhcPs (LPat GhcPs) -> String+    printField (L _ (HsFieldBind _ lbl arg _pun)) =+      ppr lbl ++ "=" ++ printPat opts (unLoc arg)+    dotPart :: [String]+    dotPart = case dotdot of+      Nothing -> []+      Just _ -> [".."]++-- | Print a tuple argument+printTupArg :: PrintOpts -> HsTupArg GhcPs -> String+printTupArg opts (Present _ e) = printExpr opts (unLoc e)+printTupArg _opts (Missing _) = ""++-- | Print arithmetic sequences+printArithSeq :: PrintOpts -> ArithSeqInfo GhcPs -> String+printArithSeq opts info = case info of+  From e -> "[" ++ printExpr opts (unLoc e) ++ "..]"+  FromThen e1 e2 -> "[" ++ printExpr opts (unLoc e1) ++ "," ++ printExpr opts (unLoc e2) ++ "..]"+  FromTo e1 e2 -> "[" ++ printExpr opts (unLoc e1) ++ ".." ++ printExpr opts (unLoc e2) ++ "]"+  FromThenTo e1 e2 e3 ->+    "[" ++ printExpr opts (unLoc e1) ++ "," ++ printExpr opts (unLoc e2) ++ ".." ++ printExpr opts (unLoc e3) ++ "]"++-- | Print an overloaded literal+printOverLit :: HsOverLit GhcPs -> String+printOverLit (OverLit _ val) = case val of+  HsIntegral il -> show (il_value il)+  HsFractional fl -> ppr fl+  HsIsString _ fs -> show fs++-- | Print a literal+printLit :: HsLit GhcPs -> String+printLit lit = case lit of+  HsChar _ c -> show c+  HsCharPrim _ c -> show c ++ "#"+  HsString _ fs -> show fs+  HsInt _ il -> show (il_value il)+  HsIntPrim _ i -> show i ++ "#"+  HsWordPrim _ i -> show i ++ "##"+  XLit x -> absurd' x+  _ -> ppr lit++-- | Print a pattern (top-level, no extra parens needed)+printPatTop :: PrintOpts -> Pat GhcPs -> String+printPatTop = printPat++-- | Print a pattern+printPat :: PrintOpts -> Pat GhcPs -> String+printPat opts pat = case pat of+  WildPat _ -> "_"+  VarPat _ lid -> pn lid+  LazyPat _ p -> "~" ++ printPatPrec opts (unLoc p)+  AsPat _ lid p -> pn lid ++ "@" ++ printPatPrec opts (unLoc p)+  ParPat _ p -> "(" ++ printPat opts (unLoc p) ++ ")"+  BangPat _ p -> "!" ++ printPatPrec opts (unLoc p)+  ListPat _ ps -> "[" ++ intercalate "," (map (printPat opts . unLoc) ps) ++ "]"+  TuplePat _ ps boxity ->+    let (open, close) = case boxity of+          Boxed -> ("(", ")")+          Unboxed -> ("(#", "#)")+    in open ++ intercalate "," (map (printPat opts . unLoc) ps) ++ close+  ConPat _ con details -> printConPatDetails opts con details+  ViewPat _ e p -> "(" ++ printExpr opts (unLoc e) ++ "->" ++ printPat opts (unLoc p) ++ ")"+  LitPat _ lit -> printLit lit+  NPat _ lit _ _ -> ppr lit+  SigPat _ p ty -> printPat opts (unLoc p) ++ "::" ++ printType opts (unLoc (hsps_body ty))+  OrPat _ ps -> intercalate ";" (map (printPat opts . unLoc) (toList' ps))+  _ -> ppr pat++-- | Print a pattern with parentheses if complex+printPatPrec :: PrintOpts -> Pat GhcPs -> String+printPatPrec opts p = case p of+  ConPat _ _ (PrefixCon _ (_:_)) -> "(" ++ printPat opts p ++ ")"+  ConPat _ _ (InfixCon _ _) -> "(" ++ printPat opts p ++ ")"+  AsPat {} -> "(" ++ printPat opts p ++ ")"+  ViewPat {} -> "(" ++ printPat opts p ++ ")"+  SigPat {} -> "(" ++ printPat opts p ++ ")"+  _ -> printPat opts p++-- | Print constructor pattern details+printConPatDetails :: PrintOpts -> XRec GhcPs (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> String+printConPatDetails opts con details = case details of+  PrefixCon _tys args ->+    pn (unLoc con) ++ concatMap (\a -> " " ++ printPatPrec opts (unLoc a)) args+  RecCon recFields ->+    pn (unLoc con) ++ printRecPatFields opts recFields+  InfixCon p1 p2 ->+    printPatPrec opts (unLoc p1) ++ " " ++ pn (unLoc con) ++ " " ++ printPatPrec opts (unLoc p2)++-- | Print a type+printType :: PrintOpts -> HsType GhcPs -> String+printType opts ty = case ty of+  HsForAllTy _ tele body ->+    printForAllTele opts tele ++ printType opts (unLoc body)+  HsQualTy _ ctx body ->+    printContext opts (Just ctx) ++ printType opts (unLoc body)+  HsTyVar _ prom lid ->+    (if isPromotedFlag prom then "'" else "") ++ pn lid+  HsAppTy _ f x -> printType opts (unLoc f) ++ " " ++ printTypePrec opts (unLoc x)+  HsAppKindTy _ f x -> printType opts (unLoc f) ++ " @" ++ printTypePrec opts (unLoc x)+  HsFunTy _ _arr l r ->+    printType opts (unLoc l) ++ "->" ++ printType opts (unLoc r)+  HsListTy _ t -> "[" ++ printType opts (unLoc t) ++ "]"+  HsTupleTy _ sort ts ->+    let (open, close) = case sort of+          HsUnboxedTuple -> ("(#", "#)")+          _ -> ("(", ")")+    in open ++ intercalate "," (map (printType opts . unLoc) ts) ++ close+  HsSumTy _ ts ->+    "(#" ++ intercalate "|" (map (printType opts . unLoc) ts) ++ "#)"+  HsOpTy _ prom l op r ->+    printType opts (unLoc l) ++ " " ++ (if isPromotedFlag prom then "'" else "") ++ pn op ++ " " ++ printType opts (unLoc r)+  HsParTy _ t -> "(" ++ printType opts (unLoc t) ++ ")"+  HsKindSig _ t k -> printType opts (unLoc t) ++ "::" ++ printType opts (unLoc k)+  HsDocTy _ t _ -> printType opts (unLoc t)+  HsBangTy _ bang t -> printHsBang bang ++ printType opts (unLoc t)+  HsRecTy _ fields ->+    "{" ++ intercalate "," (map (printConDeclField opts . unLoc) fields) ++ "}"+  HsExplicitListTy _ prom ts ->+    (if isPromotedFlag prom then "'" else "") ++ "[" ++ intercalate "," (map (printType opts . unLoc) ts) ++ "]"+  HsExplicitTupleTy _ prom ts ->+    (if isPromotedFlag prom then "'" else "")+    ++ "(" ++ intercalate "," (map (printType opts . unLoc) ts) ++ ")"+  HsTyLit _ tlit -> printTyLit tlit+  HsWildCardTy _ -> "_"+  _ -> ppr ty++-- | Print a HsSigType+printSigType :: PrintOpts -> HsSigType GhcPs -> String+printSigType opts (HsSig _ _bndrs body) = printType opts (unLoc body)+printSigType _opts (XHsSigType x) = absurd' x++-- | Print a type with parentheses if complex+printTypePrec :: PrintOpts -> HsType GhcPs -> String+printTypePrec opts t = case t of+  HsAppTy {} -> "(" ++ printType opts t ++ ")"+  HsFunTy {} -> "(" ++ printType opts t ++ ")"+  HsForAllTy {} -> "(" ++ printType opts t ++ ")"+  HsQualTy {} -> "(" ++ printType opts t ++ ")"+  HsOpTy {} -> "(" ++ printType opts t ++ ")"+  _ -> printType opts t++-- | Print forall telescope+printForAllTele :: PrintOpts -> HsForAllTelescope GhcPs -> String+printForAllTele opts tele = case tele of+  HsForAllVis _ bndrs ->+    "forall " ++ unwords (map (printTyVarBndr opts . unLoc) bndrs) ++ " -> "+  HsForAllInvis _ bndrs ->+    "forall " ++ unwords (map (printTyVarBndr opts . unLoc) bndrs) ++ "."++-- | Print type variable binders+printTyVarBndrs :: PrintOpts -> LHsQTyVars GhcPs -> String+printTyVarBndrs opts (HsQTvs _ tvs) =+  concatMap (\tv -> " " ++ printTyVarBndr opts (unLoc tv)) tvs++-- | Print a single type variable binder (9.12 uses HsTvb record)+printTyVarBndr :: PrintOpts -> HsTyVarBndr flag GhcPs -> String+printTyVarBndr opts tvb = case tvb of+  HsTvb _ _ bndrVar bndrKind -> printBndrVar bndrVar bndrKind+  XTyVarBndr x -> absurd' x+  where+    printBndrVar :: HsBndrVar GhcPs -> HsBndrKind GhcPs -> String+    printBndrVar (HsBndrVar _ lid) (HsBndrNoKind _) = pn lid+    printBndrVar (HsBndrVar _ lid) (HsBndrKind _ kind) =+      "(" ++ pn lid ++ "::" ++ printType opts (unLoc kind) ++ ")"+    printBndrVar (HsBndrWildCard _) _ = "_"+    printBndrVar (XBndrVar x) _ = absurd' x++-- | Print bang type annotation+printHsBang :: HsBang -> String+printHsBang (HsBang unpk strict) =+  unpackedness ++ strictness+  where+    unpackedness = case unpk of+      SrcUnpack   -> "{-# UNPACK #-}"+      SrcNoUnpack -> "{-# NOUNPACK #-}"+      NoSrcUnpack -> ""+    strictness = case strict of+      SrcLazy    -> "~"+      SrcStrict  -> "!"+      NoSrcStrict -> ""++-- | Print a type literal+printTyLit :: HsTyLit GhcPs -> String+printTyLit tlit = case tlit of+  HsNumTy _ i -> show i+  HsStrTy _ fs -> show fs+  HsCharTy _ c -> show c++-- | Check if promoted+isPromotedFlag :: PromotionFlag -> Bool+isPromotedFlag IsPromoted = True+isPromotedFlag NotPromoted = False++-- | Format a block using {;} syntax+braceBlock :: PrintOpts -> [String] -> String+braceBlock opts items+  | poUseBraces opts = "{" ++ intercalate ";" (filter (not . null) items) ++ "}"+  | otherwise = " " ++ intercalate "; " (filter (not . null) items)++-- | Check if a string represents an operator+isOp :: String -> Bool+isOp [] = False+isOp (c:_) = not (elem c (['a'..'z'] ++ ['A'..'Z'] ++ ['_']))++-- | Print name from located thing using Outputable+pn :: Outputable a => a -> String+pn = showPprUnsafe++-- | Fallback: use GHC's Outputable+ppr :: Outputable a => a -> String+ppr = showPprUnsafe++-- | Convert NonEmpty to list+toList' :: NonEmpty a -> [a]+toList' (x :| xs) = x : xs++-- | Eliminate impossible cases+absurd' :: DataConCantHappen -> a+absurd' x = case x of {}
+ src/HsMin/Transform.hs view
@@ -0,0 +1,47 @@+module HsMin.Transform+  ( minifySource+  , MinifyOpts(..)+  , defaultMinifyOpts+  ) where++import Data.List (isPrefixOf)++import HsMin.Parse (parseModule, ParseError(..))+import HsMin.Print (printModule, PrintOpts(..), defaultPrintOpts)++-- | Options controlling the minification pipeline+data MinifyOpts = MinifyOpts+  { moUseBraces   :: Bool  -- ^ Convert layout to {;} syntax+  , moRename      :: Bool  -- ^ Rename local identifiers (Phase 2)+  , moPointfree   :: Bool  -- ^ Apply eta reduction (Phase 3)+  } deriving (Show, Eq)++-- | Default options: all transformations enabled+defaultMinifyOpts :: MinifyOpts+defaultMinifyOpts = MinifyOpts+  { moUseBraces   = True+  , moRename      = False  -- Not yet implemented+  , moPointfree   = False  -- Not yet implemented+  }++-- | Minify Haskell source code.+--   Returns either a parse error or the minified source.+minifySource :: MinifyOpts -> FilePath -> String -> Either String String+minifySource opts filename src =+  case parseModule filename src of+    Left (ParseFailed _ps) -> Left "Parse error"+    Right modl ->+      let printOpts = defaultPrintOpts+            { poUseBraces = moUseBraces opts+            }+          pragmas = extractOptionsPragmas src+      in Right (pragmas ++ printModule printOpts modl)++-- | Extract OPTIONS_GHC pragmas from source (not preserved in AST)+extractOptionsPragmas :: String -> String+extractOptionsPragmas src =+  concatMap (\l -> l ++ "\n") (filter isOptionsPragma (lines src))+  where+    isOptionsPragma :: String -> Bool+    isOptionsPragma line =+      "{-# OPTIONS_GHC" `isPrefixOf` dropWhile (== ' ') line
+ src/HsMin/Util.hs view
@@ -0,0 +1,33 @@+module HsMin.Util+  ( nameStream+  , occNameStr+  , rdrNameStr+  , isOperator+  , pprCompact+  ) where++import Data.Char (isAlphaNum)+import GHC.Types.Name.Reader (RdrName, rdrNameOcc)+import GHC.Types.Name.Occurrence (OccName, occNameString)+import GHC.Utils.Outputable (Outputable, showPprUnsafe)++-- | Infinite stream of short variable names: a, b, ... z, aa, ab, ...+nameStream :: [String]+nameStream = [c : rest | rest <- "" : nameStream, c <- ['a'..'z']]++-- | Extract the string from an OccName+occNameStr :: OccName -> String+occNameStr = occNameString++-- | Extract the string from an RdrName+rdrNameStr :: RdrName -> String+rdrNameStr = occNameStr . rdrNameOcc++-- | Check if a name string is an operator (starts with non-alphanumeric, non-underscore)+isOperator :: String -> Bool+isOperator [] = False+isOperator (c:_) = not (isAlphaNum c) && c /= '_' && c /= '\''++-- | Compact rendering using GHC's own pretty-printer (fallback)+pprCompact :: Outputable a => a -> String+pprCompact = showPprUnsafe
+ test/Test.hs view
@@ -0,0 +1,16 @@+module Main where++import Test.Tasty++import Test.Parse qualified+import Test.Print qualified+import Test.Integration qualified+import Test.E2E qualified++main :: IO ()+main = defaultMain $ testGroup "hsmin"+  [ Test.Parse.tests+  , Test.Print.tests+  , Test.Integration.tests+  , Test.E2E.tests+  ]
+ test/Test/E2E.hs view
@@ -0,0 +1,115 @@+module Test.E2E (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import System.Exit (ExitCode(..))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcessWithExitCode, proc, cwd, readCreateProcessWithExitCode)+import System.Directory (copyFile, createDirectoryIfMissing, getCurrentDirectory)+import System.FilePath ((</>))++tests :: TestTree+tests = testGroup "E2E"+  [ testCase "bootstrap: minified hsmin produces fixed-point output" bootstrapTest+  ]++-- | The source files that make up the hsmin library and executable+sourceFiles :: [FilePath]+sourceFiles =+  [ "src/HsMin.hs"+  , "src/HsMin/Parse.hs"+  , "src/HsMin/Print.hs"+  , "src/HsMin/Transform.hs"+  , "src/HsMin/Util.hs"+  , "app/Main.hs"+  ]++-- | Bootstrap test: build hsmin, minify its own source, rebuild from+-- minified source, minify again, and verify fixed-point (idempotent).+bootstrapTest :: Assertion+bootstrapTest = do+  projectDir <- getCurrentDirectory+  withSystemTempDirectory "hsmin-e2e" $ \tmpDir -> do+    let minifiedA = tmpDir </> "minified-a"+        minifiedB = tmpDir </> "minified-b"++    -- Step 1: Build the hsmin executable+    _ <- runOrFail projectDir "cabal" ["build", "exe:hsmin"]++    -- Step 2: Find the hsmin executable path+    (_, hsminPath, _) <- runOrFail projectDir "cabal"+      ["list-bin", "hsmin"]+    let hsmin1 = strip hsminPath++    -- Step 3: Minify all source files with hsmin -> minified-a+    createDirectoryIfMissing True (minifiedA </> "src" </> "HsMin")+    createDirectoryIfMissing True (minifiedA </> "app")+    mapM_ (minifyFile hsmin1 projectDir minifiedA) sourceFiles++    -- Step 4: Copy cabal file and build scaffolding to minified-a+    copyFile (projectDir </> "hsmin.cabal") (minifiedA </> "hsmin.cabal")+    copyFile (projectDir </> "LICENSE") (minifiedA </> "LICENSE")++    -- Step 5: Build the minified hsmin (hsmin2)+    _ <- runOrFail minifiedA "cabal" ["build", "exe:hsmin", "-j"]+    (_, hsmin2Path, _) <- runOrFail minifiedA "cabal"+      ["list-bin", "hsmin"]+    let hsmin2 = strip hsmin2Path++    -- Step 6: Minify original source again with hsmin2 -> minified-b+    createDirectoryIfMissing True (minifiedB </> "src" </> "HsMin")+    createDirectoryIfMissing True (minifiedB </> "app")+    mapM_ (minifyFile hsmin2 projectDir minifiedB) sourceFiles++    -- Step 7: Compare minified-a and minified-b (fixed point)+    mapM_ (compareFiles minifiedA minifiedB) sourceFiles++-- | Run a process, failing the test if it exits with non-zero+runOrFail :: FilePath -> FilePath -> [String] -> IO (ExitCode, String, String)+runOrFail cwd cmd args = do+  result@(exitCode, stdout, stderr) <- readProcessWithExitCode' cwd cmd args+  case exitCode of+    ExitSuccess -> pure result+    ExitFailure code ->+      assertFailure $ unlines+        [ "Command failed (exit " ++ show code ++ "): " ++ cmd ++ " " ++ unwords args+        , "cwd: " ++ cwd+        , "stdout: " ++ stdout+        , "stderr: " ++ stderr+        ]+  where+    readProcessWithExitCode' :: FilePath -> FilePath -> [String] -> IO (ExitCode, String, String)+    readProcessWithExitCode' dir prog progArgs = do+      let cp = (proc prog progArgs) { cwd = Just dir }+      readCreateProcessWithExitCode cp ""++-- | Minify a single source file using the hsmin executable+minifyFile :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()+minifyFile hsminExe srcDir outDir relPath = do+  let srcPath = srcDir </> relPath+      outPath = outDir </> relPath+  (exitCode, stdout, stderr) <- readProcessWithExitCode hsminExe [srcPath] ""+  case exitCode of+    ExitSuccess -> writeFile outPath stdout+    ExitFailure code ->+      assertFailure $ unlines+        [ "hsmin failed on " ++ relPath ++ " (exit " ++ show code ++ ")"+        , "stderr: " ++ stderr+        ]++-- | Compare two files, failing if they differ+compareFiles :: FilePath -> FilePath -> FilePath -> IO ()+compareFiles dirA dirB relPath = do+  contentA <- readFile (dirA </> relPath)+  contentB <- readFile (dirB </> relPath)+  assertEqual+    ("Fixed-point check failed for " ++ relPath+      ++ "\n  minified-a: " ++ show contentA+      ++ "\n  minified-b: " ++ show contentB)+    contentA+    contentB++-- | Strip trailing whitespace/newlines+strip :: String -> String+strip = reverse . dropWhile (`elem` (" \n\r\t" :: String)) . reverse
+ test/Test/Integration.hs view
@@ -0,0 +1,159 @@+module Test.Integration (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import HsMin (minify)+import HsMin.Parse (parseModule)++tests :: TestTree+tests = testGroup "Integration"+  [ testCase "handles type classes" $ do+      let src = unlines+            [ "module Foo where"+            , "class MyClass a where"+            , "  myMethod :: a -> Int"+            , "  myDefault :: a -> String"+            , "  myDefault _ = \"default\""+            ]+      assertMinifies src++  , testCase "handles instances" $ do+      let src = unlines+            [ "module Foo where"+            , "class Show' a where"+            , "  show' :: a -> String"+            , "instance Show' Int where"+            , "  show' = show"+            ]+      assertMinifies src++  , testCase "handles data types" $ do+      let src = unlines+            [ "module Foo where"+            , "data Color = Red | Green | Blue"+            , "data Tree a = Leaf a | Branch (Tree a) (Tree a)"+            ]+      assertMinifies src++  , testCase "handles records" $ do+      let src = unlines+            [ "module Foo where"+            , "data Person = Person"+            , "  { name :: String"+            , "  , age :: Int"+            , "  }"+            ]+      assertMinifies src++  , testCase "handles newtypes" $ do+      let src = unlines+            [ "module Foo where"+            , "newtype Wrapper a = Wrapper { unwrap :: a }"+            ]+      assertMinifies src++  , testCase "handles guards" $ do+      let src = unlines+            [ "module Foo where"+            , "abs' :: Int -> Int"+            , "abs' x"+            , "  | x < 0 = negate x"+            , "  | otherwise = x"+            ]+      assertMinifies src++  , testCase "handles let expressions" $ do+      let src = unlines+            [ "module Foo where"+            , "f x = let y = x + 1"+            , "          z = x + 2"+            , "      in y + z"+            ]+      assertMinifies src++  , testCase "handles lambda expressions" $ do+      let src = unlines+            [ "module Foo where"+            , "f = \\x -> x + 1"+            , "g = \\x y -> x + y"+            ]+      assertMinifies src++  , testCase "handles type signatures with constraints" $ do+      let src = unlines+            [ "module Foo where"+            , "f :: (Show a, Eq a) => a -> String"+            , "f x = show x"+            ]+      assertMinifies src++  , testCase "handles list operations" $ do+      let src = unlines+            [ "module Foo where"+            , "xs :: [Int]"+            , "xs = [1, 2, 3]"+            , "ys :: [Int]"+            , "ys = map (\\x -> x + 1) xs"+            ]+      assertMinifies src++  , testCase "handles if-then-else" $ do+      let src = unlines+            [ "module Foo where"+            , "f :: Bool -> Int"+            , "f b = if b then 1 else 0"+            ]+      assertMinifies src++  , testCase "handles qualified imports" $ do+      let src = unlines+            [ "module Foo where"+            , "import qualified Data.Map as Map"+            , "import Data.List (sort, nub)"+            , "x = Map.empty"+            ]+      assertMinifies src++  , testCase "handles infix operators" $ do+      let src = unlines+            [ "module Foo where"+            , "f x y = x + y * 2"+            , "g x = x `div` 2"+            ]+      assertMinifies src++  , testCase "output is always shorter" $ do+      let src = unlines+            [ "module Foo where"+            , ""+            , "-- | Compute the factorial"+            , "factorial :: Integer -> Integer"+            , "factorial n"+            , "  | n <= 0   = 1"+            , "  | otherwise = n * factorial (n - 1)"+            , ""+            , "-- | Main entry point"+            , "main :: IO ()"+            , "main = do"+            , "  putStrLn \"Enter a number:\""+            , "  input <- getLine"+            , "  let n = read input"+            , "  putStrLn $ \"Factorial: \" ++ show (factorial n)"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool ("Output (" ++ show (length result) ++ ") should be shorter than input (" ++ show (length src) ++ "): " ++ show result)+            (length result < length src)+  ]++-- | Assert that source minifies and the result re-parses+assertMinifies :: String -> Assertion+assertMinifies src = do+  case minify "test.hs" src of+    Left err -> assertFailure $ "Minification failed: " ++ err+    Right result ->+      case parseModule "minified.hs" result of+        Left _ -> assertFailure $ "Failed to re-parse minified output:\n" ++ result+        Right _ -> pure ()
+ test/Test/Parse.hs view
@@ -0,0 +1,52 @@+module Test.Parse (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import HsMin.Parse (parseModule)++tests :: TestTree+tests = testGroup "Parse"+  [ testCase "parses simple module" $ do+      let src = "module Foo where\nx = 1\n"+      case parseModule "test.hs" src of+        Left _  -> assertFailure "Failed to parse simple module"+        Right _ -> pure ()++  , testCase "parses module with imports" $ do+      let src = "module Bar where\nimport Data.List\nx = sort [3,1,2]\n"+      case parseModule "test.hs" src of+        Left _  -> assertFailure "Failed to parse module with imports"+        Right _ -> pure ()++  , testCase "parses module with comments" $ do+      let src = unlines+            [ "module Baz where"+            , "-- a comment"+            , "x = 1 -- inline comment"+            , "{- block comment -}"+            , "y = 2"+            ]+      case parseModule "test.hs" src of+        Left _  -> assertFailure "Failed to parse module with comments"+        Right _ -> pure ()++  , testCase "parses do notation" $ do+      let src = unlines+            [ "module DoTest where"+            , "main :: IO ()"+            , "main = do"+            , "  putStrLn \"hello\""+            , "  x <- getLine"+            , "  putStrLn x"+            ]+      case parseModule "test.hs" src of+        Left _  -> assertFailure "Failed to parse do notation"+        Right _ -> pure ()++  , testCase "rejects invalid syntax" $ do+      let src = "module Bad where\nx = = = 1\n"+      case parseModule "test.hs" src of+        Left _  -> pure ()+        Right _ -> assertFailure "Should have failed to parse invalid syntax"+  ]
+ test/Test/Print.hs view
@@ -0,0 +1,105 @@+module Test.Print (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import HsMin (minify)+import HsMin.Parse (parseModule)++tests :: TestTree+tests = testGroup "Print"+  [ testCase "output is shorter than input" $ do+      let src = unlines+            [ "module Foo where"+            , ""+            , "-- | Documentation comment"+            , "x :: Int"+            , "x = 1"+            , ""+            , "-- another comment"+            , "y :: Int"+            , "y = 2"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool ("Output (" ++ show (length result) ++ ") should be shorter than input (" ++ show (length src) ++ ")")+            (length result < length src)++  , testCase "comments are stripped" $ do+      let src = unlines+            [ "module Foo where"+            , "-- a comment"+            , "x = 1"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool "Output should not contain '--'" (not $ "-- a comment" `isInfixOf'` result)++  , testCase "do block uses braces" $ do+      let src = unlines+            [ "module Foo where"+            , "main :: IO ()"+            , "main = do"+            , "  putStrLn \"hello\""+            , "  putStrLn \"world\""+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool ("Output should contain 'do{': " ++ show result)+            ("do{" `isInfixOf'` result)++  , testCase "where clause uses braces" $ do+      let src = unlines+            [ "module Foo where"+            , "f x = y + z"+            , "  where"+            , "    y = x + 1"+            , "    z = x + 2"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool ("Output should contain 'where{': " ++ show result)+            ("where{" `isInfixOf'` result)++  , testCase "case uses braces" $ do+      let src = unlines+            [ "module Foo where"+            , "f x = case x of"+            , "  True -> 1"+            , "  False -> 0"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure err+        Right result -> do+          assertBool ("Output should contain 'of{': " ++ show result)+            ("of{" `isInfixOf'` result)++  , testCase "output re-parses successfully" $ do+      let src = unlines+            [ "module Foo where"+            , "f :: Int -> Int"+            , "f x = x + 1"+            , "g :: String -> IO ()"+            , "g s = putStrLn s"+            ]+      case minify "test.hs" src of+        Left err -> assertFailure $ "First minification failed: " ++ err+        Right result ->+          case parseModule "minified.hs" result of+            Left _ -> assertFailure $ "Failed to re-parse minified output: " ++ show result+            Right _ -> pure ()+  ]++-- | Simple substring check+isInfixOf' :: String -> String -> Bool+isInfixOf' needle haystack = any (startsWith needle) (tails' haystack)+  where+    startsWith [] _ = True+    startsWith _ [] = False+    startsWith (a:as) (b:bs) = a == b && startsWith as bs+    tails' [] = [[]]+    tails' s@(_:rest) = s : tails' rest