packages feed

haskell-awk 1.1.1 → 1.2

raw patch · 50 files changed

+1390/−2295 lines, 50 filesdep +aesondep +attoparsecdep +extradep −networkdep ~HUnitdep ~basedep ~bytestringsetup-changed

Dependencies added: aeson, attoparsec, extra, filelock, ghc, list-t, template-haskell

Dependencies removed: network

Dependency ranges changed: HUnit, base, bytestring, containers, directory, doctest, easy-file, exceptions, filepath, haskell-src-exts, hint, hspec, mtl, process, stringsearch, temporary, test-framework, test-framework-hunit, time, transformers

Files

CHANGELOG.md view
@@ -1,5 +1,14 @@ # What's new? +## New in 1.2++* Added support for ghc-9.0.1, ghc-8.10 and ghc-8.8, dropped support for ghc-8.6 and below.+* Drop support for Windows. Please contact us if you would like us to re-enable it.+* Error messages use the correct column number.+* The flag `-d` without an argument no longer implies `-o` without an argument. That is, when using whitespace to delimit words in the input, we now also use whitespace to delimit words in the output, we no longer use the empty string as a delimiter.+* Hawk can now be installed using either stack, cabal-v1, cabal-v2, or cabal-sandbox.+* Hawk no longer suspiciously opens a port; we now use files for locking, not a unix socket.+ ## New in 1.1.1  GHC 7.10 compatibility.
README.md view
@@ -1,4 +1,4 @@-# Hawk+# Hawk [![Hackage](https://img.shields.io/hackage/v/haskell-awk.svg)](https://hackage.haskell.org/package/haskell-awk) [![Build Status](https://github.com/gelisam/hawk/workflows/CI/badge.svg)](https://github.com/gelisam/hawk/actions)  Transform text from the command-line using Haskell expressions. Similar to [awk](http://cm.bell-labs.com/cm/cs/awkbook/index.html), but using Haskell as the text-processing language. @@ -47,16 +47,16 @@ 100 ``` --For more details, see the [documentation](doc/README.md).+For more details, see the+[presentation](http://melrief.github.io/HawkPresentation/#/) and the+[documentation](doc/README.md).  ## Installation -To install the stable version, simply use `cabal install haskell-awk` (_not_-`cabal install hawk`, that's another unrelated package) and-add `~/.cabal/bin` (or your sandbox's `bin` folder) to your PATH. You should-be ready to use Hawk:+To install hawk, clone this repository, run `stack install`, and add `~/.local/bin` to your PATH. Alternatively, you can also use cabal, but only v1-style is currently supported: run `cabal v1-sandbox init && cabal v1-install`, and add `/.../.cabal-sandbox/bin` to your PATH. +You should be ready to use Hawk:+ ```bash > hawk '[1..3]' 1@@ -64,10 +64,5 @@ 3 ``` -To install the development version, clone this repository and use `cabal-install` or `cabal-dev install` to compile Hawk and its dependencies. Cabal-installs the binary to `~/.cabal/bin/hawk`, while cabal-dev installs it to-`./cabal-dev/bin/hawk`. The first run will create a default configuration into+The first run will create a default configuration file into `~/.hawk/prelude.hs` if it doesn't exist.--[![Build Status](https://secure.travis-ci.org/gelisam/hawk.png)](http://travis-ci.org/gelisam/hawk)
Setup.hs view
@@ -1,41 +1,6 @@-import Control.Monad-import Distribution.Simple-import System.Environment---import System.IO-+module Main where --- Surprisingly, if the user types "cabal install --enable-tests",--- `args` will *not* be ["install", "--enable-tests"]. Instead, cabal will--- run Setup.hs repeatedly with different arguments:--- ---     ["configure","--verbose=1","--builddir=dist/dist-sandbox-28d8356a","--ghc","--prefix=...",...]---     ["build","--verbose=1","--builddir=dist/dist-sandbox-28d8356a"]---     ["test","--builddir=dist/dist-sandbox-28d8356a"]---     ["install","--verbose=1","--builddir=dist/dist-sandbox-28d8356a"]--- --- We need to manipulate `args` via `substitute` in order to preserve those--- extra arguments.-substitute :: Eq a => [(a, [a])] -> [a] -> [a]-substitute substitutions = (>>= go)-  where-    go x = case lookup x substitutions of-             Just xs -> xs-             Nothing -> return x+import Distribution.Extra.Doctest (defaultMainWithDoctests) -main = do-    args <- getArgs-    -    --withFile "Setup.log" AppendMode $ \h -> do-    --  hPutStrLn h (show args)-    -    when ("test" `elem` args) $ do-      -- unlike most packages, this one needs to be installed before it can be tested.-      defaultMainArgs (substitute [ ("test", ["install","--verbose=1"])-                                  -                                  -- remove test-specific arguments-                                  , ("--log=$pkgid-$test-suite.log", [])-                                  , ("--machine-log=$pkgid.log", [])-                                  , ("--show-details=failures", [])-                                  ] args)-    -    defaultMainArgs args+main :: IO ()+main = defaultMainWithDoctests "reference"
haskell-awk.cabal view
@@ -1,107 +1,208 @@-Name:           haskell-awk-Version:        1.1.1-Author:         Mario Pastorelli <pastorelli.mario@gmail.com>,  Samuel Gélineau <gelisam@gmail.com>-Maintainer:     Mario Pastorelli <pastorelli.mario@gmail.com>,  Samuel Gélineau <gelisam@gmail.com>-Synopsis:       Transform text from the command-line using Haskell expressions.-Description:    Hawk is a command line utility to process streams of text-                using Haskell code. It is intended to be used in a UNIX-                pipeline. It offers a configuration system to personalize-                imported modules and a way to represent values on the console.-Category:       Console-License:        Apache-2.0-License-File:   LICENSE-Build-Type:     Custom-Cabal-version:  >=1.10-Extra-Source-Files: README.md-                  , CHANGELOG.md-                  , src/*.hs-                  , src/Control/Monad/Trans/*.hs-                  , src/Control/Monad/Trans/State/*.hs-                  , src/Data/*.hs-                  , src/Data/HaskellModule/*.hs-                  , src/Data/Monoid/*.hs-                  , src/Language/Haskell/Exts/*.hs-                  , src/System/Console/*.hs-                  , src/System/Console/Hawk/*.hs-                  , src/System/Console/Hawk/Args/*.hs-                  , src/System/Console/Hawk/Context/*.hs-                  , src/System/Console/Hawk/UserPrelude/*.hs-                  , src/System/Directory/*.hs-                  , tests/*.hs-                  , tests/Data/HaskellModule/Parse/*.hs-                  , tests/System/Console/Hawk/*.hs-                  , tests/System/Console/Hawk/Lock/*.hs-                  , tests/System/Console/Hawk/Representable/*.hs-                  , tests/preludes/default/*.hs-                  , tests/preludes/moduleName/*.hs-                  , tests/preludes/moduleNamedMain/*.hs-                  , tests/preludes/readme/*.hs-                  , tests/preludes/set/*.hs+cabal-version: 1.24 -Source-Repository head-    type: git-    location: https://github.com/gelisam/hawk+-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6eb7495d07ed97512f1c4161b59f59a2da447bba79e684418e34af5a402a7a55 -Executable hawk-    Main-is:        Main.hs-    Default-Language: Haskell98-    ghc-options:    -Wall-    build-depends:  base >=4.6.0.1 && <5-                  , bytestring-                  , containers-                  , directory-                  , easy-file-                  , exceptions >=0.1-                  , filepath-                  , haskell-awk-                  , haskell-src-exts >=1.16.0-                  , hint >=0.3.3.5-                  , mtl >=2.1.2-                  , network >=2.3.1.0-                  , stringsearch >=0.3.6.4-                  , process-                  , time-                  , transformers >=0.3.0.0-    hs-source-dirs: src+name:           haskell-awk+version:        1.2+synopsis:       Transform text from the command-line using Haskell expressions.+description:    Hawk is a command line utility to process streams of text using Haskell code. It is intended to be used in a UNIX pipeline. It offers a configuration system to personalize imported modules and a way to represent values on the console.+category:       Console+homepage:       https://github.com/gelisam/hawk#readme+bug-reports:    https://github.com/gelisam/hawk/issues+author:         Mario Pastorelli <pastorelli.mario@gmail.com>,  Samuel Gélineau <gelisam@gmail.com>+maintainer:     Mario Pastorelli <pastorelli.mario@gmail.com>,  Samuel Gélineau <gelisam@gmail.com>+license:        Apache-2.0+license-file:   LICENSE+build-type:     Custom+extra-source-files:+    README.md+    CHANGELOG.md -Library-    exposed-modules: System.Console.Hawk.Args.Spec-                    ,System.Console.Hawk.Representable-                    ,System.Console.Hawk.Runtime-                    ,System.Console.Hawk.Runtime.Base-    ghc-options:    -Wall-    hs-source-dirs: runtime-    build-depends: base >=4.6.0.1-                 , bytestring-                 , containers-                 , stringsearch >=0.3.6.4-    Default-Language: Haskell98+source-repository head+  type: git+  location: https://github.com/gelisam/hawk -Test-suite reference-  Hs-Source-Dirs:       src,tests-  Main-Is:              RunTests.hs-  Type:                 exitcode-stdio-1.0-  Ghc-Options:          -Wall-  Build-Depends:        base >=4.6.0.1 && <5-                      , bytestring-                      , containers-                      , directory-                      , doctest >=0.3.0-                      , exceptions >=0.1-                      , test-framework >=0.1-                      , test-framework-hunit >=0.2.0-                      , temporary >=1.0-                      , haskell-awk-                      , hspec >=0.2.0-                      , HUnit >=1.1-                      , easy-file-                      , haskell-src-exts >=1.14.0-                      , hint >=0.3.3.5-                      , filepath-                      , mtl >=2.1.2-                      , network >=2.3.1.0-                      , process-                      , stringsearch >=0.3.6.4-                      , time-                      , transformers >=0.3.0.0-  Default-Language: Haskell98+custom-setup+  setup-depends:+      Cabal >=3.0.1.0+    , base >=4.13.0.0 && <5+    , cabal-doctest >=1.0.8++library+  exposed-modules:+      System.Console.Hawk.Args.Spec+      System.Console.Hawk.Path+      System.Console.Hawk.Representable+      System.Console.Hawk.Runtime+      System.Console.Hawk.Runtime.Base+      System.Console.Hawk.Version+  other-modules:+      Paths_haskell_awk+  hs-source-dirs:+      runtime+  ghc-options: -Wall+  build-depends:+      base >=4.13.0.0 && <5+    , bytestring >=0.10.10.1+    , containers >=0.6.2.1+    , ghc >=8.8.4+    , list-t >=1.0.4+    , stringsearch >=0.3.6.6+  if os(windows)+    build-depends:+        base <0+  default-language: Haskell2010++executable hawk+  main-is: Main.hs+  other-modules:+      Control.Monad.Trans.OptionParser+      Control.Monad.Trans.State.Persistent+      Control.Monad.Trans.Uncertain+      Data.Cache+      Data.HaskellExpr+      Data.HaskellExpr.Base+      Data.HaskellExpr.Eval+      Data.HaskellModule+      Data.HaskellModule.Base+      Data.HaskellModule.Parse+      Data.HaskellSource+      Language.Haskell.Exts.Location+      System.Console.Hawk+      System.Console.Hawk.Args+      System.Console.Hawk.Args.Option+      System.Console.Hawk.Args.Parse+      System.Console.Hawk.Context+      System.Console.Hawk.Context.Base+      System.Console.Hawk.Context.Dir+      System.Console.Hawk.Context.Paths+      System.Console.Hawk.Help+      System.Console.Hawk.Interpreter+      System.Console.Hawk.Lock+      System.Console.Hawk.PackageDbs+      System.Console.Hawk.PackageDbs.TH+      System.Console.Hawk.Runtime.HaskellExpr+      System.Console.Hawk.UserExpr.CanonicalExpr+      System.Console.Hawk.UserExpr.InputReadyExpr+      System.Console.Hawk.UserExpr.OriginalExpr+      System.Console.Hawk.UserPrelude+      System.Console.Hawk.UserPrelude.Defaults+      System.Console.Hawk.UserPrelude.Extend+      System.Directory.Extra+      System.Directory.PathFinder+      Paths_haskell_awk+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.13.0.0 && <5+    , bytestring >=0.10.10.1+    , containers >=0.6.2.1+    , directory >=1.3.6.0+    , exceptions >=0.10.4+    , extra >=1.7.9+    , filelock >=0.1.1.5+    , filepath >=1.4.2.1+    , ghc >=8.8.4+    , haskell-awk+    , haskell-src-exts >=1.23.1+    , hint >=0.9.0.3+    , list-t >=1.0.4+    , mtl >=2.2.2+    , process >=1.6.9.0+    , stringsearch >=0.3.6.6+    , template-haskell >=2.15.0.0+    , time >=1.9.3+    , transformers >=0.5.6.2+  if os(windows)+    build-depends:+        base <0+  default-language: Haskell2010++test-suite reference+  type: exitcode-stdio-1.0+  main-is: RunTests.hs+  other-modules:+      Control.Monad.Trans.OptionParser+      Control.Monad.Trans.State.Persistent+      Control.Monad.Trans.Uncertain+      Data.Cache+      Data.HaskellExpr+      Data.HaskellExpr.Base+      Data.HaskellExpr.Eval+      Data.HaskellModule+      Data.HaskellModule.Base+      Data.HaskellModule.Parse+      Data.HaskellSource+      Language.Haskell.Exts.Location+      Main+      System.Console.Hawk+      System.Console.Hawk.Args+      System.Console.Hawk.Args.Option+      System.Console.Hawk.Args.Parse+      System.Console.Hawk.Context+      System.Console.Hawk.Context.Base+      System.Console.Hawk.Context.Dir+      System.Console.Hawk.Context.Paths+      System.Console.Hawk.Help+      System.Console.Hawk.Interpreter+      System.Console.Hawk.Lock+      System.Console.Hawk.PackageDbs+      System.Console.Hawk.PackageDbs.TH+      System.Console.Hawk.Runtime.HaskellExpr+      System.Console.Hawk.UserExpr.CanonicalExpr+      System.Console.Hawk.UserExpr.InputReadyExpr+      System.Console.Hawk.UserExpr.OriginalExpr+      System.Console.Hawk.UserPrelude+      System.Console.Hawk.UserPrelude.Defaults+      System.Console.Hawk.UserPrelude.Extend+      System.Directory.Extra+      System.Directory.PathFinder+      Data.HaskellModule.Parse.Test+      System.Console.Hawk.Lock.Test+      System.Console.Hawk.PreludeTests+      System.Console.Hawk.Representable.Test+      System.Console.Hawk.Test+      System.Console.Hawk.TestUtils+      Paths_haskell_awk+  hs-source-dirs:+      src+      tests+  ghc-options: -Wall+  build-depends:+      HUnit >=1.6.1.0+    , aeson >=1.4.7.1+    , attoparsec >=0.13.2.4+    , base >=4.13.0.0 && <5+    , bytestring >=0.10.10.1+    , containers >=0.6.2.1+    , directory >=1.3.6.0+    , doctest >=0.16.3+    , easy-file >=0.2.2+    , exceptions >=0.10.4+    , extra >=1.7.9+    , filelock >=0.1.1.5+    , filepath >=1.4.2.1+    , ghc >=8.8.4+    , haskell-awk+    , haskell-src-exts >=1.23.1+    , hint >=0.9.0.3+    , hspec >=2.7.6+    , list-t >=1.0.4+    , mtl >=2.2.2+    , process >=1.6.9.0+    , stringsearch >=0.3.6.6+    , template-haskell >=2.15.0.0+    , temporary >=1.3+    , test-framework >=0.8.2.0+    , test-framework-hunit >=0.3.0.2+    , time >=1.9.3+    , transformers >=0.5.6.2+  if os(windows)+    build-depends:+        base <0+  default-language: Haskell2010
runtime/System/Console/Hawk/Args/Spec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase, OverloadedStrings #-} -- | The precisely-typed version of Hawk's command-line arguments. module System.Console.Hawk.Args.Spec where @@ -58,21 +58,37 @@   deriving (Show, Eq)  --- A separator is a strategy for separating a string into substrings.--- One such strategy is to split the string on every occurrence of a--- particular delimiter.+-- A 'Processor' describes how to process a string; either by separating it+-- into chunks or by leaving it as-is. When separating it into chunks, we can+-- use whitespace as a delimiter (meaning one or more consecutive whitespace+-- characters), or we can use a specific delimiter. type Delimiter = ByteString data Separator = Whitespace | Delimiter Delimiter   deriving (Show, Eq)+data Processor = DoNotSeparate | SeparateOn Separator+  deriving (Show, Eq) -fromSeparator :: Separator -> Delimiter-fromSeparator Whitespace    = " "-fromSeparator (Delimiter d) = d+fromSeparator :: Delimiter -> Separator -> Delimiter+fromSeparator def = \case+  Whitespace  -> def+  Delimiter d -> d +fromProcessor :: Delimiter -> Processor -> Delimiter+fromProcessor def = \case+  DoNotSeparate -> def+  SeparateOn s  -> fromSeparator def s -data ExprSpec = ExprSpec++newtype ContextSpec = ContextSpec     { userContextDirectory :: FilePath-    , userExpression :: String+    }+  deriving (Show, Eq)++type UntypedExpr = String++data ExprSpec = ExprSpec+    { contextSpec :: ContextSpec+    , untypedExpr :: UntypedExpr     }   deriving (Show, Eq)
+ runtime/System/Console/Hawk/Path.hs view
@@ -0,0 +1,9 @@+-- | Auto-detects the installation folder, used to find the other installed packages.+module System.Console.Hawk.Path (getInstallationPath) where++-- magic self-referential module created by cabal+import Paths_haskell_awk (getBinDir)+++getInstallationPath :: IO FilePath+getInstallationPath = getBinDir
runtime/System/Console/Hawk/Representable.hs view
@@ -66,7 +66,7 @@     listRepr' _ = C8.pack  instance ListAsRow ByteString where-    listRepr' d = C8.intercalate d+    listRepr' = C8.intercalate  instance (Row a, Row b) => ListAsRow (Map a b) where     listRepr' d = listRepr' d . L.map (listRepr' d . M.toList)
runtime/System/Console/Hawk/Runtime.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification, OverloadedStrings, RankNTypes #-} -- | Applying the user expression as directed by the HawkRuntime. --   The API may change at any time. module System.Console.Hawk.Runtime-  ( processTable+  ( SomeRows(..)+  , processTable   ) where -import Control.Applicative import Control.Exception import Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Search as Search@@ -17,10 +17,13 @@ import System.Console.Hawk.Runtime.Base  -processTable :: Rows a => HawkRuntime -> ([[B.ByteString]] -> a) -> HawkIO ()+data SomeRows = forall a. Rows a => SomeRows a++processTable :: HawkRuntime -> ([[B.ByteString]] -> SomeRows) -> HawkIO () processTable runtime f = HawkIO $ do     xss <- getTable (inputSpec runtime)-    outputRows (outputSpec runtime) (f xss)+    case f xss of+      SomeRows x -> outputRows (outputSpec runtime) x   getTable :: InputSpec -> IO [[B.ByteString]]@@ -77,16 +80,16 @@   where     join' = join (B.fromStrict $ recordDelimiter spec)     toRows = repr (B.fromStrict $ fieldDelimiter spec)-    +     join :: B.ByteString -> [B.ByteString] -> B.ByteString     join "\n" = B.unlines     join sep  = B.intercalate sep  -- Don't fret if stdout is closed early, that is the way of shell pipelines. ignoringBrokenPipe :: IO () -> IO ()-ignoringBrokenPipe = handleJust isBrokenPipe $ \_ -> do+ignoringBrokenPipe = handleJust isBrokenPipe $ \_ ->     -- ignore the broken pipe     return ()   where     isBrokenPipe e | ioe_type e == ResourceVanished = Just e-    isBrokenPipe _ | otherwise                      = Nothing+    isBrokenPipe _                                  = Nothing
+ runtime/System/Console/Hawk/Version.hs view
@@ -0,0 +1,15 @@+-- | Auto-detects the current version, used by `hawk --version`.+module System.Console.Hawk.Version (versionString) where++import Data.List (intercalate)+import Data.Version (versionBranch)++-- magic self-referential module created by cabal+import Paths_haskell_awk (version)+++-- | Something like "1.0"+versionString :: String+versionString = intercalate "."+              $ map show+              $ versionBranch version
src/Control/Monad/Trans/OptionParser.hs view
@@ -1,22 +1,22 @@-{-# LANGUAGE PackageImports, RankNTypes #-}+{-# LANGUAGE DeriveFunctor, LambdaCase, PackageImports, RankNTypes #-} -- | A typeclass- and monad-based interface for GetOpt, --   designed to look as if the options had more precise types than String. module Control.Monad.Trans.OptionParser where -import Control.Applicative import Control.Monad+import qualified Control.Monad.Fail as Fail import "mtl" Control.Monad.Identity import "mtl" Control.Monad.Trans import Control.Monad.Trans.State import Data.List-import Data.Maybe import qualified System.Console.GetOpt as GetOpt import Text.Printf  import Control.Monad.Trans.Uncertain  -- $setup--- +--+-- >>> import Data.Maybe -- >>> :{ -- let testH tp = do { putStrLn "Usage: more [option]... <song.mp3>" --                   ; putStr $ optionsHelpWith head@@ -26,7 +26,7 @@ --                                              ["cowbell","guitar","saxophone"] --                   } -- :}--- +-- -- >>> let testP args tp p = runUncertain $ runOptionParserWith head id (const [""]) tp ["cowbell","guitar","saxophone"] p args  @@ -41,13 +41,13 @@ -- | The type of the argument set by the option. Since Haskell doesn't support --   dependent types, this is just a string description of the type, plus extra --   support for boolean flags and optional arguments.--- +-- -- To maintain the illusion of precise types, please use combining functions--- such as `nullable int` instead.+-- such as `optional int` instead. data OptionType     = Flag                   -- Bool, no argument     | Setting String         -- mandatory String argument-    | NullableSetting String -- optional String argument+    | OptionalSetting String -- optional String argument   deriving (Show, Eq)  @@ -74,6 +74,8 @@   OptionParserT mx >>= f = OptionParserT (mx >>= f')     where       f' = unOptionParserT . f++instance Monad m => Fail.MonadFail (OptionParserT o m) where   fail s = OptionParserT (fail s)  instance MonadTrans (OptionParserT o) where@@ -110,7 +112,7 @@     argDescr = case optionType' o of         Flag               -> GetOpt.NoArg (o, Just "")         Setting tp         -> GetOpt.ReqArg (\s -> (o, Just s)) tp-        NullableSetting tp -> GetOpt.OptArg (\ms -> (o, ms)) tp+        OptionalSetting tp -> GetOpt.OptArg (\ms -> (o, ms)) tp   -- | The part of your --help which describes each possible option.@@ -118,21 +120,20 @@ optionsHelp = optionsHelpWith shortName longName helpMsg optionType  -- | A version of `optionsHelp` which doesn't use the Option typeclass.--- +-- -- >>> :{ -- let { tp "cowbell"   = flag --     ; tp "guitar"    = string---     ; tp "saxophone" = nullable int+--     ; tp "saxophone" = optional int --     } -- :}--- +-- -- >>> testH tp -- Usage: more [option]... <song.mp3> -- Options: --   -c       --cowbell          adds more cowbell. --   -g str   --guitar=str       adds more guitar. --   -s[int]  --saxophone[=int]  adds more saxophone.---  optionsHelpWith :: (o -> Char)                 -> (o -> String)                 -> (o -> [String])@@ -156,12 +157,12 @@ runOptionParserT = runOptionParserWith shortName longName helpMsg optionType  -- | A version of `runOptionParserT` which doesn't use the Option typeclass.--- +-- -- >>> :{ -- testP ["--cowbell","-s"] (const flag) $ do---   { c <- consumeLast "cowbell"   False consumeFlag---   ; g <- consumeLast "guitar"    False consumeFlag---   ; s <- consumeLast "saxophone" False consumeFlag+--   { c <- fromMaybe False <$> consumeLast "cowbell"   flagConsumer+--   ; g <- fromMaybe False <$> consumeLast "guitar"    flagConsumer+--   ; s <- fromMaybe False <$> consumeLast "saxophone" flagConsumer --   ; return (c, g, s) --   } -- :}@@ -195,16 +196,15 @@   -- | Try to parse a setting of a particular type.--- --- The input will never be Nothing unless the optionType is nullable, and even--- then consumeNullable will get rid of it for you. Yet we still need the type--- of the input to be `Maybe String` in order for consumeNullable itself to be--- a valid OptionConsumer.-type OptionConsumer m a = Maybe String -> UncertainT m a+--+-- The input will never be Nothing unless the optionType is optional.+newtype OptionConsumerT m a = OptionConsumerT+  { runOptionConsumerT :: Maybe String -> UncertainT m a+  } deriving Functor   -- | Specifies that the option cannot be assigned a value.--- +-- -- >>> let tp = const flag -- >>> testH tp -- Usage: more [option]... <song.mp3>@@ -216,21 +216,21 @@ flag = Flag  -- | True if the given flag appears.--- +-- -- >>> let tp = const flag--- >>> let consumeCowbell = consumeLast "cowbell" False consumeFlag :: OptionParser String Bool--- +-- >>> let consumeCowbell = fromMaybe False <$> consumeLast "cowbell" flagConsumer :: OptionParser String Bool+-- -- >>> testP ["-cs"] tp consumeCowbell -- True--- +-- -- >>> testP ["--saxophone"] tp consumeCowbell -- False-consumeFlag :: Monad m => OptionConsumer m Bool-consumeFlag _ = return True+flagConsumer :: Monad m => OptionConsumerT m Bool+flagConsumer = OptionConsumerT $ \_ -> return True   -- | Specifies that the option must be assigned a String value.--- +-- -- >>> let tp = const string -- >>> testH tp -- Usage: more [option]... <song.mp3>@@ -242,72 +242,75 @@ string = Setting "str"  -- | The value assigned to the option, interpreted as a string.--- +-- -- >>> let tp = const string--- >>> let consumeCowbell = consumeLast "cowbell" "<none>" consumeString :: OptionParser String String--- +-- >>> let consumeCowbell = fromMaybe "<none>" <$> consumeLast "cowbell" stringConsumer :: OptionParser String String+-- -- >>> testP ["--cowbell", "extra"] tp consumeCowbell -- "extra"--- +-- -- >>> testP ["-cs"] tp consumeCowbell -- "s"--- +-- -- >>> testP [] tp consumeCowbell -- "<none>"--- +-- -- >>> testP ["-c"] tp consumeCowbell -- error: option `-c' requires an argument str -- *** Exception: ExitFailure 1-consumeString :: Monad m => OptionConsumer m String-consumeString (Just s) = return s-consumeString Nothing = error "please use consumeNullable to consume nullable options"+stringConsumer :: Monad m => OptionConsumerT m String+stringConsumer = OptionConsumerT $ \case+  Just s -> return s+  Nothing -> error "please use optionalConsumer to consume optional options"   -- | Specifies that the value of the option may be omitted.--- --- >>> let tp = const (nullable string)+--+-- >>> let tp = const (optional string) -- >>> testH tp -- Usage: more [option]... <song.mp3> -- Options: --   -c[str]  --cowbell[=str]    adds more cowbell. --   -g[str]  --guitar[=str]     adds more guitar. --   -s[str]  --saxophone[=str]  adds more saxophone.-nullable :: OptionType -> OptionType-nullable (Setting tp) = NullableSetting tp-nullable (NullableSetting _) = error "double nullable"-nullable Flag = error "nullable flag doesn't make sense"+optional :: OptionType -> OptionType+optional (Setting tp) = OptionalSetting tp+optional (OptionalSetting _) = error "double optional"+optional Flag = error "optional flag doesn't make sense" --- | The value assigned to an option, or a default value if no value was---   assigned. Must be used to consume `nullable` options.--- --- >>> let tp = const (nullable string)--- >>> let consumeCowbell = consumeLast "cowbell" "<none>" $ consumeNullable "<default>" consumeString :: OptionParser String String--- +-- | The value assigned to an option, or Nothing if no value was assigned.+--   Must be used to consume `optional` options.+--+-- >>> let tp = const (optional string)+-- >>> let consumeCowbell = fmap (fromMaybe "<none>") $ consumeLast "cowbell" $ fromMaybe "<default>" <$> optionalConsumer stringConsumer :: OptionParser String String+-- -- >>> testP ["-cs"] tp consumeCowbell -- "s"--- +-- -- >>> testP ["-c", "-s"] tp consumeCowbell -- "<default>"--- +-- -- >>> testP ["-s"] tp consumeCowbell -- "<none>"--- --- >>> testP ["-c"] tp $ consumeLast "cowbell" "<none>" consumeString--- *** Exception: please use consumeNullable to consume nullable options-consumeNullable :: Monad m => a -> OptionConsumer m a -> OptionConsumer m a-consumeNullable nullValue _ Nothing = return nullValue-consumeNullable _ consume o = consume o+--+-- >>> testP ["-c"] tp $ fromMaybe "<none>" <$> consumeLast "cowbell" stringConsumer+-- *** Exception: please use optionalConsumer to consume optional options+-- ...+optionalConsumer :: Monad m => OptionConsumerT m a -> OptionConsumerT m (Maybe a)+optionalConsumer optionConsumer = OptionConsumerT $ \case+  Nothing -> return Nothing+  o -> Just <$> runOptionConsumerT optionConsumer o   -- | A helper for defining custom options types.--- +-- -- >>> :{ -- let { tp "cowbell"   = readable "amount" --     ; tp "guitar"    = readable "file" --     ; tp "saxophone" = readable "weight" --     } -- :}--- +-- -- >>> testH tp -- Usage: more [option]... <song.mp3> -- Options:@@ -318,42 +321,42 @@ readable = Setting  -- | The value assigned to the option, interpreted by `read`.--- +-- -- >>> let tp = const (readable "unit")--- >>> let consumeCowbell = consumeLast "cowbell" () consumeReadable :: OptionParser String ()--- +-- >>> let consumeCowbell = fromMaybe () <$> consumeLast "cowbell" readConsumer :: OptionParser String ()+-- -- >>> testP ["--cowbell=()"] tp consumeCowbell >>= print -- ()--- +-- -- >>> testP ["--cowbell=foo"] tp consumeCowbell >>= print -- error: "foo" is not a valid value for this option. -- *** Exception: ExitFailure 1-consumeReadable :: (Read a, Monad m) => OptionConsumer m a-consumeReadable o = do-    s <- consumeString o+readConsumer :: (Read a, Monad m) => OptionConsumerT m a+readConsumer = OptionConsumerT $ \o -> do+    s <- runOptionConsumerT stringConsumer o     case reads s of       [(x, "")] -> return x       _ -> fail $ printf "%s is not a valid value for this option." $ show s   -- | Users are encouraged to create custom option types, like this.--- +-- -- (see the source) int :: OptionType int = readable "int"  -- | The value assigned to the option, interpreted as an int.--- +-- -- This is a good example of how to consume custom option types. -- (see the source)--- +-- -- >>> let tp = const int--- >>> let consumeCowbell = consumeLast "cowbell" (-1) consumeInt :: OptionParser String Int--- +-- >>> let consumeCowbell = fromMaybe (-1) <$> consumeLast "cowbell" intConsumer :: OptionParser String Int+-- -- >>> testP ["--cowbell=42"] tp consumeCowbell -- 42-consumeInt :: Monad m => OptionConsumer m Int-consumeInt = consumeReadable+intConsumer :: Monad m => OptionConsumerT m Int+intConsumer = readConsumer   -- | The value assigned to the option, interpreted as a path (String)@@ -374,29 +377,31 @@ --              else fail (e d) -- :} ----- >>> let dirExists      = checkDir doesDirectoryExist                          (++ " doesn't exist")+-- >>> let dirExists      = checkDir doesDirectoryExist                            (++ " doesn't exist") -- >>> let dirDoesntExist = checkDir (\d -> doesDirectoryExist d >>= return . not) (++ " exists")--- >>> let consumeLastInputDir = consumeLast "input-dir" "error" :: OptionConsumer IO String -> OptionParserT String IO String--- >>> let consumeExistingDir    = consumeLastInputDir (consumeFilePath dirExists)--- >>> let consumeNotExistingDir = consumeLastInputDir (consumeFilePath dirDoesntExist)+-- >>> let consumeLastInputDir c = fromMaybe "error" <$> consumeLast "input-dir" c+-- >>> let consumeExistingDir    = consumeLastInputDir (filePathConsumer dirExists)+-- >>> let consumeNotExistingDir = consumeLastInputDir (filePathConsumer dirDoesntExist) -- >>> testIO ["--input-dir=."] inputDir consumeExistingDir -- "." -- >>> testIO ["--input-dir=."] inputDir consumeNotExistingDir -- error: . exists -- *** Exception: ExitFailure 1-consumeFilePath :: MonadIO m-                => (FilePath -> UncertainT m FilePath) -> OptionConsumer m String-consumeFilePath check input = consumeString input >>= check >>= return+filePathConsumer :: MonadIO m+                 => (FilePath -> UncertainT m FilePath) -> OptionConsumerT m String+filePathConsumer check = OptionConsumerT $ \o -> do+  filePath_ <- runOptionConsumerT stringConsumer o+  check filePath_   -- | All the occurences of a given option.--- +-- -- It is an error to consume the same value twice (we currently return an -- empty list).--- +-- -- >>> let tp = const string--- >>> let consumeCowbell = consumeAll "cowbell" consumeString :: OptionParser String [String]--- +-- >>> let consumeCowbell = consumeAll "cowbell" stringConsumer :: OptionParser String [String]+-- -- >>> :{ -- testP ["--cowbell=foo", "--cowbell", "bar"] tp $ do --   { xs <- consumeCowbell@@ -406,20 +411,20 @@ -- :} -- (["foo","bar"],[]) consumeAll :: (Eq o, Monad m)-           => o -> OptionConsumer m a -> OptionParserT o m [a]-consumeAll o consume = OptionParserT $ do+           => o -> OptionConsumerT m a -> OptionParserT o m [a]+consumeAll o optionConsumer = OptionParserT $ do     matching_options <- state $ partition $ (== o) . fst-    lift . lift $ mapM (consume . snd) matching_options+    lift . lift $ mapM (runOptionConsumerT optionConsumer . snd) matching_options --- | The last occurence of a given option, or a default value if the option---   isn't specified.--- --- It is an error to consume the same value twice (we currently return the--- default value).--- +-- | The last occurence of a given option, or Nothing if the option isn't+--   specified.+--+-- If 'consumeAll' is called twice on the same option, the second call returns+-- Nothing.+-- -- >>> let tp = const string--- >>> let consumeCowbell = consumeLast "cowbell" "<none>" consumeString :: OptionParser String String--- +-- >>> let consumeCowbell = fromMaybe "<none>" <$> consumeLast "cowbell" stringConsumer :: OptionParser String String+-- -- >>> :{ -- testP ["--cowbell=foo", "--cowbell", "bar"] tp $ do --   { xs <- consumeCowbell@@ -429,40 +434,42 @@ -- :} -- ("bar","<none>") consumeLast :: (Eq o, Monad m)-            => o -> a -> OptionConsumer m a -> OptionParserT o m a-consumeLast o defaultValue consume = do-    xs <- consumeAll o consume-    return $ last $ defaultValue : xs+            => o -> OptionConsumerT m a -> OptionParserT o m (Maybe a)+consumeLast o optionConsumer = do+    xs <- consumeAll o optionConsumer+    if null xs+      then return Nothing+      else return $ Just $ last xs   -- | For use with mutually-exclusive flags. consumeExclusive :: (Option o, Functor m, Monad m)-                 => [(o, a)] -> a -> OptionParserT o m a+                 => [(o, a)] -> OptionParserT o m (Maybe a) consumeExclusive = consumeExclusiveWith longName  -- | A version of `consumeExclusive` which doesn't use the Option typeclass.--- +-- -- >>> let tp = const flag--- >>> let consume = consumeExclusiveWith id [("cowbell",0),("guitar",1),("saxophone",2)] (-1) :: OptionParser String Int--- +-- >>> let consume = fromMaybe (-1) <$> consumeExclusiveWith id [("cowbell",0),("guitar",1),("saxophone",2)] :: OptionParser String Int+-- -- >>> testP ["-s"] tp consume -- 2--- +-- -- >>> testP [] tp consume -- -1--- +-- -- >>> testP ["-cs"] tp consume -- error: cowbell and saxophone are incompatible -- *** Exception: ExitFailure 1 consumeExclusiveWith :: (Eq o, Functor m, Monad m)                      => (o -> String)-                     -> [(o, a)] -> a -> OptionParserT o m a-consumeExclusiveWith longName' assoc defaultValue = do+                     -> [(o, a)] -> OptionParserT o m (Maybe a)+consumeExclusiveWith longName' assoc = do     oss <- forM (map fst assoc) $ \o ->-      map (const o) <$> consumeAll o consumeFlag+      map (const o) <$> consumeAll o flagConsumer     case concat oss of-      []  -> return defaultValue-      [o] -> return $ fromMaybe defaultValue $ lookup o assoc+      []  -> return Nothing+      [o] -> return $ lookup o assoc       os  -> fail msg         where           n = length os@@ -471,47 +478,47 @@   -- | The next non-option argument.--- +-- -- >>> let tp = const flag--- >>> let consume = consumeExtra consumeString :: OptionParser String (Maybe String)--- +-- >>> let consume = consumeExtra stringConsumer :: OptionParser String (Maybe String)+-- -- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp consume -- Just "song.mp3"--- +-- -- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp (consume >> consume) -- Just "jazz.mp3"--- +-- -- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp (consume >> consume >> consume) -- Nothing consumeExtra :: (Functor m, Monad m)-             => OptionConsumer m a -> OptionParserT o m (Maybe a)-consumeExtra consume = OptionParserT $ do+             => OptionConsumerT m a -> OptionParserT o m (Maybe a)+consumeExtra optionConsumer = OptionParserT $ do     extra_options <- lift get     case extra_options of       [] -> return Nothing       (x:xs) -> do         lift $ put xs-        fmap Just $ lift . lift $ consume $ Just x+        fmap Just $ lift . lift $ runOptionConsumerT optionConsumer $ Just x  -- | All remaining non-option arguments.--- +-- -- >>> let tp = const flag--- >>> let consume = consumeExtras consumeString :: OptionParser String [String]--- +-- >>> let consume = consumeExtras stringConsumer :: OptionParser String [String]+-- -- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp consume -- ["song.mp3","jazz.mp3"]--- --- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp (consumeExtra consumeString >> consume)+--+-- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp (consumeExtra stringConsumer >> consume) -- ["jazz.mp3"]--- +-- -- >>> testP ["-cs", "song.mp3", "jazz.mp3"] tp (consume >> consume) -- [] consumeExtras :: (Functor m, Monad m)-              => OptionConsumer m a -> OptionParserT o m [a]-consumeExtras consume = fmap reverse $ go []+              => OptionConsumerT m a -> OptionParserT o m [a]+consumeExtras optionConsumer = fmap reverse $ go []   where     go xs = do-        r <- consumeExtra consume+        r <- consumeExtra optionConsumer         case r of           Nothing -> return xs           Just x  -> go (x:xs)
src/Control/Monad/Trans/State/Persistent.hs view
@@ -10,10 +10,10 @@ import Control.Monad.Trans.State import Data.Functor.Identity import System.Directory-import System.FilePath import System.IO  -- $setup+-- >>> import System.FilePath -- >>> tmp <- getTemporaryDirectory -- >>> let f = tmp </> "doctest.txt" @@ -67,7 +67,7 @@ --  --  -- >>> removeFile f-withPersistentStateT :: forall m s a. (Functor m, MonadIO m, Read s, Show s, Eq s)+withPersistentStateT :: forall m s a. (Functor m, MonadIO m, MonadFail m, Read s, Show s, Eq s)                      => FilePath -> s -> StateT s m a -> m a withPersistentStateT f default_s sx = do     Just s <- runMaybeT (get_s <|> get_default_s)
src/Control/Monad/Trans/Uncertain.hs view
@@ -2,10 +2,10 @@ -- | A computation which may raise warnings or fail in error. module Control.Monad.Trans.Uncertain where -import Control.Applicative+import qualified Control.Monad.Fail as Fail import "mtl" Control.Monad.Trans import "mtl" Control.Monad.Identity-import "transformers" Control.Monad.Trans.Error hiding (Error)+import "transformers" Control.Monad.Trans.Except import "transformers" Control.Monad.Trans.Writer import System.Exit import System.IO@@ -16,7 +16,7 @@ type Error = String  newtype UncertainT m a = UncertainT-  { unUncertainT :: ErrorT Error (WriterT [Warning] m) a }+  { unUncertainT :: ExceptT Error (WriterT [Warning] m) a }  type Uncertain a = UncertainT Identity a @@ -32,8 +32,10 @@   UncertainT mx >>= f = UncertainT (mx >>= f')     where       f' = unUncertainT . f-  fail s = UncertainT (fail s) +instance Monad m => Fail.MonadFail (UncertainT m) where+  fail s = UncertainT (throwE s)+ instance MonadTrans UncertainT where   lift = UncertainT . lift . lift @@ -50,7 +52,7 @@   multilineMsg :: String -> String-multilineMsg = concat . map (printf "\n  %s") . lines+multilineMsg = concatMap (printf "\n  %s") . lines  -- | Indent a multiline warning message. -- >>> :{@@ -58,7 +60,7 @@ --   multilineWarn "foo\nbar\n" --   return 42 -- :}--- warning: +-- warning: --   foo --   bar -- 42@@ -71,7 +73,7 @@ --   multilineFail "foo\nbar\n" --   return 42 -- :}--- error: +-- error: --   foo --   bar -- *** Exception: ExitFailure 1@@ -80,17 +82,21 @@   mapUncertainT :: (forall a. m a -> m' a) -> UncertainT m b -> UncertainT m' b-mapUncertainT f = UncertainT . (mapErrorT . mapWriterT) f . unUncertainT+mapUncertainT f = UncertainT . (mapExceptT . mapWriterT) f . unUncertainT  runUncertainT :: UncertainT m a -> m (Either Error a, [Warning])-runUncertainT = runWriterT . runErrorT . unUncertainT+runUncertainT = runWriterT . runExceptT . unUncertainT +uncertainT :: Monad m => (Either Error a, [Warning]) -> UncertainT m a+uncertainT (Left  e, warnings) = mapM_ warn warnings >> fail e+uncertainT (Right x, warnings) = mapM_ warn warnings >> return x + -- | A version of `runWarnings` which allows you to interleave IO actions --   with uncertain actions.--- +-- -- Note that the warnings are displayed after the IO's output.--- +-- -- >>> :{ -- runWarningsIO $ do --   warn "before"@@ -102,7 +108,7 @@ -- warning: before -- warning: after -- Right 42--- +-- -- >>> :{ -- runWarningsIO $ do --   warn "before"@@ -121,7 +127,7 @@  -- | A version of `runUncertain` which only prints the warnings, not the --   errors. Unlike `runUncertain`, it doesn't terminate on error.--- +-- -- >>> :{ -- runWarnings $ do --   warn "before"@@ -131,7 +137,7 @@ -- warning: before -- warning: after -- Right 42--- +-- -- >>> :{ -- runWarnings $ do --   warn "before"@@ -146,9 +152,9 @@  -- | A version of `runUncertain` which allows you to interleave IO actions --   with uncertain actions.--- +-- -- Note that the warnings are displayed after the IO's output.--- +-- -- >>> :{ -- runUncertainIO $ do --   warn "before"@@ -160,7 +166,7 @@ -- warning: before -- warning: after -- 42--- +-- -- >>> :{ -- runUncertainIO $ do --   warn "before"@@ -182,9 +188,9 @@       Right x -> return x  -- | Print warnings and errors, terminating on error.--- +-- -- Note that the warnings are displayed even if there is also an error.--- +-- -- >>> :{ -- runUncertainIO $ do --   warn "first"@@ -202,7 +208,7 @@  -- | Upgrade an `IO a -> IO a` wrapping function into a variant which uses --   `UncertainT IO` instead of `IO`.--- +-- -- >>> :{ -- let wrap body = do { putStrLn "before" --                    ; r <- body@@ -210,7 +216,7 @@ --                    ; return r --                    } -- :}--- +-- -- >>> :{ -- wrap $ do { putStrLn "hello" --           ; return 42@@ -220,7 +226,7 @@ -- hello -- after -- 42--- +-- -- >>> :{ -- runUncertainIO $ wrapUncertain wrap --                $ do { lift $ putStrLn "hello"@@ -243,7 +249,7 @@  -- | A version of `wrapUncertain` for wrapping functions of type --   `(Handle -> IO a) -> IO a`.--- +-- -- >>> :{ -- let wrap body = do { putStrLn "before" --                    ; r <- body 42@@ -251,7 +257,7 @@ --                    ; return r --                    } -- :}--- +-- -- >>> :{ -- wrap $ \x -> do { putStrLn "hello" --                 ; return (x + 1)@@ -261,7 +267,7 @@ -- hello -- after -- 43--- +-- -- >>> :{ -- runUncertainIO $ wrapUncertainArg wrap --                $ \x -> do { lift $ putStrLn "hello"@@ -279,7 +285,7 @@                  -> ((v -> UncertainT m b) -> UncertainT m' b) wrapUncertainArg wrap body = do     (r, ws) <- lift $ wrap $ runUncertainT . body-    +     -- repackage the warnings and errors     mapM_ warn ws     fromRightM r
src/Data/Cache.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE PackageImports #-} -- | A generic caching interface.--- +-- -- The intent is to support many concrete implementations, -- and to use specify caching policies using combinators.--- +-- -- Note that even though we _support_ many concrete implementations, -- for simplicity we only provide one based on an association-list. module Data.Cache where@@ -47,9 +47,9 @@   -- | A dummy cache which never caches anything.--- +-- -- Semantically equivalent to `finiteCache 0 $ assocCache`, except for the `m`.--- +-- -- >>> withNullCache testC -- one -- two@@ -71,7 +71,7 @@   -- | A very inefficient example implementation.--- +-- -- >>> withAssocCache testC -- one -- two@@ -97,14 +97,14 @@  -- | Only cache the first `n` requests (use n=-1 for unlimited). --   Combine with a cache policy in order to reuse those `n` slots.--- +-- -- >>> withAssocCache $ withFiniteCache 2 $ testC -- one -- two -- testing -- testing -- [3,3,3,3,7,7]--- +-- -- >>> withAssocCache $ withFiniteCache 1 $ testC -- one -- two@@ -112,7 +112,7 @@ -- testing -- testing -- [3,3,3,3,7,7]--- +-- -- >>> withAssocCache $ withFiniteCache 0 $ testC -- one -- two@@ -121,7 +121,7 @@ -- testing -- testing -- [3,3,3,3,7,7]--- +-- -- >>> withAssocCache $ withFiniteCache (-1) $ testC -- one -- two@@ -154,13 +154,13 @@   -- | An example cache-policy implementation: Least-Recently-Used.--- +-- -- >>> withAssocCache $ withFiniteCache 2 $ withLruCache testC -- one -- two -- testing -- [3,3,3,3,7,7]--- +-- -- >>> withAssocCache $ withFiniteCache 1 $ withLruCache testC -- one -- two@@ -168,7 +168,7 @@ -- two -- testing -- [3,3,3,3,7,7]--- +-- -- >>> withAssocCache $ withFiniteCache 0 $ withLruCache testC -- one -- two@@ -204,9 +204,9 @@           [] -> do             -- the cache is both full and empty? try to reset.             lift $ clearCache c-    +     write  k = modify (k:)-    remove k = modify $ filter $ (/= k)+    remove k = modify $ filter (/= k)  withLruCache :: (Monad m, Eq k)              => (Cache (StateT [k] m) k v -> StateT [k] m a)@@ -215,9 +215,9 @@   -- | An extreme version of the LRU strategy.--- +-- -- Semantically equivalent to `lruCache . finiteCache 1`, except for the `m`.--- +-- -- >>> withAssocCache $ withSingletonCache testC -- one -- two
+ src/Data/HaskellExpr.hs view
@@ -0,0 +1,33 @@+-- | A String-based representation of simple Haskell expressions, typed via phantom types.+module Data.HaskellExpr where++import Text.Printf+++newtype HaskellExpr a = HaskellExpr { code :: String }+  deriving (Show, Eq)++eAp :: HaskellExpr (a -> b) -> HaskellExpr a -> HaskellExpr b+HaskellExpr f `eAp` HaskellExpr x = HaskellExpr $ printf "(%s) (%s)" f x++eLambda :: String -> (HaskellExpr a -> HaskellExpr b) -> HaskellExpr (a -> b)+eLambda var body = HaskellExpr $ printf "\\%s -> %s" var (code eBody)+  where+    eVar = HaskellExpr var+    eBody = body eVar+++-- we cannot use any unqualified symbols in the user expression,+-- because we don't know which modules the user prelude will import.+{-# INLINE qualified #-}+qualified :: String -> String -> HaskellExpr a+qualified moduleName unqualifiedName = HaskellExpr qualifiedName+  where+    qualifiedName = printf "%s.%s" moduleName unqualifiedName++{-# INLINE qualifiedInfix #-}+qualifiedInfix :: String -> String+               -> HaskellExpr a -> HaskellExpr b -> HaskellExpr c+qualifiedInfix moduleName unqualifiedName x y = HaskellExpr qualifiedName `eAp` x `eAp` y+  where+    qualifiedName = printf "(%s.%s)" moduleName unqualifiedName
+ src/Data/HaskellExpr/Base.hs view
@@ -0,0 +1,23 @@+-- | The fully-qualified HaskellExpr representation of some functions from base.+module Data.HaskellExpr.Base where++import Data.HaskellExpr+++eId :: HaskellExpr (a -> a)+eId = qualified "Prelude" "id"++eConst :: HaskellExpr (a -> b -> a)+eConst = qualified "Prelude" "const"++eFlip :: HaskellExpr ((a -> b -> c) -> b -> a -> c)+eFlip = qualified "Prelude" "flip"++eMap :: HaskellExpr ((a -> b) -> [a] -> [b])+eMap = qualified "Prelude" "map"++eHead :: HaskellExpr ([a] -> a)+eHead = qualified "Prelude" "head"++eComp :: HaskellExpr (b -> c) -> HaskellExpr (a -> b) -> HaskellExpr (a -> c)+eComp = qualifiedInfix "Prelude" "."
+ src/Data/HaskellExpr/Eval.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Evaluate an HaskellExpr using the hint library.+module Data.HaskellExpr.Eval where++import Data.Typeable+import Language.Haskell.Interpreter++import Data.HaskellExpr+++interpretExpr :: forall m a. (MonadInterpreter m, Typeable a)+              => HaskellExpr a -> m a+interpretExpr eExpr = interpret (code eExpr) (as :: a)
src/Data/HaskellModule/Parse.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, PackageImports, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings, PackageImports, RecordWildCards, ScopedTypeVariables #-} -- | In which a Haskell module is deconstructed into extensions and imports. module Data.HaskellModule.Parse (readModule) where @@ -14,45 +14,53 @@ import Language.Haskell.Exts.Location  -locatedExtensions :: [ModulePragma] -> Located [ExtensionName]-locatedExtensions = fmap go . located+locatedExtensions :: forall si. SrcInfo si+                  => [ModulePragma si] -> Located [ExtensionName]+locatedExtensions = fmap go . traverse annotated   where-    go :: [ModulePragma] -> [ExtensionName]+    go :: [ModulePragma si] -> [ExtensionName]     go = concatMap extNames-    -    extNames :: ModulePragma -> [ExtensionName]++    extNames :: ModulePragma si -> [ExtensionName]     extNames (LanguagePragma _ exts) = map prettyPrint exts-    extNames (OptionsPragma _ _ _) = []  -- TODO: accept "-XExtName"-    extNames _ = []+    extNames  OptionsPragma{}        = []  -- TODO: accept "-XExtName"+    extNames _                       = [] -locatedImports :: [ImportDecl] -> Located [QualifiedModule]-locatedImports = fmap go . located+locatedImports :: forall si. SrcInfo si+               => [ImportDecl si] -> Located [QualifiedModule]+locatedImports = fmap go . traverse annotated   where-    go :: [ImportDecl] -> [QualifiedModule]+    go :: [ImportDecl si] -> [QualifiedModule]     go = map qualify-    -    qualify :: ImportDecl -> QualifiedModule++    qualify :: ImportDecl si -> QualifiedModule     qualify decl = (fullName decl, qualifiedName decl)-    -    fullName :: ImportDecl -> String++    fullName :: ImportDecl si -> String     fullName = prettyPrint . importModule-    -    qualifiedName :: ImportDecl -> Maybe String++    qualifiedName :: ImportDecl si -> Maybe String     qualifiedName = fmap prettyPrint . importAs -locatedModule :: SrcLoc -> HaskellSource -> ModuleName -> Located (Maybe String)-locatedModule srcLoc source (ModuleName mName) = case moduleLine of+locatedModule :: forall si. SrcInfo si+              => si -> HaskellSource -> Maybe (ModuleHead si) -> Located (Maybe String)+locatedModule srcInfo source maybeModuleHead = case moduleLine of     Nothing -> return Nothing-    Just line -> located (srcLoc {srcLine = line}) >> return (Just mName)+    Just line -> do+      located ((getPointLoc srcInfo) {srcLine = line})+      return (moduleName <$> maybeModuleHead)   where     isModuleDecl :: Either B.ByteString String -> Bool     isModuleDecl (Left xs) = "module " `B.isPrefixOf` xs     isModuleDecl (Right xs) = "module " `isPrefixOf` xs-    +     moduleLine :: Maybe Int     moduleLine = fmap index2line $ findIndex isModuleDecl source +    moduleName :: ModuleHead si -> String+    moduleName (ModuleHead _ (ModuleName _ name_) _ _) = name_ + -- line numbers start at 1, list indices start at 0. line2index, index2line :: Int -> Int line2index = subtract 1@@ -60,10 +68,10 @@   -- | A variant of `splitAt` which makes it easy to make `snd` empty.--- +-- -- >>> maybeSplitAt Nothing "abc" -- ("abc","")--- +-- -- >>> maybeSplitAt (Just 0) "abc" -- ("","abc") maybeSplitAt :: Maybe Int -> [a] -> ([a], [a])@@ -72,31 +80,31 @@  -- | Given n ordered indices before which to split, split the list into n+1 pieces. --   Omitted indices will produce empty pieces.--- +-- -- >>> multiSplit [] "foo" -- ["foo"]--- +-- -- >>> multiSplit [Just 0, Just 1, Just 2] "foo" -- ["","f","o","o"]--- +-- -- >>> multiSplit [Just 0, Just 1, Nothing] "foo" -- ["","f","oo",""]--- +-- -- >>> multiSplit [Just 0, Nothing, Just 2] "foo" -- ["","fo","","o"]--- +-- -- >>> multiSplit [Just 0, Nothing, Nothing] "foo" -- ["","foo","",""]--- +-- -- >>> multiSplit [Nothing, Just 1, Just 2] "foo" -- ["f","","o","o"]--- +-- -- >>> multiSplit [Nothing, Just 1, Nothing] "foo" -- ["f","","oo",""]--- +-- -- >>> multiSplit [Nothing, Nothing, Just 2] "foo" -- ["fo","","","o"]--- +-- -- >>> multiSplit [Nothing, Nothing, Nothing] "foo" -- ["foo","","",""] multiSplit :: [Maybe Int] -> [a] -> [[a]]@@ -114,10 +122,10 @@  -- Due to a limitation of haskell-parse-exts, there is no `parseModule` -- variant of `readModule` which would parse from a String instead of a file.--- +-- -- According to the documentation [1], only `parseFile` honors language -- pragmas, without which PackageImport-style imports will fail to parse.--- +-- -- [1] http://hackage.haskell.org/package/haskell-src-exts-1.14.0.1/docs/Language-Haskell-Exts-Parser.html#t:ParseMode  readModule :: FilePath -> UncertainT IO HaskellModule@@ -125,19 +133,29 @@     s <- lift $ readSource f     r <- lift $ parseFile f     case r of-      ParseOk (Module srcLoc moduleDecl pragmas _ _ imports decls)-        -> return $ go s srcLoc pragmas moduleDecl imports decls+      ParseOk (Module srcInfo moduleDecl pragmas imports decls)+        -> return $ go s srcInfo pragmas moduleDecl imports decls+      ParseOk (XmlPage   {}) -> fail "The XmlSyntax extension is not supported"+      ParseOk (XmlHybrid {}) -> fail "The XmlSyntax extension is not supported"       ParseFailed loc err -> multilineFail msg         where           -- we start with a newline to match ghc's errors           msg = printf "\n%s:%d:%d: %s" (srcFilename loc) (srcLine loc) (srcColumn loc) err   where-    go source srcLoc pragmas moduleDecl imports decls = HaskellModule {..}+    go :: SrcInfo si+       => HaskellSource+       -> si+       -> [ModulePragma si]+       -> Maybe (ModuleHead si)+       -> [ImportDecl si]+       -> [Decl si]+       -> HaskellModule+    go source srcInfo pragmas moduleDecl imports decls = HaskellModule {..}       where         (languageExtensions,      _) = runLocated (locatedExtensions pragmas)-        (moduleName,      moduleLoc) = runLocated (locatedModule srcLoc source moduleDecl)+        (moduleName,      moduleLoc) = runLocated (locatedModule srcInfo source moduleDecl)         (importedModules, importLoc) = runLocated (locatedImports imports)-        (_,                 declLoc) = runLocated (located decls)-        +        (_,                 declLoc) = runLocated (traverse annotated decls)+         sourceParts = splitSource [moduleLoc, importLoc, declLoc] source         [pragmaSource, moduleSource, importSource, codeSource] = sourceParts
src/Data/HaskellSource.hs view
@@ -6,11 +6,11 @@  import Control.Monad.Trans.Class import Data.ByteString.Char8 as B+import System.Directory import System.Exit import System.Process import Text.Printf -import System.Directory.Extra import Control.Monad.Trans.Uncertain  @@ -93,11 +93,11 @@  compileFileWithArgs :: [String] -> FilePath -> UncertainT IO () compileFileWithArgs args f = do-    absFilePath <- lift $ absPath f+    absFilePath <- lift $ canonicalizePath f     let args' = absFilePath : "-v0" : args     (exitCode, out, err) <- lift $ readProcessWithExitCode "ghc" args' ""     case (exitCode, out ++ err) of       (ExitSuccess, [])  -> return ()-      (ExitSuccess, msg) -> multilineWarn msg+      (ExitSuccess, _msg) -> return ()  -- TODO: output warnings via 'multilineWarn msg'?       (_          , [])  -> fail $ printf "could not compile %s" (show f)       (_          , msg) -> multilineFail msg
− src/Data/Monoid/Ord.hs 
@@ -1,82 +0,0 @@--- based on http://hackage.haskell.org/package/monoids-0.3.2/docs/src/Data-Monoid-Ord.html-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}----------------------------------------------------------------------------------- |----- Module      :  Data.Monoid.Ord----- Copyright   :  (c) Edward Kmett 2009----- License     :  BSD-style----- Maintainer  :  ekmett@gmail.com----- Stability   :  experimental----- Portability :  portable---------- Some 'Monoid' instances that should probably be in "Data.Monoid".-------------------------------------------------------------------------------------module Data.Monoid.Ord -    (-    -- * Max-      Max(Max,getMax)-    -- * Min-    , Min(Min,getMin)-    -- * MaxPriority: Max semigroup w/ added bottom-    , MaxPriority(MaxPriority,getMaxPriority)-    , minfinity-    -- * MinPriority: Min semigroup w/ added top-    , MinPriority(MinPriority,getMinPriority)-    , infinity-    ) where--import Data.Monoid (Monoid, mappend, mempty)---- | The 'Monoid' @('max','minBound')@-newtype Max a = Max { getMax :: a } deriving (Eq,Ord,Show,Read,Bounded)--instance (Ord a, Bounded a) => Monoid (Max a) where-    mempty = Max minBound-    mappend = max--instance Functor Max where -    fmap f (Max a) = Max (f a)---- | The 'Monoid' given by @('min','maxBound')@-newtype Min a = Min { getMin :: a } deriving (Eq,Ord,Show,Read,Bounded)--instance (Ord a, Bounded a) => Monoid (Min a) where-    mempty = Min maxBound-    mappend = min--instance Functor Min where-    fmap f (Min a) = Min (f a)--minfinity :: MaxPriority a-minfinity = MaxPriority Nothing---- | The 'Monoid' @('max','Nothing')@ over @'Maybe' a@ where 'Nothing' is the bottom element-newtype MaxPriority a = MaxPriority { getMaxPriority :: Maybe a } deriving (Eq,Ord,Show,Read)--instance Ord a => Monoid (MaxPriority a) where-    mempty = MaxPriority Nothing-    mappend = max--instance Functor MaxPriority where-    fmap f (MaxPriority a) = MaxPriority (fmap f a)--infinity :: MinPriority a-infinity = MinPriority Nothing---- | The 'Monoid' @('min','Nothing')@ over @'Maybe' a@ where 'Nothing' is the top element-newtype MinPriority a = MinPriority { getMinPriority :: Maybe a } deriving (Eq,Show,Read)--instance Ord a => Ord (MinPriority a) where-    MinPriority Nothing  `compare` MinPriority Nothing  = EQ-    MinPriority Nothing  `compare` _                    = GT-    _                    `compare` MinPriority Nothing  = LT-    MinPriority (Just a) `compare` MinPriority (Just b) = a `compare` b--instance Ord a => Monoid (MinPriority a) where-    mempty = MinPriority Nothing-    mappend = min--instance Functor MinPriority where-    fmap f (MinPriority a) = MinPriority (fmap f a)
src/Language/Haskell/Exts/Location.hs view
@@ -1,85 +1,31 @@ -- | Easier access to haskell-src-exts's SrcLoc values. module Language.Haskell.Exts.Location where -import Control.Monad import Control.Monad.Trans.Writer+import Data.Semigroup+import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Syntax -import Data.Monoid.Ord ---- | Many haskell-src-exts datastructures contain a SrcLoc,---   this provides a uniform way to access them.-class Location a where-  location :: a -> Maybe SrcLoc--instance Location SrcLoc where-  location = Just--instance Location Module where-  location (Module loc _ _ _ _ _ _) = Just loc--instance Location ModulePragma where-  location (LanguagePragma  loc _)   = Just loc-  location (OptionsPragma   loc _ _) = Just loc-  location (AnnModulePragma loc _)   = Just loc--instance Location ImportDecl where-  location = Just . importLoc--instance Location Decl where-  location (TypeDecl         loc _ _ _)         = Just loc-  location (TypeFamDecl      loc _ _ _)         = Just loc-  location (DataDecl         loc _ _ _ _ _ _)   = Just loc-  location (GDataDecl        loc _ _ _ _ _ _ _) = Just loc-  location (DataFamDecl      loc _ _ _ _)       = Just loc-  location (TypeInsDecl      loc _ _)           = Just loc-  location (DataInsDecl      loc _ _ _ _)       = Just loc-  location (GDataInsDecl     loc _ _ _ _ _)     = Just loc-  location (ClassDecl        loc _ _ _ _ _)     = Just loc-  location (InstDecl         loc _ _ _ _ _ _)   = Just loc-  location (DerivDecl        loc _ _ _ _ _)     = Just loc-  location (InfixDecl        loc _ _ _)         = Just loc-  location (DefaultDecl      loc _)             = Just loc-  location (SpliceDecl       loc _)             = Just loc-  location (TypeSig          loc _ _)           = Just loc-  location (FunBind matches) = location matches-  location (PatBind          loc _ _ _)         = Just loc-  location (ForImp           loc _ _ _ _ _)     = Just loc-  location (ForExp           loc _ _ _ _)       = Just loc-  location (RulePragmaDecl   loc _)             = Just loc-  location (DeprPragmaDecl   loc _)             = Just loc-  location (WarnPragmaDecl   loc _)             = Just loc-  location (InlineSig        loc _ _ _)         = Just loc-  location (InlineConlikeSig loc _ _)           = Just loc-  location (SpecSig          loc _ _ _)         = Just loc-  location (SpecInlineSig    loc _ _ _ _)       = Just loc-  location (InstSig          loc _ _ _ _)       = Just loc-  location (AnnPragma        loc _)             = Just loc--instance Location Match where-  location (Match loc _ _ _ _ _) = Just loc--instance Location a => Location (Maybe a) where-  location = join . fmap location--instance Location a => Location [a] where-  -- the earliest location.-  location = getMinPriority . execWriter . mapM_ located-+-- TODO: haskell-src-exts now supports SrcSpanInfo, which is more informative+-- than SrcLoc, should we switch?  -- | A value obtained from a particular location in the source code. --  -- The location only indicates the beginning of a range, because that's what -- haskell-src-exts provides.-type Located a = Writer (MinPriority SrcLoc) a+type Located a = Writer (Option (Min SrcLoc)) a -located :: Location a => a -> Located a-located x = do-    tell $ MinPriority $ location x+located :: SrcLoc -> Located ()+located srcLoc | srcLoc == noLoc = tell $ Option $ Nothing+               | otherwise       = tell $ Option $ Just $ Min srcLoc++annotated :: (Annotated ast, SrcInfo si) => ast si -> Located (ast si)+annotated x = do+    located $ getPointLoc $ ann x     return x  runLocated :: Located a -> (a, Maybe SrcLoc) runLocated = go . runWriter   where-    go (x, p) = (x, getMinPriority p)+    go (x, p) = (x, fmap getMin $ getOption $ p)
src/System/Console/Hawk.hs view
@@ -19,15 +19,20 @@   ) where  +import Control.Monad.Trans+import Data.List import Language.Haskell.Interpreter-import Text.Printf (printf)  import Control.Monad.Trans.Uncertain+import Data.HaskellExpr.Eval import System.Console.Hawk.Args import System.Console.Hawk.Args.Spec import System.Console.Hawk.Help import System.Console.Hawk.Interpreter import System.Console.Hawk.Runtime.Base+import System.Console.Hawk.UserExpr.CanonicalExpr+import System.Console.Hawk.UserExpr.InputReadyExpr+import System.Console.Hawk.UserExpr.OriginalExpr import System.Console.Hawk.Version  @@ -44,59 +49,80 @@ processSpec :: HawkSpec -> IO () processSpec Help          = help processSpec Version       = putStrLn versionString-processSpec (Eval  e   o) = applyExpr (wrapExpr "const" e) noInput o-processSpec (Apply e i o) = applyExpr e                    i       o-processSpec (Map   e i o) = applyExpr (wrapExpr "map"   e) i       o--wrapExpr :: String -> ExprSpec -> ExprSpec-wrapExpr f e = e'-  where-    u = userExpression e-    u' = printf "%s (%s)" (prel f) u-    e' = e { userExpression = u' }+processSpec (Eval  e   o) = myRunUncertainIO e $ processEvalSpec  (contextSpec e)   o (userExpr e)+processSpec (Apply e i o) = myRunUncertainIO e $ processApplySpec (contextSpec e) i o (userExpr e)+processSpec (Map   e i o) = myRunUncertainIO e $ processMapSpec   (contextSpec e) i o (userExpr e) -applyExpr :: ExprSpec -> InputSpec -> OutputSpec -> IO ()-applyExpr e i o = do-    let contextDir = userContextDirectory e-    let expr = userExpression e-    -    processRuntime <- runUncertainIO $ runHawkInterpreter $ do-      applyContext contextDir-      interpret' $ processTable' $ tableExpr expr-    runHawkIO $ processRuntime hawkRuntime+-- | A version of `runUncertainIO` which detects poor error messages and improves them.+myRunUncertainIO :: ExprSpec -> UncertainT IO () -> IO ()+myRunUncertainIO e = runUncertainIO . clarifyErrors e   where-    interpret' expr = do-      interpret expr (as :: HawkRuntime -> HawkIO ())-    -    hawkRuntime = HawkRuntime i o-    -    processTable' :: String -> String-    processTable' = printf "(%s) (%s) (%s)" (prel "flip")-                                            (runtime "processTable")-    -    -- turn the user expr into an expression manipulating [[B.ByteString]]-    tableExpr :: String -> String-    tableExpr = (`compose` fromTable)+    clarifyErrors :: ExprSpec -> UncertainT IO () -> UncertainT IO ()+    clarifyErrors exprSpec body = do+        r <- lift $ runUncertainT body+        case r of+          (Left errorMsg, _) | fromWrapperCode errorMsg -> do+            -- try again without the wrapper code+            let contextDir = userContextDirectory (contextSpec exprSpec)+            runHawkInterpreter contextDir $ do+              applyContext contextDir+              interpret annotatedExpr+                        (as :: ())  -- not the right type, but it should+                                    -- error-out before type-checking anyway.+            +            -- Unfortunately, if we messed up and the error really was in the wrapper+            -- code, the above will tell the user that the problem is that their user+            -- expression did not have type unit. In the unlikely case that it did+            -- have type unit, tell them that we messed up.+            warn "this should not happen."+            warn "please report this to https://github.com/gelisam/hawk/issues/new"+          _ -> return ()+        +        -- we didn't succeed at replacing the error (of we would have aborted by now).+        -- rethrow the original errors and warnings.+        uncertainT r       where-        fromTable = case inputFormat i of-            RawStream            -> head' `compose` head'-            Records _ RawRecord  -> map' head'-            Records _ (Fields _) -> prel "id"-    -    compose :: String -> String -> String-    compose f g = printf "(%s) %s (%s)" f (prel ".") g-    -    head' :: String-    head' = prel "head"+        annotatedExpr = "{-# LINE 1 \"user expression\" #-}\n" ++ untypedExpr exprSpec     -    map' :: String -> String-    map' = printf "(%s) (%s)" (prel "map")+    fromWrapperCode :: String -> Bool+    fromWrapperCode msg = "\twrapper code:" `isPrefixOf` firstLine+      where+        firstLine = (lines msg ++ ["",""]) !! 1 --- we cannot use any unqualified symbols in the user expression,--- because we don't know which modules the user prelude will import.-qualify :: String -> String -> String-qualify moduleName = printf "%s.%s" moduleName+userExpr :: ExprSpec -> OriginalExpr+userExpr = originalExpr . untypedExpr -prel, runtime :: String -> String-prel = qualify "Prelude"-runtime = qualify "System.Console.Hawk.Runtime"++processEvalSpec :: ContextSpec -> OutputSpec -> OriginalExpr -> UncertainT IO ()+processEvalSpec c o = processInputReadyExpr c noInput o . constExpr++processApplySpec :: ContextSpec -> InputSpec -> OutputSpec -> OriginalExpr -> UncertainT IO ()+processApplySpec c i o = processInputReadyExpr c i o . applyExpr++processMapSpec :: ContextSpec -> InputSpec -> OutputSpec -> OriginalExpr -> UncertainT IO ()+processMapSpec c i o = processInputReadyExpr c i o . mapExpr+++processInputReadyExpr :: ContextSpec+                      -> InputSpec+                      -> OutputSpec+                      -> InputReadyExpr+                      -> UncertainT IO ()+processInputReadyExpr c i o e = case canonicalizeExpr i e of+    Just e' -> processCanonicalExpr c i o e'+    Nothing -> fail "conflicting flags"++processCanonicalExpr :: ContextSpec+                     -> InputSpec+                     -> OutputSpec+                     -> CanonicalExpr+                     -> UncertainT IO ()+processCanonicalExpr c i o e = do+    let contextDir = userContextDirectory c+    processRuntime <- runHawkInterpreter contextDir $ do+      applyContext contextDir+      interpretExpr (runCanonicalExpr e)+    lift $ runHawkIO $ processRuntime hawkRuntime+  where+    hawkRuntime :: HawkRuntime+    hawkRuntime = HawkRuntime i o
src/System/Console/Hawk/Args.hs view
@@ -6,7 +6,7 @@   , InputFormat(..), RecordFormat(..)   , OutputFormat(..)   , Separator(..), Delimiter-  , ExprSpec(..)+  , ContextSpec(..), UntypedExpr, ExprSpec(..)   , parseArgs   ) where
src/System/Console/Hawk/Args/Option.hs view
@@ -7,6 +7,7 @@ import Text.Printf  import Control.Monad.Trans.OptionParser+import System.Console.Hawk.Args.Spec (Processor(DoNotSeparate, SeparateOn), Separator(Delimiter), Delimiter)   data HawkOption@@ -27,7 +28,7 @@   delimiter :: OptionType-delimiter = nullable (Setting "delim")+delimiter = optional (Setting "delim")  -- | Interpret escape sequences, but don't worry if they're invalid. -- @@ -48,8 +49,18 @@     _          -> s  -- | Almost like a string, except escape sequences are interpreted.-consumeDelimiter :: (Functor m, Monad m) => OptionConsumer m ByteString-consumeDelimiter = fmap parseDelimiter . consumeNullable "" consumeString+delimiterConsumer :: Monad m+                  => OptionConsumerT m Delimiter+delimiterConsumer = parseDelimiter <$> stringConsumer++separatorConsumer :: Monad m+                  => OptionConsumerT m Separator+separatorConsumer = Delimiter <$> delimiterConsumer++processorConsumer :: Monad m+                  => OptionConsumerT m Processor+processorConsumer = maybe DoNotSeparate SeparateOn+                <$> optionalConsumer separatorConsumer  instance Option HawkOption where   shortName Apply                 = 'a'
src/System/Console/Hawk/Args/Parse.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE OverloadedStrings, PackageImports #-}+{-# LANGUAGE OverloadedStrings, PackageImports, ScopedTypeVariables #-} -- | In which Hawk's command-line arguments are structured into a `HawkSpec`. module System.Console.Hawk.Args.Parse (parseArgs) where -import Control.Applicative import Data.Char                                 (isSpace)+import Data.Maybe import "mtl" Control.Monad.Trans  import Control.Monad.Trans.OptionParser@@ -17,39 +17,43 @@ -- >>> let testP parser = runUncertainIO . runOptionParserT options parser  --- | (record separator, field separator)-type CommonSeparators = (Separator, Separator)+-- | (record processor, field processor)+type CommonProcessors = (Processor, Processor)  -- | Extract '-D' and '-d'. We perform this step separately because those two --   delimiters are used by both the input and output specs. -- --- >>> let test = testP commonSeparators+-- >>> let test = testP commonProcessors --  -- >>> test []--- (Delimiter "\n",Whitespace)+-- (SeparateOn (Delimiter "\n"),SeparateOn Whitespace) --  -- >>> test ["-D\\n", "-d\\t"]--- (Delimiter "\n",Delimiter "\t")+-- (SeparateOn (Delimiter "\n"),SeparateOn (Delimiter "\t")) --  -- >>> test ["-D|", "-d,"]--- (Delimiter "|",Delimiter ",")-commonSeparators :: (Functor m, Monad m)-                 => OptionParserT HawkOption m CommonSeparators-commonSeparators = do-    r <- lastSep Option.RecordDelimiter defaultRecordSeparator-    f <- lastSep Option.FieldDelimiter defaultFieldSeparator+-- (SeparateOn (Delimiter "|"),SeparateOn (Delimiter ","))+--+-- >>> test ["-D", "-d"]+-- (DoNotSeparate,DoNotSeparate)+commonProcessors :: forall m. (Functor m, Monad m)+                 => OptionParserT HawkOption m CommonProcessors+commonProcessors = do+    r <- consumeProcessor Option.RecordDelimiter defaultRecordSeparator+    f <- consumeProcessor Option.FieldDelimiter  defaultFieldSeparator     return (r, f)   where-    lastSep opt def = consumeLast opt def consumeSep-    consumeSep = fmap Delimiter . Option.consumeDelimiter+    consumeProcessor :: HawkOption -> Separator -> OptionParserT HawkOption m Processor+    consumeProcessor opt def = fromMaybe (SeparateOn def)+                           <$> consumeLast opt (Option.processorConsumer)   -- | The input delimiters have already been parsed, but we still need to --   interpret them and to determine the input source. --  -- >>> :{--- let test = testP $ do { c <- commonSeparators---                       ; _ <- consumeExtra consumeString  -- skip expr+-- let test = testP $ do { c <- commonProcessors+--                       ; _ <- consumeExtra stringConsumer  -- skip expr --                       ; i <- inputSpec c --                       ; lift $ print $ inputSource i --                       ; lift $ print $ inputFormat i@@ -72,25 +76,27 @@ -- InputFile "/etc/passwd" -- Records (Delimiter "\n") (Fields (Delimiter ":")) inputSpec :: (Functor m, Monad m)-          => CommonSeparators -> OptionParserT HawkOption m InputSpec-inputSpec (r, f) = InputSpec <$> source <*> format+          => CommonProcessors -> OptionParserT HawkOption m InputSpec+inputSpec (rProc, fProc) = InputSpec <$> source <*> format   where     source = do-        r <- consumeExtra consumeString+        r <- consumeExtra stringConsumer         return $ case r of           Nothing -> UseStdin           Just f  -> InputFile f     format = return streamFormat-    streamFormat | r == Delimiter "" = RawStream-                 | otherwise         = Records r recordFormat-    recordFormat | f == Delimiter ""   = RawRecord-                 | otherwise           = Fields f+    streamFormat = case rProc of+      DoNotSeparate   -> RawStream+      SeparateOn rSep -> Records rSep recordFormat+    recordFormat = case fProc of+      DoNotSeparate   -> RawRecord+      SeparateOn fSep -> Fields fSep  -- | The output delimiters take priority over the input delimiters, regardless --   of the order in which they appear. --  -- >>> :{--- let test = testP $ do { c <- commonSeparators+-- let test = testP $ do { c <- commonProcessors --                       ; o <- outputSpec c --                       ; let OutputFormat r f = outputFormat o --                       ; lift $ print $ outputSink o@@ -104,31 +110,38 @@ --  -- >>> test ["-D;", "-d", "-a", "L.reverse"] -- UseStdout--- (";","")+-- (";"," ") --  -- >>> test ["-o\t", "-d,", "-O|"] -- UseStdout -- ("|","\t")-outputSpec :: (Functor m, Monad m)-           => CommonSeparators -> OptionParserT HawkOption m OutputSpec+outputSpec :: forall m. (Functor m, Monad m)+           => CommonProcessors -> OptionParserT HawkOption m OutputSpec outputSpec (r, f) = OutputSpec <$> sink <*> format   where+    sink :: OptionParserT HawkOption m OutputSink     sink = return UseStdout++    format :: OptionParserT HawkOption m OutputFormat     format = OutputFormat <$> record <*> field-    record = consumeLast Option.OutputRecordDelimiter r' Option.consumeDelimiter-    field = consumeLast Option.OutputFieldDelimiter f' Option.consumeDelimiter-    r' = fromSeparator r-    f' = fromSeparator f +    record, field :: OptionParserT HawkOption m Delimiter+    record = fmap (fromMaybe r') $ consumeLast Option.OutputRecordDelimiter $ fromMaybe "" <$> optionalConsumer Option.delimiterConsumer+    field  = fmap (fromMaybe f') $ consumeLast Option.OutputFieldDelimiter  $ fromMaybe "" <$> optionalConsumer Option.delimiterConsumer +    r', f' :: Delimiter+    r' = fromProcessor defaultRecordDelimiter r+    f' = fromProcessor defaultFieldDelimiter  f++ -- | The information we need in order to evaluate a user expression: --   the expression itself, and the context in which it should be evaluated. --   In Hawk, that context is the user prelude. --  -- >>> :{ -- let test = testP $ do { e <- exprSpec---                       ; lift $ print $ userExpression e---                       ; lift $ print $ userContextDirectory e+--                       ; lift $ print $ untypedExpr e+--                       ; lift $ print $ userContextDirectory (contextSpec e) --                       } -- :} -- @@ -145,15 +158,16 @@ -- "somedir" exprSpec :: (Functor m, MonadIO m)          => OptionParserT HawkOption m ExprSpec-exprSpec = ExprSpec <$> contextDir <*> expr+exprSpec = ExprSpec <$> (ContextSpec <$> contextDir)+                    <*> expr   where     contextDir = do-      dir <- consumeLast Option.ContextDirectory "" consumeString-      if null dir-        then liftIO findContextFromCurrDirOrDefault-        else return dir+      maybeDir <- consumeLast Option.ContextDirectory stringConsumer+      case maybeDir of+        Nothing -> liftIO findContextFromCurrDirOrDefault+        Just dir -> return dir     expr = do-        r <- consumeExtra consumeString+        r <- consumeExtra stringConsumer         case r of           Just e  -> if all isSpace e                       then fail "user expression cannot be empty"@@ -170,9 +184,9 @@ --                    ; case spec of --                        Help        -> putStrLn "Help" --                        Version     -> putStrLn "Version"---                        Eval  e   o -> putStrLn "Eval"  >> print (userExpression e)                                         >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))---                        Apply e i o -> putStrLn "Apply" >> print (userExpression e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))---                        Map   e i o -> putStrLn "Map"   >> print (userExpression e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))+--                        Eval  e   o -> putStrLn "Eval"  >> print (untypedExpr e)                                         >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))+--                        Apply e i o -> putStrLn "Apply" >> print (untypedExpr e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))+--                        Map   e i o -> putStrLn "Map"   >> print (untypedExpr e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o)) --                    } -- :} -- @@ -207,8 +221,8 @@   where     parser = do         lift $ return ()  -- silence a warning-        cmd <- consumeExclusive assoc eval-        c <- commonSeparators+        cmd <- fromMaybe eval <$> consumeExclusive assoc+        c <- commonProcessors         cmd c     assoc = [ (Option.Help,    help)             , (Option.Version, version)@@ -216,7 +230,7 @@             , (Option.Map,     map')             ]     -    help, version, eval, apply, map' :: (Functor m,MonadIO m) => CommonSeparators+    help, version, eval, apply, map' :: (Functor m,MonadIO m) => CommonProcessors                                      -> OptionParserT HawkOption m HawkSpec     help    _ = return Help     version _ = return Version
src/System/Console/Hawk/Context/Base.hs view
@@ -15,7 +15,6 @@ import Control.Monad.Trans.State.Persistent import Data.Cache import qualified Data.HaskellModule as M-import System.Console.Hawk.Context.Dir import System.Console.Hawk.Context.Paths import System.Console.Hawk.UserPrelude import System.Console.Hawk.Version@@ -29,12 +28,11 @@   } deriving (Eq, Read, Show)  -- | Obtains a Context, either from the cache or from the user prelude.--- --- Must be called inside a `withLock` block, otherwise the cache file--- might get accessed by two instances of Hawk at once.+--+-- Must be called inside a `runHawkInterpreter contextDir` block so that the+-- context folder is initialized. TODO: use the types to enforce this. getContext :: FilePath -> UncertainT IO Context getContext contextDir = do-    createDefaultContextDir paths     key <- lift $ getKey preludeFile          -- skip `newContext` if the cached copy is still good.
src/System/Console/Hawk/Context/Dir.hs view
@@ -9,24 +9,24 @@ import Control.Monad import "mtl" Control.Monad.Trans import System.Directory-import System.EasyFile (readable) import System.FilePath  import Control.Monad.Trans.Uncertain import System.Console.Hawk.Context.Paths import System.Console.Hawk.UserPrelude.Defaults+import System.Directory.Extra   -- | Create a default context-createDefaultContextDir :: ContextPaths -> UncertainT IO ()-createDefaultContextDir paths = do+createDefaultContextDir :: FilePath -> UncertainT IO ()+createDefaultContextDir contextDir = do     _ <- checkContextDir contextDir     liftIO $ do       createDirectoryIfMissing True contextDir       preludeExists <- doesFileExist preludeFile       unless preludeExists $ writeFile preludeFile defaultPrelude   where-    contextDir = contextDirPath paths+    paths = mkContextPaths contextDir     preludeFile = originalPreludePath paths  -- | Find a project context@@ -34,14 +34,9 @@ findContext startDir =     foldM (maybe validDirOrNothing (const . return . Just)) Nothing possibleContextDirs   where-    (drive, startPath) = splitDrive startDir-    mkHawkPath relPath = joinDrive drive (relPath </> ".hawk")-    -    parentPath = init . dropFileName-    parentPaths = takeWhile (/= ".") . iterate parentPath-    -    possibleContextDirs = map mkHawkPath (parentPaths startPath)-    +    mkHawkPath = (</> ".hawk")+    possibleContextDirs = map mkHawkPath (ancestors startDir)+     validDirOrNothing dir = do       dirExists <- doesDirectoryExist dir       if dirExists@@ -54,7 +49,7 @@                Nothing -> return Nothing                Just f -> do                  preludePermissions <- getPermissions f-                 if System.EasyFile.readable preludePermissions+                 if readable preludePermissions                    then return $ Just dir                    else return Nothing            else return Nothing@@ -85,10 +80,10 @@     if dirExists       then do         permissions <- liftIO $ getPermissions dir-        when (not $ writable permissions) $ fail $ concat [+        unless (writable permissions) $ fail $ concat [            "cannot use '",dir,"' as context directory because it is not "           ,"writable"]-        when (not $ searchable permissions) $ fail $ concat [+        unless (searchable permissions) $ fail $ concat [            "cannot use '",dir,"' as context directory because it is not "           ,"searchable"]         return False@@ -97,10 +92,10 @@         -- and searchable         let parent = case takeDirectory dir of {"" -> ".";p -> p}         permissions <- liftIO $ getPermissions parent-        when (not $ writable permissions) $ fail $ concat[+        unless (writable permissions) $ fail $ concat[            "cannot create context directory '",dir,"' because the parent "           ," directory is not writable (",show permissions,")"]-        when (not $ searchable permissions) $ fail $ concat[+        unless (searchable permissions) $ fail $ concat[            "cannot create context directory '",dir,"' because the parent "           ," directory is not searchable (",show permissions,")"]         warn $ concat ["directory '",dir,"' doesn't exist, creating a "
src/System/Console/Hawk/Context/Paths.hs view
@@ -18,6 +18,9 @@   , cachedPreludePath :: FilePath   } deriving (Eq, Read, Show) +-- TODO: if we're always using the same relative paths, we could make illegal+-- states unrepresentable by making ContextPaths = contextDir and turning the+-- accessors into functions mkContextPaths :: FilePath -> ContextPaths mkContextPaths contextDir = ContextPaths     { contextDirPath       = contextDir
src/System/Console/Hawk/Interpreter.hs view
@@ -10,7 +10,8 @@  import Control.Monad.Trans.Uncertain import qualified System.Console.Hawk.Context as Context-import qualified System.Console.Hawk.Sandbox as Sandbox+import qualified System.Console.Hawk.Context.Dir as Context+import qualified System.Console.Hawk.PackageDbs as PackageDbs import System.Console.Hawk.UserPrelude.Defaults import System.Console.Hawk.Lock @@ -55,5 +56,7 @@ wrapErrors (Right x) = return x  -runHawkInterpreter :: InterpreterT IO a -> UncertainT IO a-runHawkInterpreter = wrapErrorsM . withLock . Sandbox.runHawkInterpreter+runHawkInterpreter :: FilePath -> InterpreterT IO a -> UncertainT IO a+runHawkInterpreter cxtDir body = do+  Context.createDefaultContextDir cxtDir+  wrapErrorsM . withLock cxtDir . PackageDbs.runHawkInterpreter $ body
src/System/Console/Hawk/Lock.hs view
@@ -20,106 +20,20 @@     , withTestLock     ) where -import Control.Concurrent ( threadDelay )-import Control.Exception-import Control.Monad ( when, guard )-import Data.List ( elemIndex )-import GHC.IO.Exception-import GHC.IO.Handle ( Handle, hGetContents, hClose )-import Network.BSD ( getProtocolNumber ) -- still cross-platform, don't let the name fool you-import Network ( PortID (..), connectTo )-import Network.Socket-import Text.Printf----- use a socket number as a lock indicator.-withSocketLock :: Bool -> IO a -> IO a-withSocketLock testing = withSocketsDo . bracket (lock testing) unlock . const---- make sure GHC inlines withSocketLock in the following two functions--- and optimizes the testing and non-testing versions separately.-{-# INLINE withSocketLock #-}--withLock :: IO a -> IO a-withLock = withSocketLock False--withTestLock :: IO a -> IO a-withTestLock = withSocketLock True---type Lock = Socket--lock :: Bool -> IO Lock-lock testing = catchJust isADDRINUSE openSocket $ \() -> do-    -- open failed, the lock must be in use.-    -    when testing $ putStrLn "** LOCKED **"-    -    -- used to test an interleaving in which the socket is closed here,-    -- between openSocket and waitForException.-    when testing $ threadDelay 20000-    -    -- wait for the other instance to signal that it is done with the lock.-    catchJust isDisconnected waitForException $ \reason -> do-      -- we were disconnected, the server must have released the lock!-      -      when testing $ printf "** UNLOCKED (%s) **\n" reason-      -      -- try again.-      lock testing--unlock :: Lock -> IO ()-unlock = closeSocket---waitForException :: IO a-waitForException = bracket openHandle closeHandle $ \h -> do-    s <- hGetContents h-    length s `seq` return ()  -- blocks until EOF, which never comes-                              -- because the server never accepted the connection-    error $ printf "port %s in use by a program other than hawk" $ show portNumber---isADDRINUSE :: IOError -> Maybe ()-isADDRINUSE = guard . (== "bind") . ioe_location--isDisconnected :: IOError -> Maybe String-isDisconnected = fmap (xs !!) . indexOf . ioe_location-  where-    xs = ["connect", "hGetContents"]-    indexOf x = elemIndex x xs---openHandle :: IO Handle-openHandle = connectTo "localhost" $ PortNumber portNumber--closeHandle :: Handle -> IO ()-closeHandle = hClose---openSocket :: IO Socket-openSocket = listenOn portNumber--closeSocket :: Socket -> IO ()-closeSocket = sClose-+import System.FileLock ( SharedExclusive( Exclusive ), withFileLock )+import System.FilePath ( (</>) ) --- the first few [0-9] characters of the sha1 of "hawk"-portNumber :: PortNumber-portNumber = 62243+-- | Create a temporary file to indicate to other hawk process+--  not to run until this process is unblocked+withLock :: FilePath -> IO a -> IO a+withLock ctxDir action = withFileLock tempFile Exclusive (const action)+    where tempFile = ctxDir </> "lock.tmp" --- from the source of Network.listenTo-listenOn :: PortNumber -> IO Socket-listenOn port = do-    proto <- getProtocolNumber "tcp"-    bracketOnError-        (socket AF_INET Stream proto)-        (sClose)-        (\sock -> do-            -- unlike the original listenOn, we do NOT set ReuseAddr.-            -- this way the call will fail if another instance holds the lock.-            --setSocketOption sock ReuseAddr 1-            bindSocket sock (SockAddrInet port iNADDR_ANY)-            listen sock maxListenQueue-            return sock-        )+-- | withLock but with additional messages+withTestLock :: FilePath -> IO a -> IO a+withTestLock ctxDir action = withFileLock tempFile Exclusive $ \_ -> do+    putStrLn "** LOCKED **"+    res <- action+    putStrLn "** UNLOCKED **"+    return res+    where tempFile = ctxDir </> "lock.tmp"
+ src/System/Console/Hawk/PackageDbs.hs view
@@ -0,0 +1,265 @@+--   Copyright 2013 Mario Pastorelli (pastorelli.mario@gmail.com) Samuel Gélineau (gelisam@gmail.com)+--+--   Licensed under the Apache License, Version 2.0 (the "License");+--   you may not use this file except in compliance with the License.+--   You may obtain a copy of the License at+--+--       http://www.apache.org/licenses/LICENSE-2.0+--+--   Unless required by applicable law or agreed to in writing, software+--   distributed under the License is distributed on an "AS IS" BASIS,+--   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+--   See the License for the specific language governing permissions and+--   limitations under the License.++-- Extra steps to be performed if hawk was installed from a sandbox.+-- +-- Extra steps are needed because the hawk binary needs runtime access+-- to the hawk library, but the hint library only knows about the globally-+-- installed libraries. If hawk has been installed with a sandbox, its+-- binary and its library will be installed in a local folder instead of+-- in the global location.+{-# LANGUAGE CPP, LambdaCase, TemplateHaskell, TupleSections #-}+module System.Console.Hawk.PackageDbs+    ( extraGhcArgs+    , runHawkInterpreter+    ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Writer+import Data.Foldable+import Data.List.Extra (stripSuffix, wordsBy)+import Language.Haskell.Interpreter (InterpreterError, InterpreterT)+import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)+import System.Directory.PathFinder+import Text.Printf (printf)+import qualified System.FilePath as FilePath++import System.Console.Hawk.PackageDbs.TH+import System.Console.Hawk.Path (getInstallationPath)+++data InstallationMethod a = InstallationMethod+  { installationMethodName :: String+  , installationMethodData :: a+  }++type InstallationMethodChecker = IO (Maybe PackageDbFinder)+type PackageDbFinder = IO [FilePath]++supportedInstallationMethods :: [InstallationMethod InstallationMethodChecker]+supportedInstallationMethods+  = [ InstallationMethod "stack" $ do+        pure $ do+          haskellPackageSandboxes <- $$(compileTimeEnvVar "HASKELL_PACKAGE_SANDBOXES")+          pure $ do+            pure $ wordsBy (== ':') haskellPackageSandboxes+    , InstallationMethod "cabal v2-run" $ do  -- also used by cabal v2-test+        bindir <- getInstallationPath+        maybePaths <- runMaybeT $ do+          -- "~/.cabal/bin" might not exist yet, but "~/.cabal" does+          let binSuffix = FilePath.pathSeparator : "bin"+          bindirParent <- MaybeT $ pure $ stripSuffix binSuffix bindir+          dotCabal <- MaybeT $ flip runPathFinder bindirParent $ do+            filenameIs ".cabal"++          haskellDistDir <- MaybeT $ pure $$(compileTimeEnvVar "HASKELL_DIST_DIR")+          distNewstyle <- MaybeT $ flip runPathFinder haskellDistDir $ do+            -- "/.../dist-newstyle/build/x86_64-osx/ghc-8.4.4/haskell-awk-1.1.1"+            relativePath ".."+            filenameIs (printf "ghc-%s" VERSION_ghc)+            -- "/.../dist-newstyle/build/x86_64-osx/ghc-8.4.4"+            relativePath ".."+            -- "/.../dist-newstyle/build/x86_64-osx"+            relativePath ".."+            filenameIs "build"+            -- "/.../dist-newstyle/build"+            relativePath ".."+            filenameIs "dist-newstyle"+            -- "/.../dist-newstyle"+          pure (dotCabal, haskellDistDir, distNewstyle)+        pure $ do+          (dotCabal, haskellDistDir, distNewstyle) <- maybePaths+          pure $ do+            globalPackageDb <- findSinglePackageDb dotCabal $ do+              -- "~/.cabal"+              relativePath "store"+              -- "~/.cabal/store"+              relativePath (printf "ghc-%s" VERSION_ghc)+              -- "~/.cabal/store/ghc-8.4.4"+              relativePath "package.db"+              -- "~/.cabal/store/ghc-8.4.4/package.db"+            localPackageDb <- findSinglePackageDb distNewstyle $ do+              -- "/.../dist-newstyle"+              relativePath "packagedb"+              -- "/.../dist-newstyle/packagedb"+              relativePath (printf "ghc-%s" VERSION_ghc)+              -- "/.../dist-newstyle/packagedb/ghc-8.4.4"+            inPlacePackageDb <- findSinglePackageDb haskellDistDir $ do+              -- "/.../dist-newstyle/build/x86_64-osx/ghc-8.4.4/haskell-awk-1.1.1"+              relativePath "package.conf.inplace"+              -- "/.../dist-newstyle/build/x86_64-osx/ghc-8.4.4/haskell-awk-1.1.1/package.conf.inplace"+            pure [globalPackageDb, localPackageDb, inPlacePackageDb]+    , InstallationMethod "cabal v2-install" $ do+        bindir <- getInstallationPath+        maybeDotCabal <- flip runPathFinder bindir $ do+          -- "~/.cabal/store/ghc-8.4.4/hskll-wk-1.1.1-f21ccfdf/bin"+          relativePath ".."+          -- "~/.cabal/store/ghc-8.4.4/hskll-wk-1.1.1-f21ccfdf"+          relativePath ".."+          filenameIs (printf "ghc-%s" VERSION_ghc)+          -- "~/.cabal/store/ghc-8.4.4"+          relativePath ".."+          filenameIs "store"+          -- "~/.cabal/store"+          relativePath ".."+          filenameIs ".cabal"+          -- "~/.cabal"+        pure $ do+          dotCabal <- maybeDotCabal++          -- to distinguish between v1-install and v2-install+          guard ( "dist-newstyle"+           `elem` FilePath.splitDirectories $$(compileTimeWorkingDirectory)+                )++          pure $ do+            globalPackageDb <- findSinglePackageDb dotCabal $ do+              -- "~/.cabal"+              relativePath "store"+              -- "~/.cabal/store"+              relativePath (printf "ghc-%s" VERSION_ghc)+              -- "~/.cabal/store/ghc-8.4.4"+              relativePath "package.db"+              -- "~/.cabal/store/ghc-8.4.4/package.db"+            pure [globalPackageDb]+    , InstallationMethod "cabal v1-sandbox" $ do+        bindir <- getInstallationPath+        maybeCabalSandbox <- flip runPathFinder bindir $ do+          -- "/.../haskell-awk/.cabal-sandbox/bin"+          relativePath ".."+          filenameIs ".cabal-sandbox"+          -- "/.../haskell-awk/.cabal-sandbox"+        pure $ do+          cabalSandbox <- maybeCabalSandbox+          pure $ do+            packageDb <- findSinglePackageDb cabalSandbox $ do+              -- "/.../haskell-awk/.cabal-sandbox"+              someChild+              filenameMatches "" (printf "-ghc-%s-packages.conf.d" VERSION_ghc)+              -- "/.../haskell-awk/.cabal-sandbox/x86_64-osx-ghc-8.4.4-packages.conf.d"+            pure [packageDb]+    , InstallationMethod "cabal v1-install" $ do+        bindir <- getInstallationPath+        maybeDotGhc <- flip runPathFinder bindir $ do+          -- "~/.cabal/bin"+          relativePath ".."+          filenameIs ".cabal"+          -- "~/.cabal"+          relativePath ".."+          -- "~"+          relativePath ".ghc"+          -- "~/.ghc"+        maybeDist <- flip runPathFinder $$(compileTimeWorkingDirectory) $ do+          -- "/.../haskell-awk"+          relativePath "dist"+          -- "/.../haskell-awk/dist"+        pure $ do+          dotGhc <- maybeDotGhc++          -- to distinguish between v1-install and v2-install+          _ <- maybeDist++          -- to distinguish between v1-install and v2-run+          haskellDistDir <- $$(compileTimeEnvVar "HASKELL_DIST_DIR")+          guard (haskellDistDir == "dist")++          pure $ do+            packageDb <- findSinglePackageDb dotGhc $ do+              -- "~/.ghc"+              someChild+              filenameMatches "" (printf "-%s" VERSION_ghc)+              -- "~/.ghc/x86_64-darwin-8.4.4"+              relativePath "package.conf.d"+              -- "~/.ghc/x86_64-darwin-8.4.4/package.conf.d"+            pure [packageDb]+    ]++findSinglePackageDb :: FilePath -> MultiPathFinder -> IO FilePath+findSinglePackageDb searchPath multiPathFinder = do+  runMultiPathFinder multiPathFinder searchPath >>= \case+    [] -> do+      error $ "No package database found in " ++ searchPath+    [packageDb] -> do+      pure packageDb+    packageDbs -> do+      error $ "Multiple package databases found in " ++ searchPath+        ++ ": " ++ multiPhrase "and" packageDbs+        ++ ". It is ambiguous which one to use."++-- |+-- >>> unsupportedInstallationMethodMessage+-- "Please install hawk using stack, cabal v2-run, cabal v2-install, cabal v1-sandbox, or cabal v1-install. Hawk doesn't know how to find the package database using your chosen installation method."+unsupportedInstallationMethodMessage :: String+unsupportedInstallationMethodMessage+  = "Please install hawk using "+ ++ multiPhrase "or" (fmap installationMethodName supportedInstallationMethods)+ ++ ". Hawk doesn't know how to find the package database using your chosen installation method."++multiPhrase :: String -> [String] -> String+multiPhrase connective = \case+  [x]+    -> x+  [x,y]+    -> x ++ " " ++ connective ++ " " ++ y+  xs+    -> concat (fmap (++ ", ") (init xs))+    ++ connective+    ++ " " ++ last xs+++detectInstallationMethods :: IO [InstallationMethod PackageDbFinder]+detectInstallationMethods = execWriterT $ do+  for_ supportedInstallationMethods $ \(InstallationMethod name detect) -> do+    liftIO detect >>= \case+      Just packageDbFinder -> do+        tell [InstallationMethod name packageDbFinder]+      Nothing -> do+        pure ()++detectInstallationMethod :: IO (InstallationMethod PackageDbFinder)+detectInstallationMethod = do+  detectInstallationMethods >>= \case+    [] -> do+      error unsupportedInstallationMethodMessage+    [x] -> do+      pure x+    installationMethods -> do+      error $ "Multiple installation methods detected: "+           ++ multiPhrase "and" (fmap installationMethodName installationMethods)+           ++ ". It is ambiguous which package database to use."++detectPackageDbs :: IO [FilePath]+detectPackageDbs = do+  InstallationMethod _ findPackageDbs <- detectInstallationMethod+  findPackageDbs+++-- something like ["-package-db /.../haskell-awk/cabal-dev/package-7.6.3.conf"]+extraGhcArgs :: IO [String]+extraGhcArgs = fmap (printf "-package-db %s") <$> detectPackageDbs++-- | a version of runInterpreter which can load libraries+--   installed along hawk's sandbox folder, if applicable.+-- +-- Must be called inside a `withLock` block, otherwise hint will generate+-- conflicting temporary files.+-- +-- TODO: Didn't we write a patch for hint about this?+--       Do we still need the lock?+runHawkInterpreter :: InterpreterT IO a -> IO (Either InterpreterError a)+runHawkInterpreter mx = do+    args <- extraGhcArgs+    unsafeRunInterpreterWithArgs args mx
+ src/System/Console/Hawk/PackageDbs/TH.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+module System.Console.Hawk.PackageDbs.TH+    ( compileTimeEnvVar+    , compileTimeWorkingDirectory+    ) where++import Language.Haskell.TH.Syntax (TExp(TExp), Q, lift, runIO)+#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH.Syntax (Code, liftCode)+#endif+import System.Directory (getCurrentDirectory)+import System.Environment (getEnvironment)+++#if !MIN_VERSION_template_haskell(2,17,0)+type Code m a = m (TExp a)++liftCode :: m (TExp a) -> Code m a+liftCode = id+#endif++compileTimeEnvVar :: String -> Code Q (Maybe String)+compileTimeEnvVar varname = liftCode $ do+  env <- runIO getEnvironment+  let r :: Maybe String+      r = lookup varname env+  TExp <$> lift r++compileTimeWorkingDirectory :: Code Q String+compileTimeWorkingDirectory = liftCode $ do+  pwd <- runIO getCurrentDirectory+  TExp <$> lift pwd
+ src/System/Console/Hawk/Runtime/HaskellExpr.hs view
@@ -0,0 +1,17 @@+-- | The fully-qualified HaskellExpr representation of some functions from+--   System.Console.Hawk.Runtime+module System.Console.Hawk.Runtime.HaskellExpr where++import qualified Data.ByteString.Lazy.Char8 as B++import Data.HaskellExpr+import System.Console.Hawk.Representable+import System.Console.Hawk.Runtime+import System.Console.Hawk.Runtime.Base+++eSomeRows :: Rows a => HaskellExpr (a -> SomeRows)+eSomeRows = qualified "System.Console.Hawk.Runtime" "SomeRows"++eProcessTable :: HaskellExpr (HawkRuntime -> ([[B.ByteString]] -> SomeRows) -> HawkIO ())+eProcessTable = qualified "System.Console.Hawk.Runtime" "processTable"
− src/System/Console/Hawk/Sandbox.hs 
@@ -1,124 +0,0 @@---   Copyright 2013 Mario Pastorelli (pastorelli.mario@gmail.com) Samuel Gélineau (gelisam@gmail.com)------   Licensed under the Apache License, Version 2.0 (the "License");---   you may not use this file except in compliance with the License.---   You may obtain a copy of the License at------       http://www.apache.org/licenses/LICENSE-2.0------   Unless required by applicable law or agreed to in writing, software---   distributed under the License is distributed on an "AS IS" BASIS,---   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.---   See the License for the specific language governing permissions and---   limitations under the License.---- Extra steps to be performed if hawk was installed from a sandbox.--- --- Extra steps are needed because the hawk binary needs runtime access--- to the hawk library, but the hint library only knows about the globally---- installed libraries. If hawk has been installed with a sandbox, its--- binary and its library will be installed in a local folder instead of--- in the global location.-module System.Console.Hawk.Sandbox-    ( extraGhcArgs-    , runHawkInterpreter-    ) where--import Control.Applicative-import Data.List-import Language.Haskell.Interpreter (InterpreterT, InterpreterError)-import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)-import System.Directory (getDirectoryContents)-import System.FilePath (pathSeparator)-import Text.Printf (printf)---- magic self-referential module created by cabal-import Paths_haskell_awk (getBinDir)---data Sandbox = Sandbox-  { folder :: FilePath-  , packageFilePrefix :: String-  , packageFileSuffix :: String-  } deriving Show--cabalDev, cabalSandbox :: Sandbox-cabalDev = Sandbox "cabal-dev" "packages-" ".conf"-cabalSandbox = Sandbox ".cabal-sandbox" "" "-packages.conf.d"---- all the sandbox systems we support.-sandboxes :: [Sandbox]-sandboxes = [cabalDev, cabalSandbox]----- a version of isSuffixOf which returns the string stripped of its suffix.-isSuffixOf' :: String -> String -> Maybe String-isSuffixOf' suffix s = if suffix `isSuffixOf` s-                         then Just (take (n - m) s)-                         else Nothing-  where-    n = length s-    m = length suffix----- convert slashes to backslashes if needed-path :: String -> String-path = map replaceSeparator where-    replaceSeparator '/' = pathSeparator-    replaceSeparator x = x----- if hawk has been compiled by a sandboxing tool,--- its binary has been placed in a special folder.--- --- return something like (Just "/.../cabal-dev")-getSandboxDir :: Sandbox -> IO (Maybe String)-getSandboxDir sandbox = do-    dir <- Paths_haskell_awk.getBinDir-    let sandboxFolder = folder sandbox-    let suffix = path (sandboxFolder ++ "/bin")-    let basePath = suffix `isSuffixOf'` dir-    let sandboxPath = fmap (++ sandboxFolder) basePath-    return sandboxPath---- something like "packages-7.6.3.conf"-isPackageFile :: Sandbox -> FilePath -> Bool-isPackageFile sandbox f = packageFilePrefix sandbox `isPrefixOf` f-                       && packageFileSuffix sandbox `isSuffixOf` f---- something like "/.../cabal-dev/package-7.6.3.conf"-getPackageFile :: Sandbox -> String -> IO String-getPackageFile sandbox dir = do-    files <- getDirectoryContents dir-    case filter (isPackageFile sandbox) files of-      [file] -> return $ printf (path "%s/%s") dir file-      [] -> fail' "no package-db"-      _ -> fail' $ "multiple package-db's"-  where-    fail' s = error $ printf "%s found in sandbox %s" s (folder sandbox)--sandboxSpecificGhcArgs :: Sandbox -> IO [String]-sandboxSpecificGhcArgs sandbox = do-    sandboxDir <- getSandboxDir sandbox-    case sandboxDir of-      Nothing -> return []-      Just dir -> do packageFile <- getPackageFile sandbox dir-                     let arg = printf "-package-db %s" packageFile-                     return [arg]---extraGhcArgs :: IO [String]-extraGhcArgs = concat <$> mapM sandboxSpecificGhcArgs sandboxes---- | a version of runInterpreter which can load libraries---   installed along hawk's sandbox folder, if applicable.--- --- Must be called inside a `withLock` block, otherwise hint will generate--- conflicting temporary files.--- --- TODO: Didn't we write a patch for hint about this?---       Do we still need the lock?-runHawkInterpreter :: InterpreterT IO a -> IO (Either InterpreterError a)-runHawkInterpreter mx = do-    args <- extraGhcArgs-    unsafeRunInterpreterWithArgs args mx
+ src/System/Console/Hawk/UserExpr/CanonicalExpr.hs view
@@ -0,0 +1,33 @@+module System.Console.Hawk.UserExpr.CanonicalExpr where+++import qualified Data.ByteString.Lazy.Char8 as B++import Data.HaskellExpr+import Data.HaskellExpr.Base+import System.Console.Hawk.Args+import System.Console.Hawk.Runtime+import System.Console.Hawk.Runtime.Base+import System.Console.Hawk.Runtime.HaskellExpr+import System.Console.Hawk.UserExpr.InputReadyExpr+import System.Console.Hawk.UserExpr.OriginalExpr+++-- | Regardless of the requested input format, we currently convert all user expressions+--   so that they expect a `[[ByteString]]`. The runtime will also look at the input format,+--   in order to encode it as a `[[ByteString]]` as well. For example, if the input format is+--   supposed to be a single `ByteString`, the runtime will pack that string `s` into a nested+--   singleton list `[[s]]`, and the canonical user expression will expect this format.+type CanonicalExpr = HaskellExpr ([[B.ByteString]] -> SomeRows)++-- | Could fail if the required case of the user expression is `Nothing`, meaning that the+--   other flags were not compatible with the requested input format.+canonicalizeExpr :: InputSpec -> InputReadyExpr -> Maybe CanonicalExpr+canonicalizeExpr i (UserExpr _ e1 e2 e3) = case inputFormat i of+  RawStream            -> (`eComp` (eHead `eComp` eHead)) <$> e1+  Records _ RawRecord  -> (`eComp` (eMap `eAp` eHead)) <$> e2+  Records _ (Fields _) -> e3+++runCanonicalExpr :: CanonicalExpr -> HaskellExpr (HawkRuntime -> HawkIO ())+runCanonicalExpr eExpr = eFlip `eAp` eProcessTable `eAp` eExpr
+ src/System/Console/Hawk/UserExpr/InputReadyExpr.hs view
@@ -0,0 +1,44 @@+module System.Console.Hawk.UserExpr.InputReadyExpr where+++import qualified Data.ByteString.Lazy.Char8 as B++import Data.HaskellExpr+import Data.HaskellExpr.Base+import System.Console.Hawk.Runtime+import System.Console.Hawk.Runtime.HaskellExpr+import System.Console.Hawk.UserExpr.OriginalExpr+++-- | While the original user input may describe a value or a function on a+--   single record, the processed user expression is always a function on+--   the entire input. Also, its output is wrapped in `SomeRows`, to make+--   sure we don't accidentally rely on the fake `()` return type used by+--   `OriginalExpr`.+type InputReadyExpr = UserExpr (() -> SomeRows)+                               (B.ByteString -> SomeRows)+                               ([B.ByteString] -> SomeRows)+                               ([[B.ByteString]] -> SomeRows)++-- | Asserts that the user expression is not a function, and applies `const`+--   to it in order to make it a function.+constExpr :: OriginalExpr -> InputReadyExpr+constExpr (UserExpr e _ _ _) = UserExpr (eAp eConst . eAp eSomeRows <$> e)+                                        (eAp eConst . eAp eSomeRows <$> e)+                                        (eAp eConst . eAp eSomeRows <$> e)+                                        (eAp eConst . eAp eSomeRows <$> e)++-- | Asserts that the user expression is a function.+applyExpr :: OriginalExpr -> InputReadyExpr+applyExpr (UserExpr _ e1 e2 e3) = UserExpr Nothing+                                           (eComp eSomeRows <$> e1)+                                           (eComp eSomeRows <$> e2)+                                           (eComp eSomeRows <$> e3)++-- | Asserts that the user expression is a function on one record, and applies+--   `map` to it in order to make it a function on all records.+mapExpr :: OriginalExpr -> InputReadyExpr+mapExpr (UserExpr _ e1 e2 _) = UserExpr Nothing+                                        Nothing+                                        (eComp eSomeRows . eAp eMap <$> e1)+                                        (eComp eSomeRows . eAp eMap <$> e2)
+ src/System/Console/Hawk/UserExpr/OriginalExpr.hs view
@@ -0,0 +1,40 @@+module System.Console.Hawk.UserExpr.OriginalExpr where++import qualified Data.ByteString.Lazy.Char8 as B++import Text.Printf++import Data.HaskellExpr+++-- | The user expression could have many different types, and we need to track+--   how that type changes under our various manipulations. Use `Nothing` to+--   indicate that a particular type is not compatible with the modifications+--   mandated by the command-line flags.+data UserExpr a b c d = UserExpr (Maybe (HaskellExpr a))+                                 (Maybe (HaskellExpr b))+                                 (Maybe (HaskellExpr c))+                                 (Maybe (HaskellExpr d))++-- | To avoid an ambiguous type variable, we instantiate the output type of the+--   user expression to unit. The code will still work with any instance of Rows.+type OriginalExpr = UserExpr ()+                             (B.ByteString -> ())+                             ([B.ByteString] -> ())+                             ([[B.ByteString]] -> ())++-- | The user expression is expected to have one of the above four types.+--   For now we just pretend like it has all four types, and as the flags+--   are processed, some of those cases will be eliminated, until only+--   one case remains.+-- +-- If the actual user expression doesn't have the type we use it at, hint+-- will give a type error, and that's fine.+originalExpr :: String -> OriginalExpr+originalExpr s = UserExpr (wrapExpr s) (wrapExpr s) (wrapExpr s) (wrapExpr s)+  where+    wrapExpr :: String -> Maybe (HaskellExpr a)+    wrapExpr = Just . HaskellExpr . annotateExpr+    +    annotateExpr :: String -> String+    annotateExpr = printf "{-# LINE 1 \"user expression\" #-}\n%s{-# LINE 2 \"wrapper code\" #-}\n"
src/System/Console/Hawk/UserPrelude.hs view
@@ -1,14 +1,13 @@ -- | In which the user prelude is massaged into the form hint needs. module System.Console.Hawk.UserPrelude where -import Control.Applicative import Control.Monad.Trans.Class import Data.ByteString as B import Text.Printf  import Control.Monad.Trans.Uncertain import Data.HaskellModule-import System.Console.Hawk.Sandbox+import System.Console.Hawk.PackageDbs import System.Console.Hawk.UserPrelude.Extend
− src/System/Console/Hawk/Version.hs 
@@ -1,15 +0,0 @@--- | Auto-detects the current version, used by `hawk --version`.-module System.Console.Hawk.Version (versionString) where--import Data.List (intercalate)-import Data.Version (versionBranch)---- magic self-referential module created by cabal-import Paths_haskell_awk (version)----- | Something like "1.0"-versionString :: String-versionString = intercalate "."-              $ map show-              $ versionBranch version
src/System/Directory/Extra.hs view
@@ -1,13 +1,23 @@ -- | For functions which should have been System.Directory module System.Directory.Extra where -import System.Directory+import Data.List import System.FilePath  --- A version of `canonicalizePath` which works even if the file--- doesn't exist.-absPath :: FilePath -> IO FilePath-absPath f = do-    pwd <- getCurrentDirectory-    return (pwd </> f)+-- | Only works with absolute paths.+-- +-- >>> ancestors "/bin"+-- ["/","/bin"]+-- +-- >>> ancestors "/bin/foo/bar"+-- ["/","/bin","/bin/foo","/bin/foo/bar"]+ancestors :: FilePath -> [FilePath]+ancestors absPath = absPaths+  where+    (drive, fullRelPath) = splitDrive absPath +    reconstruct relPath = joinDrive drive relPath+    +    components = splitDirectories fullRelPath+    relPaths = map joinPath (inits components)+    absPaths = map reconstruct relPaths
+ src/System/Directory/PathFinder.hs view
@@ -0,0 +1,56 @@+-- | Tiny DSL for finding a path from the current path.+{-# LANGUAGE LambdaCase, PackageImports #-}+module System.Directory.PathFinder where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Data.List+import "list-t" ListT (ListT)+import System.Directory+import System.FilePath+import qualified "list-t" ListT+++type PathFinder = StateT FilePath (MaybeT IO) ()+type MultiPathFinder = StateT FilePath (ListT IO) ()++runPathFinder :: PathFinder -> FilePath -> IO (Maybe FilePath)+runPathFinder p pwd = runMaybeT (execStateT p pwd)++runMultiPathFinder :: MultiPathFinder -> FilePath -> IO [FilePath]+runMultiPathFinder p pwd = ListT.toList (execStateT p pwd)+++filenameIs :: MonadPlus m => String -> StateT FilePath m ()+filenameIs s = do+    pwd <- get+    guard (takeFileName pwd == s)++filenameMatches :: MonadPlus m => String -> String -> StateT FilePath m ()+filenameMatches prefix suffix = do+    pwd <- get+    guard (prefix `isPrefixOf` pwd && suffix `isSuffixOf` pwd)++hasAncestor :: MonadPlus m => String -> StateT FilePath m ()+hasAncestor s = do+    pwd <- get+    guard (s `elem` splitDirectories pwd)++relativePath :: (MonadIO m, MonadPlus m) => FilePath -> StateT FilePath m ()+relativePath rel = do+    pwd <- get+    let pwd' = pwd </> rel+    exists <- liftIO $ doesDirectoryExist pwd'+    guard exists+    pwd'' <- liftIO $ canonicalizePath pwd'+    put pwd''++someChild :: MultiPathFinder+someChild = do+    pwd <- get+    childs <- liftIO $ getDirectoryContents pwd+    child <- lift $ ListT.fromFoldable childs+    put (pwd </> child)
− tests/Everything.hs 
@@ -1,1286 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings, PackageImports, RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedStrings, PackageImports #-}-{-# LANGUAGE PackageImports, RankNTypes #-}-module Everything where---import Control.Monad.Trans.Class-import qualified Data.ByteString.Char8 as B--import Data.HaskellSource---- Most of the API is re-exported from those submodules-import Data.HaskellModule.Base--import "mtl" Control.Monad.Trans-import qualified Data.ByteString.Char8 as B-import Data.List-import Language.Haskell.Exts-import Text.Printf--import Data.HaskellModule.Base-import Data.HaskellSource-import Language.Haskell.Exts.Location---import Language.Haskell.Interpreter hiding (Option, languageExtensions)-import Text.Printf (printf)--import System.Console.Hawk.Args-import System.Console.Hawk.Args.Spec-import System.Console.Hawk.Help-import System.Console.Hawk.Interpreter-import System.Console.Hawk.Version--import System.FilePath--import System.Console.Hawk--import qualified Data.ByteString.Char8 as B--import Data.HaskellModule.Base--import Data.ByteString (ByteString)-import Data.ByteString.Char8 (pack)-import Text.Printf--import Control.Monad.Trans.OptionParser--import Control.Applicative-import Data.Char                                 (isSpace)-import "mtl" Control.Monad.Trans--import Control.Monad.Trans.OptionParser-import qualified System.Console.Hawk.Args.Option as Option-import           System.Console.Hawk.Args.Option (HawkOption, options)-import           System.Console.Hawk.Args.Spec-import           System.Console.Hawk.Context.Dir--import Control.Applicative-import Control.Monad.Trans.Class-import Data.ByteString as B-import Text.Printf--import System.Console.Hawk.Sandbox---import Control.Applicative-import Data.Maybe--import System.Console.Hawk.UserPrelude.Defaults---import Control.Applicative-import "mtl" Control.Monad.Trans-import "mtl" Control.Monad.Identity-import "transformers" Control.Monad.Trans.Error hiding (Error)-import "transformers" Control.Monad.Trans.Writer-import System.Exit-import System.IO-import Text.Printf----- |--- >>> B.putStr $ showModule "orig.hs" $ emptyModule--- --- >>> B.putStr $ showModule "orig.hs" $ addExtension "OverloadedStrings" $ addImport ("Data.ByteString.Char8", Just "B") $ addExtension "RecordWildCards" $ addImport ("Prelude", Nothing) $ emptyModule--- {-# LANGUAGE OverloadedStrings #-}--- {-# LANGUAGE RecordWildCards #-}--- import qualified Data.ByteString.Char8 as B--- import Prelude-showModule :: FilePath -- ^ the original's filename,-                       --   used for fixing up line numbers-           -> HaskellModule -> B.ByteString-showModule orig (HaskellModule {..}) = showSource orig fullSource-  where-    fullSource = Data.List.concat [ pragmaSource-                        , moduleSource-                        , importSource-                        , codeSource-                        ]--writeModule :: FilePath -- ^ the original's filename,-                        --   used for fixing up line numbers-            -> FilePath-            -> HaskellModule-            -> IO ()-writeModule orig f = B.writeFile f . showModule orig---compileModule :: FilePath -- ^ the original's filename,-                          --   used for fixing up line numbers-              -> FilePath -- ^ new filename, because ghc compiles from disk.-                          --   the compiled output will be in the same folder.-              -> HaskellModule-              -> UncertainT IO ()-compileModule = compileModuleWithArgs []--compileModuleWithArgs :: [String] -- ^ extra ghc args-                      -> FilePath -- ^ the original's filename,-                                  --   used for fixing up line numbers-                      -> FilePath -- ^ new filename, because ghc compiles from disk.-                                  --   the compiled output will be in the same folder.-                      -> HaskellModule-                      -> UncertainT IO ()-compileModuleWithArgs args orig f m = do-    lift $ writeModule orig f m-    compileFileWithArgs args f--- | In which a Haskell module is deconstructed into extensions and imports.--locatedExtensions :: [ModulePragma] -> Located [ExtensionName]-locatedExtensions = fmap go . located-  where-    go :: [ModulePragma] -> [ExtensionName]-    go = concatMap extNames-    -    extNames :: ModulePragma -> [ExtensionName]-    extNames (LanguagePragma _ exts) = Data.List.map prettyPrint exts-    extNames (OptionsPragma _ _ _) = []  -- TODO: accept "-XExtName"-    extNames _ = []--locatedImports :: [ImportDecl] -> Located [QualifiedModule]-locatedImports = fmap go . located-  where-    go :: [ImportDecl] -> [QualifiedModule]-    go = Data.List.map qualify-    -    qualify :: ImportDecl -> QualifiedModule-    qualify decl = (fullName decl, qualifiedName decl)-    -    fullName :: ImportDecl -> String-    fullName = prettyPrint . importModule-    -    qualifiedName :: ImportDecl -> Maybe String-    qualifiedName = fmap prettyPrint . importAs--locatedModule :: SrcLoc -> HaskellSource -> ModuleName -> Located (Maybe String)-locatedModule srcLoc source (ModuleName mName) = case moduleLine of-    Nothing -> return Nothing-    Just line -> located (srcLoc {srcLine = line}) >> return (Just mName)-  where-    isModuleDecl :: Either B.ByteString String -> Bool-    isModuleDecl (Left xs) = "module " `B.isPrefixOf` xs-    isModuleDecl (Right xs) = "module " `isPrefixOf` xs-    -    moduleLine :: Maybe Int-    moduleLine = fmap index2line $ findIndex isModuleDecl source----- line numbers start at 1, list indices start at 0.-line2index, index2line :: Int -> Int-line2index = subtract 1-index2line = (+ 1)----- | A variant of `splitAt` which makes it easy to make `snd` empty.--- --- >>> maybeSplitAt Nothing "abc"--- ("abc","")--- --- >>> maybeSplitAt (Just 0) "abc"--- ("","abc")-maybeSplitAt :: Maybe Int -> [a] -> ([a], [a])-maybeSplitAt Nothing  ys = (ys, [])-maybeSplitAt (Just i) ys = splitAt i ys---- | Given n ordered indices before which to split, split the list into n+1 pieces.---   Omitted indices will produce empty pieces.--- --- >>> multiSplit [] "foo"--- ["foo"]--- --- >>> multiSplit [Just 0, Just 1, Just 2] "foo"--- ["","f","o","o"]--- --- >>> multiSplit [Just 0, Just 1, Nothing] "foo"--- ["","f","oo",""]--- --- >>> multiSplit [Just 0, Nothing, Just 2] "foo"--- ["","fo","","o"]--- --- >>> multiSplit [Just 0, Nothing, Nothing] "foo"--- ["","foo","",""]--- --- >>> multiSplit [Nothing, Just 1, Just 2] "foo"--- ["f","","o","o"]--- --- >>> multiSplit [Nothing, Just 1, Nothing] "foo"--- ["f","","oo",""]--- --- >>> multiSplit [Nothing, Nothing, Just 2] "foo"--- ["fo","","","o"]--- --- >>> multiSplit [Nothing, Nothing, Nothing] "foo"--- ["foo","","",""]-multiSplit :: [Maybe Int] -> [a] -> [[a]]-multiSplit []           xs = [xs]-multiSplit (j:js) xs = ys1 : ys2 : yss-  where-    (ys:yss) = multiSplit js xs-    (ys1, ys2) = maybeSplitAt j ys---- | Given n ordered source locations, split the source into n+1 pieces.---   Omitted source locations will produce empty pieces.-splitSource :: [Maybe SrcLoc] -> HaskellSource -> [HaskellSource]-splitSource = multiSplit . (fmap . fmap) (line2index . srcLine)----- Due to a limitation of haskell-parse-exts, there is no `parseModule`--- variant of `readModule` which would parse from a String instead of a file.--- --- According to the documentation [1], only `parseFile` honors language--- pragmas, without which PackageImport-style imports will fail to parse.--- --- [1] http://hackage.haskell.org/package/haskell-src-exts-1.14.0.1/docs/Language-Haskell-Exts-Parser.html#t:ParseMode--readModule :: FilePath -> UncertainT IO HaskellModule-readModule f = do-    s <- lift $ readSource f-    r <- lift $ parseFile f-    case r of-      ParseOk (Module srcLoc moduleDecl pragmas _ _ imports decls)-        -> return $ go s srcLoc pragmas moduleDecl imports decls-      ParseFailed loc err -> multilineFail msg-        where-          -- we start with a newline to match ghc's errors-          msg = printf "\n%s:%d:%d: %s" (srcFilename loc) (srcLine loc) (srcColumn loc) err-  where-    go source srcLoc pragmas moduleDecl imports decls = HaskellModule {..}-      where-        (languageExtensions,      _) = runLocated (locatedExtensions pragmas)-        (moduleName,      moduleLoc) = runLocated (locatedModule srcLoc source moduleDecl)-        (importedModules, importLoc) = runLocated (locatedImports imports)-        (_,                 declLoc) = runLocated (located decls)-        -        sourceParts = splitSource [moduleLoc, importLoc, declLoc] source-        [pragmaSource, moduleSource, importSource, codeSource] = sourceParts---   Copyright 2013 Mario Pastorelli (pastorelli.mario@gmail.com) Samuel Gélineau (gelisam@gmail.com)------   Licensed under the Apache License, Version 2.0 (the "License");---   you may not use this file except in compliance with the License.---   You may obtain a copy of the License at------       http://www.apache.org/licenses/LICENSE-2.0------   Unless required by applicable law or agreed to in writing, software---   distributed under the License is distributed on an "AS IS" BASIS,---   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.---   See the License for the specific language governing permissions and---   limitations under the License.---- | Hawk as seen from the outside world: parsing command-line arguments,---   evaluating user expressions.---- | Same as if the given arguments were passed to Hawk on the command-line.-processArgs :: [String] -> IO ()-processArgs args = do-    r <- runWarningsIO $ parseArgs args-    case r of-      Left err -> failHelp err-      Right spec -> processSpec spec---- | A variant of `processArgs` which accepts a structured specification---   instead of a sequence of strings.-processSpec :: HawkSpec -> IO ()-processSpec Help          = help-processSpec Version       = putStrLn versionString-processSpec (Eval  e   o) = applyExpr (wrapExpr "const" e) noInput o-processSpec (Apply e i o) = applyExpr e                    i       o-processSpec (Map   e i o) = applyExpr (wrapExpr "map"   e) i       o--wrapExpr :: String -> ExprSpec -> ExprSpec-wrapExpr f e = e'-  where-    u = userExpression e-    u' = printf "%s (%s)" (prel f) u-    e' = e { userExpression = u' }--applyExpr :: ExprSpec -> InputSpec -> OutputSpec -> IO ()-applyExpr e i o = do-    let contextDir = userContextDirectory e-    let expr = userExpression e-    -    processRuntime <- runUncertainIO $ runHawkInterpreter $ do-      applyContext contextDir-      interpret' $ processTable' $ tableExpr expr-    runHawkIO $ processRuntime hawkRuntime-  where-    interpret' expr = do-      interpret expr (as :: HawkRuntime -> HawkIO ())-    -    hawkRuntime = HawkRuntime i o-    -    processTable' :: String -> String-    processTable' = printf "(%s) (%s) (%s)" (prel "flip")-                                            (runtime "processTable")-    -    -- turn the user expr into an expression manipulating [[B.ByteString]]-    tableExpr :: String -> String-    tableExpr = (`compose` fromTable)-      where-        fromTable = case inputFormat i of-            RawStream            -> head' `compose` head'-            Records _ RawRecord  -> map' head'-            Records _ (Fields _) -> prel "id"-    -    compose :: String -> String -> String-    compose f g = printf "(%s) %s (%s)" f (prel ".") g-    -    head' :: String-    head' = prel "head"-    -    map' :: String -> String-    map' = printf "(%s) (%s)" (prel "map")---- we cannot use any unqualified symbols in the user expression,--- because we don't know which modules the user prelude will import.-qualify :: String -> String -> String-qualify moduleName = printf "%s.%s" moduleName--prel, runtime :: String -> String-prel = qualify "Prelude"-runtime = qualify "System.Console.Hawk.Runtime"--- | Tests which require particular prelude files.---- | A helper for specifying which arguments to pass to Hawk.---   Simplifies testing.-testBuilder :: FilePath -> FilePath -> [String] -> String -> FilePath -> IO ()-testBuilder preludeBase preludeBasename flags expr inputBasename-  = processArgs args-  where-    args = preludeArgs preludeBasename-        ++ flags-        ++ [expr]-        ++ inputArgs inputBasename-    -    preludePath f = preludeBase </> f-    inputPath f = "tests" </> "inputs" </> f-    -    preludeArgs f = ["-c", preludePath f]-    -    inputArgs "" = []-    inputArgs f = [inputPath f]---- | A version of `testBuilder` without a custom prelude.--- --- We still need to specify a prelude file, because the user running these--- tests might have installed a custom prelude.-test :: [String] -> String -> FilePath -> IO ()-test = testBuilder ("tests" </> "preludes") "default"---- | A version of `test` without a custom input file either.-testEval :: [String] -> String -> IO ()-testEval flags expr = test flags expr ""----- | A version of `testBuilder` using the preludes from "tests/preludes".--- --- The first example from the README:--- --- >>> test ["-d:", "-m"] "head" "passwd"--- root--- --- --- The second example, which adds `takeLast` to the user prelude:--- --- >>> testPrelude "readme" ["-a"] "takeLast 3" "0-100"--- 98--- 99--- 100--- --- --- The last example from the README, a quick test to validate that Hawk was--- properly installed:--- --- >>> testEval [] "[1..3]"--- 1--- 2--- 3--- --- --- Making sure that we don't assume the user prelude exports "map":--- --- >>> testPrelude "set" ["-m"] "const $ \"hello\"" "1-3"--- hello--- hello--- hello--- --- Making sure that we can find "map" even with NoImplicitPrelude:--- --- >>> testPrelude "noImplicitPrelude" ["-m"] "\\_ -> hello" "1-3"--- hello--- hello--- hello--- --- Making sure sequences of whitespace count as one delimiter:--- --- >>> testPrelude "default" ["-a"] "L.transpose" "1-12"--- 1 4 7 10--- 2 5 8 11--- 3 6 9 12-testPrelude :: FilePath -> [String] -> String -> FilePath -> IO ()-testPrelude = testBuilder ("tests" </> "preludes")---- | A version of `testBuilder` using the preludes from the documentation.--- --- All the examples from the documentation:--- --- >>> test ["-a"] "L.reverse" "1-3"--- 3--- 2--- 1--- --- >>> test ["-ad"] "L.takeWhile (/=\"7\") . L.dropWhile (/=\"3\")" "1-10"--- 3--- 4--- 5--- 6--- --- >>> testDoc "between" ["-ad"] "between \"3\" \"7\"" "1-10"--- 3--- 4--- 5--- 6--- --- >>> test ["-a"] "L.take 3" "1-10"--- 1--- 2--- 3--- --- >>> test ["-m"] "L.reverse" "1-9"--- 3 2 1--- 6 5 4--- 9 8 7--- --- >>> testDoc "postorder" ["-ad"] "postorder (\\x -> printf \"(%s)\" . L.intercalate \" \" . (unpack x:))" "example.in"--- (foo (bar1) (bar2 (baz)) (bar3))--- --- >>> test ["-ad"] "sum . L.map (read . B.unpack)" "1-3"--- 6--- --- >>> testDoc "conversions" ["-ad"] "sum . L.map toInt" "1-3"--- 6--- --- >>> testEval [] "2 ^ 100"--- 1267650600228229401496703205376--- --- >>> test ["-a"] "L.take 2" "1-9"--- 1 2 3--- 4 5 6--- --- >>> test ["-m"] "L.take 2" "1-9"--- 1 2--- 4 5--- 7 8--- --- >>> test ["-a"] "show" "1-9"--- [["1","2","3"],["4","5","6"],["7","8","9"]]--- --- >>> test ["-a"] "id :: [[B.ByteString]] -> [[B.ByteString]]" "1-9"--- 1 2 3--- 4 5 6--- 7 8 9--- --- >>> test ["-a", "-d\\t"] "id" "1-9tabs"--- 1	2	3--- 4	5	6--- 7	8	9--- --- >>> test ["-ad,"] "id" "1-9commas"--- 1,2,3--- 4,5,6--- 7,8,9--- --- >>> test ["-D + ", "-d*", "-a"] "L.transpose" "equation"--- x1*x2 + y1*y2 + z1*z2--- --- >>> test ["-d", "-a"] "show :: [B.ByteString] -> String" "1-3"--- ["1","2","3"]--- --- >>> test ["-d", "-D", "-a"] "show :: B.ByteString -> String" "1-3"--- "1\n2\n3\n"--- --- >>> testEval [] "[[B.pack \"1\",B.pack \"2\"], [B.pack \"3\",B.pack \"4\"]]"--- 1 2--- 3 4--- --- >>> testEval [] "[[\"1\",\"2\"], [\"3\",\"4\"]]"--- 1 2--- 3 4--- --- >>> testEval [] "[[1,2], [3,4]] :: [[Float]]"--- 1.0 2.0--- 3.0 4.0--- --- >>> testEval [] "1 :: Double"--- 1.0--- --- >>> testEval [] "(True,False)"--- True--- False--- --- >>> testEval [] "[(1,2),(3,4)] :: [(Int,Float)]"--- 1 2.0--- 3 4.0--- --- >>> testEval ["-O or "] "(True,False)"--- True or False--- --- >>> testEval ["-o\\t"] "[(1,2),(3,4.0)] :: [(Int,Float)]"--- 1	2.0--- 3	4.0--- --- >>> test ["-m", "-d ", "-o*", "-D\\n", "-O+"] "id" "1-6"--- 1*2*3+4*5*6--- --- >> testEval ["-a"] "L.length"--- 3-testDoc :: String -> [String] -> String -> FilePath -> IO ()-testDoc = testBuilder "doc"---- | Test that `readModule` splits prelude files into correct sections.--- --- >>> testM "tests/preludes/default/prelude.hs"--- "{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}"--- ["ExtendedDefaultRules","OverloadedStrings"]--- ===--- Nothing--- ===--- "import Prelude"--- "import qualified Data.ByteString.Lazy.Char8 as B"--- "import qualified Data.List as L"--- [("Prelude",Nothing),("Data.ByteString.Lazy.Char8",Just "B"),("Data.List",Just "L")]--- ===--- --- >>> testM "tests/preludes/readme/prelude.hs"--- "{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}"--- ["ExtendedDefaultRules","OverloadedStrings"]--- ===--- Nothing--- ===--- "import Prelude"--- "import qualified Data.ByteString.Lazy.Char8 as B"--- "import qualified Data.List as L"--- [("Prelude",Nothing),("Data.ByteString.Lazy.Char8",Just "B"),("Data.List",Just "L")]--- ===--- "takeLast n = reverse . take n . reverse"--- --- >>> testM "tests/preludes/moduleName/prelude.hs"--- []--- ===--- "module MyPrelude where"--- Just "MyPrelude"--- ===--- []--- ===--- "t = take"--- --- >>> testM "tests/preludes/moduleNamedMain/prelude.hs"--- []--- ===--- "module Main where"--- Just "Main"--- ===--- []--- ===--- "t = take"-testM :: FilePath -> IO ()-testM f = do-    m <- runUncertainIO $ readModule f-    putSource (pragmaSource m)-    print (languageExtensions m)-    putStrLn "==="-    putSource (moduleSource m)-    print (moduleName m)-    putStrLn "==="-    putSource (importSource m)-    print (importedModules m)-    putStrLn "==="-    putSource (codeSource m)-  where-    putSource = mapM_ (print . either id B.pack)--- | The string-typed version of Hawk's command-line arguments.--data HawkOption-    = Apply-    | Map-    | FieldDelimiter-    | RecordDelimiter-    | OutputFieldDelimiter-    | OutputRecordDelimiter-    | Version-    | Help-    | ContextDirectory-  deriving (Show, Eq, Enum, Bounded)---- | In the order listed by --help.-options :: [HawkOption]-options = enumFrom minBound---delimiter :: OptionType-delimiter = nullable (Setting "delim")---- | Interpret escape sequences, but don't worry if they're invalid.--- --- >>> parseDelimiter ","--- ","--- --- >>> parseDelimiter "\\n"--- "\n"--- --- >>> parseDelimiter "\\t"--- "\t"--- --- >>> parseDelimiter "\\"--- "\\"-parseDelimiter :: String -> ByteString-parseDelimiter s = pack $ case reads (printf "\"%s\"" s) of-    [(s', "")] -> s'-    _          -> s---- | Almost like a string, except escape sequences are interpreted.-consumeDelimiter :: (Functor m, Monad m) => OptionConsumer m ByteString-consumeDelimiter = fmap parseDelimiter . consumeNullable "" consumeString--instance Option HawkOption where-  shortName Apply                 = 'a'-  shortName Map                   = 'm'-  shortName FieldDelimiter        = 'd'-  shortName RecordDelimiter       = 'D'-  shortName OutputFieldDelimiter  = 'o'-  shortName OutputRecordDelimiter = 'O'-  shortName Version               = 'v'-  shortName Help                  = 'h'-  shortName ContextDirectory      = 'c'-  -  longName Apply                 = "apply"-  longName Map                   = "map"-  longName FieldDelimiter        = "field-delimiter"-  longName RecordDelimiter       = "record-delimiter"-  longName OutputFieldDelimiter  = "output-field-delim"-  longName OutputRecordDelimiter = "output-record-delim"-  longName Version               = "version"-  longName Help                  = "help"-  longName ContextDirectory      = "context-directory"-  -  helpMsg Apply                      = ["apply <expr> to the entire table"]-  helpMsg Map                        = ["apply <expr> to each row"]-  helpMsg FieldDelimiter             = ["default whitespace"]-  helpMsg RecordDelimiter            = ["default '\\n'"]-  helpMsg OutputFieldDelimiter       = ["default <field-delim>"]-  helpMsg OutputRecordDelimiter      = ["default <record-delim>"]-  helpMsg Version                    = ["print version and exit"]-  helpMsg Help                       = ["this help"]-  helpMsg ContextDirectory           = ["<ctx-dir> directory, default is"-                                       ,"'~/.hawk'"]-  -  optionType Apply                 = flag-  optionType Map                   = flag-  optionType FieldDelimiter        = delimiter-  optionType RecordDelimiter       = delimiter-  optionType OutputFieldDelimiter  = delimiter-  optionType OutputRecordDelimiter = delimiter-  optionType Version               = flag-  optionType Help                  = flag-  optionType ContextDirectory      = filePath--- | In which Hawk's command-line arguments are structured into a `HawkSpec`.---- $setup--- >>> let testP parser = runUncertainIO . runOptionParserT options parser----- | (record separator, field separator)-type CommonSeparators = (Separator, Separator)---- | Extract '-D' and '-d'. We perform this step separately because those two---   delimiters are used by both the input and output specs.--- --- >>> let test = testP commonSeparators--- --- >>> test []--- (Delimiter "\n",Whitespace)--- --- >>> test ["-D\\n", "-d\\t"]--- (Delimiter "\n",Delimiter "\t")--- --- >>> test ["-D|", "-d,"]--- (Delimiter "|",Delimiter ",")-commonSeparators :: (Functor m, Monad m)-                 => OptionParserT HawkOption m CommonSeparators-commonSeparators = do-    r <- lastSep Option.RecordDelimiter defaultRecordSeparator-    f <- lastSep Option.FieldDelimiter defaultFieldSeparator-    return (r, f)-  where-    lastSep opt def = consumeLast opt def consumeSep-    consumeSep = fmap Delimiter . Option.consumeDelimiter----- | The input delimiters have already been parsed, but we still need to---   interpret them and to determine the input source.--- --- >>> :{--- let test = testP $ do { c <- commonSeparators---                       ; _ <- consumeExtra consumeString  -- skip expr---                       ; i <- inputSpec c---                       ; lift $ print $ inputSource i---                       ; lift $ print $ inputFormat i---                       }--- :}--- --- >>> test []--- UseStdin--- Records (Delimiter "\n") (Fields Whitespace)--- --- >>> test ["-d", "-a", "L.reverse"]--- UseStdin--- Records (Delimiter "\n") RawRecord--- --- >>> test ["-D", "-a", "B.reverse"]--- UseStdin--- RawStream--- --- >>> test ["-d:", "-m", "L.head", "/etc/passwd"]--- InputFile "/etc/passwd"--- Records (Delimiter "\n") (Fields (Delimiter ":"))-inputSpec :: (Functor m, Monad m)-          => CommonSeparators -> OptionParserT HawkOption m InputSpec-inputSpec (r, f) = InputSpec <$> source <*> format-  where-    source = do-        r <- consumeExtra consumeString-        return $ case r of-          Nothing -> UseStdin-          Just f  -> InputFile f-    format = return streamFormat-    streamFormat | r == Delimiter "" = RawStream-                 | otherwise         = Records r recordFormat-    recordFormat | f == Delimiter ""   = RawRecord-                 | otherwise           = Fields f---- | The output delimiters take priority over the input delimiters, regardless---   of the order in which they appear.--- --- >>> :{--- let test = testP $ do { c <- commonSeparators---                       ; o <- outputSpec c---                       ; let OutputFormat r f = outputFormat o---                       ; lift $ print $ outputSink o---                       ; lift $ print (r, f)---                       }--- :}--- --- >>> test []--- UseStdout--- ("\n"," ")--- --- >>> test ["-D;", "-d", "-a", "L.reverse"]--- UseStdout--- (";","")--- --- >>> test ["-o\t", "-d,", "-O|"]--- UseStdout--- ("|","\t")-outputSpec :: (Functor m, Monad m)-           => CommonSeparators -> OptionParserT HawkOption m OutputSpec-outputSpec (r, f) = OutputSpec <$> sink <*> format-  where-    sink = return UseStdout-    format = OutputFormat <$> record <*> field-    record = consumeLast Option.OutputRecordDelimiter r' Option.consumeDelimiter-    field = consumeLast Option.OutputFieldDelimiter f' Option.consumeDelimiter-    r' = fromSeparator r-    f' = fromSeparator f----- | The information we need in order to evaluate a user expression:---   the expression itself, and the context in which it should be evaluated.---   In Hawk, that context is the user prelude.--- --- >>> :{--- let test = testP $ do { e <- exprSpec---                       ; lift $ print $ userExpression e---                       ; lift $ print $ userContextDirectory e---                       }--- :}--- --- >>> test []--- error: missing user expression--- *** Exception: ExitFailure 1--- --- >>> test [""]--- error: user expression cannot be empty--- *** Exception: ExitFailure 1------ >>> test ["-D;", "-d", "-a", "L.reverse","-c","somedir"]--- "L.reverse"--- "somedir"-exprSpec :: (Functor m, MonadIO m)-         => OptionParserT HawkOption m ExprSpec-exprSpec = ExprSpec <$> contextDir <*> expr-  where-    contextDir = do-      dir <- consumeLast Option.ContextDirectory "" consumeString-      if null dir-        then liftIO findContextFromCurrDirOrDefault-        else return dir-    expr = do-        r <- consumeExtra consumeString-        case r of-          Just e  -> if all isSpace e-                      then fail "user expression cannot be empty"-                      else return e-          Nothing -> fail "missing user expression"----- | Parse command-line arguments to construct a `HawkSpec`.--- --- TODO: complain if some arguments are unused (except perhaps "-d" and "-D").--- --- >>> :{--- let test args = do { spec <- runUncertainIO $ parseArgs args---                    ; case spec of---                        Help        -> putStrLn "Help"---                        Version     -> putStrLn "Version"---                        Eval  e   o -> putStrLn "Eval"  >> print (userExpression e)                                         >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))---                        Apply e i o -> putStrLn "Apply" >> print (userExpression e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))---                        Map   e i o -> putStrLn "Map"   >> print (userExpression e, inputSource i) >> print (inputFormat i) >> print (recordDelimiter (outputFormat o), fieldDelimiter (outputFormat o))---                    }--- :}--- --- >>> test []--- Help--- --- >>> test ["--help"]--- Help--- --- >>> test ["--version"]--- Version--- --- >>> test ["-d\\t", "L.head"]--- Eval--- "L.head"--- ("\n","\t")--- --- >>> test ["-D\r\n", "-d\\t", "-m", "L.head"]--- Map--- ("L.head",UseStdin)--- Records (Delimiter "\r\n") (Fields (Delimiter "\t"))--- ("\r\n","\t")--- --- >>> test ["-D", "-O\n", "-m", "L.head", "file.in"]--- Map--- ("L.head",InputFile "file.in")--- RawStream--- ("\n"," ")-parseArgs :: (Functor m,MonadIO m) => [String] -> UncertainT m HawkSpec-parseArgs [] = return Help-parseArgs args = runOptionParserT options parser args-  where-    parser = do-        lift $ return ()  -- silence a warning-        cmd <- consumeExclusive assoc eval-        c <- commonSeparators-        cmd c-    assoc = [ (Option.Help,    help)-            , (Option.Version, version)-            , (Option.Apply,   apply)-            , (Option.Map,     map')-            ]-    -    help, version, eval, apply, map' :: (Functor m,MonadIO m) => CommonSeparators-                                     -> OptionParserT HawkOption m HawkSpec-    help    _ = return Help-    version _ = return Version-    eval    c = Eval  <$> exprSpec <*>                 outputSpec c-    apply   c = Apply <$> exprSpec <*> inputSpec c <*> outputSpec c-    map'    c = Map   <$> exprSpec <*> inputSpec c <*> outputSpec c--- | In which the user prelude is massaged into the form hint needs.----type UserPrelude = HaskellModule---testC :: FilePath -> IO ()-testC f = do-    let orig = printf "tests/preludes/%s/prelude.hs" f-    m <- runUncertainIO $ readModule orig-    B.putStr $ showModule orig (canonicalizeUserPrelude m)---- |--- >>> testC "default"--- {-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}--- module System.Console.Hawk.CachedPrelude where--- {-# LINE 2 "tests/preludes/default/prelude.hs" #-}--- import Prelude--- import qualified Data.ByteString.Lazy.Char8 as B--- import qualified Data.List as L--- --- >>> testC "moduleName"--- module MyPrelude where--- import Prelude--- {-# LINE 2 "tests/preludes/moduleName/prelude.hs" #-}--- t = take-canonicalizeUserPrelude :: HaskellModule -> UserPrelude-canonicalizeUserPrelude = extendModuleName . extendImports--readUserPrelude :: FilePath -> UncertainT IO UserPrelude-readUserPrelude f = canonicalizeUserPrelude <$> readModule f---compileUserPrelude :: FilePath -- ^ the original's filename,-                               --   used for fixing up line numbers-                   -> FilePath -- ^ new filename, because ghc compiles from disk.-                               --   the compiled output will be in the same folder.-                   -> UserPrelude-                   -> UncertainT IO ()-compileUserPrelude = compileUserPreludeWithArgs []--compileUserPreludeWithArgs :: [String] -- ^ extra ghc args-                           -> FilePath -- ^ the original's filename,-                                       --   used for fixing up line numbers-                           -> FilePath -- ^ new filename, because ghc compiles from disk.-                                       --   the compiled output will be in the same folder.-                           -> UserPrelude-                           -> UncertainT IO ()-compileUserPreludeWithArgs args orig f m = do-    extraArgs <- lift $ extraGhcArgs-    let args' = (extraArgs ++ args)-    compileModuleWithArgs args' orig f m--- | In which the implicit defaults are explicitly added.----- | We cannot import a module unless it has a name.-extendModuleName :: HaskellModule -> HaskellModule-extendModuleName = until hasModuleName-                       $ addDefaultModuleName defaultModuleName-  where-    hasModuleName = isJust . moduleName---moduleNames :: HaskellModule -> [String]-moduleNames = Data.List.map fst . importedModules---- | GHC imports the Haskell Prelude by default, but hint doesn't.--- --- >>> let m name = (name, Nothing)--- >>> :{---   let testM exts modules = moduleNames m'---         where---           m0  = emptyModule---           m1  = foldr addExtension m0 exts---           m2  = foldr addImport m1 modules---           m' = extendImports m2--- :}--- --- >>> testM [] []--- ["Prelude"]--- --- >>> testM [] [m "Data.Maybe"]--- ["Prelude","Data.Maybe"]--- --- >>> testM [] [m "Data.Maybe", m "Prelude", m "Data.Either"]--- ["Data.Maybe","Prelude","Data.Either"]--- --- >>> :{--- testM [] [ ("Data.Maybe", Just "M")---          , ("Prelude", Just "P")---          , ("Data.Either", Just "E")---          ]--- :}--- ["Data.Maybe","Prelude","Data.Either"]--- --- >>> :{--- testM ["OverloadedStrings","NoImplicitPrelude"]---       [m "Data.Maybe"]--- :}--- ["Data.Maybe"]-extendImports :: HaskellModule -> HaskellModule-extendImports = until preludeOk-                    $ addImport unqualified_prelude-  where-    prelude = "Prelude"-    noPrelude = "NoImplicitPrelude"-    unqualified_prelude = (prelude, Nothing)-    -    preludeOk = liftA2 (||) hasPrelude noImplicitPrelude-    hasPrelude        m =   prelude `Data.List.elem` moduleNames m-    noImplicitPrelude m = noPrelude `Data.List.elem` languageExtensions m--- | A computation which may raise warnings or fail in error.---type Warning = String-type Error = String--newtype UncertainT m a = UncertainT-  { unUncertainT :: ErrorT Error (WriterT [Warning] m) a }--type Uncertain a = UncertainT Identity a--instance Functor m => Functor (UncertainT m) where-  fmap f = UncertainT . fmap f . unUncertainT--instance (Functor m, Monad m) => Applicative (UncertainT m) where-  pure = UncertainT . pure-  UncertainT mf <*> UncertainT mx = UncertainT (mf <*> mx)--instance Monad m => Monad (UncertainT m) where-  return = UncertainT . return-  UncertainT mx >>= f = UncertainT (mx >>= f')-    where-      f' = unUncertainT . f-  fail s = UncertainT (fail s)--instance MonadTrans UncertainT where-  lift = UncertainT . lift . lift--instance MonadIO m => MonadIO (UncertainT m) where-  liftIO = lift . liftIO---warn :: Monad m => String -> UncertainT m ()-warn s = UncertainT $ lift $ tell [s]--fromRightM :: Monad m => Either String a -> UncertainT m a-fromRightM (Left e)  = fail e-fromRightM (Right x) = return x---multilineMsg :: String -> String-multilineMsg = Data.List.concat . Data.List.map (printf "\n  %s") . lines---- | Indent a multiline warning message.--- >>> :{--- runUncertainIO $ do---   multilineWarn "foo\nbar\n"---   return 42--- :}--- warning: ---   foo---   bar--- 42-multilineWarn :: Monad m => String -> UncertainT m ()-multilineWarn = warn . multilineMsg---- | Indent a multiline error message.--- >>> :{--- runUncertainIO $ do---   multilineFail "foo\nbar\n"---   return 42--- :}--- error: ---   foo---   bar--- *** Exception: ExitFailure 1-multilineFail :: Monad m => String -> UncertainT m a-multilineFail = fail . multilineMsg---mapUncertainT :: (forall a. m a -> m' a) -> UncertainT m b -> UncertainT m' b-mapUncertainT f = UncertainT . (mapErrorT . mapWriterT) f . unUncertainT--runUncertainT :: UncertainT m a -> m (Either Error a, [Warning])-runUncertainT = runWriterT . runErrorT . unUncertainT----- | A version of `runWarnings` which allows you to interleave IO actions---   with uncertain actions.--- --- Note that the warnings are displayed after the IO's output.--- --- >>> :{--- runWarningsIO $ do---   warn "before"---   lift $ putStrLn "IO"---   warn "after"---   return 42--- :}--- IO--- warning: before--- warning: after--- Right 42--- --- >>> :{--- runWarningsIO $ do---   warn "before"---   lift $ putStrLn "IO"---   fail "fatal"---   return 42--- :}--- IO--- warning: before--- Left "fatal"-runWarningsIO :: UncertainT IO a -> IO (Either String a)-runWarningsIO u = do-    (r, warnings) <- runUncertainT u-    mapM_ (System.IO.hPutStrLn stderr . printf "warning: %s") warnings-    return r---- | A version of `runUncertain` which only prints the warnings, not the---   errors. Unlike `runUncertain`, it doesn't terminate on error.--- --- >>> :{--- runWarnings $ do---   warn "before"---   warn "after"---   return 42--- :}--- warning: before--- warning: after--- Right 42--- --- >>> :{--- runWarnings $ do---   warn "before"---   fail "fatal"---   return 42--- :}--- warning: before--- Left "fatal"-runWarnings :: Uncertain a -> IO (Either String a)-runWarnings = runWarningsIO . mapUncertainT (return . runIdentity)----- | A version of `runUncertain` which allows you to interleave IO actions---   with uncertain actions.--- --- Note that the warnings are displayed after the IO's output.--- --- >>> :{--- runUncertainIO $ do---   warn "before"---   lift $ putStrLn "IO"---   warn "after"---   return 42--- :}--- IO--- warning: before--- warning: after--- 42--- --- >>> :{--- runUncertainIO $ do---   warn "before"---   lift $ putStrLn "IO"---   fail "fatal"---   return 42--- :}--- IO--- warning: before--- error: fatal--- *** Exception: ExitFailure 1-runUncertainIO :: UncertainT IO a -> IO a-runUncertainIO u = do-    r <- runWarningsIO u-    case r of-      Left e -> do-        System.IO.hPutStrLn stderr $ printf "error: %s" e-        exitFailure-      Right x -> return x---- | Print warnings and errors, terminating on error.--- --- Note that the warnings are displayed even if there is also an error.--- --- >>> :{--- runUncertainIO $ do---   warn "first"---   warn "second"---   fail "fatal"---   return 42--- :}--- warning: first--- warning: second--- error: fatal--- *** Exception: ExitFailure 1-runUncertain :: Uncertain a -> IO a-runUncertain = runUncertainIO . mapUncertainT (return . runIdentity)----- | Upgrade an `IO a -> IO a` wrapping function into a variant which uses---   `UncertainT IO` instead of `IO`.--- --- >>> :{--- let wrap body = do { putStrLn "before"---                    ; r <- body---                    ; putStrLn "after"---                    ; return r---                    }--- :}--- --- >>> :{--- wrap $ do { putStrLn "hello"---           ; return 42---           }--- :}--- before--- hello--- after--- 42--- --- >>> :{--- runUncertainIO $ wrapUncertain wrap---                $ do { lift $ putStrLn "hello"---                     ; warn "be careful!"---                     ; return 42---                     }--- :}--- before--- hello--- after--- warning: be careful!--- 42-wrapUncertain :: (Monad m, Monad m')-              => (forall a. m a -> m' a)-              -> (UncertainT m b -> UncertainT m' b)-wrapUncertain wrap body = wrapUncertainArg wrap' body'-  where-    wrap' f = wrap $ f ()-    body' () = body---- | A version of `wrapUncertain` for wrapping functions of type---   `(Handle -> IO a) -> IO a`.--- --- >>> :{--- let wrap body = do { putStrLn "before"---                    ; r <- body 42---                    ; putStrLn "after"---                    ; return r---                    }--- :}--- --- >>> :{--- wrap $ \x -> do { putStrLn "hello"---                 ; return (x + 1)---                 }--- :}--- before--- hello--- after--- 43--- --- >>> :{--- runUncertainIO $ wrapUncertainArg wrap---                $ \x -> do { lift $ putStrLn "hello"---                           ; warn "be careful!"---                           ; return (x + 1)---                           }--- :}--- before--- hello--- after--- warning: be careful!--- 43-wrapUncertainArg :: (Monad m, Monad m')-                 => (forall a. (v -> m a) -> m' a)-                 -> ((v -> UncertainT m b) -> UncertainT m' b)-wrapUncertainArg wrap body = do-    (r, ws) <- lift $ wrap $ runUncertainT . body-    -    -- repackage the warnings and errors-    mapM_ warn ws-    fromRightM r
tests/RunTests.hs view
@@ -12,55 +12,25 @@ --   See the License for the specific language governing permissions and --   limitations under the License. -import Control.Applicative-import Data.List-import qualified System.Console.Hawk.Representable.Test as ReprTest-import qualified System.Console.Hawk.Test as HawkTest-import System.FilePath-import System.Environment-import Text.Printf-+import System.Environment (unsetEnv) import Test.DocTest (doctest) import Test.Hspec (hspec) +import qualified Build_doctests as CabalDoctest+import qualified System.Console.Hawk.Representable.Test as ReprTest+import qualified System.Console.Hawk.Test as HawkTest -substSuffix :: Eq a => [a] -> [a] -> [a] -> [a]-substSuffix oldSuffix newSuffix xs | oldSuffix `isSuffixOf` xs = prefix ++ newSuffix-  where-    prefix = take (length xs - length oldSuffix) xs-substSuffix _ _ xs = xs --- make sure doctest can see the source of Hawk and the generated Paths_haskell_awk.hs-doctest' :: String -> IO ()-doctest' file = do-    exePath <- dropExtension <$> getExecutablePath-    -    let srcPath = "src"-    let autogenPath = substSuffix ("reference" </> "reference")-                                  "autogen"-                                  exePath-    -    let includeSrc      = printf "-i%s" srcPath-    let includeAutogen  = printf "-i%s" autogenPath-    -    doctest [includeSrc, includeAutogen, file]- main :: IO () main = do-    doctest' "tests/System/Console/Hawk/Lock/Test.hs"-    doctest' "src/Data/Cache.hs"-    doctest' "src/Data/HaskellSource.hs"-    doctest' "src/Data/HaskellModule.hs"-    doctest' "src/Data/HaskellModule/Parse.hs"-    doctest' "src/System/Console/Hawk.hs"-    doctest' "tests/System/Console/Hawk/PreludeTests.hs"-    doctest' "tests/Data/HaskellModule/Parse/Test.hs"-    doctest' "src/System/Console/Hawk/Args/Option.hs"-    doctest' "src/System/Console/Hawk/Args/Parse.hs"-    doctest' "src/System/Console/Hawk/UserPrelude.hs"-    doctest' "src/System/Console/Hawk/UserPrelude/Extend.hs"-    doctest' "src/Control/Monad/Trans/Uncertain.hs"-    doctest' "src/Control/Monad/Trans/OptionParser.hs"+    unsetEnv "GHC_ENVIRONMENT" -- as explained in the cabal-doctest documentation+    doctest $ CabalDoctest.flags+           ++ CabalDoctest.pkgs+           ++ CabalDoctest.module_sources+    doctest $ CabalDoctest.flags_exe_hawk+           ++ CabalDoctest.pkgs_exe_hawk+           ++ CabalDoctest.module_sources_exe_hawk+     hspec $ do         ReprTest.reprSpec'         ReprTest.reprSpec
tests/System/Console/Hawk/Lock/Test.hs view
@@ -15,9 +15,12 @@ module System.Console.Hawk.Lock.Test where  import Control.Concurrent-import System.Console.Hawk.Lock  -- $setup+-- >>> import System.Console.Hawk.Lock+-- >>> import System.Directory+-- >>> let cxtDir = "tmp"+-- >>> createDirectoryIfMissing False cxtDir -- >>> :{ --   let par body1 body2 = do --         done1 <- newEmptyMVar@@ -40,8 +43,9 @@ --   other instances of hawk. --  -- In the ideal case, nobody else is trying to use `withLock`.+-- Perform all tests with context directory as current directory -- --- >>> withLock print3+-- >>> withLock cxtDir print3 -- 1 -- 2 -- 3@@ -60,7 +64,7 @@ --  -- By using `withLock`, we serialize the execution of the two critical sections. -- --- >>> withLock print3 `par` withLock print3+-- >>> withLock cxtDir print3 `par` withLock cxtDir print3 -- 1 -- 2 -- 3@@ -71,39 +75,23 @@ -- There is a verbose version of `withLock` which makes it easy to see when -- two instances are trying to enter `withLock` at the same time. -- --- >>> withTestLock print3+-- >>> withTestLock cxtDir print3+-- ** LOCKED ** -- 1 -- 2 -- 3+-- ** UNLOCKED ** -- --- >>> withTestLock print3 `par` withTestLock print3+-- >>> withTestLock cxtDir print3 `par` withTestLock cxtDir print3 -- ** LOCKED ** -- 1 -- 2 -- 3--- ** UNLOCKED (hGetContents) **--- 1--- 2--- 3--- --- This verbosity allows us to test a special case: a race condition in which--- instance 1 releases the lock immediately after instance 2 notices that the--- lock is busy, but before instance 2 begins waiting for the lock to be released.--- --- We can trigger this special case with a bit of collaboration from `withTestLock`.--- It inserts an artificial delay at the point in which we want the lock to be--- released, and we time our instances so that instance 1 unlocks just at the right--- moment. If we timed the experiment right, the error message should be "connect"--- instead of "hGetContents".--- --- >>> withTestLock print3 `par` (threadDelay 15000 >> withTestLock print3)--- 1+-- ** UNLOCKED ** -- ** LOCKED **--- 2--- 3--- ** UNLOCKED (connect) ** -- 1 -- 2 -- 3+-- ** UNLOCKED ** print3 :: IO () print3 = printDelayed [1..3]
tests/System/Console/Hawk/PreludeTests.hs view
@@ -1,5 +1,5 @@ -- | Tests which require particular prelude files.-module System.Console.Hawk.PreludeTests () where+module System.Console.Hawk.PreludeTests where  import System.FilePath @@ -60,7 +60,48 @@ -- 2 -- 3 -- +-- Making sure that we support multi-line, whitespace-sensitive expressions: -- +-- >>> testEval [] "do x <- [1,2,3]\n   y <- [10,20,30]\n   return (x+y)"+-- 11+-- 21+-- 31+-- 12+-- 22+-- 32+-- 13+-- 23+-- 33+-- +-- Making sure that we report errors in the user expression, not our wrapper code:+-- +-- >>> testEval [] "[[],"+-- error: Won't compile:+-- 	user expression:1:5: error:+--     parse error (possibly incorrect indentation or mismatched brackets)+-- *** Exception: ExitFailure 1+-- +-- Making sure that setting line-mode or stream-mode doesn't affect the output format+-- unless specifically requested:+-- +-- >>> testPrelude "default" ["-d", "-m"]       "\\x -> ('a', x, 'b')" "1-3"+-- a 1 b+-- a 2 b+-- a 3 b+-- +-- >>> testPrelude "default" ["-d", "-o", "-m"] "\\x -> ('a', x, 'b')" "1-3"+-- a1b+-- a2b+-- a3b+-- +-- >>> testPrelude "default" ["-D", "-a"]       "\\x -> ('a', x, 'b')" "equation"+-- a+-- x1*y1*z1 + x2*y2*z2+-- b+-- +-- >>> testPrelude "default" ["-D", "-O", "-a"] "\\x -> ('a', x, 'b')" "equation"+-- ax1*y1*z1 + x2*y2*z2b+--  -- Making sure that we don't assume the user prelude exports "map": --  -- >>> testPrelude "set" ["-m"] "const $ \"hello\"" "1-3"@@ -144,18 +185,21 @@ -- 4 5 6 -- 7 8 9 -- --- >>> test ["-a", "-d\\t"] "id" "1-9tabs"--- 1	2	3--- 4	5	6--- 7	8	9+-- >>> test ["-a", "-d\\t"] "L.transpose" "1-9tabs"+-- 1	4	7+-- 2	5	8+-- 3	6	9 -- --- >>> test ["-ad,"] "id" "1-9commas"--- 1,2,3--- 4,5,6--- 7,8,9+-- >>> test ["-ad,"] "L.transpose" "1-9commas"+-- 1,4,7+-- 2,5,8+-- 3,6,9 --  -- >>> test ["-D + ", "-d*", "-a"] "L.transpose" "equation" -- x1*x2 + y1*y2 + z1*z2+-- +-- >>> testDoc "aeson" ["-aD"] "show . P.parse J.json" "json"+-- Done "\n" Object (fromList [("code",Number 200.0),("message",String "OK")]) --  -- >>> test ["-d", "-a"] "show :: [B.ByteString] -> String" "1-3" -- ["1","2","3"]
tests/System/Console/Hawk/Test.hs view
@@ -29,7 +29,6 @@         describe "Hawk" $ do           itEval "1" `into` "1\n"           itEval "1+1" `into` "2\n"-          itEval "[]" `into` ""           itEval "[1]" `into` "1\n"           itEval "[1,2]" `into` "1\n2\n"           itEval "(1,2)" `into` "1\n2\n"
− tests/preludes/default/prelude.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}-import Prelude-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.List as L
− tests/preludes/moduleName/prelude.hs 
@@ -1,2 +0,0 @@-module MyPrelude where-t = take
− tests/preludes/moduleNamedMain/prelude.hs 
@@ -1,2 +0,0 @@-module Main where-t = take
− tests/preludes/readme/prelude.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}-import Prelude-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.List as L-takeLast n = reverse . take n . reverse
− tests/preludes/set/prelude.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}-import Prelude-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.List as L-import Data.Set