scc-0.2: Shell.hs
{-
Copyright 2008 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
version.
SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with SCC. If not, see
<http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE ScopedTypeVariables, Rank2Types, GADTs, FlexibleContexts, PatternSignatures #-}
module Main where
import Prelude hiding ((&&), (||), appendFile, interact, last, sequence)
import qualified Prelude
import Data.List (intersperse, partition)
import Data.Maybe (fromJust)
import Data.Typeable (Typeable)
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad (liftM, when)
import Text.Parsec hiding (count)
import Text.Parsec.String
import Text.Parsec.Language (emptyDef)
import Text.Parsec.Token
import System.Console.GetOpt
import System.Console.Readline
import System.Environment (getArgs)
import System.IO (BufferMode (NoBuffering), hFlush, hIsWritable, hPutStrLn, hReady, hSetBuffering, stderr, stdout)
import qualified System.Process as Process
import Control.Concurrent.MVar
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
hGetChar, hGetContents, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
import Control.Concurrent.SCC.Components
import Control.Concurrent.SCC.Combinators
data Expression where
-- Compiled expressions
Compiled :: Component x => TypeTag x -> x -> Expression
-- Generic expressions
NativeCommand :: String -> Expression
TypeError :: TypeTag x -> TypeTag y -> Expression -> Expression
Join :: Expression -> Expression -> Expression
Sequence :: Expression -> Expression -> Expression
Pipe :: Expression -> Expression -> Expression
If :: Expression -> Expression -> Expression -> Expression
ForEach :: Expression -> Expression -> Expression -> Expression
-- Void expressions, i.e. commands
Exit :: Expression
-- Producer constructs
FromList :: String -> Expression
FileProducer :: String -> Expression
StdInProducer :: Expression
-- Consumer constructs
FileConsumer :: String -> Expression
FileAppend :: String -> Expression
Suppress :: Expression
ErrorConsumer :: String -> Expression
-- Transducer constructs
Select :: Expression -> Expression
While :: Expression -> Expression -> Expression
IdentityTransducer :: Expression
Count :: Expression
Concatenate :: Expression
Group :: Expression
Uppercase :: Expression
ShowTransducer :: Expression
-- Splitter constructs
EverythingSplitter :: Expression
NothingSplitter :: Expression
WhitespaceSplitter :: Expression
LineSplitter :: Expression
LetterSplitter :: Expression
DigitSplitter :: Expression
OneSplitter :: Expression
SubstringSplitter :: String -> Expression
And :: Expression -> Expression -> Expression
Or :: Expression -> Expression -> Expression
ZipWithAnd :: Expression -> Expression -> Expression
ZipWithOr :: Expression -> Expression -> Expression
Not :: Expression -> Expression
FollowedBy :: Expression -> Expression -> Expression
Nested :: Expression -> Expression -> Expression
Having :: Expression -> Expression -> Expression
HavingOnly :: Expression -> Expression -> Expression
Between :: Expression -> Expression -> Expression
First :: Expression -> Expression
Last :: Expression -> Expression
Prefix :: Expression -> Expression
Suffix :: Expression -> Expression
Prepend :: Expression -> Expression
Append :: Expression -> Expression
Substitute :: Expression -> Expression
StartOf :: Expression -> Expression
EndOf :: Expression -> Expression
instance Show Expression where
showsPrec _ (Compiled tag c) rest = "compiled " ++ shows tag rest
showsPrec _ (NativeCommand cmd) rest = "native \"" ++ cmd ++ "\"" ++ rest
showsPrec p (Pipe left right) rest | p < 3 = showsPrec 3 left (" | " ++ showsPrec 2 right rest)
showsPrec _ (If s t f) rest = "if " ++ showsPrec 0 s (" then " ++ showsPrec 0 t (" else " ++ showsPrec 0 f (" end if" ++ rest)))
showsPrec _ (ForEach s t f) rest = "foreach " ++ showsPrec 0 s (" then " ++ showsPrec 0 t
(" else " ++ showsPrec 0 f (" end foreach" ++ rest)))
showsPrec _ Exit rest = "Exit" ++ rest
showsPrec _ (FileProducer f) rest = "FileProducer \"" ++ f ++ "\"" ++ rest
showsPrec _ (FromList str) rest = "echo \"" ++ str ++ "\"" ++ rest
showsPrec 0 (Sequence p1 p2) rest = showsPrec 2 p1 (";\n" ++ showsPrec 0 p2 rest)
showsPrec 1 (Sequence p1 p2) rest = showsPrec 2 p1 ("; " ++ showsPrec 1 p2 rest)
showsPrec p e@Sequence{} rest = "(" ++ showsPrec 1 e (')' : rest)
showsPrec 0 (Join p1 p2) rest = showsPrec 2 p1 (" &\n" ++ showsPrec 0 p2 rest)
showsPrec 1 (Join p1 p2) rest = showsPrec 2 p1 (" & " ++ showsPrec 1 p2 rest)
showsPrec p e@Join{} rest = "(" ++ showsPrec 1 e (')' : rest)
showsPrec _ (FileConsumer f) rest = "> \"" ++ f ++ "\"" ++ rest
showsPrec _ (FileAppend f) rest = ">> \"" ++ f ++ "\"" ++ rest
showsPrec _ (Suppress) rest = "suppress" ++ rest
showsPrec _ (ErrorConsumer e) rest = "error \"" ++ e ++ "\"" ++ rest
showsPrec p (Select s) rest | p < 4 = "select " ++ showsPrec 4 s rest
showsPrec _ (While s t) rest = "while " ++ showsPrec 0 s (" do " ++ showsPrec 0 t (" end while" ++ rest))
showsPrec p (And s1 s2) rest | p < 4 = showsPrec 4 s1 (" >& " ++ showsPrec 4 s2 rest)
showsPrec p (Or s1 s2) rest | p < 4 = showsPrec 4 s1 (" >| " ++ showsPrec 4 s2 rest)
showsPrec p (ZipWithAnd s1 s2) rest | p < 4 = showsPrec 4 s1 (" && " ++ showsPrec 4 s2 rest)
showsPrec p (ZipWithOr s1 s2) rest | p < 4 = showsPrec 4 s1 (" || " ++ showsPrec 4 s2 rest)
showsPrec p (FollowedBy s1 s2) rest | p < 4 = showsPrec 4 s1 (", " ++ showsPrec 4 s2 rest)
showsPrec p (Not s) rest | p < 4 = ">! " ++ showsPrec 4 s rest
showsPrec p (Nested s1 s2) rest | p < 4 = showsPrec 4 s1 (" nested in " ++ showsPrec 4 s2 rest)
showsPrec p (Having s1 s2) rest | p < 4 = showsPrec 4 s1 (" having " ++ showsPrec 4 s2 rest)
showsPrec p (HavingOnly s1 s2) rest | p < 4 = showsPrec 4 s1 (" having-only " ++ showsPrec 4 s2 rest)
showsPrec p (Between s1 s2) rest | p < 4 = showsPrec 4 s1 (" ... " ++ showsPrec 4 s2 rest)
showsPrec p (First s) rest | p < 4 = "first " ++ showsPrec 4 s rest
showsPrec p (Last s) rest | p < 4 = "last " ++ showsPrec 4 s rest
showsPrec p (Prefix s) rest | p < 4 = "prefix " ++ showsPrec 4 s rest
showsPrec p (Suffix s) rest | p < 4 = "suffix " ++ showsPrec 4 s rest
showsPrec p (Prepend s) rest | p < 4 = "prepend " ++ showsPrec 4 s rest
showsPrec p (Append s) rest | p < 4 = "append " ++ showsPrec 4 s rest
showsPrec p (Substitute s) rest | p < 4 = "substitute " ++ showsPrec 4 s rest
showsPrec p (StartOf s) rest | p < 4 = "start-of " ++ showsPrec 4 s rest
showsPrec p (EndOf s) rest | p < 4 = "end-of " ++ showsPrec 4 s rest
showsPrec _ IdentityTransducer rest = "id" ++ rest
showsPrec _ Count rest = "count" ++ rest
showsPrec _ Concatenate rest = "concatenate" ++ rest
showsPrec _ Group rest = "group" ++ rest
showsPrec _ Uppercase rest = "uppercase" ++ rest
showsPrec _ ShowTransducer rest = "show" ++ rest
showsPrec _ EverythingSplitter rest = "everything" ++ rest
showsPrec _ NothingSplitter rest = "nothing" ++ rest
showsPrec _ WhitespaceSplitter rest = "whitespace" ++ rest
showsPrec _ LineSplitter rest = "line" ++ rest
showsPrec _ LetterSplitter rest = "letters" ++ rest
showsPrec _ DigitSplitter rest = "digits" ++ rest
showsPrec _ OneSplitter rest = "one" ++ rest
showsPrec _ (SubstringSplitter s) rest = "substring " ++ shows s rest
showsPrec _ (TypeError tag1 tag2 e) rest = ("Type error: expecting " ++ show tag2 ++ ", received " ++ show tag1
++ "\nin expression " ++ showsPrec 9 e rest)
showsPrec p e rest | p > 0 = "(" ++ showsPrec 0 e (')' : rest)
data TypeTag x where
-- Data type tags
AnyTag :: TypeTag ()
UnitTag :: TypeTag ()
ShowableTag :: (Typeable x, Show x) => TypeTag x
CharTag :: TypeTag Char
IntTag :: TypeTag Integer
ListTag :: Typeable x => TypeTag x -> TypeTag [x]
PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)
-- Streaming component type tags
CommandTag :: TypeTag (Performer IO ())
ConsumerTag :: Typeable x => TypeTag x -> TypeTag (Consumer IO x ())
ProducerTag :: Typeable x => TypeTag x -> TypeTag (Producer IO x ())
SplitterTag :: Typeable x => TypeTag x -> TypeTag (Splitter IO x)
TransducerTag :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)
GenericInputTag :: forall x y. (Typeable x, Typeable y) => (TypeTag x -> TypeTag y) -> TypeTag y
instance Show (TypeTag x) where
show AnyTag = "Any"
show UnitTag = "()"
show CharTag = "Char"
show IntTag = "Int"
show (ListTag x) = '[' : shows x "]"
show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")
show CommandTag = "Command"
show (ConsumerTag x) = "Consumer " ++ show x
show (ProducerTag x) = "Producer " ++ show x
show (SplitterTag x) = "Splitter " ++ show x
show (TransducerTag x y) = "Transducer " ++ shows x (" -> " ++ show y)
show GenericInputTag{} = "Generic"
-- Weirich's higher-order type-safe cast
data CConsumer c x = CConsumer (c (Consumer IO x ()))
data CProducer c x = CProducer (c (Producer IO x ()))
data CSplitter c x = CSplitter (c (Splitter IO x))
data CList c a = CList (c [a])
data CFlip c b a = CFlip (c a b)
data CL c a d = CL (c (d,a))
data CR c a d = CR (c (a,d))
data CTL c a d = CTL (c (Transducer IO d a))
data CTR c a d = CTR (c (Transducer IO a d))
typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)
typecast UnitTag UnitTag x = Just x
typecast CharTag CharTag x = Just x
typecast IntTag IntTag x = Just x
typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))
typecast (PairTag (ra::TypeTag a0) (rb::TypeTag b0)) (PairTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
let g = (typecast ra ra' :: (CL c b0) a0 -> Maybe ((CL c b0) a0'))
h = (typecast rb rb' :: (CR c a0') b0 -> Maybe ((CR c a0') b0'))
in case g (CL x)
of Just (CL x') -> case h (CR x')
of Just (CR y') -> Just y'
typecast CommandTag CommandTag x = Just x
typecast (ConsumerTag a) (ConsumerTag b) x = fmap (\(CConsumer y)-> y) (typecast a b (CConsumer x))
typecast (ProducerTag a) (ProducerTag b) x = fmap (\(CProducer y)-> y) (typecast a b (CProducer x))
typecast (SplitterTag a) (SplitterTag b) x = fmap (\(CSplitter y)-> y) (typecast a b (CSplitter x))
typecast (TransducerTag (ra::TypeTag a0) (rb::TypeTag b0)) (TransducerTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x
= let g = (typecast ra ra' :: (CTL c b0) a0 -> Maybe ((CTL c b0) a0'))
h = (typecast rb rb' :: (CTR c a0') b0 -> Maybe ((CTR c a0') b0'))
in case g (CTL x)
of Just (CTL x') -> case h (CTR x')
of Just (CTR y') -> Just y'
typecast _ _ _ = Nothing
trycast :: forall a b. TypeTag a -> TypeTag b -> a -> Expression -> (b -> Expression) -> Expression
trycast tag1 tag2 x e constructor = case typecast tag1 tag2 (Just x)
of Just (Just y) -> constructor y
Nothing -> TypeError tag1 tag2 e
data Flag = Command | Help | Interactive | PrettyPrint | ScriptFile String | StandardInput | Threads String
deriving Eq
data InputSource = UnspecifiedSource | CommandLineSource | InteractiveSource | ScriptFileSource String | StandardInputSource
data Flags = Flags {helpFlag :: Bool,
inputSourceFlag :: InputSource,
prettyPrintFlag :: Bool,
threadCount :: Maybe Int}
flagList = [Option "c" ["command"] (NoArg Command) "Execute a single command",
Option "p" ["prettyprint"] (NoArg PrettyPrint) "Pretty print the input expression instead of executing it",
Option "h" ["help"] (NoArg Help) "Show help",
Option "f" ["file"] (ReqArg ScriptFile "file") "Execute commands from a script file",
Option "i" ["interactive"] (NoArg Interactive) "Execute commands interactively",
Option "s" ["stdin"] (NoArg StandardInput) "Execute commands from the standard input",
Option "t" ["threads"] (ReqArg Threads "threads") "Specify number of threads to use"]
usageSyntax = "Usage: shsh (-c <command> | -f <file> | -i | -s) "
main = do args <- getArgs
let (specifiedOptions, arguments, errors) = getOpt Permute flagList args
emptyOptions = Flags {helpFlag = False,
inputSourceFlag = UnspecifiedSource,
prettyPrintFlag = False,
threadCount = Nothing}
options = foldr extractOption emptyOptions specifiedOptions
extractOption Command options@Flags{inputSourceFlag= UnspecifiedSource} = options{inputSourceFlag= CommandLineSource}
extractOption Help options = options{helpFlag= True}
extractOption Interactive options@Flags{inputSourceFlag= UnspecifiedSource}
= options{inputSourceFlag= InteractiveSource}
extractOption StandardInput options@Flags{inputSourceFlag= UnspecifiedSource}
= options{inputSourceFlag= StandardInputSource}
extractOption PrettyPrint options = options{prettyPrintFlag= True}
extractOption (ScriptFile name) options@Flags{inputSourceFlag= UnspecifiedSource}
= options{inputSourceFlag= ScriptFileSource name}
extractOption (Threads count) options@Flags{threadCount= Nothing} = options{threadCount= Just (read count)}
if not (null errors) Prelude.|| helpFlag options
then showHelp
else case inputSourceFlag options
of CommandLineSource -> interpret options (concat (intersperse " " arguments)) >> return ()
InteractiveSource -> interact options
ScriptFileSource name -> readFile name >>= interpret options >> return ()
StandardInputSource -> getContents >>= interpret options >> return ()
UnspecifiedSource -> interact options
prettyprint options expression = print expression
>> case compile UnitTag expression
of Compiled tag component -> putStrLn "::" >> print tag
>> putStrLn (showComponentTree $ adjust options component)
e@TypeError{} -> print e
showHelp = putStrLn (usageInfo usageSyntax flagList)
interact options = do Just command <- readline "> "
addHistory command
finish <- interpret options command
when (not finish) (interact options)
interpret options command = case parseExpression command
of Left position -> hPutStrLn stderr ("Error at " ++ show position) >> return False
Right (Exit, "", _) -> return True
Right (expression, "", _) -> (if (prettyPrintFlag options)
then prettyprint options expression
else case compile UnitTag expression
of e@Compiled{} -> execute options e
e@TypeError{} -> print e)
>> return False
Right (expression, rest, _) -> hPutStrLn stderr ("Cannot parse \"" ++ rest
++ "\"\nafter " ++ show expression)
>> return False
execute :: Flags -> Expression -> IO ()
execute options (Compiled CommandTag command) = runPipes (perform $ adjust options command)
execute options (Compiled (ProducerTag CharTag) producer) = liftM fst (runPipes (pipe (produce $ adjust options producer)
(consume toStdOut)))
>> hFlush stdout
execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a Producer Char, received a " ++ show tag)
adjust Flags{threadCount= Just threads} component = usingThreads threads component
adjust _ component = component
compile :: Typeable x => TypeTag x -> Expression -> Expression
compile inputTag e@Compiled{} = e
compile inputTag e@TypeError{} = e
compile inputTag (Pipe left right)
= case compile inputTag left
of Compiled tag@(ProducerTag tag1) p
-> case compile tag1 right
of Compiled (ConsumerTag tag2) c -> trycast tag (ProducerTag tag2) p left $ \p'-> Compiled CommandTag (p' >-> c)
Compiled (TransducerTag tag2 tag3) t -> trycast tag (ProducerTag tag2) p left $
\p'-> Compiled (ProducerTag tag3) (p' >-> t)
e@TypeError{} -> e
Compiled (TransducerTag tag1 tag2) t
-> case compile tag2 right
of Compiled tag3@ConsumerTag{} c -> trycast tag3 (ConsumerTag tag2) c right $
\c'-> Compiled (ConsumerTag tag1) (t >-> c')
Compiled tag@(TransducerTag tag3 tag4) t2 -> trycast tag (TransducerTag tag2 tag4) t2 right $
\t2'-> Compiled (TransducerTag tag1 tag4) (t >-> t2')
e@TypeError{} -> e
e@TypeError{} -> e
compile UnitTag (NativeCommand command)
= Compiled (ProducerTag CharTag) (liftAtomicProducer command ioCost $
\sink-> do (_, stdout, _, pid) <- liftPipe (Process.runInteractiveCommand command)
produce (fromHandle stdout True) sink)
compile UnitTag (FileProducer path) = Compiled (ProducerTag CharTag) (fromFile path)
compile UnitTag StdInProducer = Compiled (ProducerTag CharTag) fromStdIn
compile inputTag (FromList string) = Compiled (ProducerTag CharTag) (liftAtomicProducer "putList" 1 $
\sink-> putList string sink >> return ())
compile inputTag (FileConsumer path) = Compiled (ConsumerTag CharTag) (toFile path)
compile inputTag (FileAppend path) = Compiled (ConsumerTag CharTag) (appendFile path)
compile inputTag Suppress = Compiled (ConsumerTag inputTag) suppress
compile inputTag (ErrorConsumer message) = Compiled (ConsumerTag inputTag) (erroneous message)
compile inputTag (Sequence e1 e2) = compileJoin sequence inputTag e1 e2
compile inputTag (Join e1 e2) = compileJoin join inputTag e1 e2
compile inputTag (ForEach splitter true false) = combineSplitterAndBranches foreach inputTag splitter true false
compile inputTag (If splitter true false) = combineSplitterAndBranches ifs inputTag splitter true false
compile inputTag (NativeCommand command) = Compiled (TransducerTag CharTag CharTag) (liftAtomicTransducer command ioCost f)
where f source sink = do (stdin, stdout, stderr, pid) <- liftPipe (Process.runInteractiveCommand command)
liftPipe (do hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
err <- hGetContents stderr
forkIO (evaluate (length err) >> return ()))
interleave source stdin pid stdout sink
return []
interleave :: forall c. Source c Char -> Handle -> Process.ProcessHandle -> Handle -> Sink c Char -> Pipe c IO ()
interleave source stdin pid stdout sink = interleave1
where interleave1 = get source
>>= maybe
(liftPipe (hClose stdin) >> interleaveEnd)
(\x-> liftPipe (Process.getProcessExitCode pid)
>>= maybe
(liftPipe (hPutChar stdin x) >> interleave2)
(const interleave2))
interleave2 = canPut sink
>>= flip when (liftPipe (hReady stdout)
>>= flip when (liftPipe (hGetChar stdout)
>>= put sink
>> return ())
>> interleave1)
interleaveEnd = canPut sink
>>= flip when (liftPipe (hIsEOF stdout)
>>= cond
(liftPipe $ hClose stdout)
(liftPipe (hGetChar stdout)
>>= put sink
>> interleaveEnd))
compile inputTag (Select e) = case compile inputTag e
of Compiled (SplitterTag tag) s -> Compiled (TransducerTag tag tag) (select s)
Compiled tag _ -> TypeError tag (SplitterTag inputTag) e
e'@TypeError{} -> e'
compile inputTag (While condition body)
= case (compile inputTag condition, compile inputTag body)
of (Compiled (SplitterTag tag1) s, Compiled tag2@TransducerTag{} t)
-> let tag2' = TransducerTag tag1 tag1
in trycast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))
compile inputTag (FollowedBy left right) = combineSplittersOfSameType followedBy inputTag left right
compile inputTag (And left right) = combineSplittersOfSameType (>&) inputTag left right
compile inputTag (Or left right) = combineSplittersOfSameType (>|) inputTag left right
compile inputTag (ZipWithAnd left right) = combineSplittersOfSameType (&&) inputTag left right
compile inputTag (ZipWithOr left right) = combineSplittersOfSameType (||) inputTag left right
compile inputTag (Nested left right) = combineSplittersOfSameType nestedIn inputTag left right
compile inputTag (Having left right) = combineSplittersOfSameType having inputTag left right
compile inputTag (HavingOnly left right) = combineSplittersOfSameType havingOnly inputTag left right
compile inputTag (Between left right) = combineSplittersOfSameType (...) inputTag left right
compile inputTag (Not splitter) = wrapSplitter snot inputTag splitter
compile inputTag (First splitter) = wrapSplitter first inputTag splitter
compile inputTag (Last splitter) = wrapSplitter last inputTag splitter
compile inputTag (Prefix splitter) = wrapSplitter prefix inputTag splitter
compile inputTag (Suffix splitter) = wrapSplitter suffix inputTag splitter
compile inputTag (StartOf splitter) = wrapSplitter startOf inputTag splitter
compile inputTag (EndOf splitter) = wrapSplitter endOf inputTag splitter
compile inputTag (Prepend prefix) = wrapProducerIntoTransducer prepend inputTag prefix
compile inputTag (Append suffix) = wrapProducerIntoTransducer append inputTag suffix
compile inputTag (Substitute replacement) = wrapGenericProducerIntoTransducer substitute inputTag replacement
compile inputTag IdentityTransducer = Compiled (TransducerTag inputTag inputTag) asis
compile inputTag Count = Compiled (TransducerTag inputTag IntTag) count
compile inputTag@(ListTag itemTag) Concatenate = Compiled (TransducerTag inputTag itemTag) concatenate
compile inputTag Concatenate = TypeError inputTag (ListTag AnyTag) Concatenate
compile inputTag Group = Compiled (TransducerTag inputTag (ListTag inputTag)) group
compile CharTag Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase
compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag inputTag) Uppercase
compile inputTag@CharTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag@IntTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag ShowTransducer
= TypeError (TransducerTag IntTag (ListTag CharTag)) (TransducerTag inputTag AnyTag) ShowTransducer
{-
compile inputTag ShowTransducer = let targetType = TransducerTag ShowableTag (ListTag CharTag)
actualType = TransducerTag inputTag (ListTag CharTag)
in trycast targetType actualType toString ShowTransducer (Compiled actualType)
-}
compile inputTag EverythingSplitter = Compiled (SplitterTag inputTag) everything
compile inputTag NothingSplitter = Compiled (SplitterTag inputTag) nothing
compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag) whitespace
compile inputTag LineSplitter = Compiled (SplitterTag CharTag) line
compile inputTag LetterSplitter = Compiled (SplitterTag CharTag) letters
compile inputTag DigitSplitter = Compiled (SplitterTag CharTag) digits
compile inputTag OneSplitter = Compiled (SplitterTag inputTag) one
compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag) (substring part)
compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag) (SplitterTag inputTag) e
compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)
compileJoin :: forall t. Typeable t =>
(forall t1 t2 t3 m x y c1 c2 c3. JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => c1 -> c2 -> c3)
-> TypeTag t -> Expression -> Expression -> Expression
compileJoin combinator inputTag e1 e2 = case (compile inputTag e1, compile inputTag e2)
of (Compiled CommandTag c1, Compiled CommandTag c2)
-> Compiled CommandTag (combinator c1 c2)
(Compiled tag1@ProducerTag{} p1, Compiled tag2@ProducerTag{} p2)
-> trycast tag2 tag1 p2 e2 (\p2'-> Compiled tag1 (combinator p1 p2'))
(Compiled tag1@ConsumerTag{} c1, Compiled tag2@ConsumerTag{} c2)
-> trycast tag2 tag1 c2 e2 (\c2'-> Compiled tag1 (combinator c1 c2'))
(Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
-> trycast tag2 tag1 t2 e2 (\t2'-> Compiled tag1 (combinator t1 t2'))
(Compiled CommandTag c, Compiled tag@ProducerTag{} p) -> Compiled tag (combinator c p)
(Compiled tag@ProducerTag{} p, Compiled CommandTag c) -> Compiled tag (combinator p c)
(Compiled CommandTag c1, Compiled tag@ConsumerTag{} c2)
-> Compiled tag (combinator c1 c2)
(Compiled tag@ConsumerTag{} c1, Compiled CommandTag c2)
-> Compiled tag (combinator c1 c2)
(Compiled CommandTag c, Compiled tag@TransducerTag{} t) -> Compiled tag (combinator c t)
(Compiled tag@TransducerTag{} t, Compiled CommandTag c) -> Compiled tag (combinator t c)
(Compiled (ProducerTag tag1) p, Compiled (ConsumerTag tag2) c)
-> Compiled (TransducerTag tag2 tag1) (combinator p c)
(Compiled (ConsumerTag tag1) p, Compiled (ProducerTag tag2) c)
-> Compiled (TransducerTag tag1 tag2) (combinator p c)
(Compiled (ProducerTag tag1) p, Compiled tag@(TransducerTag tag2 tag3) t)
-> let tag' = TransducerTag tag2 tag1
in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator p t'))
(Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ProducerTag{} p)
-> let tag' = TransducerTag tag2 tag1
in trycast tag3 (ProducerTag tag2) p e2 (\p'-> Compiled tag (combinator t p'))
(Compiled (ConsumerTag tag1) c, Compiled tag@(TransducerTag tag2 tag3) t)
-> let tag' = TransducerTag tag1 tag3
in trycast tag tag' t e2 (\t'-> Compiled tag' (combinator c t'))
(Compiled tag@(TransducerTag tag1 tag2) t, Compiled tag3@ConsumerTag{} c)
-> let tag' = TransducerTag tag2 tag1
in trycast tag3 (ConsumerTag tag1) c e2 (\c'-> Compiled tag (combinator t c'))
(e@TypeError{}, _) -> e
(_, e@TypeError{}) -> e
(Compiled tag@SplitterTag{} _, _) -> TypeError tag (ProducerTag AnyTag) e1
(_, Compiled tag@SplitterTag{} _) -> TypeError tag (ProducerTag AnyTag) e2
wrapSplitter :: forall x. Typeable x =>
(forall x. Typeable x => Splitter IO x -> Splitter IO x) -> TypeTag x -> Expression -> Expression
wrapSplitter combinator inputTag expression = case compile inputTag expression
of Compiled tag@SplitterTag{} splitter -> Compiled tag (combinator splitter)
Compiled tag _ -> TypeError tag (SplitterTag inputTag) expression
e@TypeError{} -> e
wrapProducerIntoTransducer :: forall x. Typeable x =>
(Producer IO x () -> Transducer IO x x) -> TypeTag x -> Expression -> Expression
wrapProducerIntoTransducer combinator inputTag expression
= case compile inputTag expression
of Compiled tag@ProducerTag{} p
-> trycast tag (ProducerTag inputTag) p expression (\p'-> Compiled (TransducerTag inputTag inputTag) (combinator p'))
Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
e@TypeError{} -> e
wrapGenericProducerIntoTransducer :: forall x. Typeable x =>
(forall y r. Typeable y => Producer IO y r -> Transducer IO x y)
-> TypeTag x -> Expression -> Expression
wrapGenericProducerIntoTransducer combinator inputTag expression
= case compile inputTag expression of Compiled (ProducerTag outTag) p -> Compiled (TransducerTag inputTag outTag) (combinator p)
Compiled tag _ -> TypeError tag (ProducerTag inputTag) expression
e@TypeError{} -> e
combineSplittersOfSameType :: forall x. Typeable x =>
(forall x. Typeable x => Splitter IO x -> Splitter IO x -> Splitter IO x)
-> TypeTag x -> Expression -> Expression -> Expression
combineSplittersOfSameType combinator inputTag left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@SplitterTag{} s1, Compiled tag2@SplitterTag{} s2)
-> trycast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))
combineTransducersOfSameType :: forall x. Typeable x =>
(forall x y. (Typeable x, Typeable y)=> Transducer IO x y -> Transducer IO x y -> Transducer IO x y)
-> TypeTag x -> Expression -> Expression -> Expression
combineTransducersOfSameType combinator inputTag left right
= case (compile inputTag left, compile inputTag right)
of (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
-> trycast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))
combineSplitterAndBranches :: forall x. Typeable x =>
(forall x cc. (Typeable x, BranchComponent cc IO x [x])=> Splitter IO x -> cc -> cc -> cc)
-> TypeTag x -> Expression -> Expression -> Expression -> Expression
combineSplitterAndBranches combinator inputTag splitter true false
= case (compile inputTag splitter, compile inputTag true, compile inputTag false)
of (Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@ConsumerTag{} f)
-> trycast tag2 (ConsumerTag tag1) t true $
\t'-> trycast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled (ConsumerTag tag1) (combinator s t' f')
(Compiled tag1@SplitterTag{} s, Compiled tag2@SplitterTag{} t, Compiled tag3@SplitterTag{} f)
-> trycast tag2 tag1 t true $
\t'-> trycast tag3 tag1 f false $
\f'-> Compiled tag1 (combinator s t' f')
(Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@TransducerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
in trycast tag2 tag2' t true $
\t'-> trycast tag3 tag2' f false $
\f'-> Compiled tag2' (combinator s t' f')
(Compiled (SplitterTag tag1) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ConsumerTag{} f)
-> let tag2' = TransducerTag tag1 tag2b
in trycast tag2 tag2' t true $
\t'-> trycast tag3 (ConsumerTag tag1) f false $
\f'-> Compiled tag2' (combinator s t' (consumeBy f'))
(Compiled (SplitterTag tag1) s, Compiled tag2@ConsumerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
-> let tag3' = TransducerTag tag1 tag3b
in trycast tag2 (ConsumerTag tag1) t true $
\t'-> trycast tag3 tag3' f false $
\f'-> Compiled tag3' (combinator s (consumeBy t') f')
(e@TypeError{}, _, _) -> e
(_, e@TypeError{}, _) -> e
(_, _, e@TypeError{}) -> e
(Compiled SplitterTag{} _, Compiled tag _, _) -> TypeError tag (TransducerTag inputTag AnyTag) true
(Compiled SplitterTag{} _, _, Compiled tag _) -> TypeError tag (TransducerTag inputTag AnyTag) false
(Compiled tag _, _, _) -> TypeError tag (SplitterTag inputTag) splitter
parseExpression :: String -> Either Int (Expression, [Char], Int)
parseExpression s = case parse partialExpressionParser "" s of
Left error -> Left (sourceLine (errorPos error))
Right result -> Right result
lexer = (makeTokenParser language) {stringLiteral= stringLexemeParser}
language = emptyDef{commentLine= "#",
reservedOpNames= ["...", ">!", ">", ">&", ">,", ">>", ">|", "|", "||", ";", "&"],
reservedNames= ["append", "concatenate", "count", "digits", "do",
"else", "end", "error", "exit", "everything", "first", "foreach",
"group", "having", "having-only", "id", "if", "in",
"last", "letters", "line", "nested", "nothing", "prefix", "prepend",
"select", "show", "stdin", "substitute", "substring", "suffix", "suppress",
"then", "uppercase", "while", "whitespace"]}
reservedTokens = reservedOpNames language ++ reservedNames language
partialExpressionParser :: Parser (Expression, [Char], Int)
partialExpressionParser = do whiteSpace lexer
t <- expressionParser
whiteSpace lexer
rest <- getInput
pos <- getPosition
return (t, rest, sourceLine pos - 1)
expressionParser :: Parser Expression
expressionParser = do head <- stepParser
whiteSpace lexer
(do tail <- many1 (try (symbol lexer ";" >> stepParser))
return (foldr1 Sequence (head:tail))
<|>
do tail <- many1 (try (symbol lexer "&" >> stepParser))
return (foldr1 Join (head:tail))
<|>
return head
)
stepParser :: Parser Expression
stepParser = do head <- termParser
whiteSpace lexer
tail <- many (try (char '|' >> whiteSpace lexer >> termParser))
return (foldr1 Pipe (head:tail))
termParser :: Parser Expression
termParser =
do first <- prefixTermParser
whiteSpace lexer
option first (liftM (foldr1 FollowedBy . (first :)) (many1 $ try (symbol lexer ">," >> prefixTermParser))
<|>
liftM (foldr1 Or . (first :)) (many1 $ try (symbol lexer ">|" >> prefixTermParser))
<|>
liftM (foldr1 And . (first :)) (many1 $ try (symbol lexer ">&" >> prefixTermParser))
<|>
liftM (foldr1 ZipWithOr . (first :)) (many1 $ try (symbol lexer "||" >> prefixTermParser))
<|>
liftM (foldr1 ZipWithAnd . (first :)) (many1 $ try (symbol lexer "&&" >> prefixTermParser))
<|>
liftM (Between first) (try (symbol lexer "..." >> prefixTermParser))
<|>
liftM (Having first) (try (symbol lexer "having" >> prefixTermParser))
<|>
liftM (HavingOnly first) (try (symbol lexer "having-only" >> prefixTermParser))
)
prefixTermParser :: Parser Expression
prefixTermParser =
try (symbol lexer ">!" >> liftM Not prefixTermParser)
<|> try (symbol lexer "prefix" >> liftM Prefix prefixTermParser)
<|> try (symbol lexer "suffix" >> liftM Suffix prefixTermParser)
<|> try (symbol lexer "prepend" >> liftM Prepend prefixTermParser)
<|> try (symbol lexer "append" >> liftM Append prefixTermParser)
<|> try (symbol lexer "substitute" >> liftM Substitute prefixTermParser)
<|> try (symbol lexer "first" >> liftM First prefixTermParser)
<|> try (symbol lexer "last" >> liftM Last prefixTermParser)
<|> try (symbol lexer "start-of" >> liftM StartOf prefixTermParser)
<|> try (symbol lexer "end-of" >> liftM EndOf prefixTermParser)
<|> try (symbol lexer "select" >> liftM Select prefixTermParser)
<|> primaryParser
primaryParser :: Parser Expression
primaryParser =
try (do char '('
whiteSpace lexer
expression <- expressionParser
whiteSpace lexer
char ')'
return expression)
<|> try (symbol lexer "exit" >> return Exit)
<|> try (nativeSourceParser "cat")
<|> try (nativeSourceParser "ls")
<|> try (do symbol lexer "echo"
string <- nativeCommand True
return (FromList string))
<|> try (symbol lexer "stdin" >> return StdInProducer)
<|> try (do symbol lexer ">>"
file <- parameterParser True
return (FileAppend file))
<|> try (do symbol lexer ">"
file <- parameterParser True
return (FileConsumer file))
<|> try (symbol lexer "suppress" >> return Suppress)
<|> try (do symbol lexer "error"
message <- (try (parameterParser True) <|> return "Error sink reached!")
return (ErrorConsumer message))
<|> try (symbol lexer "id" >> return IdentityTransducer)
<|> try (symbol lexer "uppercase" >> return Uppercase)
<|> try (symbol lexer "count" >> return Count)
<|> try (symbol lexer "show" >> return ShowTransducer)
<|> try (symbol lexer "concatenate" >> return Concatenate)
<|> try (symbol lexer "group" >> return Group)
<|> try (symbol lexer "everything" >> return EverythingSplitter)
<|> try (symbol lexer "nothing" >> return NothingSplitter)
<|> try (symbol lexer "whitespace" >> return WhitespaceSplitter)
<|> try (symbol lexer "line" >> return LineSplitter)
<|> try (symbol lexer "letters" >> return LetterSplitter)
<|> try (symbol lexer "digits" >> return DigitSplitter)
<|> try (symbol lexer "one" >> return OneSplitter)
<|> try (do symbol lexer "substring"
part <- parameterParser True
return (SubstringSplitter part))
<|> try (do symbol lexer "if"
splitter <- expressionParser
whiteSpace lexer
symbol lexer "then"
true <- expressionParser
false <- (try (symbol lexer "else" >> expressionParser)
<|> return Suppress)
symbol lexer "end"
option "" (symbol lexer "if")
return (If splitter true false))
<|> try (do symbol lexer "nested"
core <- expressionParser
whiteSpace lexer
symbol lexer "in"
shell <- expressionParser
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "nested")
return (Nested core shell))
<|> try (do symbol lexer "while"
test <- expressionParser
whiteSpace lexer
symbol lexer "do"
body <- expressionParser
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "while")
return (While test body))
<|> try (do symbol lexer "foreach"
splitter <- expressionParser
whiteSpace lexer
symbol lexer "then"
trueBranch <- expressionParser
whiteSpace lexer
falseBranch <- (try (symbol lexer "else" >> expressionParser)
<|> return IdentityTransducer)
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "foreach")
return (ForEach splitter trueBranch falseBranch))
<|> liftM NativeCommand (nativeCommand False)
nativeSourceParser :: String -> Parser Expression
nativeSourceParser command = do symbol lexer command
params <- nativeCommand False
return (NativeCommand (command ++ " " ++ params))
nativeCommand :: Bool -> Parser String
nativeCommand normalize = do parts <- try (lexeme lexer (parameterParser normalize)
`manyTill`
((eof >> return "") <|> lookAhead (choice (map (try . symbol lexer) reservedTokens))))
return (concat (intersperse " " parts))
where manyTill :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a]
manyTill p end = scan
where scan = do{ end; return [] }
<|>
do{ x <- p; xs <- scan; return (x:xs) }
<|>
return []
parameterParser :: Bool -> Parser String
parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&;")
(do try (string "\\n")
rest <- option "" (parameterParser normalize)
return (chars ++ '\n' : rest)
<|>
do try (string "\\t")
rest <- option "" (parameterParser normalize)
return (chars ++ '\t' : rest)
<|>
do next <- escape
rest <- option "" (parameterParser normalize)
return (chars ++ next : rest)
<|>
do quote <- oneOf "'\"`"
string <- many (try (noneOf (quote : "\\")) <|> escape)
char quote
rest <- option "" (parameterParser normalize)
return (chars ++ (if normalize then string else quote : (string ++ [quote])) ++ rest)
<|>
do try (char '(')
whiteSpace lexer
inside <- nativeCommand normalize
char ')'
rest <- option "" (parameterParser normalize)
return (chars ++ '(' : inside ++ ')' : rest)
<|>
do try (char '[')
whiteSpace lexer
inside <- nativeCommand normalize
char ']'
rest <- parameterParser normalize
return (chars ++ '[' : inside ++ ']' : rest)
<|>
do try (char '{')
whiteSpace lexer
inside <- nativeCommand normalize
char '}'
rest <- option "" (parameterParser normalize)
return (chars ++ '{' : inside ++ '}' : rest)
<|>
do when (null chars) parserZero
return chars)
escape :: Parser Char
escape = do char '\\'
escaped <- anyChar
return (case escaped of 'n' -> '\n'
'r' -> '\r'
't' -> '\t'
_ -> escaped)
stringLexemeParser :: Parser String
stringLexemeParser = do terminator <- oneOf "'\"`"
content <- many (try (noneOf ['\\', terminator]
<|> (string "\\t" >> return '\t')
<|> (string "\\n" >> return '\n')
<|> (char '\\' >> anyChar)))
char terminator
return (terminator : (content ++ [terminator]))