diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/haskell-awk.cabal b/haskell-awk.cabal --- a/haskell-awk.cabal +++ b/haskell-awk.cabal @@ -1,5 +1,5 @@ Name: haskell-awk -Version: 1.0.1 +Version: 1.1 Author: Mario Pastorelli , Samuel Gélineau Maintainer: Mario Pastorelli , Samuel Gélineau 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 diff --git a/runtime/System/Console/Hawk/Args/Spec.hs b/runtime/System/Console/Hawk/Args/Spec.hs new file mode 100644 --- /dev/null +++ b/runtime/System/Console/Hawk/Args/Spec.hs @@ -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 = " " diff --git a/runtime/System/Console/Hawk/Representable.hs b/runtime/System/Console/Hawk/Representable.hs new file mode 100644 --- /dev/null +++ b/runtime/System/Console/Hawk/Representable.hs @@ -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] diff --git a/runtime/System/Console/Hawk/Runtime.hs b/runtime/System/Console/Hawk/Runtime.hs new file mode 100644 --- /dev/null +++ b/runtime/System/Console/Hawk/Runtime.hs @@ -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 diff --git a/runtime/System/Console/Hawk/Runtime/Base.hs b/runtime/System/Console/Hawk/Runtime/Base.hs new file mode 100644 --- /dev/null +++ b/runtime/System/Console/Hawk/Runtime/Base.hs @@ -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 diff --git a/src/Control/Monad/Trans/OptionParser.hs b/src/Control/Monad/Trans/OptionParser.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/OptionParser.hs @@ -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]... " +-- ; 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]... +-- 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]... +-- 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]... +-- 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" "" consumeString :: OptionParser String String +-- +-- >>> testP ["--cowbell", "extra"] tp consumeCowbell +-- "extra" +-- +-- >>> testP ["-cs"] tp consumeCowbell +-- "s" +-- +-- >>> testP [] tp consumeCowbell +-- "" +-- +-- >>> 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]... +-- 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" "" $ consumeNullable "" consumeString :: OptionParser String String +-- +-- >>> testP ["-cs"] tp consumeCowbell +-- "s" +-- +-- >>> testP ["-c", "-s"] tp consumeCowbell +-- "" +-- +-- >>> testP ["-s"] tp consumeCowbell +-- "" +-- +-- >>> testP ["-c"] tp $ consumeLast "cowbell" "" 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]... +-- 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" "" consumeString :: OptionParser String String +-- +-- >>> :{ +-- testP ["--cowbell=foo", "--cowbell", "bar"] tp $ do +-- { xs <- consumeCowbell +-- ; xs' <- consumeCowbell +-- ; return (xs, xs') +-- } +-- :} +-- ("bar","") +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) diff --git a/src/Control/Monad/Trans/State/Persistent.hs b/src/Control/Monad/Trans/State/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/State/Persistent.hs @@ -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 diff --git a/src/Control/Monad/Trans/Uncertain.hs b/src/Control/Monad/Trans/Uncertain.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Uncertain.hs @@ -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 diff --git a/src/Data/Cache.hs b/src/Data/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Cache.hs @@ -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) diff --git a/src/Data/HaskellModule.hs b/src/Data/HaskellModule.hs new file mode 100644 --- /dev/null +++ b/src/Data/HaskellModule.hs @@ -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 diff --git a/src/Data/HaskellModule/Base.hs b/src/Data/HaskellModule/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/HaskellModule/Base.hs @@ -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] [as ] +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 diff --git a/src/Data/HaskellModule/Parse.hs b/src/Data/HaskellModule/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/HaskellModule/Parse.hs @@ -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 diff --git a/src/Data/HaskellSource.hs b/src/Data/HaskellSource.hs new file mode 100644 --- /dev/null +++ b/src/Data/HaskellSource.hs @@ -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 diff --git a/src/Data/Monoid/Ord.hs b/src/Data/Monoid/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Ord.hs @@ -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) diff --git a/src/Language/Haskell/Exts/Location.hs b/src/Language/Haskell/Exts/Location.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Exts/Location.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/System/Console/Hawk.hs b/src/System/Console/Hawk.hs --- a/src/System/Console/Hawk.hs +++ b/src/System/Console/Hawk.hs @@ -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 +-- 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" diff --git a/src/System/Console/Hawk/Args.hs b/src/System/Console/Hawk/Args.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Args.hs @@ -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 diff --git a/src/System/Console/Hawk/Args/Option.hs b/src/System/Console/Hawk/Args/Option.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Args/Option.hs @@ -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 to the entire table"] + helpMsg Map = ["apply to each row"] + helpMsg FieldDelimiter = ["default whitespace"] + helpMsg RecordDelimiter = ["default '\\n'"] + helpMsg OutputFieldDelimiter = ["default "] + helpMsg OutputRecordDelimiter = ["default "] + helpMsg Version = ["print version and exit"] + helpMsg Help = ["this help"] + helpMsg ContextDirectory = [" 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 diff --git a/src/System/Console/Hawk/Args/Parse.hs b/src/System/Console/Hawk/Args/Parse.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Args/Parse.hs @@ -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 diff --git a/src/System/Console/Hawk/Config.hs b/src/System/Console/Hawk/Config.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config.hs +++ /dev/null @@ -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) diff --git a/src/System/Console/Hawk/Config/Base.hs b/src/System/Console/Hawk/Config/Base.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config/Base.hs +++ /dev/null @@ -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" diff --git a/src/System/Console/Hawk/Config/Cache.hs b/src/System/Console/Hawk/Config/Cache.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config/Cache.hs +++ /dev/null @@ -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 diff --git a/src/System/Console/Hawk/Config/Compile.hs b/src/System/Console/Hawk/Config/Compile.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config/Compile.hs +++ /dev/null @@ -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 diff --git a/src/System/Console/Hawk/Config/Extend.hs b/src/System/Console/Hawk/Config/Extend.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config/Extend.hs +++ /dev/null @@ -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 diff --git a/src/System/Console/Hawk/Config/Parse.hs b/src/System/Console/Hawk/Config/Parse.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Config/Parse.hs +++ /dev/null @@ -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 diff --git a/src/System/Console/Hawk/Context.hs b/src/System/Console/Hawk/Context.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Context.hs @@ -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 diff --git a/src/System/Console/Hawk/Context/Base.hs b/src/System/Console/Hawk/Context/Base.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Context/Base.hs @@ -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 diff --git a/src/System/Console/Hawk/Context/Dir.hs b/src/System/Console/Hawk/Context/Dir.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Context/Dir.hs @@ -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" diff --git a/src/System/Console/Hawk/Context/Paths.hs b/src/System/Console/Hawk/Context/Paths.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Context/Paths.hs @@ -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" diff --git a/src/System/Console/Hawk/Help.hs b/src/System/Console/Hawk/Help.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Help.hs @@ -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]... []\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 diff --git a/src/System/Console/Hawk/IO.hs b/src/System/Console/Hawk/IO.hs deleted file mode 100644 --- a/src/System/Console/Hawk/IO.hs +++ /dev/null @@ -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 diff --git a/src/System/Console/Hawk/Interpreter.hs b/src/System/Console/Hawk/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Interpreter.hs @@ -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 diff --git a/src/System/Console/Hawk/Lock.hs b/src/System/Console/Hawk/Lock.hs --- a/src/System/Console/Hawk/Lock.hs +++ b/src/System/Console/Hawk/Lock.hs @@ -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 () diff --git a/src/System/Console/Hawk/Options.hs b/src/System/Console/Hawk/Options.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Options.hs +++ /dev/null @@ -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 "") delimiterHelp - , Option ['d'] ["words-delimiter"] (OptArg wordsDelimAction "") wordsDelimHelp - , Option ['O'] ["output-lines-delim"] (OptArg outDelimAction "") outDelimHelp - , Option ['o'] ["output-words-delim"] (OptArg outWordsDelimAction "") 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 to the stream" - mapHelp = "map 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 diff --git a/src/System/Console/Hawk/Representable.hs b/src/System/Console/Hawk/Representable.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Representable.hs +++ /dev/null @@ -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] diff --git a/src/System/Console/Hawk/Runtime.hs b/src/System/Console/Hawk/Runtime.hs deleted file mode 100644 --- a/src/System/Console/Hawk/Runtime.hs +++ /dev/null @@ -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 - diff --git a/src/System/Console/Hawk/Sandbox.hs b/src/System/Console/Hawk/Sandbox.hs --- a/src/System/Console/Hawk/Sandbox.hs +++ b/src/System/Console/Hawk/Sandbox.hs @@ -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 diff --git a/src/System/Console/Hawk/UserPrelude.hs b/src/System/Console/Hawk/UserPrelude.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/UserPrelude.hs @@ -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 diff --git a/src/System/Console/Hawk/UserPrelude/Defaults.hs b/src/System/Console/Hawk/UserPrelude/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/UserPrelude/Defaults.hs @@ -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" diff --git a/src/System/Console/Hawk/UserPrelude/Extend.hs b/src/System/Console/Hawk/UserPrelude/Extend.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/UserPrelude/Extend.hs @@ -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 diff --git a/src/System/Console/Hawk/Version.hs b/src/System/Console/Hawk/Version.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Hawk/Version.hs @@ -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 diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/Extra.hs @@ -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) diff --git a/tests/Data/HaskellModule/Parse/Test.hs b/tests/Data/HaskellModule/Parse/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Data/HaskellModule/Parse/Test.hs @@ -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) diff --git a/tests/RunTests.hs b/tests/RunTests.hs --- a/tests/RunTests.hs +++ b/tests/RunTests.hs @@ -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 diff --git a/tests/System/Console/Hawk/Lock/Test.hs b/tests/System/Console/Hawk/Lock/Test.hs new file mode 100644 --- /dev/null +++ b/tests/System/Console/Hawk/Lock/Test.hs @@ -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] diff --git a/tests/System/Console/Hawk/PreludeTests.hs b/tests/System/Console/Hawk/PreludeTests.hs new file mode 100644 --- /dev/null +++ b/tests/System/Console/Hawk/PreludeTests.hs @@ -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" diff --git a/tests/System/Console/Hawk/Test.hs b/tests/System/Console/Hawk/Test.hs new file mode 100644 --- /dev/null +++ b/tests/System/Console/Hawk/Test.hs @@ -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 diff --git a/tests/System/Console/Hawk/TestUtils.hs b/tests/System/Console/Hawk/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/System/Console/Hawk/TestUtils.hs @@ -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 diff --git a/tests/preludes/default/prelude.hs b/tests/preludes/default/prelude.hs new file mode 100644 --- /dev/null +++ b/tests/preludes/default/prelude.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-} +import Prelude +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.List as L diff --git a/tests/preludes/moduleName/prelude.hs b/tests/preludes/moduleName/prelude.hs new file mode 100644 --- /dev/null +++ b/tests/preludes/moduleName/prelude.hs @@ -0,0 +1,2 @@ +module MyPrelude where +t = take diff --git a/tests/preludes/moduleNamedMain/prelude.hs b/tests/preludes/moduleNamedMain/prelude.hs new file mode 100644 --- /dev/null +++ b/tests/preludes/moduleNamedMain/prelude.hs @@ -0,0 +1,2 @@ +module Main where +t = take diff --git a/tests/preludes/readme/prelude.hs b/tests/preludes/readme/prelude.hs new file mode 100644 --- /dev/null +++ b/tests/preludes/readme/prelude.hs @@ -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 diff --git a/tests/preludes/set/prelude.hs b/tests/preludes/set/prelude.hs new file mode 100644 --- /dev/null +++ b/tests/preludes/set/prelude.hs @@ -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