packages feed

haskell-awk 1.0.1 → 1.1

raw patch · 56 files changed

+3949/−1540 lines, 56 filesdep +exceptionsdep +haskell-awkdep +mtldep ~HUnitdep ~MonadCatchIO-mtldep ~basebuild-type:Customsetup-changednew-uploader

Dependencies added: exceptions, haskell-awk, mtl, transformers

Dependency ranges changed: HUnit, MonadCatchIO-mtl, base, bytestring, directory, doctest, easy-file, filepath, hspec, process, temporary, test-framework, test-framework-hunit

Files

README.md view
@@ -20,8 +20,8 @@ root ``` -The `-d` option tells Hawk to use `:` as word delimiters, causing the first line to be interpreted as `["root", "x", "0", "0", "root", "/root", "/bin/bash"]`.-The `-m` tells Hawk to map a function over each line of the input. In this case, the function `head` extracts the first word of the line, which happens to be the username.+The `-d` option tells Hawk to use `:` as field delimiters, causing the first line to be interpreted as `["root", "x", "0", "0", "root", "/root", "/bin/bash"]`.+The `-m` tells Hawk to map a function over each line of the input. In this case, the function `head` extracts the first field of the line, which happens to be the username.  We could of course have achieved identical results by using awk instead of Hawk: @@ -52,7 +52,8 @@  ## Installation -To install the stable version, simply use `cabal install haskell-hawk` and+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: @@ -68,3 +69,5 @@ 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 `~/.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,16 +1,41 @@---   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.-+import Control.Monad import Distribution.Simple-main = defaultMain+import System.Environment+--import System.IO+++-- 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++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
haskell-awk.cabal view
@@ -1,5 +1,5 @@ Name:           haskell-awk-Version:        1.0.1+Version:        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.@@ -10,13 +10,32 @@ Category:       Console License:        Apache-2.0 License-File:   LICENSE-Build-Type:     Simple+Build-Type:     Custom Cabal-version:  >=1.10-Extra-Source-Files: src/System/Console/*.hs+Extra-Source-Files: README.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/Config/*.hs-                  , README.md-                  , tests/System/Console/Hawk/Representable/Test.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  Source-Repository head     type: git@@ -27,29 +46,34 @@     Default-Language: Haskell98     ghc-options:    -Wall     build-depends:  base >=4.6.0.1 && <5-                  , bytestring >=0.10.0.2-                  , containers -any-                  , directory >=1.2.0.1-                  , easy-file >=0.1.1-                  , filepath >=1.3.0.1+                  , bytestring+                  , containers+                  , directory+                  , easy-file+                  , exceptions >=0.1+                  , filepath+                  , haskell-awk                   , haskell-src-exts >=1.14.0                   , hint >=0.3.3.5-                  , MonadCatchIO-mtl >=0.3.0.0+                  , MonadCatchIO-mtl >=0.2.0.0+                  , mtl >=2.1.2                   , network >=2.3.1.0                   , stringsearch >=0.3.6.4-                  , process >=1.1.0.2-                  , time -any+                  , process+                  , time+                  , transformers >=0.3.0.0     hs-source-dirs: src  Library-    exposed-modules: System.Console.Hawk.Representable+    exposed-modules: System.Console.Hawk.Args.Spec+                    ,System.Console.Hawk.Representable                     ,System.Console.Hawk.Runtime-                    ,System.Console.Hawk.IO-    ghc-options:    -Wall -    hs-source-dirs: src+                    ,System.Console.Hawk.Runtime.Base+    ghc-options:    -Wall+    hs-source-dirs: runtime     build-depends: base >=4.6.0.1-                 , bytestring >=0.10.0.2-                 , containers -any+                 , bytestring+                 , containers                  , stringsearch >=0.3.6.4     Default-Language: Haskell98 @@ -58,22 +82,26 @@   Main-Is:              RunTests.hs   Type:                 exitcode-stdio-1.0   Ghc-Options:          -Wall-  Build-Depends:        base>=4.6.0.1 && <5-                      , bytestring>=0.10.0.2-                      , containers -any-                      , directory >=1.2.0.1-                      , doctest >= 0.8-                      , test-framework-                      , test-framework-hunit-                      , temporary-                      , hspec-                      , HUnit-                      , easy-file >=0.1.1-                      , haskell-src-exts >= 1.14.0+  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 >=1.3.0.1+                      , filepath+                      , mtl >=2.1.2                       , network >=2.3.1.0-                      , process >=1.1.0.2+                      , process                       , stringsearch >=0.3.6.4-                      , time -any+                      , time+                      , transformers >=0.3.0.0   Default-Language: Haskell98
+ runtime/System/Console/Hawk/Args/Spec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}+-- | The precisely-typed version of Hawk's command-line arguments.+module System.Console.Hawk.Args.Spec where++import Data.ByteString (ByteString)+++data HawkSpec+    = Help+    | Version+    | Eval  ExprSpec           OutputSpec+    | Apply ExprSpec InputSpec OutputSpec+    | Map   ExprSpec InputSpec OutputSpec+  deriving (Show, Eq)+++data InputSpec = InputSpec+    { inputSource :: InputSource+    , inputFormat :: InputFormat+    }+  deriving (Show, Eq)++data OutputSpec = OutputSpec+    { outputSink :: OutputSink+    , outputFormat :: OutputFormat+    }+  deriving (Show, Eq)+++data InputSource+    = NoInput+    | UseStdin+    | InputFile FilePath+  deriving (Show, Eq)++data OutputSink+    = UseStdout+    -- OutputFile FilePath  -- we might want to implement --in-place+                            -- in the future+  deriving (Show, Eq)++data InputFormat+    = RawStream+    | Records Separator RecordFormat+  deriving (Show, Eq)++data RecordFormat+    = RawRecord+    | Fields Separator+  deriving (Show, Eq)++-- We can't know ahead of time whether it's going to be a raw stream+-- or raw records or fields, it depends on the type of the user expression.+data OutputFormat = OutputFormat+    { recordDelimiter :: Delimiter+    , fieldDelimiter :: Delimiter+    }+  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.+type Delimiter = ByteString+data Separator = Whitespace | Delimiter Delimiter+  deriving (Show, Eq)++fromSeparator :: Separator -> Delimiter+fromSeparator Whitespace    = " "+fromSeparator (Delimiter d) = d+++data ExprSpec = ExprSpec+    { userContextDirectory :: FilePath+    , userExpression :: String+    }+  deriving (Show, Eq)++defaultInputSpec, noInput :: InputSpec+defaultInputSpec = InputSpec UseStdin defaultInputFormat+noInput          = InputSpec NoInput  defaultInputFormat++defaultOutputSpec :: OutputSpec+defaultOutputSpec = OutputSpec UseStdout defaultOutputFormat+++defaultInputFormat :: InputFormat+defaultInputFormat = Records defaultRecordSeparator+                   $ Fields defaultFieldSeparator++defaultOutputFormat :: OutputFormat+defaultOutputFormat = OutputFormat defaultRecordDelimiter defaultFieldDelimiter+++defaultRecordSeparator, defaultFieldSeparator :: Separator+defaultRecordSeparator = Delimiter defaultRecordDelimiter+defaultFieldSeparator = Whitespace++defaultRecordDelimiter, defaultFieldDelimiter :: Delimiter+defaultRecordDelimiter = "\n"+defaultFieldDelimiter = " "
+ runtime/System/Console/Hawk/Representable.hs view
@@ -0,0 +1,365 @@+--   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.++-- | Used by Hawk's runtime to format the output of a Hawk expression.+--    You can use this from your user prelude if you want Hawk to print+--    your custom datatypes in a console-friendly format.+module System.Console.Hawk.Representable (++    ListAsRow (listRepr')+  , ListAsRows (listRepr)+  , Row  (repr')+  , Rows (repr)++) where++import Prelude+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as C8 hiding (hPutStrLn)+import qualified Data.List as L+import Data.Set (Set)+import qualified Data.Set as S+import Data.Map (Map)+import qualified Data.Map as M+++-- | A type that instantiate ListAsRow is a type that has a representation+-- when is embedded inside a list+--+-- For example:+--+-- >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr Data.ByteString.Lazy.Char8.empty "test"+-- test+class (Show a) => ListAsRow a where+    listRepr' :: ByteString -> [a] -> ByteString+    listRepr' d = C8.intercalate d . L.map (C8.pack . show)++instance ListAsRow Bool+instance ListAsRow Float+instance ListAsRow Double+instance ListAsRow Int+instance ListAsRow Integer+instance ListAsRow ()++instance (ListAsRow a) => ListAsRow [a] where+    -- todo check the first delimiter if it should be d+    listRepr' d = C8.intercalate d . L.map (listRepr' d)++instance (Row a) => ListAsRow (Maybe a) where+    listRepr' d = C8.intercalate d . L.map (repr' d)++instance (ListAsRow a) => ListAsRow (Set a) where+    listRepr' d = listRepr' d . L.map (listRepr' d . S.toList)++instance ListAsRow Char where+    listRepr' _ = C8.pack++instance ListAsRow ByteString where+    listRepr' d = C8.intercalate d++instance (Row a, Row b) => ListAsRow (Map a b) where+    listRepr' d = listRepr' d . L.map (listRepr' d . M.toList)++instance (Row a,Row b) => ListAsRow (a,b) where+    listRepr' d = C8.intercalate d . L.map (\(x,y) -> C8.unwords+                  [repr' d x,repr' d y])++instance (Row a,Row b,Row c) => ListAsRow (a,b,c) where+    listRepr' d = C8.intercalate d . L.map (\(x,y,z) -> C8.unwords+                  [repr' d x,repr' d y,repr' d z])++instance (Row a,Row b,Row c,Row d) => ListAsRow (a,b,c,d) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e])++instance (Row a,Row b,Row c,Row d,Row e) => ListAsRow (a,b,c,d,e) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f])++instance (Row a,Row b,Row c,Row d,Row e,Row f) => ListAsRow (a,b,c,d,e,f) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f+                  ,repr' d g])++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g)+  => ListAsRow (a,b,c,d,e,f,g) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f+                  ,repr' d g,repr' d h])++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)+  => ListAsRow (a,b,c,d,e,f,g,h) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f+                  ,repr' d g,repr' d h,repr' d i])++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)+  => ListAsRow (a,b,c,d,e,f,g,h,i) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i,l) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f+                  ,repr' d g,repr' d h,repr' d i,repr' d l])++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)+  => ListAsRow (a,b,c,d,e,f,g,h,i,l) where+    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i,l,m) -> C8.unwords+                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f+                  ,repr' d g,repr' d h,repr' d i,repr' d l,repr' d m])++++-- | A Row is something that can be expressed as a record.+-- The output of repr' should be formatted such that+-- it can be read and processed from the command line.+--+-- For example:+--+-- >>> putStrLn $ show [1,2,3,4]+-- [1,2,3,4]+--+-- >>> Data.ByteString.Lazy.Char8.putStrLn $ repr' (Data.ByteString.Lazy.Char8.pack " ") [1,2,3,4]+-- 1 2 3 4+class (Show a) => Row a where+    repr' :: ByteString -- ^ columns delimiter+          -> a           -- ^ value to represent+          -> ByteString+    repr' _ = C8.pack . show++instance Row Bool+instance Row Float+instance Row Double+instance Row Int+instance Row Integer+instance Row ()++instance Row Char where+    repr' _ = C8.singleton++instance (ListAsRow a) => Row [a] where+    repr' = listRepr'++instance (ListAsRow a) => Row (Set a) where+    repr' d = listRepr' d . S.toList++instance (Row a,Row b) => Row (Map a b) where+    repr' d = listRepr' d . M.toList++instance Row ByteString where+    repr' _ = id++instance (Row a) => Row (Maybe a) where+    repr' _ Nothing = C8.empty+    repr' d (Just x) = repr' d x -- check if d is correct here++instance (Row a,Row b) => Row (a,b) where+    repr' d (a,b) = repr' d a `C8.append` (d `C8.append` repr' d b)+    --repr' d (a,b) = repr' d [repr' d a,repr' d b]++instance (Row a,Row b,Row c) => Row (a,b,c) where+    repr' d (a,b,c) =  repr' d a `C8.append` (d `C8.append`+                      (repr' d b `C8.append` (d `C8.append` repr' d c)))++instance (Row a,Row b,Row c,Row d) => Row (a,b,c,d) where+    repr' d (a,b,c,e) = repr' d a `C8.append` (d `C8.append`+                        (repr' d b `C8.append` (d `C8.append`+                        (repr' d c `C8.append` (d `C8.append` repr' d e)))))++instance (Row a,Row b,Row c,Row d,Row e) => Row (a,b,c,d,e) where+    repr' d (a,b,c,e,f) = repr' d a `C8.append` (d `C8.append`+                        (repr' d b `C8.append` (d `C8.append`+                        (repr' d c `C8.append` (d `C8.append`+                        (repr' d e `C8.append` (d `C8.append` repr' d f)))))))++instance (Row a,Row b,Row c,Row d,Row e,Row f) => Row (a,b,c,d,e,f) where+    repr' d (a,b,c,e,f,g) = repr' d a `C8.append` (d `C8.append`+                            (repr' d b `C8.append` (d `C8.append`+                            (repr' d c `C8.append` (d `C8.append`+                            (repr' d e `C8.append` (d `C8.append`+                            (repr' d f `C8.append` (d `C8.append` repr' d g)))))))))++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g) => Row (a,b,c,d,e,f,g) where+    repr' d (a,b,c,e,f,g,h) = repr' d a `C8.append` (d `C8.append`+                              (repr' d b `C8.append` (d `C8.append`+                              (repr' d c `C8.append` (d `C8.append`+                              (repr' d e `C8.append` (d `C8.append`+                              (repr' d f `C8.append` (d `C8.append`+                              (repr' d g `C8.append` (d `C8.append` repr' d h)))))))))))++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)+        => Row (a,b,c,d,e,f,g,h) where+    repr' d (a,b,c,e,f,g,h,i) =+        repr' d a `C8.append` (d `C8.append`+       (repr' d b `C8.append` (d `C8.append`+       (repr' d c `C8.append` (d `C8.append`+       (repr' d e `C8.append` (d `C8.append`+       (repr' d f `C8.append` (d `C8.append`+       (repr' d g `C8.append` (d `C8.append`+       (repr' d h `C8.append` (d `C8.append` repr' d i)))))))))))))++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)+        => Row (a,b,c,d,e,f,g,h,i) where+    repr' d (a,b,c,e,f,g,h,i,l) =+        repr' d a `C8.append` (d `C8.append`+       (repr' d b `C8.append` (d `C8.append`+       (repr' d c `C8.append` (d `C8.append`+       (repr' d e `C8.append` (d `C8.append`+       (repr' d f `C8.append` (d `C8.append`+       (repr' d g `C8.append` (d `C8.append`+       (repr' d h `C8.append` (d `C8.append`+       (repr' d i `C8.append` (d `C8.append` repr' d l)))))))))))))))++instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)+        => Row (a,b,c,d,e,f,g,h,i,l) where+    repr' d (a,b,c,e,f,g,h,i,l,m) =+        repr' d a `C8.append` (d `C8.append`+       (repr' d b `C8.append` (d `C8.append`+       (repr' d c `C8.append` (d `C8.append`+       (repr' d e `C8.append` (d `C8.append`+       (repr' d f `C8.append` (d `C8.append`+       (repr' d g `C8.append` (d `C8.append`+       (repr' d h `C8.append` (d `C8.append`+       (repr' d i `C8.append` (d `C8.append`+       (repr' d l `C8.append` (d `C8.append` repr' d m)))))))))))))))))+++-- | A type that instantiate ListAsRows is a type that has a representation+-- when is embedded inside a list+--+-- Note: we use this class for representing a list of chars as String+-- instead of the standard list representation. Without this repr "test" would+-- yield ['t','e','s','r'] instead of "test".+--+-- For example:+--+-- >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr Data.ByteString.Lazy.Char8.empty "test"+-- test+class (Row a) => ListAsRows a where+    listRepr :: ByteString -- ^ column delimiter+               -> [a]         -- ^ list of values to represent+               -> [ByteString]+    listRepr d = L.map (repr' d)++instance ListAsRows ByteString+instance ListAsRows Bool+instance ListAsRows Double+instance ListAsRows Float+instance ListAsRows Int+instance ListAsRows Integer+instance (Row a) => ListAsRows (Maybe a)+instance ListAsRows ()+instance (ListAsRow a,ListAsRows a) => ListAsRows [a]+instance (Row a,Row b) => ListAsRows (a,b)+instance (Row a,Row b,Row c) => ListAsRows (a,b,c)+instance (Row a,Row b,Row c,Row d) => ListAsRows (a,b,c,d)+instance (Row a,Row b,Row c,Row d,Row e) => ListAsRows (a,b,c,d,e)+instance (Row a,Row b,Row c,Row d,Row e,Row f) => ListAsRows (a,b,c,d,e,f)+instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g) => ListAsRows (a,b,c,d,e,f,g)+instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)+  => ListAsRows (a,b,c,d,e,f,g,h)+instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)+  => ListAsRows (a,b,c,d,e,f,g,h,i)+instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)+  => ListAsRows (a,b,c,d,e,f,g,h,i,l)++instance ListAsRows Char where+    listRepr _ = (:[]) . C8.pack++instance (ListAsRow a,ListAsRows a) => ListAsRows (Set a) where+    listRepr d = listRepr d . L.map S.toList++instance (Row a,Row b) => ListAsRows (Map a b) where+    listRepr d = listRepr d . L.map M.toList++instance (ListAsRows a) => Rows [a] where+    repr = listRepr+++-- | A type that instantiate Rows is a type that can be represented as+-- a list of rows, where typically a row is a line.+--+-- For example:+--+-- >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr (Data.ByteString.Lazy.Char8.singleton '\n') [1,2,3,4]+-- 1+-- 2+-- 3+-- 4+class (Show a) => Rows a where+    -- | Return a representation of the given value as list of strings.+    repr :: ByteString -- ^ rows delimiter+         -> a           -- ^ value to represent+         -> [C8.ByteString]+    repr _ = (:[]) . C8.pack . show+++instance Rows Bool+instance Rows Double+instance Rows Float+instance Rows Int+instance Rows Integer++instance Rows () where+    repr _ = const [C8.empty]++instance Rows Char where+    repr _ = (:[]) . C8.singleton++instance Rows ByteString where+    repr _ = (:[])++instance (Rows a) => Rows (Maybe a) where+    repr d = maybe [C8.empty] (repr d)++instance (Row a, Row b) => Rows (Map a b) where+    repr d = listRepr d . M.toList++instance (ListAsRows a) => Rows (Set a) where+    repr d = listRepr d . S.toList++instance (Row a, Row b) => Rows (a,b) where+    repr d (x,y) = [repr' d x,repr' d y]++instance (Row a, Row b, Row c) => Rows (a,b,c) where+    repr d (a,b,c) = [repr' d a, repr' d b, repr' d c]++instance (Row a, Row b, Row c, Row d) => Rows (a,b,c,d) where+    repr d (a,b,c,e) = [repr' d a, repr' d b, repr' d c, repr' d e]++instance (Row a, Row b, Row c, Row d, Row e) => Rows (a,b,c,d,e) where+    repr d (a,b,c,e,f) = [repr' d a, repr' d b, repr' d c, repr' d e, repr' d f]++instance (Row a, Row b, Row c, Row d, Row e, Row f) => Rows (a,b,c,d,e,f) where+    repr d (a,b,c,e,f,g) = [repr' d a, repr' d b, repr' d c,repr' d e+                           ,repr' d f, repr' d g]++instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g)+       => Rows (a,b,c,d,e,f,g) where+    repr d (a,b,c,e,f,g,h) = [repr' d a, repr' d b, repr' d c,repr' d e+                             ,repr' d f, repr' d g, repr' d h]++instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h)+       => Rows (a,b,c,d,e,f,g,h) where+    repr d (a,b,c,e,f,g,h,i) = [repr' d a, repr' d b, repr' d c, repr' d e+                               ,repr' d f, repr' d g, repr' d h, repr' d i]++instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h, Row i)+       => Rows (a,b,c,d,e,f,g,h,i) where+    repr d (a,b,c,e,f,g,h,i,l) = [repr' d a, repr' d b, repr' d c, repr' d e+                                 ,repr' d f, repr' d g, repr' d h, repr' d i+                                 , repr' d l]++instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h, Row i, Row l)+       => Rows (a,b,c,d,e,f,g,h,i,l) where+    repr d (a,b,c,e,f,g,h,i,l,m) = [repr' d a, repr' d b, repr' d c, repr' d e+                                   ,repr' d f, repr' d g, repr' d h, repr' d i+                                   ,repr' d l, repr' d m]
+ runtime/System/Console/Hawk/Runtime.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Applying the user expression as directed by the HawkRuntime.+--   The API may change at any time.+module System.Console.Hawk.Runtime+  ( processTable+  ) where++import Control.Applicative+import Control.Exception+import Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Search as Search+import GHC.IO.Exception+import System.IO++import System.Console.Hawk.Args.Spec+import System.Console.Hawk.Representable+import System.Console.Hawk.Runtime.Base+++processTable :: Rows a => HawkRuntime -> ([[B.ByteString]] -> a) -> HawkIO ()+processTable runtime f = HawkIO $ do+    xss <- getTable (inputSpec runtime)+    outputRows (outputSpec runtime) (f xss)+++getTable :: InputSpec -> IO [[B.ByteString]]+getTable spec = splitIntoTable' <$> getInputString'+  where+    splitIntoTable' = splitIntoTable (inputFormat spec)+    getInputString' = getInputString (inputSource spec)++getInputString :: InputSource -> IO B.ByteString+getInputString NoInput = return B.empty+getInputString UseStdin = B.getContents+getInputString (InputFile f) = B.readFile f++-- [[contents]]+-- or+-- [[record0], [record1], ...]+-- or+-- [[field0, field1, ...], [field0, field1, ...], ...]+splitIntoTable :: InputFormat -> B.ByteString -> [[B.ByteString]]+splitIntoTable RawStream = return . return+splitIntoTable (Records sep format) = fmap splitIntoFields' . splitIntoRecords'+  where+    splitIntoFields' = splitIntoFields format+    splitIntoRecords' = splitAtSeparator sep++-- [record]+-- or+-- [field0, field1, ...]+splitIntoFields :: RecordFormat -> B.ByteString -> [B.ByteString]+splitIntoFields RawRecord = return+splitIntoFields (Fields sep) = splitAtSeparator sep++splitAtSeparator :: Separator -> B.ByteString -> [B.ByteString]+splitAtSeparator Whitespace = B.words+splitAtSeparator (Delimiter "\n") = fmap dropWindowsNewline . B.lines+  where+    dropWindowsNewline :: B.ByteString -> B.ByteString+    dropWindowsNewline "" = ""+    dropWindowsNewline s+        | last_char == '\r' = s'+        | otherwise = s+      where+        last_char = B.last s+        n = B.length s+        s' = B.take (n - 1) s+splitAtSeparator (Delimiter d) = Search.split d+++outputRows :: Rows a => OutputSpec -> a -> IO ()+outputRows (OutputSpec _ spec) x = ignoringBrokenPipe $ do+    let s = join' (toRows x)+    B.putStr s+    hFlush stdout+  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+    -- ignore the broken pipe+    return ()+  where+    isBrokenPipe e | ioe_type e == ResourceVanished = Just e+    isBrokenPipe _ | otherwise                      = Nothing
+ runtime/System/Console/Hawk/Runtime/Base.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | The part of a HawkSpec used at Runtime. The API may change at any time.+-- +-- Due to a `hint` limitation, this module is imported unqualified when+-- interpreting the user expression. This allows `hint` to read and write the+-- type of the expression which it interprets without falling prey to module+-- scoping issues.+module System.Console.Hawk.Runtime.Base where++import Data.Typeable++import System.Console.Hawk.Args.Spec+++data HawkRuntime = HawkRuntime+    { inputSpec :: InputSpec+    , outputSpec :: OutputSpec+    }+  deriving (Show, Eq, Typeable)++-- reexport IO under a unique name+newtype HawkIO a = HawkIO { runHawkIO :: IO a }+  deriving Typeable
+ src/Control/Monad/Trans/OptionParser.hs view
@@ -0,0 +1,517 @@+{-# LANGUAGE 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 "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+-- +-- >>> :{+-- let testH tp = do { putStrLn "Usage: more [option]... <song.mp3>"+--                   ; putStr $ optionsHelpWith head+--                                              id+--                                              (return . printf "adds more %s.")+--                                              tp+--                                              ["cowbell","guitar","saxophone"]+--                   }+-- :}+-- +-- >>> let testP args tp p = runUncertain $ runOptionParserWith head id (const [""]) tp ["cowbell","guitar","saxophone"] p args+++-- | List your options as a datatype, so you can consume specific values later.+--   Then make your datatype an Option instance so we know how to parse them.+class Eq a => Option a where+  shortName :: a -> Char+  longName :: a -> String+  helpMsg :: a -> [String]+  optionType :: a -> OptionType++-- | 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.+data OptionType+    = Flag                   -- Bool, no argument+    | Setting String         -- mandatory String argument+    | NullableSetting String -- optional String argument+  deriving (Show, Eq)+++-- | The monad in which you can consume options.+type OptionParser o a = OptionParserT o Identity a++-- | A monad-transformer version of `OptionParser`.+data OptionParserT o m a = OptionParserT+    { unOptionParserT :: StateT [(o, Maybe String)] -- flags and settings+                       ( StateT [String]            -- extra arguments+                       ( UncertainT m+                       )) a+    }++instance Functor m => Functor (OptionParserT o m) where+  fmap f = OptionParserT . fmap f . unOptionParserT++instance (Functor m, Monad m) => Applicative (OptionParserT o m) where+  pure = OptionParserT . pure+  OptionParserT mf <*> OptionParserT mx = OptionParserT (mf <*> mx)++instance Monad m => Monad (OptionParserT o m) where+  return = OptionParserT . return+  OptionParserT mx >>= f = OptionParserT (mx >>= f')+    where+      f' = unOptionParserT . f+  fail s = OptionParserT (fail s)++instance MonadTrans (OptionParserT o) where+  lift = OptionParserT . lift . lift . lift++instance MonadIO m => MonadIO (OptionParserT o m) where+  liftIO = lift . liftIO++mapOptionParserT :: (forall a. m a -> m' a)+                 -> OptionParserT o m b -> OptionParserT o m' b+mapOptionParserT f = OptionParserT+                   . (mapStateT $ mapStateT $ mapUncertainT f)+                   . unOptionParserT++liftUncertain :: (Monad m) => UncertainT m a -> OptionParserT o m a+liftUncertain = OptionParserT . lift . lift++-- | Convert an option into the structure `getOpt` expects.+optDescr :: forall o. Option o => o -> GetOpt.OptDescr (o, Maybe String)+optDescr = optDescrWith shortName longName helpMsg optionType++-- | A version of `optDescr` which doesn't use the Option typeclass.+optDescrWith :: (o -> Char)+             -> (o -> String)+             -> (o -> [String])+             -> (o -> OptionType)+             -> o -> GetOpt.OptDescr (o, Maybe String)+optDescrWith shortName' longName' helpMsg' optionType'+             o = GetOpt.Option [shortName' o]+                               [longName' o]+                               argDescr+                               (intercalate "\n" $ helpMsg' o)+  where+    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+++-- | The part of your --help which describes each possible option.+optionsHelp :: Option o => [o] -> String+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+--     }+-- :}+-- +-- >>> 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])+                -> (o -> OptionType)+                -> [o] -> String+optionsHelpWith shortName' longName' helpMsg' optionType'+  = GetOpt.usageInfo "Options:" . map optDescrWith'+  where+    optDescrWith' = optDescrWith shortName' longName' helpMsg' optionType'+++-- | Use this instead of `getOpt`. It's not a drop-in replacement, it's a+--   different interface which allows you to consume arguments if and when you+--   need them. Ideal when different commands need a different subset of all+--   available arguments.+runOptionParserT :: (Option o, Monad m)+                 => [o]                  -- ^ every possible option+                 -> OptionParserT o m a  -- ^ an action which consumes options+                 -> [String]             -- ^ the command-line arguments+                 -> UncertainT m a+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+--   ; return (c, g, s)+--   }+-- :}+-- (True,False,True)+runOptionParserWith :: (Eq o, Monad m)+                    => (o -> Char)+                    -> (o -> String)+                    -> (o -> [String])+                    -> (o -> OptionType)+                    -> [o] -> OptionParserT o m a+                    -> [String] -> UncertainT m a+runOptionParserWith shortName' longName' helpMsg' optionType'+                    available_options parser args+  = case GetOpt.getOpt GetOpt.Permute optDescrs args of+      (given_options, extra_options, [])+        -> flip evalStateT extra_options+         $ flip evalStateT given_options+         $ unOptionParserT parser+      (_, _, error_mesage:_) -> fail msg+        where+          n = length error_mesage+          msg | last error_mesage == '\n' = take (n - 1) error_mesage+              | otherwise                 = error_mesage+  where+    optDescrWith' = optDescrWith shortName'+                                 longName'+                                 helpMsg'+                                 optionType'+    optDescrs = map optDescrWith'+                    available_options+++-- | 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+++-- | Specifies that the option cannot be assigned a value.+-- +-- >>> let tp = const flag+-- >>> testH tp+-- Usage: more [option]... <song.mp3>+-- Options:+--   -c  --cowbell    adds more cowbell.+--   -g  --guitar     adds more guitar.+--   -s  --saxophone  adds more saxophone.+flag :: OptionType+flag = Flag++-- | True if the given flag appears.+-- +-- >>> let tp = const flag+-- >>> let consumeCowbell = consumeLast "cowbell" False consumeFlag :: OptionParser String Bool+-- +-- >>> testP ["-cs"] tp consumeCowbell+-- True+-- +-- >>> testP ["--saxophone"] tp consumeCowbell+-- False+consumeFlag :: Monad m => OptionConsumer m Bool+consumeFlag _ = return True+++-- | Specifies that the option must be assigned a String value.+-- +-- >>> let tp = const 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.+string :: OptionType+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+-- +-- >>> 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"+++-- | Specifies that the value of the option may be omitted.+-- +-- >>> let tp = const (nullable 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"++-- | 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+-- +-- >>> 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+++-- | 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:+--   -c amount  --cowbell=amount    adds more cowbell.+--   -g file    --guitar=file       adds more guitar.+--   -s weight  --saxophone=weight  adds more saxophone.+readable :: String -> OptionType+readable = Setting++-- | The value assigned to the option, interpreted by `read`.+-- +-- >>> let tp = const (readable "unit")+-- >>> let consumeCowbell = consumeLast "cowbell" () consumeReadable :: 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+    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+-- +-- >>> testP ["--cowbell=42"] tp consumeCowbell+-- 42+consumeInt :: Monad m => OptionConsumer m Int+consumeInt = consumeReadable+++-- | The value assigned to the option, interpreted as a path (String)+filePath :: OptionType+filePath = Setting "path"++-- | The value assigned to the option if the check function doesn't fail with+-- an error. The check functions must return a file path.+--+-- >>> import Control.Monad+-- >>> import System.EasyFile (doesDirectoryExist)+-- >>> let testIO args tp p = runUncertainIO $ runOptionParserWith head id (const [""]) tp ["input-dir"] p args+-- >>> let inputDir = const filePath+-- >>> :{+--   let checkDir f e d = do+--         c <- lift (f d)+--         if c then return d  :: UncertainT IO FilePath+--              else fail (e d)+-- :}+--+-- >>> 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)+-- >>> 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+++-- | 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]+-- +-- >>> :{+-- testP ["--cowbell=foo", "--cowbell", "bar"] tp $ do+--   { xs <- consumeCowbell+--   ; xs' <- consumeCowbell+--   ; return (xs, xs')+--   }+-- :}+-- (["foo","bar"],[])+consumeAll :: (Eq o, Monad m)+           => o -> OptionConsumer m a -> OptionParserT o m [a]+consumeAll o consume = OptionParserT $ do+    matching_options <- state $ partition $ (== o) . fst+    lift . lift $ mapM (consume . 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).+-- +-- >>> let tp = const string+-- >>> let consumeCowbell = consumeLast "cowbell" "<none>" consumeString :: OptionParser String String+-- +-- >>> :{+-- testP ["--cowbell=foo", "--cowbell", "bar"] tp $ do+--   { xs <- consumeCowbell+--   ; xs' <- consumeCowbell+--   ; return (xs, xs')+--   }+-- :}+-- ("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+++-- | For use with mutually-exclusive flags.+consumeExclusive :: (Option o, Functor m, Monad m)+                 => [(o, a)] -> a -> OptionParserT o m 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+-- +-- >>> 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+    oss <- forM (map fst assoc) $ \o ->+      map (const o) <$> consumeAll o consumeFlag+    case concat oss of+      []  -> return defaultValue+      [o] -> return $ fromMaybe defaultValue $ lookup o assoc+      os  -> fail msg+        where+          n = length os+          (ss, [s]) = splitAt (n - 1) (map longName' os)+          msg = printf "%s and %s are incompatible" (intercalate ", " ss) s+++-- | The next non-option argument.+-- +-- >>> let tp = const flag+-- >>> let consume = consumeExtra consumeString :: 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+    extra_options <- lift get+    case extra_options of+      [] -> return Nothing+      (x:xs) -> do+        lift $ put xs+        fmap Just $ lift . lift $ consume $ Just x++-- | All remaining non-option arguments.+-- +-- >>> let tp = const flag+-- >>> let consume = consumeExtras consumeString :: 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)+-- ["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 []+  where+    go xs = do+        r <- consumeExtra consume+        case r of+          Nothing -> return xs+          Just x  -> go (x:xs)
+ src/Control/Monad/Trans/State/Persistent.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE PackageImports, ScopedTypeVariables #-}+-- | In which the state of a State monad is persisted to disk.+module Control.Monad.Trans.State.Persistent where++import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class+import "mtl" Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Data.Functor.Identity+import System.Directory+import System.FilePath+import System.IO++-- $setup+-- >>> tmp <- getTemporaryDirectory+-- >>> let f = tmp </> "doctest.txt"+++-- | Read and write the cache to a file. Not atomic.+-- +-- >>> :{+-- do { exists <- doesFileExist f+--    ; when exists $ removeFile f+--    }+-- :}+-- +-- >>> withPersistentState f 0 $ modify (+1) >> get+-- 1+-- >>> withPersistentState f 0 $ modify (+1) >> get+-- 2+-- +-- >>> removeFile f+withPersistentState :: forall s a. (Read s, Show s, Eq s)+                    => FilePath -> s -> State s a -> IO a+withPersistentState f default_s sx = do+    withPersistentStateT f default_s sTx+  where+    sTx :: StateT s IO a+    sTx = mapStateT (return . runIdentity) sx++-- | A monad-transformer version of `withPersistentState`.+-- +-- >>> :{+-- do { exists <- doesFileExist f+--    ; when exists $ removeFile f+--    }+-- :}+-- +-- >>> withPersistentStateT f 0 $ lift (putStrLn "hello") >> modify (+1) >> get+-- hello+-- 1+-- >>> withPersistentStateT f 0 $ lift (putStrLn "hello") >> modify (+1) >> get+-- hello+-- 2+-- +-- +-- If the contents of the file has been corrupted, revert to the default value.+-- +-- >>> withPersistentStateT f "." $ lift (putStrLn "hello") >> modify (++".") >> get+-- hello+-- ".."+-- >>> withPersistentStateT f "." $ lift (putStrLn "hello") >> modify (++".") >> get+-- hello+-- "..."+-- +-- +-- >>> removeFile f+withPersistentStateT :: forall m s a. (Functor m, MonadIO 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)+    (x, s') <- runStateT sx s+    when (s' /= s) $ do+      liftIO $ writeFile f $ show s'+    return x+  where+    get_s :: MaybeT m s+    get_s = do+        exists <- liftIO $ doesFileExist f+        guard exists+        +        -- close the file even if the parsing fails+        Just s <- liftIO $ withFile f ReadMode $ \h -> do+          file_contents <- hGetContents h+          case reads file_contents of+            [(s, "")] -> return (Just s)+            _         -> return Nothing+        return s+    +    get_default_s :: MaybeT m s+    get_default_s = return default_s+++-- | Combine consecutive StateT transformers into a single StateT, so the state+--   can be persisted to a single file.+-- +-- >>> let sx = modify (+10)       :: StateT Int (State Int) ()+-- >>> let tx = lift $ modify (*2) :: StateT Int (State Int) ()+-- >>> execState (withCombinedState $ sx >> tx) (1, 2)+-- (11,4)+withCombinedState :: Monad m => StateT s (StateT t m) a -> StateT (s, t) m a+withCombinedState ssx = do+    (s, t) <- get+    ((x, s'), t') <- lift $ runStateT (runStateT ssx s) t+    put (s', t')+    return x
+ src/Control/Monad/Trans/Uncertain.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE PackageImports, RankNTypes #-}+-- | A computation which may raise warnings or fail in error.+module Control.Monad.Trans.Uncertain where++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+++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 = concat . 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_ (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+        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
+ src/Data/Cache.hs view
@@ -0,0 +1,236 @@+{-# 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++import Control.Monad+import "mtl" Control.Monad.Trans+import Control.Monad.Trans.State+import Data.Maybe++-- $setup+-- >>> let verboseLength xs = liftIO (putStrLn xs) >> return (length xs)+-- >>> let cachedLength c xs = cached c xs (verboseLength xs)+-- >>> let testC c = mapM (cachedLength c) (words "one two one two testing testing")+++-- Implementation notes: the `m` is a monad transformer stack, mostly StateT's,+-- holding the state of the cache. The combinators extend caches by adding more+-- state and code around the base object. This is analogous to the Decorator+-- pattern in OO, except each modification to `m` is visible in the type.+data Cache m k a = Cache+  { readCache      :: k      -> m (Maybe a)+  , writeCache     :: k -> a -> m Bool -- ^ False if full+  , clearCache     ::           m ()+  , clearFromCache :: k      -> m ()+  }++-- | Tries to avoid executing this computation in the future by storing it in+--   the cache.+cached :: Monad m => Cache m k a -> k -> m a -> m a+cached c k computeSlowly = do+    r <- readCache c k+    case r of+      Just x -> return x+      Nothing -> do+        x <- computeSlowly+        _ <- writeCache c k x+        return x+++-- implementations+++-- | A dummy cache which never caches anything.+-- +-- Semantically equivalent to `finiteCache 0 $ assocCache`, except for the `m`.+-- +-- >>> withNullCache testC+-- one+-- two+-- one+-- two+-- testing+-- testing+-- [3,3,3,3,7,7]+nullCache :: Monad m => Cache m k a+nullCache = Cache+    { readCache      = \_   -> return Nothing+    , writeCache     = \_ _ -> return False  -- always full!+    , clearCache     =         return ()+    , clearFromCache = \_   -> return ()+    }++withNullCache :: Monad m => (Cache m k v -> m a) -> m a+withNullCache body = body nullCache+++-- | A very inefficient example implementation.+-- +-- >>> withAssocCache testC+-- one+-- two+-- testing+-- [3,3,3,3,7,7]+assocCache :: (Monad m, Eq k) => Cache (StateT [(k,a)] m) k a+assocCache = Cache+    { readCache      = \k   -> liftM (lookup k) $ get+    , writeCache     = \k v -> modify ((k,v):)+                            >> return True  -- never full.+    , clearCache     =         put []+    , clearFromCache = \k   -> modify $ filter $ (/= k) . fst+    }++withAssocCache :: (Monad m, Eq k)+               => (Cache (StateT [(k,v)] m) k v -> StateT [(k,v)] m a)+               -> m a+withAssocCache body = evalStateT (body assocCache) []+++-- decorators+++-- | 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+-- two+-- testing+-- testing+-- [3,3,3,3,7,7]+-- +-- >>> withAssocCache $ withFiniteCache 0 $ testC+-- one+-- two+-- one+-- two+-- testing+-- testing+-- [3,3,3,3,7,7]+-- +-- >>> withAssocCache $ withFiniteCache (-1) $ testC+-- one+-- two+-- testing+-- [3,3,3,3,7,7]+finiteCache :: Monad m => Int -> Cache m k a -> Cache (StateT Int m) k a+finiteCache n c = Cache+    { readCache      = \k   ->          (lift $ readCache      c k  )+    , writeCache     = \k v -> do+        alreadyFull <- isFull+        if alreadyFull+          then return False+          else do+            r <- lift $ writeCache c k v+            when r incr+            return r+    , clearCache     =         put 0 >> (lift $ clearCache     c    )+    , clearFromCache = \k   -> decr  >> (lift $ clearFromCache c k  )+    }+  where+    isFull = liftM (== n) $ get+    incr = modify (+1)+    decr = modify (subtract 1)++withFiniteCache :: Monad m+                => Int+                -> (Cache (StateT Int m) k v -> StateT Int m a)+                -> (Cache m k v -> m a)+withFiniteCache n body c = evalStateT (body $ finiteCache n c) 0+++-- | 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+-- one+-- two+-- testing+-- [3,3,3,3,7,7]+-- +-- >>> withAssocCache $ withFiniteCache 0 $ withLruCache testC+-- one+-- two+-- one+-- two+-- testing+-- testing+-- [3,3,3,3,7,7]+lruCache :: (Monad m, Eq k) => Cache m k a -> Cache (StateT [k] m) k a+lruCache c = Cache+    { readCache      = \k   -> do+      r <- lift $ readCache c k+      when (isJust r) $ touch k+      return r+    , writeCache     = \k v -> do+        r <- lift $ writeCache c k v+        if r+          then return True+          else do+            makeRoom+            lift $ writeCache c k v+    , clearCache     =                     (lift $ clearCache     c    )+    , clearFromCache = \k   -> remove k >> (lift $ clearFromCache c k  )+    }+  where+    touch k = write k+    makeRoom = do+        mostRecentlyUsed <- get+        case mostRecentlyUsed of+          (k:ks) -> do+            put ks+            lift $ clearFromCache c k+          [] -> do+            -- the cache is both full and empty? try to reset.+            lift $ clearCache c+    +    write  k = modify (k:)+    remove k = modify $ filter $ (/= k)++withLruCache :: (Monad m, Eq k)+             => (Cache (StateT [k] m) k v -> StateT [k] m a)+             -> (Cache m k v -> m a)+withLruCache body c = evalStateT (body $ lruCache c) []+++-- | An extreme version of the LRU strategy.+-- +-- Semantically equivalent to `lruCache . finiteCache 1`, except for the `m`.+-- +-- >>> withAssocCache $ withSingletonCache testC+-- one+-- two+-- one+-- two+-- testing+-- [3,3,3,3,7,7]+singletonCache :: (Monad m, Eq k) => Cache m k a -> Cache m k a+singletonCache c = c { writeCache = go }+  where+    go k mx = clearCache c >> writeCache c k mx++withSingletonCache :: (Monad m, Eq k)+                   => (Cache m k v -> m a)+                   -> (Cache m k v -> m a)+withSingletonCache body c = body (singletonCache c)
+ src/Data/HaskellModule.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards #-}+-- | An opaque representation of a Haskell module.+-- +-- The few parts which can be modified are easier to modify than using raw+-- bytes or a raw HaskellSource.+module Data.HaskellModule+  ( module Data.HaskellModule.Base+  , module Data.HaskellModule.Parse+  , showModule, writeModule+  , compileModule, compileModuleWithArgs+  ) where++import Control.Monad.Trans.Class+import qualified Data.ByteString.Char8 as B++import Data.HaskellSource+import Control.Monad.Trans.Uncertain++-- Most of the API is re-exported from those submodules+import Data.HaskellModule.Base+import Data.HaskellModule.Parse+++-- |+-- >>> 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 = 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
+ src/Data/HaskellModule/Base.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+-- | A version of HaskellSource with slightly more semantics.+module Data.HaskellModule.Base where++import Control.Applicative+import Text.Printf++import Data.HaskellSource+++-- | hint has `Interpreter.Extension`, but strings are simpler.+type ExtensionName = String++-- | import [qualified] <module-name> [as <qualified-name>]+type QualifiedModule = (String, Maybe String)++-- | Three key pieces of information about a Haskell Module:+--   the language extensions it enables,+--   the module's name (if any), and+--   the modules it imports.+data HaskellModule = HaskellModule+  { languageExtensions :: [ExtensionName]   , pragmaSource :: HaskellSource+  , moduleName         :: Maybe String      , moduleSource :: HaskellSource+  , importedModules    :: [QualifiedModule] , importSource :: HaskellSource+                                            , codeSource   :: HaskellSource+  } deriving (Show, Eq)+++emptyModule :: HaskellModule+emptyModule = HaskellModule [] [] Nothing [] [] [] []+++addExtension :: ExtensionName -> HaskellModule -> HaskellModule+addExtension e m = m+    { languageExtensions = extraExtensions e ++ languageExtensions m+    , pragmaSource       = extraSource e ++ pragmaSource m+    }+  where+    extraExtensions = return+    extraSource = return . return . languagePragma+    +    languagePragma = printf "{-# LANGUAGE %s #-}"++addDefaultModuleName :: String -> HaskellModule -> HaskellModule+addDefaultModuleName s m = m+    { moduleName   = moduleName m <|> defaultName s+    , moduleSource = extraSource s ++ moduleSource m+    }+  where+    defaultName = return+    extraSource = return . return . moduleDeclaration+    +    moduleDeclaration = printf "module %s where"++addImport :: QualifiedModule -> HaskellModule -> HaskellModule+addImport qm m = m+    { importedModules = extraModules qm ++ importedModules m+    , importSource    = extraSource qm ++ importSource m+    }+  where+    extraModules = return+    extraSource = return . return . importStatement+    +    importStatement (fullName, Nothing) =+        printf "import %s" fullName+    importStatement (fullName, Just qualifiedName) =+        printf "import qualified %s as %s" fullName qualifiedName
+ src/Data/HaskellModule/Parse.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings, PackageImports, RecordWildCards #-}+-- | In which a Haskell module is deconstructed into extensions and imports.+module Data.HaskellModule.Parse (readModule) where++import "mtl" Control.Monad.Trans+import qualified Data.ByteString.Char8 as B+import Data.List+import Language.Haskell.Exts+import Text.Printf++import Control.Monad.Trans.Uncertain+import Data.HaskellModule.Base+import Data.HaskellSource+import Language.Haskell.Exts.Location+++locatedExtensions :: [ModulePragma] -> Located [ExtensionName]+locatedExtensions = fmap go . located+  where+    go :: [ModulePragma] -> [ExtensionName]+    go = concatMap extNames+    +    extNames :: ModulePragma -> [ExtensionName]+    extNames (LanguagePragma _ exts) = map prettyPrint exts+    extNames (OptionsPragma _ _ _) = []  -- TODO: accept "-XExtName"+    extNames _ = []++locatedImports :: [ImportDecl] -> Located [QualifiedModule]+locatedImports = fmap go . located+  where+    go :: [ImportDecl] -> [QualifiedModule]+    go = 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 (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
+ src/Data/HaskellSource.hs view
@@ -0,0 +1,103 @@+-- | A representation of Haskell source code.+-- +-- Unlike haskell-src-exts, our goal is not to reconstruct detailed semantics,+-- but to preserve original line numbers (if applicable).+module Data.HaskellSource where++import Control.Monad.Trans.Class+import Data.ByteString.Char8 as B+import System.Exit+import System.Process+import Text.Printf++import System.Directory.Extra+import Control.Monad.Trans.Uncertain+++-- | The ByteStrings are original lines, which we never delete in order to+--   infer line numbers, while the Strings were inserted into the original.+type HaskellSource = [Either B.ByteString String]+++parseSource :: B.ByteString -> HaskellSource+parseSource = fmap Left . B.lines++-- | A string representation containing line pragmas so that compiler errors+--   are reported about the original file instead of the modified one.+-- +-- >>> let (x:xs) = parseSource $ B.pack "import Data.ByteString\nmain = print 42\n"+-- >>> B.putStr $ showSource "orig.hs" (x:xs)+-- import Data.ByteString+-- main = print 42+-- +-- >>> B.putStr $ showSource "orig.hs" (x:Right "import Prelude":xs)+-- import Data.ByteString+-- import Prelude+-- {-# LINE 2 "orig.hs" #-}+-- main = print 42+showSource :: FilePath -- ^ the original's filename,+                       --   used for fixing up line numbers+           -> HaskellSource -> B.ByteString+showSource orig = B.unlines . go True 1+  where+    go :: Bool -- ^ are line numbers already ok?+       -> Int  -- ^ the original number of the next original line+       -> HaskellSource+       -> [B.ByteString]+    go _     _ []           = []+    go True  i (Left x:xs)  = x+                            : go True (i + 1) xs+    go False i (Left x:xs)  = B.pack (line_marker i)+                            : x+                            : go True (i + 1) xs+    go _     i (Right x:xs) = B.pack x+                            : go False i xs+    +    line_marker :: Int -> String+    line_marker i = printf "{-# LINE %s %s #-}" (show i) (show orig)+++readSource :: FilePath -> IO HaskellSource+readSource = fmap parseSource . B.readFile++writeSource :: FilePath -- ^ the original's filename,+                        --   used for fixing up line numbers+            -> FilePath+            -> HaskellSource+            -> IO ()+writeSource orig f = B.writeFile f . showSource orig+++compileSource :: 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.+              -> HaskellSource+              -> UncertainT IO ()+compileSource = compileSourceWithArgs []++compileSourceWithArgs :: [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.+                      -> HaskellSource+                      -> UncertainT IO ()+compileSourceWithArgs args orig f s = do+    lift $ writeSource orig f s+    compileFileWithArgs args f+++compileFile :: FilePath -> UncertainT IO ()+compileFile = compileFileWithArgs []++compileFileWithArgs :: [String] -> FilePath -> UncertainT IO ()+compileFileWithArgs args f = do+    absFilePath <- lift $ absPath f+    let args' = absFilePath : "-v0" : args+    (exitCode, out, err) <- lift $ readProcessWithExitCode "ghc" args' ""+    case (exitCode, out ++ err) of+      (ExitSuccess, [])  -> return ()+      (ExitSuccess, msg) -> multilineWarn msg+      (_          , [])  -> fail $ printf "could not compile %s" (show f)+      (_          , msg) -> multilineFail msg
+ src/Data/Monoid/Ord.hs view
@@ -0,0 +1,82 @@+-- 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
@@ -0,0 +1,85 @@+-- | Easier access to haskell-src-exts's SrcLoc values.+module Language.Haskell.Exts.Location where++import Control.Monad+import Control.Monad.Trans.Writer+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+++-- | 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++located :: Location a => a -> Located a+located x = do+    tell $ MinPriority $ location x+    return x++runLocated :: Located a -> (a, Maybe SrcLoc)+runLocated = go . runWriter+  where+    go (x, p) = (x, getMinPriority p)
src/Main.hs view
@@ -14,7 +14,9 @@  module Main where +import System.Environment+ import qualified System.Console.Hawk as Hawk  main :: IO ()-main = Hawk.main+main = getArgs >>= Hawk.processArgs
src/System/Console/Hawk.hs view
@@ -12,225 +12,91 @@ --   See the License for the specific language governing permissions and --   limitations under the License. -{-# LANGUAGE NoImplicitPrelude-           , OverloadedStrings-           , ScopedTypeVariables-           , TupleSections #-}--module System.Console.Hawk (--    hawk-  , main--) where+-- | Hawk as seen from the outside world: parsing command-line arguments,+--   evaluating user expressions.+module System.Console.Hawk+  ( processArgs+  ) where  -import Control.Applicative ((<$>))-import Control.Monad-import qualified Data.List as L-import Data.List ((++),(!!))-import Data.Either-import Data.Function-import Data.Ord-import Data.Maybe-import Data.String-import qualified Data.Typeable.Internal as Typeable-import Data.Typeable.Internal-  (TypeRep(..)-  ,tyConName)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import Data.Version (versionBranch) import Language.Haskell.Interpreter-import qualified Prelude as P-import System.Console.GetOpt (usageInfo)-import System.Environment (getArgs,getProgName)-import System.Exit (exitFailure,exitSuccess)-import qualified System.IO as IO-import System.IO (IO) import Text.Printf (printf) -import System.Console.Hawk.Sandbox-import System.Console.Hawk.Config-import System.Console.Hawk.Lock-import System.Console.Hawk.IO-import System.Console.Hawk.Options---- magic self-referential module created by cabal-import Paths_haskell_awk (version)+import Control.Monad.Trans.Uncertain+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.Version  -initInterpreter :: (String, String) -- ^ config file and module name-                -> [(String,Maybe String)] -- ^ the modules maybe qualified-                -> [Extension]-                -> InterpreterT IO ()-initInterpreter (preludeFile,preludeModule) userModules extensions = do-        -        set [languageExtensions := extensions]--        -- load the config file-        loadModules [preludeFile]--        -- load the config module plus representable-        setImportsQ $ (preludeModule,Nothing):defaultModules-                                           ++ userModules--printErrors :: InterpreterError -> IO ()-printErrors e = case e of-                  WontCompile es' -> do-                    IO.hPutStrLn IO.stderr "\nWon't compile:"-                    forM_ es' $ \e' ->-                      case e' of-                        GhcError e'' -> IO.hPutStrLn IO.stderr $ '\t':e'' ++ "\n"-                  _ -> IO.print e--runHawk :: Options-        ->  (String,String)-        -> [String]-        -> IO ()-runHawk os prelude nos = do-  let file = if L.length nos > 1 then Just (nos !! 1) else Nothing-  extensions <- P.read <$> (getExtensionsFile >>= IO.readFile)-  modules <- maybe (return []) (\f -> P.read <$> IO.readFile f) (optModuleFile os)--  maybe_f <- hawk os prelude modules extensions (L.head nos)-  case maybe_f of-    Left ie -> printErrors ie-    Right f -> getInput file >>= printOutput . f--runLockedHawkInterpreter :: forall a . InterpreterT IO a-                            -> IO (Either InterpreterError a)-runLockedHawkInterpreter i = do-    withLock $ runHawkInterpreter i--data StreamFormat = StreamFormat | LinesFormat | WordsFormat-    deriving (P.Eq,P.Show,P.Read)--streamFormat :: B.ByteString-             -> B.ByteString-             -> StreamFormat-streamFormat ld wd = if B.null ld-                        then StreamFormat-                        else if B.null wd-                                then LinesFormat-                                else WordsFormat---- | 'ByteString' wrapper used to override the 'ByteString' @typeOf@ into--- a qualified version--- @typeOf (ByteString.pack "test") == "ByteString"@--- @typeof (QualifiedByteString $ ByteString.pack "test") == "Data.ByteString.Lazy.Char8.Bytestring"@-newtype QualifiedByteString = QB { unQB :: LB.ByteString }+-- | 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 -instance Typeable.Typeable QualifiedByteString where-  typeOf (QB bs) = let TypeRep fp tc trs = Typeable.typeOf bs-                   in TypeRep fp-                              tc{ tyConName = "Data.ByteString.Lazy.Char8."-                                          ++ tyConName tc }-                              trs+-- | 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 -hawk :: Options                -- ^ Program options-     -> (String,String)         -- ^ The prelude file and module name-     -> [(String,Maybe String)] -- ^ The modules maybe qualified-     -> [Extension]             -- ^ The extensions to enable-     -> String                  -- ^ The user expression to evaluate-     -> IO (Either InterpreterError (LB.ByteString -> LB.ByteString))-hawk opts prelude modules extensions userExpr = do-    eitherErrorF <- runLockedHawkInterpreter $ do+wrapExpr :: String -> ExprSpec -> ExprSpec+wrapExpr f e = e'+  where+    u = userExpression e+    u' = printf "%s (%s)" (prel f) u+    e' = e { userExpression = u' } -        initInterpreter prelude modules extensions-        -        -- eval program based on the existence of a delimiter-        case (optMode opts,streamFormat linesDelim wordsDelim) of-            (EvalMode,_)             -> interpret' $ evalExpr      userExpr-            (ApplyMode,StreamFormat) -> interpret' $ streamExpr    userExpr-            (ApplyMode,LinesFormat)  -> interpret' $ linesExpr     userExpr-            (ApplyMode,WordsFormat)  -> interpret' $ wordsExpr     userExpr-            (MapMode,StreamFormat)   -> interpret' $ mapStreamExpr userExpr-            (MapMode,LinesFormat)    -> interpret' $ mapLinesExpr  userExpr-            (MapMode,WordsFormat)    -> interpret' $ mapWordsExpr  userExpr+applyExpr :: ExprSpec -> InputSpec -> OutputSpec -> IO ()+applyExpr e i o = do+    let contextDir = userContextDirectory e+    let expr = userExpression e     -    return ((\f -> unQB . f . QB) <$> eitherErrorF)-    where -          interpret' expr = do-            -- print the user expression-            -- lift $ IO.hPutStrLn IO.stderr expr -            interpret expr (as :: QualifiedByteString -> QualifiedByteString)-          evalExpr = printf "const (%s (%s))" showRows-          mapStreamExpr = streamExpr . listMap-          mapLinesExpr = linesExpr . listMap-          mapWordsExpr = wordsExpr . listMap-          streamExpr expr = compose [showRows, expr]-          linesExpr expr = compose [showRows, expr, parseRows]-          wordsExpr expr = compose [showRows, expr, parseWords]-          linesDelim = optLinesDelim opts-          wordsDelim = optWordsDelim opts-          outLinesDelim = case optOutLinesDelim opts of-                            Nothing -> linesDelim-                            Just delim -> delim-          outWordsDelim = case optOutWordsDelim opts of-                            Nothing -> wordsDelim-                            Just delim -> delim-          compose :: [String] -> String-          compose = L.intercalate (prel ".") . P.map (printf "(%s)")-          listMap :: String -> String-          listMap = printf (runtime "listMap (%s)")-          c8pack :: String -> String-          c8pack = printf (runtime "c8pack (%s)")-          sc8pack :: String -> String-          sc8pack = printf (runtime "sc8pack (%s)")-          showRows :: String-          showRows = printf (runtime "showRows (%s) (%s)")-                             (c8pack $ P.show outLinesDelim)-                             (c8pack $ P.show outWordsDelim)-          parseRows :: String-          parseRows = printf (runtime "parseRows (%s)")-                             (sc8pack $ P.show linesDelim)--          parseWords :: String-          parseWords = printf (runtime "parseWords (%s) (%s)")-                              (sc8pack $ P.show linesDelim)-                              (sc8pack $ P.show wordsDelim)-          -          qualify :: String -> String -> String-          qualify moduleName = printf "%s.%s" moduleName-          -          prel = qualify "Prelude"-          runtime = qualify "System.Console.Hawk.Runtime"+    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") -getUsage :: IO String-getUsage = do-    pn <- getProgName-    return $ usageInfo ("Usage: " ++ pn ++ " [<options>] <expr> [<file>]") -                       options+-- 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 -main :: IO ()-main = do-    moduleFile <- getModulesFile-    optsArgs <- processArgs moduleFile <$> getArgs-    either printErrorAndExit go optsArgs-    where processArgs moduleFile args =-                case compileOpts args of-                    Left err -> Left err-                    Right (opts,notOpts) -> -                        Right (opts{ optModuleFile = Just moduleFile},notOpts)-          printErrorAndExit errors = errorMessage errors >> exitFailure-          errorMessage errs = do-                usage <- getUsage-                IO.hPutStr IO.stderr $ L.intercalate "\n" (errs ++ ['\n':usage])-          go (opts,notOpts) = do-                config <- if optRecompile opts-                              then recompileConfig-                              else recompileConfigIfNeeded-                -                when (optVersion opts) $ do-                  let versionString = L.intercalate "."-                                    $ P.map P.show-                                    $ versionBranch version-                  IO.putStrLn versionString-                  exitSuccess-                -                when (optHelp opts) $ do-                  getUsage >>= IO.putStr-                  exitSuccess-                -                runHawk opts config notOpts+prel, runtime :: String -> String+prel = qualify "Prelude"+runtime = qualify "System.Console.Hawk.Runtime"
+ src/System/Console/Hawk/Args.hs view
@@ -0,0 +1,14 @@+-- | Re-export the most important functions from Args.*+module System.Console.Hawk.Args+  ( HawkSpec(..)+  , InputSpec(..), OutputSpec(..)+  , InputSource(..), OutputSink(..)+  , InputFormat(..), RecordFormat(..)+  , OutputFormat(..)+  , Separator(..), Delimiter+  , ExprSpec(..)+  , parseArgs+  ) where++import System.Console.Hawk.Args.Parse+import System.Console.Hawk.Args.Spec
+ src/System/Console/Hawk/Args/Option.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+-- | The string-typed version of Hawk's command-line arguments.+module System.Console.Hawk.Args.Option where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import Text.Printf++import Control.Monad.Trans.OptionParser+++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
+ src/System/Console/Hawk/Args/Parse.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}+-- | 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 "mtl" Control.Monad.Trans++import Control.Monad.Trans.OptionParser+import Control.Monad.Trans.Uncertain+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++-- $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
− src/System/Console/Hawk/Config.hs 
@@ -1,160 +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.--{-# LANGUAGE OverloadedStrings #-}-module System.Console.Hawk.Config (-      defaultModules-    , defaultPrelude-    , recompileConfigIfNeeded-    , getExtensionsFile-    , getModulesFile-    , parseModules-    , recompileConfig-    , recompileConfig'-) where--import Control.Applicative ((<$>))-import Control.Monad (when, unless)--import Data.Time-import System.EasyFile--import System.Console.Hawk.Config.Base-import System.Console.Hawk.Config.Cache-import System.Console.Hawk.Config.Compile-import System.Console.Hawk.Config.Extend-import System.Console.Hawk.Config.Parse-import System.Console.Hawk.Lock---defaultModules :: [QualifiedModule]-defaultModules = map fully_qualified [ -                                       "Prelude"-                                     , "System.Console.Hawk.IO"-                                     , "System.Console.Hawk.Representable"-                                     , "System.Console.Hawk.Runtime"-                                     , "System.IO.Unsafe"-                                     , "Data.ByteString.Lazy.Char8"-                                     ]-  where-    fully_qualified x = (x, Just x)--defaultPrelude :: String-defaultPrelude = unlines-               [ "{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}"-               , "import Prelude"-               , "import qualified Data.ByteString.Lazy.Char8 as B"-               , "import qualified Data.List as L"-               ]---- ----- From now the code is heavy, it needs a refactoring (renaming)---- maybe (file name, module name)--- TODO: error handling--recompileConfigIfNeeded :: IO (String,String) -- ^ Maybe (FileName,ModuleName)-recompileConfigIfNeeded = withLock $ do-    dir <- getConfigDir-    dirExists <- doesDirectoryExist dir-    unless dirExists $-        createDirectoryIfMissing True dir-    configFile <- getConfigFile-    configFileExists <- doesFileExist configFile-    unless configFileExists $-        writeFile configFile defaultPrelude-    configInfosFile <- getConfigInfosFile-    configInfosExists <- doesFileExist configInfosFile-    if configInfosExists-      then do-          configInfos <- lines <$> readFile configInfosFile-          if length configInfos /= 3 -- error-            then recompileConfig-            else do-                let [fileName,moduleName,rawLastModTime] = configInfos-                let withoutExt = dropExtension fileName-                let hiFile = withoutExt ++ ".hi"-                hiFileDoesntExist <- not <$> doesFileExist hiFile-                let objFile = withoutExt ++ ".o"-                objFileDoesntExist <- not <$> doesFileExist objFile-                let lastModTime = (read rawLastModTime :: UTCTime)-                currModTime <- getModificationTime configFile-                if hiFileDoesntExist || objFileDoesntExist -                                     || currModTime > lastModTime-                 then recompileConfig-                 else return (fileName,moduleName)-      else recompileConfig----- TODO: error handling-recompileConfig :: IO (String,String)-recompileConfig = do-  configFile <- getConfigFile-  cacheDir <- getCacheDir-  sourceFile <- getSourceFile-  extensionFile <- getExtensionsFile-  modulesFile <- getModulesFile-  compiledFile <- getCompiledFile-  configInfosFile <- getConfigInfosFile-  recompileConfig' configFile-                   cacheDir-                   sourceFile-                   extensionFile-                   modulesFile-                   compiledFile-                   configInfosFile--recompileConfig' :: FilePath -- ^ config file-                 -> FilePath -- ^ cache dir-                 -> FilePath -- ^ source file-                 -> FilePath -- ^ output extensions cache file-                 -> FilePath -- ^ output modules cache file-                 -> FilePath -- ^ output compiled file-                 -> FilePath -- ^ output config info path-                 -> IO (String,String)-recompileConfig' configFile-                 cacheDir-                 sourceFile-                 extensionsFile-                 modulesFile-                 compiledFile-                 configInfosFile = do-    clean-    createDirectoryIfMissing True cacheDir-    -    extensions <- parseExtensions configFile-    orig_modules <- parseModules configFile extensions-    orig_source <- parseSource configFile-    -    let modules = extendModules extensions orig_modules-    let source = extendSource configFile extensions orig_modules orig_source-    -    cacheExtensions extensionsFile extensions-    cacheModules modulesFile modules-    cacheSource sourceFile source-    -    compile sourceFile compiledFile cacheDir-    -    let moduleName = getModuleName source-    lastModTime <- getModificationTime configFile-    writeFile configInfosFile $ unlines [sourceFile-                                         ,moduleName-                                         ,show lastModTime]-    -    return (sourceFile, moduleName)-  where-    clean :: IO ()-    clean = do-        dirExists <- doesDirectoryExist cacheDir-        when (dirExists) (removeDirectoryRecursive cacheDir)
− src/System/Console/Hawk/Config/Base.hs 
@@ -1,25 +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.--module System.Console.Hawk.Config.Base where--import Data.ByteString.Char8---type ExtensionName = String-type QualifiedModule = (String, Maybe String)-type Source = ByteString--defaultModuleName :: String-defaultModuleName = "System.Console.Hawk.CachedPrelude"
− src/System/Console/Hawk/Config/Cache.hs 
@@ -1,91 +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.--{-# LANGUAGE OverloadedStrings #-}-module System.Console.Hawk.Config.Cache-    ( getConfigDir-    , getConfigFile-    , getCacheDir-    , getConfigInfosFile-    , getExtensionsFile-    , getModulesFile-    , getCompiledFile-    , getSourceFile-    , cacheExtensions-    , cacheModules-    , cacheSource-    )-  where--import Control.Applicative ((<$>))--import qualified Data.ByteString.Char8 as B-import qualified Language.Haskell.Interpreter as Interpreter-import System.EasyFile--import System.Console.Hawk.Config.Base---(<//>) :: IO FilePath -- the left filepath in the IO monad-       -> FilePath -- the right filepath-       -> IO FilePath -- the filepath resulting-lpath <//> rpath = (</> rpath) <$> lpath--getConfigDir :: IO FilePath-getConfigDir = getHomeDirectory <//> ".hawk"--getConfigFile :: IO FilePath-getConfigFile = getConfigDir <//> "prelude.hs"--getCacheDir :: IO FilePath-getCacheDir = getConfigDir <//> "cache"--getConfigInfosFile :: IO FilePath-getConfigInfosFile = getCacheDir <//> "configInfos"--getModulesFile :: IO FilePath-getModulesFile = getCacheDir <//> "modules"--getExtensionsFile :: IO FilePath-getExtensionsFile = getCacheDir <//> "extensions"---getSourceBasename :: IO String-getSourceBasename = getCacheDir <//> "cached_prelude"--getCompiledFile :: IO String-getCompiledFile = getSourceBasename--getSourceFile :: IO String-getSourceFile = (++ ".hs") <$> getSourceBasename---cacheExtensions :: FilePath-                -> [ExtensionName]-                -> IO ()-cacheExtensions extensionsFile extensions = -  writeFile extensionsFile $ show extensions'-  where-    extensions' :: [Interpreter.Extension]-    extensions' = map read extensions--cacheModules :: FilePath-             -> [QualifiedModule]-             -> IO ()-cacheModules modulesFile modules = writeFile modulesFile $ show modules--cacheSource :: FilePath-            -> Source-            -> IO ()-cacheSource = B.writeFile
− src/System/Console/Hawk/Config/Compile.hs 
@@ -1,55 +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.--{-# LANGUAGE OverloadedStrings #-}-module System.Console.Hawk.Config.Compile-    ( compile-    )-  where--import Control.Monad (when)--import System.Exit-import System.IO-import System.Process--import System.Console.Hawk.Sandbox (extraGhcArgs)----- compile a haskell file--- TODO: this should return the error instead of print it and exit-compile :: FilePath -- ^ the source file-        -> FilePath -- ^ the output file-        -> FilePath -- ^ the directory used for compiler files-        -> IO ()-compile sourceFile outputFile dir = do-    let basicArgs = [ "--make"-                    , sourceFile-                    , "-i"-                    , "-ilib"-                    , "-fforce-recomp"-                    , "-v0"-                    , "-o",outputFile]-    extraArgs <- extraGhcArgs-    let args = basicArgs ++ extraArgs-    compExitCode <--            waitForProcess =<< runProcess "ghc"-                                          args-                                          (Just dir)-                                          Nothing-                                          Nothing-                                          Nothing-                                          (Just stderr)-    when (compExitCode /= ExitSuccess) $ do-        exitFailure
− src/System/Console/Hawk/Config/Extend.hs 
@@ -1,115 +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.--{-# LANGUAGE OverloadedStrings #-}-module System.Console.Hawk.Config.Extend-    ( extendModules-    , extendSource-    , getModuleName-    )-  where--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Search as BSS-import Data.Char-import Data.Maybe-import Data.Monoid ((<>))-import Text.Printf--import System.Console.Hawk.Config.Base---extendModules :: [ExtensionName]-              -> [QualifiedModule]-              -> [QualifiedModule]-extendModules extensions modules = addIfNecessary (shouldAddPrelude extensions modules)-                                                  (unqualified_prelude:)-                                                  modules-  where-    unqualified_prelude = ("Prelude", Nothing)----- adjust the prelude to make it loadable from hint.-extendSource :: FilePath-             -> [ExtensionName]-             -> [QualifiedModule]-             -> Source-             -> Source-extendSource configFile extensions modules = addPreludeIfMissing . addModuleIfMissing-  where-    addModuleIfMissing s = addIfNecessary (shouldAddModule s)-                                          (addModule configFile)-                                          s-    addPreludeIfMissing = addIfNecessary (shouldAddPrelude extensions modules)-                                         (addImport "Prelude" configFile)---addIfNecessary :: Bool -> (a -> a) -> a -> a-addIfNecessary True  f x = f x-addIfNecessary False _ x = x--shouldAddModule :: Source -> Bool-shouldAddModule = (== Nothing) . parseModuleName --shouldAddPrelude :: [ExtensionName] -> [QualifiedModule] -> Bool-shouldAddPrelude extensions _ | "NoImplicitPrelude" `elem` extensions = False-shouldAddPrelude _ modules    | "Prelude" `elem` map fst modules      = False-shouldAddPrelude _ _          | otherwise                             = True----- add a module to a string representing a Haskell source file-addModule :: FilePath -> Source -> Source-addModule configFile source =-    let strippedCode = C8.dropWhile isSpace source-        maybePragma = if "{-#" `C8.isPrefixOf` strippedCode-                        then let (pragma,afterPragma) = BSS.breakAfter "#-}" strippedCode-                             in (Just pragma, afterPragma)-                        else (Nothing,strippedCode)-        line :: Int -> ByteString-        line n = C8.pack $ printf "{-# LINE %d %s #-}" n $ show configFile-        moduleLine = C8.pack $ unwords ["module", defaultModuleName, "where"]-    in case maybePragma of-        (Nothing,c) -> C8.unlines [moduleLine,c]-        (Just pragma,c) -> let n = 1 + C8.length (C8.filter (=='\n') pragma)-                            in C8.unlines [line 1,pragma,moduleLine,line n,c]---- add an import statement to a string representing a Haskell source file-addImport :: String -> FilePath -> Source -> Source-addImport moduleName configFile source =-    let (premodule,postmodule)   = BSS.breakAfter "module " source-        (prewhere,postwhere)     = BSS.breakAfter " where" postmodule-        (prenewline,postnewline) = BSS.breakAfter "\n" postwhere-        preimports = premodule <> prewhere <> prenewline-        postimports = postnewline-        line :: Int -> ByteString-        line n = C8.pack $ printf "{-# LINE %d %s #-}" n $ show configFile-        importLine = C8.pack $ unwords ["import", moduleName]-        m = 1 + C8.length (C8.filter (=='\n') preimports)-        extraLines = C8.unlines [importLine, line m]-    in preimports <> extraLines <> postimports----- get the module name from a file if it exists-parseModuleName :: Source -> Maybe ByteString-parseModuleName bs = case BSS.indices (C8.pack "module") bs of-                       [] -> Nothing-                       (i:_) -> Just-                              . C8.takeWhile (\c -> isAlphaNum c || c == '.')-                              . C8.dropWhile isSpace-                              . C8.drop (i + 6) $ bs---- same, but crash if there is no module-getModuleName :: Source -> String-getModuleName = C8.unpack . fromJust . parseModuleName
− src/System/Console/Hawk/Config/Parse.hs 
@@ -1,89 +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.--{-# LANGUAGE OverloadedStrings #-}-module System.Console.Hawk.Config.Parse-    ( ExtensionName-    , QualifiedModule-    , parseExtensions-    , parseModules-    , parseSource-    )-  where--import Control.Applicative ((<$>))--import qualified Data.ByteString.Char8 as C8-import Data.Maybe-import Language.Haskell.Exts ( parseFileWithExts )-import Language.Haskell.Exts.Extension ( parseExtension, Extension (..) )-import Language.Haskell.Exts.Parser-    ( getTopPragmas-    , ParseResult (..)-    )-import Language.Haskell.Exts.Syntax-import System.Exit-import Text.Printf--import System.Console.Hawk.Config.Base---getResult :: FilePath -> ParseResult a -> IO a-getResult _ (ParseOk x) = return x-getResult sourceFile (ParseFailed srcLoc err) = do-    putStrLn $ printf "error parsing file %s:%s: %s" sourceFile (show srcLoc) err-    exitFailure---parseExtensions :: FilePath -> IO [ExtensionName]-parseExtensions sourceFile = do-    result <- getTopPragmas <$> readFile sourceFile -    listExtensions <$> getResult sourceFile result-  where-    listExtensions :: [ModulePragma] -> [ExtensionName]-    listExtensions = map getName . concat . mapMaybe extensionNames-    -    extensionNames :: ModulePragma -> Maybe [Name]-    extensionNames (LanguagePragma _ names) = Just names-    extensionNames _                        = Nothing-    -    getName :: Name -> ExtensionName-    getName (Ident  s) = s-    getName (Symbol s) = s---parseModules :: FilePath -> [ExtensionName] -> IO [QualifiedModule]-parseModules sourceFile extensions = do-    result <- parseFileWithExts extensions' sourceFile-    Module _ _ _ _ _ importDeclarations _ <- getResult sourceFile result-    return $ concatMap toHintModules importDeclarations-  where-    extensions' :: [Extension]-    extensions' = map parseExtension extensions-    -    toHintModules :: ImportDecl -> [QualifiedModule]-    toHintModules importDecl =-      case importDecl of-        ImportDecl _ (ModuleName mn) False _ _ Nothing _ -> [(mn,Nothing)]-        ImportDecl _ (ModuleName mn) False _ _ (Just (ModuleName s)) _ ->-                              [(mn,Nothing),(mn,Just s)]-        ImportDecl _ (ModuleName mn) True _ _ Nothing _ -> [(mn,Just mn)]-        ImportDecl _ (ModuleName mn) True _ _ (Just (ModuleName s)) _ ->-                              [(mn,Just s)]----- the configuration format is designed to look like a Haskell module,--- so we just return the whole file.-parseSource :: FilePath -> IO Source-parseSource = C8.readFile
+ src/System/Console/Hawk/Context.hs view
@@ -0,0 +1,8 @@+-- | Re-export the most important functions from Context.*+module System.Console.Hawk.Context+  ( module System.Console.Hawk.Context.Base+  , module System.Console.Hawk.Context.Paths+  ) where++import System.Console.Hawk.Context.Base+import System.Console.Hawk.Context.Paths
+ src/System/Console/Hawk/Context/Base.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE PackageImports #-}+-- | Everything we need to know in order to evaluate a user expression,+--   except for the user expression itself.+module System.Console.Hawk.Context.Base+  ( Context(..)+  , getContext+  ) where++import "mtl" Control.Monad.Trans+import Data.Maybe+import System.Directory+import System.IO++import Control.Monad.Trans.Uncertain+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+++data Context = Context+  { contextPaths :: ContextPaths+  , moduleName :: String+  , extensions :: [M.ExtensionName]+  , modules :: [M.QualifiedModule]+  } 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.+getContext :: FilePath -> UncertainT IO Context+getContext contextDir = do+    createDefaultContextDir paths+    key <- lift $ getKey preludeFile+    +    -- skip `newContext` if the cached copy is still good.+    withPersistentStateT cacheFile [] $ cached cache key+                                      $ lift+                                      $ newContext paths+  where+    paths = mkContextPaths contextDir+    preludeFile = originalPreludePath paths+    cacheFile   = cachedPreludePath paths+    cache = singletonCache assocCache+    +    getKey f = do+        modifiedTime <- getModificationTime f+        fileSize <- withFile f ReadMode hFileSize+        return (versionString, f, modifiedTime, fileSize)++-- | Construct a Context by parsing the user prelude.+newContext :: ContextPaths -> UncertainT IO Context+newContext paths = do+    userPrelude <- readUserPrelude originalFile+    lift $ createDirectoryIfMissing True cacheDir+    compileUserPrelude originalFile canonicalFile userPrelude+    +    return $ Context+           { contextPaths = paths+           , moduleName = fromJust (M.moduleName userPrelude)+           , extensions = M.languageExtensions userPrelude+           , modules = M.importedModules userPrelude+           }+  where+    originalFile  = originalPreludePath paths+    cacheDir      = cacheDirPath paths+    canonicalFile = canonicalPreludePath paths
+ src/System/Console/Hawk/Context/Dir.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE PackageImports #-}+-- | About the directory in which the context is persited.+module System.Console.Hawk.Context.Dir+  ( createDefaultContextDir+  , findContextFromCurrDirOrDefault+  , checkContextDir+  ) where++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+++-- | Create a default context+createDefaultContextDir :: ContextPaths -> UncertainT IO ()+createDefaultContextDir paths = do+    _ <- checkContextDir contextDir+    liftIO $ do+      createDirectoryIfMissing True contextDir+      preludeExists <- doesFileExist preludeFile+      unless preludeExists $ writeFile preludeFile defaultPrelude+  where+    contextDir = contextDirPath paths+    preludeFile = originalPreludePath paths++-- | Find a project context+findContext :: FilePath -> IO (Maybe FilePath)+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)+    +    validDirOrNothing dir = do+      dirExists <- doesDirectoryExist dir+      if dirExists+       then do+         permissions <- getPermissions dir+         if writable permissions && searchable permissions+           then do+             prelude <- findFile [dir] "prelude.hs"+             case prelude of+               Nothing -> return Nothing+               Just f -> do+                 preludePermissions <- getPermissions f+                 if System.EasyFile.readable preludePermissions+                   then return $ Just dir+                   else return Nothing+           else return Nothing+       else return Nothing++-- | Find a project context starting from the current working directory+findContextFromCurrDir :: IO (Maybe FilePath)+findContextFromCurrDir = getCurrentDirectory >>= findContext++-- | Find a project context or return the default+findContextFromCurrDirOrDefault :: IO FilePath+findContextFromCurrDirOrDefault = do+    maybeProjectContextDir <- findContextFromCurrDir+    case maybeProjectContextDir of+      Nothing -> getDefaultContextDir+      Just projectContextDir -> return projectContextDir++-- | Check if a directory is a valid context and return true if the directory+-- doesn't exist and the parent has the right permissions+checkContextDir :: FilePath -> UncertainT IO Bool+checkContextDir dir = do+    fileExists <- liftIO $ doesFileExist dir+    when fileExists $ fail $ concat [+       "context directory '",dir,"' cannot be"+      ,"created because a file with the same"+      ,"name exists"]+    dirExists <- liftIO $ doesDirectoryExist dir+    if dirExists+      then do+        permissions <- liftIO $ getPermissions dir+        when (not $ writable permissions) $ fail $ concat [+           "cannot use '",dir,"' as context directory because it is not "+          ,"writable"]+        when (not $ searchable permissions) $ fail $ concat [+           "cannot use '",dir,"' as context directory because it is not "+          ,"searchable"]+        return False+      else do+        -- if the directory doesn't exist then its parent must be writable+        -- and searchable+        let parent = case takeDirectory dir of {"" -> ".";p -> p}+        permissions <- liftIO $ getPermissions parent+        when (not $ writable permissions) $ fail $ concat[+           "cannot create context directory '",dir,"' because the parent "+          ," directory is not writable (",show permissions,")"]+        when (not $ 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 "+                      ,"default one"]+        return True++getDefaultContextDir :: IO FilePath+getDefaultContextDir = do+    home <- getHomeDirectory+    return $ home </> ".hawk"
+ src/System/Console/Hawk/Context/Paths.hs view
@@ -0,0 +1,31 @@+-- | The names of the important files inside the context directory.+module System.Console.Hawk.Context.Paths+  ( ContextPaths  -- the type, not the constructor+  , contextDirPath, originalPreludePath+  , cacheDirPath, canonicalPreludePath, compiledPreludePath, cachedPreludePath+  , mkContextPaths+  ) where++import System.FilePath+++data ContextPaths = ContextPaths+  { contextDirPath :: FilePath+  , originalPreludePath :: FilePath+  , cacheDirPath :: FilePath+  , canonicalPreludePath :: FilePath+  , compiledPreludePath :: FilePath+  , cachedPreludePath :: FilePath+  } deriving (Eq, Read, Show)++mkContextPaths :: FilePath -> ContextPaths+mkContextPaths contextDir = ContextPaths+    { contextDirPath       = contextDir+    , originalPreludePath  = contextDir </> "prelude.hs"+    , cacheDirPath         = cacheDir+    , canonicalPreludePath = cacheDir </> "cached_prelude.hs"+    , compiledPreludePath  = cacheDir </> "cached_prelude.o"+    , cachedPreludePath    = cacheDir </> "cached_prelude.dat"+    }+  where+    cacheDir = contextDir </> "cache"
+ src/System/Console/Hawk/Help.hs view
@@ -0,0 +1,34 @@+-- | In which --help prints the usage.+module System.Console.Hawk.Help+  ( help+  , failHelp+  ) where+++import System.Environment+import System.Exit+import System.IO+import Text.Printf++import Control.Monad.Trans.OptionParser+import System.Console.Hawk.Args.Option+++hPrintUsage :: Handle -> IO ()+hPrintUsage h = do+    hawk <- getProgName+    hPutStr h $ printf "Usage: %s [option]... <expr> [<file>]\n" hawk+    hPutStr h $ optionsHelp options+++help :: IO ()+help = hPrintUsage stdout++-- | A version of `help` which prints the usage to stderr, after printing a+--   custom error message.+failHelp :: String -> IO ()+failHelp msg = do+    hPutStrLn stderr msg+    hPutStrLn stderr ""+    hPrintUsage stderr+    exitFailure
− src/System/Console/Hawk/IO.hs 
@@ -1,45 +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.--{-# LANGUAGE NoImplicitPrelude #-}--- | Used by Hawk's runtime to write to stdout.---   The API may change at any time.-module System.Console.Hawk.IO -  (getInput-  ,printOutput)-where--import Control.Exception-  (handle)-import Data.ByteString.Lazy.Char8-import GHC.IO.Exception-  (IOErrorType(ResourceVanished)-  ,IOException(ioe_type))-import System.IO-  (hFlush-  ,hPrint-  ,stderr-  ,stdout)-import Prelude hiding (getContents,putStrLn,readFile)--getInput :: Maybe FilePath-         -> IO ByteString-getInput = maybe getContents readFile--printOutput :: ByteString-            -> IO ()-printOutput s = handle ioHandler (putStrLn s >> hFlush stdout)-  where ioHandler e = case ioe_type e of-                        ResourceVanished -> return ()-                        _ -> hPrint stderr e
+ src/System/Console/Hawk/Interpreter.hs view
@@ -0,0 +1,59 @@+-- | A wrapper around the hint library, specialized for Hawk usage.+module System.Console.Hawk.Interpreter+  ( applyContext+  , runHawkInterpreter+  ) where++import Control.Monad+import Data.List+import Language.Haskell.Interpreter++import Control.Monad.Trans.Uncertain+import qualified System.Console.Hawk.Context as Context+import qualified System.Console.Hawk.Sandbox as Sandbox+import System.Console.Hawk.UserPrelude.Defaults+import System.Console.Hawk.Lock++-- $setup+-- >>> import System.Console.Hawk.Args.Spec+++-- | Tell hint to load the user prelude, the modules it imports, and the+--   language extensions it specifies.+applyContext :: FilePath -- ^ context directory+             -> InterpreterT IO ()+applyContext contextDir = do+    context <- lift $ runUncertainIO $ Context.getContext contextDir+    +    let extensions = map read $ Context.extensions context+    let preludeFile = Context.canonicalPreludePath (Context.contextPaths context)+    let preludeModule = Context.moduleName context+    let userModules = Context.modules context+    +    set [languageExtensions := extensions]+    +    -- load the prelude file+    loadModules [preludeFile]+    +    -- load the prelude module plus representable etc.+    setImportsQ $ (preludeModule,Nothing):defaultModules+                                       ++ userModules+++errorString :: InterpreterError -> String+errorString (WontCompile es) = intercalate "\n" (header : map indent es)+  where+    header = "Won't compile:"+    indent (GhcError e) = ('\t':e)+errorString e = show e++wrapErrorsM :: Monad m => m (Either InterpreterError a) -> UncertainT m a+wrapErrorsM = lift >=> wrapErrors++wrapErrors :: Monad m => Either InterpreterError a -> UncertainT m a+wrapErrors (Left e) = fail $ errorString e+wrapErrors (Right x) = return x+++runHawkInterpreter :: InterpreterT IO a -> UncertainT IO a+runHawkInterpreter = wrapErrorsM . withLock . Sandbox.runHawkInterpreter
src/System/Console/Hawk/Lock.hs view
@@ -12,6 +12,9 @@ --   See the License for the specific language governing permissions and --   limitations under the License. +-- | Two concurrent Hawk processes (when the output of a Hawk command is piped+--   into another, for example) are in a race condition to compile and cache+--   the user prelude. The global application lock prevents this. module System.Console.Hawk.Lock     ( withLock     , withTestLock@@ -71,10 +74,10 @@  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+    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 ()
− src/System/Console/Hawk/Options.hs 
@@ -1,113 +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.--module System.Console.Hawk.Options where--import Data.ByteString (ByteString)--import qualified Data.ByteString.Char8 as C8-import qualified Data.List as L-import qualified System.FilePath as FP--import System.Console.GetOpt---data Modes = EvalMode | ApplyMode | MapMode-    deriving (Eq,Enum,Read,Show)--data Options = Options { optMode :: Modes -                       , optLinesDelim :: ByteString-                       , optWordsDelim :: ByteString-                       , optOutLinesDelim :: Maybe ByteString-                       , optOutWordsDelim :: Maybe ByteString-                       , optRecompile :: Bool-                       , optVersion :: Bool-                       , optHelp :: Bool-                       , optIgnoreErrors :: Bool-                       , optModuleFile :: Maybe FP.FilePath}-    deriving Show--defaultOptions :: Options-defaultOptions = Options { optMode = EvalMode-                         , optLinesDelim = C8.singleton '\n'-                         , optWordsDelim = C8.singleton ' '-                         , optOutLinesDelim = Nothing -                         , optOutWordsDelim =  Nothing-                         , optRecompile = False-                         , optVersion = False-                         , optHelp = False-                         , optIgnoreErrors = False-                         , optModuleFile = Nothing }--delimiter :: ByteString -> ByteString-delimiter = C8.concat . (\ls -> L.head ls:L.map subFirst (L.tail ls))-                     . C8.splitWith (== '\\')-    where subFirst s = case C8.head s of-                        'n' -> C8.cons '\n' $ C8.tail s-                        't' -> C8.cons '\t' $ C8.tail s-                        _ -> s--options :: [OptDescr (Options -> Options)]-options = - -- delimiters- [ Option ['D'] ["lines-delimiter"] (OptArg delimiterAction "<delim>") delimiterHelp- , Option ['d'] ["words-delimiter"] (OptArg wordsDelimAction "<delim>") wordsDelimHelp- , Option ['O'] ["output-lines-delim"] (OptArg outDelimAction "<delim>") outDelimHelp- , Option ['o'] ["output-words-delim"] (OptArg outWordsDelimAction "<delim>") outWordsDelimHelp-- -- modes- , Option ['a'] ["apply"] (NoArg $ setMode ApplyMode) applyHelp- , Option ['m'] ["map"] (NoArg $ setMode MapMode) mapHelp-- -- other options- , Option ['r'] ["recompile"] (NoArg setRecompile) recompileHelp- , Option ['v'] ["version"] (NoArg $ \o -> o{ optVersion = True }) versionHelp- , Option ['h'] ["help"] (NoArg $ \o -> o{ optHelp = True }) helpHelp--- , Option ['k'] ["keep-going"] (NoArg keepGoingAction) keepGoingHelp - ]-    where outDelimAction d o = o{ optOutLinesDelim = fmap (delimiter . C8.pack) d }-          outDelimHelp = "output lines delimiter, default " ++-                         "is equal to the input lines delimiter (-D)"-          outWordsDelimAction d o = o{ optOutWordsDelim = fmap (delimiter . C8.pack) d }-          outWordsDelimHelp = "output words delimiter, default " ++-                              "is equal to the input words delimiter (-d)"-          delimiterAction ms o = let d = case ms of-                                            Nothing -> C8.pack ""-                                            Just "" -> C8.pack ""-                                            Just s -> delimiter $ C8.pack s-                                 in o{ optLinesDelim = d } -          delimiterHelp = "lines delimiter, default '\\n'"-          wordsDelimAction ms o = let d = case ms of-                                            Nothing -> C8.pack ""-                                            Just "" -> C8.pack ""-                                            Just s -> delimiter $ C8.pack s-                                  in o{ optWordsDelim = d}-          wordsDelimHelp = "words delimiter, default ' '"-          setRecompile o = o{ optRecompile = True}-          recompileHelp = "recompile ~/.hawk/prelude.hs\neven if it did not change"-          -          applyHelp = "apply <expr> to the stream"-          mapHelp = "map <expr> to the stream"--          versionHelp = "print the version number and exit"-          helpHelp = "print this help message and exit"-          --keepGoingAction o = o{ optIgnoreErrors = True}-          --keepGoingHelp = "keep going when one line fails"-          setMode m o = o{ optMode = m }--compileOpts :: [String] -> Either [String] (Options,[String])-compileOpts argv =-   case getOpt Permute options argv of-      (os,nos,[]) -> Right (L.foldl (.) id (L.reverse os) defaultOptions, nos)-      (_,_,errs) -> Left errs
− src/System/Console/Hawk/Representable.hs 
@@ -1,365 +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.---- | Used by Hawk's runtime to format the output of a Hawk expression.---    You can use this from your user prelude if you want Hawk to print---    your custom datatypes in a console-friendly format.-module System.Console.Hawk.Representable (--    ListAsRow (listRepr')-  , ListAsRows (listRepr)-  , Row  (repr')-  , Rows (repr)--) where--import Prelude-import Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as C8 hiding (hPutStrLn)-import qualified Data.List as L-import Data.Set (Set)-import qualified Data.Set as S-import Data.Map (Map)-import qualified Data.Map as M----- | A type that instantiate ListAsRow is a type that has a representation--- when is embedded inside a list------ For example:------ >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr Data.ByteString.Lazy.Char8.empty "test"--- test-class (Show a) => ListAsRow a where-    listRepr' :: ByteString -> [a] -> ByteString-    listRepr' d = C8.intercalate d . L.map (C8.pack . show)--instance ListAsRow Bool-instance ListAsRow Float-instance ListAsRow Double-instance ListAsRow Int-instance ListAsRow Integer-instance ListAsRow ()--instance (ListAsRow a) => ListAsRow [a] where-    -- todo check the first delimiter if it should be d-    listRepr' d = C8.intercalate d . L.map (listRepr' d)--instance (Row a) => ListAsRow (Maybe a) where-    listRepr' d = C8.intercalate d . L.map (repr' d)--instance (ListAsRow a) => ListAsRow (Set a) where-    listRepr' d = listRepr' d . L.map (listRepr' d . S.toList)--instance ListAsRow Char where-    listRepr' _ = C8.pack--instance ListAsRow ByteString where-    listRepr' d = C8.intercalate d--instance (Row a, Row b) => ListAsRow (Map a b) where-    listRepr' d = listRepr' d . L.map (listRepr' d . M.toList)--instance (Row a,Row b) => ListAsRow (a,b) where-    listRepr' d = C8.intercalate d . L.map (\(x,y) -> C8.unwords-                  [repr' d x,repr' d y])--instance (Row a,Row b,Row c) => ListAsRow (a,b,c) where-    listRepr' d = C8.intercalate d . L.map (\(x,y,z) -> C8.unwords-                  [repr' d x,repr' d y,repr' d z])--instance (Row a,Row b,Row c,Row d) => ListAsRow (a,b,c,d) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e])--instance (Row a,Row b,Row c,Row d,Row e) => ListAsRow (a,b,c,d,e) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f])--instance (Row a,Row b,Row c,Row d,Row e,Row f) => ListAsRow (a,b,c,d,e,f) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f-                  ,repr' d g])--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g)-  => ListAsRow (a,b,c,d,e,f,g) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f-                  ,repr' d g,repr' d h])--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)-  => ListAsRow (a,b,c,d,e,f,g,h) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f-                  ,repr' d g,repr' d h,repr' d i])--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)-  => ListAsRow (a,b,c,d,e,f,g,h,i) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i,l) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f-                  ,repr' d g,repr' d h,repr' d i,repr' d l])--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)-  => ListAsRow (a,b,c,d,e,f,g,h,i,l) where-    listRepr' d = C8.intercalate d . L.map (\(a,b,c,e,f,g,h,i,l,m) -> C8.unwords-                  [repr' d a,repr' d b,repr' d c,repr' d e,repr' d f-                  ,repr' d g,repr' d h,repr' d i,repr' d l,repr' d m])------ | A Row is something that can be expressed as a line. --- The output of repr' should be formatted such that--- it can be read and processed from the command line.------ For example:------ >>> IO.putStrLn $ show [1,2,3,4]--- [1,2,3,4]------ >>> Data.ByteString.Lazy.Char8.putStrLn $ repr' (Data.ByteString.Lazy.Char8.pack " ") [1,2,3,4]--- 1 2 3 4-class (Show a) => Row a where-    repr' :: ByteString -- ^ columns delimiter-          -> a           -- ^ value to represent-          -> ByteString-    repr' _ = C8.pack . show--instance Row Bool-instance Row Float-instance Row Double-instance Row Int-instance Row Integer-instance Row ()--instance Row Char where-    repr' _ = C8.singleton--instance (ListAsRow a) => Row [a] where-    repr' = listRepr'--instance (ListAsRow a) => Row (Set a) where-    repr' d = listRepr' d . S.toList--instance (Row a,Row b) => Row (Map a b) where-    repr' d = listRepr' d . M.toList--instance Row ByteString where-    repr' _ = id--instance (Row a) => Row (Maybe a) where-    repr' _ Nothing = C8.empty-    repr' d (Just x) = repr' d x -- check if d is correct here--instance (Row a,Row b) => Row (a,b) where-    repr' d (a,b) = repr' d a `C8.append` (d `C8.append` repr' d b)-    --repr' d (a,b) = repr' d [repr' d a,repr' d b] --instance (Row a,Row b,Row c) => Row (a,b,c) where-    repr' d (a,b,c) =  repr' d a `C8.append` (d `C8.append`-                      (repr' d b `C8.append` (d `C8.append` repr' d c)))--instance (Row a,Row b,Row c,Row d) => Row (a,b,c,d) where-    repr' d (a,b,c,e) = repr' d a `C8.append` (d `C8.append`-                        (repr' d b `C8.append` (d `C8.append`-                        (repr' d c `C8.append` (d `C8.append` repr' d e)))))--instance (Row a,Row b,Row c,Row d,Row e) => Row (a,b,c,d,e) where-    repr' d (a,b,c,e,f) = repr' d a `C8.append` (d `C8.append`-                        (repr' d b `C8.append` (d `C8.append`-                        (repr' d c `C8.append` (d `C8.append`-                        (repr' d e `C8.append` (d `C8.append` repr' d f)))))))--instance (Row a,Row b,Row c,Row d,Row e,Row f) => Row (a,b,c,d,e,f) where-    repr' d (a,b,c,e,f,g) = repr' d a `C8.append` (d `C8.append`-                            (repr' d b `C8.append` (d `C8.append`-                            (repr' d c `C8.append` (d `C8.append`-                            (repr' d e `C8.append` (d `C8.append`-                            (repr' d f `C8.append` (d `C8.append` repr' d g)))))))))--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g) => Row (a,b,c,d,e,f,g) where-    repr' d (a,b,c,e,f,g,h) = repr' d a `C8.append` (d `C8.append`-                              (repr' d b `C8.append` (d `C8.append`-                              (repr' d c `C8.append` (d `C8.append`-                              (repr' d e `C8.append` (d `C8.append`-                              (repr' d f `C8.append` (d `C8.append`-                              (repr' d g `C8.append` (d `C8.append` repr' d h)))))))))))--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)-        => Row (a,b,c,d,e,f,g,h) where-    repr' d (a,b,c,e,f,g,h,i) =-        repr' d a `C8.append` (d `C8.append`-       (repr' d b `C8.append` (d `C8.append`-       (repr' d c `C8.append` (d `C8.append`-       (repr' d e `C8.append` (d `C8.append`-       (repr' d f `C8.append` (d `C8.append`-       (repr' d g `C8.append` (d `C8.append`-       (repr' d h `C8.append` (d `C8.append` repr' d i)))))))))))))--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)-        => Row (a,b,c,d,e,f,g,h,i) where-    repr' d (a,b,c,e,f,g,h,i,l) =-        repr' d a `C8.append` (d `C8.append`-       (repr' d b `C8.append` (d `C8.append`-       (repr' d c `C8.append` (d `C8.append`-       (repr' d e `C8.append` (d `C8.append`-       (repr' d f `C8.append` (d `C8.append`-       (repr' d g `C8.append` (d `C8.append`-       (repr' d h `C8.append` (d `C8.append`-       (repr' d i `C8.append` (d `C8.append` repr' d l)))))))))))))))--instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)-        => Row (a,b,c,d,e,f,g,h,i,l) where-    repr' d (a,b,c,e,f,g,h,i,l,m) =-        repr' d a `C8.append` (d `C8.append`-       (repr' d b `C8.append` (d `C8.append`-       (repr' d c `C8.append` (d `C8.append`-       (repr' d e `C8.append` (d `C8.append`-       (repr' d f `C8.append` (d `C8.append`-       (repr' d g `C8.append` (d `C8.append`-       (repr' d h `C8.append` (d `C8.append`-       (repr' d i `C8.append` (d `C8.append`-       (repr' d l `C8.append` (d `C8.append` repr' d m)))))))))))))))))----- | A type that instantiate ListAsRows is a type that has a representation--- when is embedded inside a list------ Note: we use this class for representing a list of chars as String--- instead of the standard list representation. Without this repr "test" would--- yield ['t','e','s','r'] instead of "test".------ For example:------ >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr Data.ByteString.Lazy.Char8.empty "test"--- test-class (Row a) => ListAsRows a where-    listRepr :: ByteString -- ^ column delimiter-               -> [a]         -- ^ list of values to represent-               -> [ByteString]-    listRepr d = L.map (repr' d)--instance ListAsRows ByteString-instance ListAsRows Bool-instance ListAsRows Double-instance ListAsRows Float-instance ListAsRows Int-instance ListAsRows Integer-instance (Row a) => ListAsRows (Maybe a)-instance ListAsRows ()-instance (ListAsRow a,ListAsRows a) => ListAsRows [a]-instance (Row a,Row b) => ListAsRows (a,b)-instance (Row a,Row b,Row c) => ListAsRows (a,b,c)-instance (Row a,Row b,Row c,Row d) => ListAsRows (a,b,c,d)-instance (Row a,Row b,Row c,Row d,Row e) => ListAsRows (a,b,c,d,e)-instance (Row a,Row b,Row c,Row d,Row e,Row f) => ListAsRows (a,b,c,d,e,f)-instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g) => ListAsRows (a,b,c,d,e,f,g)-instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h)-  => ListAsRows (a,b,c,d,e,f,g,h)-instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i)-  => ListAsRows (a,b,c,d,e,f,g,h,i)-instance (Row a,Row b,Row c,Row d,Row e,Row f,Row g,Row h,Row i,Row l)-  => ListAsRows (a,b,c,d,e,f,g,h,i,l)--instance ListAsRows Char where-    listRepr _ = (:[]) . C8.pack--instance (ListAsRow a,ListAsRows a) => ListAsRows (Set a) where-    listRepr d = listRepr d . L.map S.toList--instance (Row a,Row b) => ListAsRows (Map a b) where-    listRepr d = listRepr d . L.map M.toList--instance (ListAsRows a) => Rows [a] where-    repr = listRepr----- | A type that instantiate Rows is a type that can be represented as--- a list of rows, where typically a row is a line.------ For example:------ >>> mapM_ Data.ByteString.Lazy.Char8.putStrLn $ repr (Data.ByteString.Lazy.Char8.singleton '\n') [1,2,3,4]--- 1--- 2--- 3--- 4-class (Show a) => Rows a where-    -- | Return a representation of the given value as list of strings.-    repr :: ByteString -- ^ rows delimiter-         -> a           -- ^ value to represent-         -> [C8.ByteString]-    repr _ = (:[]) . C8.pack . show---instance Rows Bool-instance Rows Double-instance Rows Float-instance Rows Int-instance Rows Integer--instance Rows () where-    repr _ = const [C8.empty]--instance Rows Char where-    repr _ = (:[]) . C8.singleton--instance Rows ByteString where-    repr _ = (:[])--instance (Rows a) => Rows (Maybe a) where-    repr d = maybe [C8.empty] (repr d)--instance (Row a, Row b) => Rows (Map a b) where-    repr d = listRepr d . M.toList--instance (ListAsRows a) => Rows (Set a) where-    repr d = listRepr d . S.toList--instance (Row a, Row b) => Rows (a,b) where-    repr d (x,y) = [repr' d x,repr' d y]--instance (Row a, Row b, Row c) => Rows (a,b,c) where-    repr d (a,b,c) = [repr' d a, repr' d b, repr' d c]--instance (Row a, Row b, Row c, Row d) => Rows (a,b,c,d) where-    repr d (a,b,c,e) = [repr' d a, repr' d b, repr' d c, repr' d e]--instance (Row a, Row b, Row c, Row d, Row e) => Rows (a,b,c,d,e) where-    repr d (a,b,c,e,f) = [repr' d a, repr' d b, repr' d c, repr' d e, repr' d f]--instance (Row a, Row b, Row c, Row d, Row e, Row f) => Rows (a,b,c,d,e,f) where-    repr d (a,b,c,e,f,g) = [repr' d a, repr' d b, repr' d c,repr' d e-                           ,repr' d f, repr' d g]--instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g)-       => Rows (a,b,c,d,e,f,g) where-    repr d (a,b,c,e,f,g,h) = [repr' d a, repr' d b, repr' d c,repr' d e-                             ,repr' d f, repr' d g, repr' d h]--instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h)-       => Rows (a,b,c,d,e,f,g,h) where-    repr d (a,b,c,e,f,g,h,i) = [repr' d a, repr' d b, repr' d c, repr' d e-                               ,repr' d f, repr' d g, repr' d h, repr' d i]--instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h, Row i)-       => Rows (a,b,c,d,e,f,g,h,i) where-    repr d (a,b,c,e,f,g,h,i,l) = [repr' d a, repr' d b, repr' d c, repr' d e-                                 ,repr' d f, repr' d g, repr' d h, repr' d i-                                 , repr' d l]--instance (Row a, Row b, Row c, Row d, Row e, Row f, Row g, Row h, Row i, Row l)-       => Rows (a,b,c,d,e,f,g,h,i,l) where-    repr d (a,b,c,e,f,g,h,i,l,m) = [repr' d a, repr' d b, repr' d c, repr' d e-                                   ,repr' d f, repr' d g, repr' d h, repr' d i-                                   ,repr' d l, repr' d m]
− src/System/Console/Hawk/Runtime.hs 
@@ -1,165 +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.--{-# LANGUAGE ExistentialQuantification-           , ExtendedDefaultRules-           , OverloadedStrings-           , ScopedTypeVariables #-}---- | This is Hawk's runtime, it needs to be installed in order to evaluate Hawk---   expressions. The API may change at any time.-module System.Console.Hawk.Runtime (-    c8pack-  , sc8pack-  , listMap-  , listMapWords-  , printRows-  , printRow-  , parseRows-  , parseWords-  , showRows-  , runExpr---  , runExprs-) where--import Prelude-import Control.Exception (SomeException,handle)-import qualified Data.ByteString.Char8 as SC8-import Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as C8 hiding (hPutStrLn)-import qualified Data.List as L-import qualified Data.ByteString.Lazy.Search as BS-import qualified System.IO as IO--import System.Console.Hawk.Representable-import qualified System.Console.Hawk.IO as HawkIO--handleErrors :: IO () -> IO ()-handleErrors = handle (\(e :: SomeException) -> IO.hPrint IO.stderr e)--dropLastIfEmpty :: [C8.ByteString] -> [C8.ByteString]-dropLastIfEmpty [] = []-dropLastIfEmpty (x:[]) = if C8.null x then [] else [x]-dropLastIfEmpty (x:xs) = x:dropLastIfEmpty xs--listMap :: (a -> b) -> [a] -> [b]-listMap = L.map--listMapWords :: ([a] -> b) -> [[a]] -> [b]-listMapWords = L.map--c8pack :: String-       -> C8.ByteString-c8pack = C8.pack--sc8pack :: String-        -> SC8.ByteString-sc8pack = SC8.pack--dropTrailingNewline :: C8.ByteString -> C8.ByteString-dropTrailingNewline "" = ""-dropTrailingNewline s = if last_char == '\r' then s' else s-    where last_char = C8.last s-          n = C8.length s-          s' = C8.take (n - 1) s---- if delim is "\n", Windows-style "\r\n" delimiters are also accepted.-parseRows :: SC8.ByteString -> C8.ByteString -> [C8.ByteString]-parseRows delim str = dropLastIfEmpty-                    $ maybeDropTrailingNewline-                    $ BS.split delim str-    where maybeDropTrailingNewline = if delim == "\n"-                                       then map dropTrailingNewline-                                       else id------ special case for space-parseWords :: SC8.ByteString -> SC8.ByteString -> C8.ByteString -> [[C8.ByteString]]-parseWords rowsDelim columnsDelim str = let rows = parseRows rowsDelim str-                                        in L.map f rows-    where f = if columnsDelim == SC8.singleton ' '-                then L.filter  (not . C8.null) . BS.split columnsDelim-                else BS.split columnsDelim-         ---parseWords :: SC8.ByteString -> [C8.ByteString] -> [[C8.ByteString]]---parseWords delim strs = L.map f strs---    where f = if delim == SC8.singleton ' '---                then L.filter  (not . C8.null) . BS.split delim---                else BS.split delim----runOnInput :: Maybe FilePath -- ^ the input file or stdout when Nothing---            -> (C8.ByteString -> IO ()) -- ^ the action to run on the input---            -> IO ()---runOnInput fp f = do---    input <- maybe C8.getContents C8.readFile fp---    f input---    IO.hFlush IO.stdout-    -- TODO: we need also hFlush stderr?--runExpr :: Maybe FilePath -- ^ if the input is a file-        -> (Maybe FilePath -> IO C8.ByteString) -- ^ input reader-        -> (C8.ByteString -> C8.ByteString)-        -> (C8.ByteString -> IO ())-        -> IO ()-runExpr m i f o = i m >>= o . f---runExpr = runOnInput------runExprs :: Maybe FilePath -> (C8.ByteString -> [IO ()]) -> IO ()---runExprs fp f = runOnInput fp (sequence_ . f)----showRows :: forall a . (Rows a)-         => C8.ByteString -- ^ rows delimiter-         -> C8.ByteString -- ^ columns delimiter-         -> a -- ^ value to print-         -> C8.ByteString-showRows rd cd = C8.intercalate rd . repr cd--printRows :: forall a . (Rows a) -          => Bool -- ^ if printRows will continue after errors-          -> C8.ByteString -- ^ rows delimiter-          -> C8.ByteString -- ^ columns delimiter-          -> a -- ^ the value to print as rows-          -> IO ()-printRows _ rd cd = HawkIO.printOutput . showRows rd cd---printRows _ rd cd v = handle handler printRows_ ---  where handler e = case ioe_type e of---                      ResourceVanished -> return ()---                      _ -> IO.hPrint IO.stderr e---        printRows_ = C8.putStrLn (showRows rd cd v) >> IO.hFlush IO.stdout---printRows b rowDelimiter columnDelimiter = printFirstRow_ . repr columnDelimiter---    where printRows_ [] = return ()---          printRows_ (x:xs) = do---            putStrAndDelim x---            handle ioExceptionsHandler (continue xs)---          printFirstRow_ [] = return ()---          printFirstRow_ (x:xs) = do---            putStrOnly x---            handle ioExceptionsHandler (continue xs)---          putStrAndDelim = if b then handleErrors . putDelimAndStr_---                                else putDelimAndStr_---          putStrOnly = if b then handleErrors . C8.putStr else C8.putStr---          putDelimAndStr_ :: C8.ByteString -> IO ()---          putDelimAndStr_ c = C8.putStr rowDelimiter >> C8.putStr c---          continue xs = IO.hFlush IO.stdout >> printRows_ xs---          ioExceptionsHandler e = case ioe_type e of---                                    ResourceVanished -> return ()---                                    _ -> IO.hPrint IO.stderr e--printRow :: forall a . (Row a)-         => Bool -- ^ if printRow should continue after errors-         -> ByteString -- ^ the column delimiter-         -> a -- ^ the value to print-         -> IO ()-printRow b d = if b then handleErrors . f else f-  where f = C8.putStrLn . repr' d-
src/System/Console/Hawk/Sandbox.hs view
@@ -25,21 +25,22 @@     ) where  import Control.Applicative-import Control.Monad import Data.List import Language.Haskell.Interpreter (InterpreterT, InterpreterError) import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)-import System.Directory (getDirectoryContents, getHomeDirectory, doesFileExist)-import System.Environment (getExecutablePath)-import System.FilePath (pathSeparator, splitFileName)+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"@@ -59,46 +60,12 @@     n = length s     m = length suffix --- a version of doesFileExist which returns the file path if it exists.-doesFileExist' :: FilePath -> IO (Maybe FilePath)-doesFileExist' f = do-    r <- doesFileExist f-    if r-      then return (Just f)-      else return Nothing -firstWhichExists :: [FilePath] -> IO (Maybe FilePath)-firstWhichExists fs = do-    fs' <- mapM doesFileExist' fs-    return $ msum fs'-- -- convert slashes to backslashes if needed path :: String -> String path = map replaceSeparator where-  replaceSeparator '/' = pathSeparator-  replaceSeparator x = x---- a version of getExecutablePath which returns the path to the installed hawk--- executable even the current executable is actually hawk's test suite.-getHawkPath :: IO FilePath-getHawkPath = do-    executablePath <- getExecutablePath-    case path "/dist/build/reference/reference" `isSuffixOf'` executablePath of-      Nothing -> return executablePath-      Just basePath -> do-        -- We are running the test suite. Is hawk installed?-        -        home <- getHomeDirectory-        let userPath = home ++ "/.cabal/bin/hawk"-        -        let folders = map folder sandboxes-        let sandboxPaths = map (printf "%s/%s/bin/hawk" basePath) folders-        -        firstMatch <- firstWhichExists (userPath:sandboxPaths)-        case firstMatch of-          Nothing -> fail "please run 'cabal install' before 'cabal test'."-          Just hawkPath -> return hawkPath+    replaceSeparator '/' = pathSeparator+    replaceSeparator x = x   -- if hawk has been compiled by a sandboxing tool,@@ -107,9 +74,9 @@ -- return something like (Just "/.../cabal-dev") getSandboxDir :: Sandbox -> IO (Maybe String) getSandboxDir sandbox = do-    (dir, _) <- splitFileName <$> getHawkPath+    dir <- Paths_haskell_awk.getBinDir     let sandboxFolder = folder sandbox-    let suffix = path (sandboxFolder ++ "/bin/")+    let suffix = path (sandboxFolder ++ "/bin")     let basePath = suffix `isSuffixOf'` dir     let sandboxPath = fmap (++ sandboxFolder) basePath     return sandboxPath@@ -123,8 +90,12 @@ getPackageFile :: Sandbox -> String -> IO String getPackageFile sandbox dir = do     files <- getDirectoryContents dir-    let [file] = filter (isPackageFile sandbox) files-    return $ printf (path "%s/%s") dir file+    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@@ -139,8 +110,14 @@ extraGhcArgs :: IO [String] extraGhcArgs = concat <$> mapM sandboxSpecificGhcArgs sandboxes --- a version of runInterpreter which can load libraries--- installed along hawk's sandbox folder, if applicable.+-- | 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
+ src/System/Console/Hawk/UserPrelude.hs view
@@ -0,0 +1,63 @@+-- | 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.UserPrelude.Extend+++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
+ src/System/Console/Hawk/UserPrelude/Defaults.hs view
@@ -0,0 +1,36 @@+-- | The user prelude you get if the user doesn't have a prelude.+module System.Console.Hawk.UserPrelude.Defaults where++import Control.Arrow ((&&&))++import Data.HaskellModule+++-- | Imported at runtime even if missing from the user prelude.+--   Since they are fully qualified, they should not conflict with any+--   user-imported module.+defaultModules :: [QualifiedModule]+defaultModules =+    -- types used to describe the expression interpreted by hint+    -- must be imported unqualified+    ("System.Console.Hawk.Runtime.Base", Nothing)+    : map fullyQualified+      [ "Prelude"+      , "System.Console.Hawk.Representable"+      , "System.Console.Hawk.Runtime"+      , "System.IO.Unsafe"+      , "Data.ByteString.Lazy.Char8"+      ]+  where+    fullyQualified = (id &&& Just)++defaultPrelude :: String+defaultPrelude = unlines+    [ "{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}"+    , "import Prelude"+    , "import qualified Data.ByteString.Lazy.Char8 as B"+    , "import qualified Data.List as L"+    ]++defaultModuleName :: String+defaultModuleName = "System.Console.Hawk.CachedPrelude"
+ src/System/Console/Hawk/UserPrelude/Extend.hs view
@@ -0,0 +1,69 @@+-- | In which the implicit defaults are explicitly added.+module System.Console.Hawk.UserPrelude.Extend+  ( extendModuleName+  , extendImports+  ) where++import Control.Applicative+import Data.Maybe++import Data.HaskellModule+import System.Console.Hawk.UserPrelude.Defaults+++-- | 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 = 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 `elem` moduleNames m+    noImplicitPrelude m = noPrelude `elem` languageExtensions m
+ src/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/System/Directory/Extra.hs view
@@ -0,0 +1,13 @@+-- | For functions which should have been System.Directory+module System.Directory.Extra where++import System.Directory+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)
+ tests/Data/HaskellModule/Parse/Test.hs view
@@ -0,0 +1,69 @@+module Data.HaskellModule.Parse.Test where++import qualified Data.ByteString.Char8 as B++import Control.Monad.Trans.Uncertain+import Data.HaskellModule.Base+import Data.HaskellModule.Parse++-- | 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)
tests/RunTests.hs view
@@ -12,18 +12,56 @@ --   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.Config.Test as ConfigTest import qualified System.Console.Hawk.Test as HawkTest+import System.FilePath+import System.Environment+import Text.Printf  import Test.DocTest (doctest) import Test.Hspec (hspec) ++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 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 ["-isrc", "tests/System/Console/Hawk/Lock/Test.hs"]+    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"     hspec $ do         ReprTest.reprSpec'         ReprTest.reprSpec-        ConfigTest.spec     HawkTest.run
+ tests/System/Console/Hawk/Lock/Test.hs view
@@ -0,0 +1,109 @@+--   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.++module System.Console.Hawk.Lock.Test where++import Control.Concurrent+import System.Console.Hawk.Lock++-- $setup+-- >>> :{+--   let par body1 body2 = do+--         done1 <- newEmptyMVar+--         done2 <- newEmptyMVar+--         forkFinally body1 (\_ -> putMVar done1 ())+--         forkFinally body2 (\_ -> putMVar done2 ())+--         takeMVar done1+--         takeMVar done2+-- :}+++printDelayed :: [Int] -> IO ()+printDelayed [] = return ()+printDelayed (x:xs) = do threadDelay 10000+                         print x+                         printDelayed xs+++-- | Use `withLock` around critical sections which cannot run in parallel with+--   other instances of hawk.+-- +-- In the ideal case, nobody else is trying to use `withLock`.+-- +-- >>> withLock print3+-- 1+-- 2+-- 3+-- +-- If two instances of hawk are trying to use same resource (here stdout) at+-- the same time, problems can occur.+-- (test disabled because the unlocked behaviour isn't deterministic)+-- +-- -- >>> print3 `par` print3+-- -- 1+-- -- 1+-- -- 2+-- -- 2+-- -- 3+-- -- 3+-- +-- By using `withLock`, we serialize the execution of the two critical sections.+-- +-- >>> withLock print3 `par` withLock print3+-- 1+-- 2+-- 3+-- 1+-- 2+-- 3+-- +-- 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+-- 1+-- 2+-- 3+-- +-- >>> withTestLock print3 `par` withTestLock 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+-- ** LOCKED **+-- 2+-- 3+-- ** UNLOCKED (connect) **+-- 1+-- 2+-- 3+print3 :: IO ()+print3 = printDelayed [1..3]
+ tests/System/Console/Hawk/PreludeTests.hs view
@@ -0,0 +1,202 @@+-- | Tests which require particular prelude files.+module System.Console.Hawk.PreludeTests () where++import System.FilePath++import System.Console.Hawk++-- | 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"
+ tests/System/Console/Hawk/Test.hs view
@@ -0,0 +1,87 @@+--   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.++{-# LANGUAGE OverloadedStrings #-}+module System.Console.Hawk.Test where++import System.Directory+import System.IO+import Test.Hspec+import Test.HUnit+import GHC.IO.Handle++import System.Console.Hawk+++run :: IO ()+run = withContextHSpec $ \itEval itApply itMap ->+        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"+          itEval "[[1]]" `into` "1\n"+          itEval "[[1,2]]" `into` "1 2\n"+          itEval "[[1,2],[3,4]]" `into` "1 2\n3 4\n"+          +          itApply "id" `onInput` "foo" `into` "foo\n"+          itApply "L.transpose" `onInput` "1 2\n3 4" `into` "1 3\n2 4\n"+          itApply "L.map (!! 1)" `onInput` "1 2\n3 4" `into` "2\n4\n"++          itMap "(!! 1)" `onInput` "1 2\n3 4" `into` "2\n4\n"+  where onInput f x = f x+        into f x = f x++withContextHSpec :: ((String -> String -> Spec)+                    -> (String -> String -> String -> Spec)+                    -> (String -> String -> String -> Spec)+                    -> Spec)+                 -> IO ()+withContextHSpec body = do+  let it' flags expr input expected =+        let descr = "evals " ++ show expr +++                    " on input " ++ show input +++                    " equals to " ++ show expected+        in it descr $ do+             tmpd <- getTemporaryDirectory+             (tmpf, tmph) <- openTempFile tmpd "hawk_input"+             hPutStr tmph input+             hClose tmph+             out <- catchOutput $ do+               processArgs $ concat [ ["-c", "tests/preludes/default"]+                                    , flags+                                    , [expr, tmpf]+                                    ]+             removeFile tmpf+             assertEqual descr expected out+  let [itApply,itMap] = map it' [["-a"],["-m"]]+  let itEval expr expected = it' [] expr "" expected+  hspec $ body itEval itApply itMap+++-- from http://stackoverflow.com/a/9664017/3286185+catchOutput :: IO () -> IO String+catchOutput f = do+    tmpd <- getTemporaryDirectory+    (tmpf, tmph) <- openTempFile tmpd "haskell_stdout"+    stdout_dup <- hDuplicate stdout+    hDuplicateTo tmph stdout+    hClose tmph+    f+    hDuplicateTo stdout_dup stdout+    str <- readFile tmpf+    length str `seq` removeFile tmpf+    return str
+ tests/System/Console/Hawk/TestUtils.hs view
@@ -0,0 +1,86 @@+--   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.++module System.Console.Hawk.TestUtils where++import Control.Applicative+  ( (<$>) )+import Control.Exception+  ( bracket_ )+import Data.List+  ( isSuffixOf+  , isPrefixOf )+import System.Directory+  ( createDirectory +  , getDirectoryContents+  , getTemporaryDirectory+  , removeFile+  , removeDirectoryRecursive)+import System.FilePath+  ( (</>)+  , dropExtension+  , takeExtension)+++nextFilePath :: FilePath -- ^ directory+             -> String -- ^ prefix+             -> String -- ^ suffix+             -> IO FilePath -- ^ next file path available+nextFilePath dir pre post = do+    contents <- getDirectoryContents dir+    let maxNum = foldl maybeTakeNum 0 contents+    return $ pre ++ show (maxNum+1) ++ post+    where maybeTakeNum :: Int -> String -> Int+          maybeTakeNum acc str =+            if pre `isPrefixOf` str && post `isSuffixOf` str+                then let num = read $ take (lnum str) $ drop lpre str+                     in max acc num+                else acc+          lpre = length pre+          lnum str = length str - lpre - length post++withTempFilePath :: FilePath -- ^ directory+                 -> String -- ^ file template+                 -> (FilePath -> IO a) -- ^ action to be run with the temp file+                 -> Bool+                 -> IO a+withTempFilePath dir template action isDir = do+    let pre = dropExtension template+    let post = takeExtension template+    tempFileName <- ((</>) dir) <$> nextFilePath dir pre post+    bracket_ (create tempFileName) (delete tempFileName) (action tempFileName)+  where create fp = if isDir+                      then createDirectory fp+                      else writeFile fp "" +        delete fp = if isDir+                      then removeDirectoryRecursive fp+                      else removeFile fp++withTempFilePath' :: String -- ^ file template+                  -> (FilePath -> IO a) -- ^ action to be run with the temp file+                  -> Bool+                  -> IO a+withTempFilePath' template action isDir = do+    tempDir <- getTemporaryDirectory+    withTempFilePath tempDir template action isDir++withTempFile' :: String+              -> (FilePath -> IO a)+              -> IO a+withTempFile' template action = withTempFilePath' template action False++withTempDir' :: String+             -> (FilePath -> IO a)+             -> IO a+withTempDir' template action = withTempFilePath' template action True
+ tests/preludes/default/prelude.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}+import Prelude+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.List as L
+ tests/preludes/moduleName/prelude.hs view
@@ -0,0 +1,2 @@+module MyPrelude where+t = take
+ tests/preludes/moduleNamedMain/prelude.hs view
@@ -0,0 +1,2 @@+module Main where+t = take
+ tests/preludes/readme/prelude.hs view
@@ -0,0 +1,5 @@+{-# 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 view
@@ -0,0 +1,5 @@+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}+import Prelude+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.List as L+import Data.Set