scc-0.1: 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, PatternSignatures #-}
module Main where
import Prelude hiding ((&&), (||), appendFile, interact, last)
import Data.List (intersperse)
import Data.Maybe (fromJust)
import Data.Typeable (Typeable)
import Control.Monad (liftM, when)
import Text.ParserCombinators.Parsec hiding (between, count)
import Text.ParserCombinators.Parsec.Language (emptyDef)
import Text.ParserCombinators.Parsec.Token
import System.Console.GetOpt
import System.Console.Readline
import System.Environment (getArgs)
import System.IO (hFlush, hPutStrLn, stderr, stdout)
import System.Process (runCommand, runInteractiveCommand)
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
import Control.Concurrent.SCC.Components
import Control.Concurrent.SCC.Combinators
data VoidExpression where
NativeVoidCommand :: String -> VoidExpression
VoidPipe :: Typeable x => ProducerExpression x -> ConsumerExpression x -> VoidExpression
Exit :: VoidExpression
data ProducerExpression x where
PrimitiveProducer :: Typeable x => String -> Producer IO x () -> ProducerExpression x
NativeProducerCommand :: String -> ProducerExpression Char
VoidSource :: Typeable x => VoidExpression -> ProducerExpression x
ProducerPipe :: (Typeable x, Typeable y) => ProducerExpression x -> TransducerExpression x y -> ProducerExpression y
FileSource :: String -> ProducerExpression Char
StdInSource :: ProducerExpression Char
Sequence :: Typeable x => ProducerExpression x -> ProducerExpression x -> ProducerExpression x
data ConsumerExpression x where
NativeConsumerCommand :: String -> ConsumerExpression Char
VoidSink :: Typeable x => VoidExpression -> ConsumerExpression x
ConsumerPipe :: (Typeable x, Typeable y) => TransducerExpression x y -> ConsumerExpression y -> ConsumerExpression x
FileSink :: String -> ConsumerExpression Char
FileAppendSink :: String -> ConsumerExpression Char
SuppressingConsumer :: Typeable x => ConsumerExpression x
ErrorSink :: Typeable x => String -> ConsumerExpression x
Tee :: Typeable x => ConsumerExpression x -> ConsumerExpression x -> ConsumerExpression x
data TransducerExpression x y where
PrimitiveTransducer :: (Typeable x, Typeable y) => String -> Transducer IO x y -> TransducerExpression x y
NativeTransducerCommand :: String -> TransducerExpression Char Char
TransducerPipe :: (Typeable x, Typeable y, Typeable z)
=> TransducerExpression x y -> TransducerExpression y z -> TransducerExpression x z
TransducerJoin :: (Typeable x, Typeable y) => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y
Select :: Typeable x => SplitterExpression x -> TransducerExpression x x
If :: (Typeable x, Typeable y)
=> SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y
While :: Typeable x => SplitterExpression x -> TransducerExpression x x -> TransducerExpression x x
ForEach :: (Typeable x, Typeable y)
=> SplitterExpression x -> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y
data SplitterExpression x where
PrimitiveSplitter :: Typeable x => String -> Splitter IO x -> SplitterExpression x
And :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
Or :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
ZipWithAnd :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
ZipWithOr :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
Not :: Typeable x => SplitterExpression x -> SplitterExpression x
FollowedBy :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
Nested :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
Having :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
HavingOnly :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
Between :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
BetweenInclusive :: Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x
First :: Typeable x => SplitterExpression x -> SplitterExpression x
Last :: Typeable x => SplitterExpression x -> SplitterExpression x
Prefix :: Typeable x => SplitterExpression x -> SplitterExpression x
Suffix :: Typeable x => SplitterExpression x -> SplitterExpression x
instance Show VoidExpression where
show (NativeVoidCommand cmd) = "NativeVoidCommand \"" ++ cmd ++ "\""
show (VoidPipe p c) = "(VoidPipe " ++ shows p (" " ++ shows c ")")
show (Exit) = "Exit"
instance Show (ProducerExpression x) where
show (PrimitiveProducer name p) = name
show (NativeProducerCommand cmd) = cmd
show (VoidSource v) = "(VoidSource " ++ shows v ")"
show (ProducerPipe p t) = "(" ++ shows p (" | " ++ shows t ")")
show (FileSource f) = "FileSource \"" ++ f ++ "\""
show (Sequence p1 p2) = "(Sequence " ++ shows p1 (" "++ shows p2 ")")
instance Show (ConsumerExpression x) where
show (NativeConsumerCommand cmd) = cmd
show (VoidSink v) = "(VoidSink " ++ shows v ")"
show (ConsumerPipe t c) = "(ConsumerPipe " ++ shows t (" " ++ shows c ")")
show (FileSink f) = "> \"" ++ f ++ "\""
show (FileAppendSink f) = ">> \"" ++ f ++ "\""
show (SuppressingConsumer) = "SuppressingConsumer"
show (ErrorSink e) = "ErrorSink \"" ++ e ++ "\""
show (Tee c1 c2) = "(" ++ shows c1 (" tee " ++ shows c2 ")")
instance Show (TransducerExpression x y) where
show (PrimitiveTransducer name t) = name
show (NativeTransducerCommand cmd) = cmd
show (TransducerPipe t1 t2) = "(" ++ shows t1 (" | " ++ shows t2 ")")
show (TransducerJoin t1 t2) = "(" ++ shows t1 (" >< " ++ shows t2 ")")
show (Select s) = "(select " ++ shows s ")"
show (If s t1 t2) = "if " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end if"))
show (While s t) = "while " ++ shows s (" do " ++ shows t " end while")
show (ForEach s t1 t2) = "foreach " ++ shows s (" then " ++ shows t1 (" else " ++ shows t2 " end foreach"))
instance Show (SplitterExpression x) where
show (PrimitiveSplitter name s) = name
show (And s1 s2) = shows s1 (" >& " ++ show s2)
show (Or s1 s2) = shows s1 (" >| " ++ show s2)
show (ZipWithAnd s1 s2) = shows s1 (" >& " ++ show s2)
show (ZipWithOr s1 s2) = shows s1 (" >| " ++ show s2)
show (FollowedBy s1 s2) = shows s1 (", " ++ show s2)
show (Not s) = "Not " ++ show s
show (Nested s1 s2) = shows s1 (" nested in " ++ show s2)
show (Having s1 s2) = shows s1 (" having " ++ show s2)
show (HavingOnly s1 s2) = shows s1 (" having-only " ++ show s2)
show (Between s1 s2) = shows s1 (" having " ++ show s2)
show (BetweenInclusive s1 s2) = shows s1 (" having " ++ show s2)
show (First s) = "first " ++ show s
show (Last s) = "last " ++ show s
show (Prefix s) = "prefix " ++ show s
show (Suffix s) = "suffix " ++ show s
data TaggedExpression where
TaggedCommand :: VoidExpression -> TaggedExpression
TaggedConsumer :: Typeable x => TypeTag x -> ConsumerExpression x -> TaggedExpression
TaggedProducer :: Typeable x => TypeTag x -> ProducerExpression x -> TaggedExpression
TaggedSplitter :: Typeable x => TypeTag x -> SplitterExpression x -> TaggedExpression
TaggedTransducer :: (Typeable x, Typeable y) => TypeTag x -> TypeTag y -> TransducerExpression x y -> TaggedExpression
GenericInputExpression :: (forall x. Typeable x => TypeTag x -> TaggedExpression) -> TaggedExpression
TypeErrorExpression :: TypeTag x -> TypeTag y -> String -> TaggedExpression
instance Show TaggedExpression where
show (TaggedCommand e) = "TaggedCommand " ++ show e
show (TaggedConsumer tag e) = "TaggedConsumer " ++ shows e (" :: " ++ show tag)
show (TaggedProducer tag e) = "TaggedProducer " ++ shows e (" :: " ++ show tag)
show (TaggedSplitter tag e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag)
show (TaggedTransducer tag1 tag2 e) = "TaggedSplitter " ++ shows e (" :: " ++ show tag1 ++ " -> " ++ show tag2)
show (TypeErrorExpression tag1 tag2 s) = "TypeError " ++ shows s (" :: " ++ show tag1 ++ " -> " ++ show tag2)
show GenericInputExpression{} = "Cannot show a generic expression!"
data TypeTag x where
AnyTag :: 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)
instance Show (TypeTag x) where
show AnyTag = "Any"
show CharTag = "Char"
show IntTag = "Int"
show (ListTag x) = '[' : shows x "]"
show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")
-- we use Weirich's higher-order type-safe cast to avoid deep traversals
-- one can replace the type_cast with a more simple traversal-based
-- version.
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))
typecast :: forall a b c. TypeTag a -> TypeTag b -> c a -> Maybe (c b)
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 _ _ _ = Nothing
typecast2 :: forall a a' b b' c. TypeTag a -> TypeTag b -> TypeTag a' -> TypeTag b' -> c a b -> Maybe (c a' b')
typecast2 a b a' b' x = typecast a a' (CFlip x) >>= \(CFlip x')-> typecast b b' x'
trycast :: forall a b c. Show (c a) => TypeTag a -> TypeTag b -> (c b -> TaggedExpression) -> c a -> TaggedExpression
trycast a b wrap x = case typecast a b x of Just y -> wrap y
Nothing -> TypeErrorExpression a b (show x)
data Flag = Command | Help | Interactive | ScriptFile String | StandardInput
deriving Eq
options = [Option "c" ["command"] (NoArg Command) "Execute a single command",
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"]
usageSyntax = "Usage: shsh (-c <command> | -f <file> | -i | -s) "
main = do args <- getArgs
case getOpt Permute options args
of (_, _, errors) | not (null errors) -> putStr (concat errors)
(option, _, []) | Help `elem` option -> showHelp
(options, arguments, []) | Command `elem` options -> interpret (concat (intersperse " " arguments)) >> return ()
([ScriptFile name], [], []) -> readFile name >>= interpret >> return ()
([Interactive], [], []) -> interact
([StandardInput], [], []) -> getContents >>= interpret >> return ()
_ -> showHelp
showHelp = putStrLn (usageInfo usageSyntax options)
interact = do Just command <- readline "> "
addHistory command
finish <- interpret command
when (not finish) interact
interpret command = case parseExpression command
of Left position -> putStrLn ("Error at " ++ show position) >> return False
Right (TaggedCommand Exit, "", _) -> return True
Right (expression, "", _) -> execute expression >> return False
Right (expression, rest, _) -> putStrLn ("Cannot parse " ++ show rest) >> return False
execute :: TaggedExpression -> IO ()
execute (TaggedCommand command) = runPipes (evaluateVoidExpression command)
execute (TaggedProducer CharTag producer) = liftM fst (runPipes (pipe (evaluateProducerExpression producer) toStdOut))
>> hFlush stdout
execute (TaggedProducer tag _) = hPutStrLn stderr ("Expecting a Char Producer, received a " ++ shows tag " producer.")
execute (TypeErrorExpression tag1 tag2 e) = hPutStrLn stderr ("Expecting " ++ show tag2 ++ ", received " ++ show tag1
++ " in expression " ++ e)
evaluateConsumerExpression :: Typeable x => ConsumerExpression x -> Consumer IO x ()
evaluateConsumerExpression (NativeConsumerCommand command) =
\source-> do (stdin, _, _, pid) <- liftPipe (runInteractiveCommand command)
toHandle stdin source
evaluateConsumerExpression (ConsumerPipe filter sink) = evaluateTransducerExpression filter ->> evaluateConsumerExpression sink
evaluateConsumerExpression (FileSink path) = toFile path
evaluateConsumerExpression (FileAppendSink path) = appendFile path
evaluateConsumerExpression SuppressingConsumer = consumeAndSuppress
evaluateConsumerExpression (ErrorSink message) = undefined
evaluateConsumerExpression (Tee ce1 ce2) = \source-> pipe (\sink1-> pipe (\sink2-> tee source sink1 sink2)
(evaluateConsumerExpression ce2)
)
(evaluateConsumerExpression ce1)
>> return ()
evaluateProducerExpression :: Typeable x => ProducerExpression x -> Producer IO x ()
evaluateProducerExpression (PrimitiveProducer _ producer) = producer
evaluateProducerExpression (NativeProducerCommand command) =
\sink-> do (_, stdout, _, pid) <- liftPipe (runInteractiveCommand command)
fromHandle stdout sink
evaluateProducerExpression (ProducerPipe source filter) = evaluateTransducerExpression filter <<- evaluateProducerExpression source
evaluateProducerExpression (FileSource path) = fromFile path
evaluateProducerExpression StdInSource = fromStdIn
evaluateVoidExpression :: VoidExpression -> Pipe c IO ()
evaluateVoidExpression (NativeVoidCommand command) = liftPipe (runCommand command >> return ())
evaluateVoidExpression (VoidPipe source sink) =
do pipe (evaluateProducerExpression source) (evaluateConsumerExpression sink)
return ()
evaluateTransducerExpression :: (Typeable x, Typeable y) => TransducerExpression x y -> Transducer IO x y
evaluateTransducerExpression (PrimitiveTransducer _ filter) = filter
evaluateTransducerExpression (NativeTransducerCommand command) = Transducer f
where f source sink = do (stdin, stdout, _, pid) <- liftPipe (runInteractiveCommand command)
interleavedPour source (toHandle stdin) (fromHandle stdout) sink
return []
interleavedPour :: forall c c1 c2 m x y. (Monad m, Typeable x, Typeable y)
=> Source c1 x -> Consumer m x () -> Producer m y () -> Sink c2 y -> Pipe c m ()
interleavedPour source consumer producer sink = pipe (\sink-> pipe producer (interleave sink)) consumer
>> return ()
where interleave consumerSink producerSource = interleave1
where interleave1 = canPut consumerSink
>>= flip when (get source >>= maybe interleaveEnd (\x-> put consumerSink x >> interleave2))
interleave2 = canPut sink
>>= flip when (getSuccess producerSource (\y-> put sink y >> interleave1))
interleaveEnd = canPut sink
>>= flip when (getSuccess producerSource (\y-> put sink y >> interleaveEnd))
evaluateTransducerExpression (TransducerPipe f1 f2) = evaluateTransducerExpression f1 >-> evaluateTransducerExpression f2
evaluateTransducerExpression (TransducerJoin f1 f2) = evaluateTransducerExpression f1 `join` evaluateTransducerExpression f2
evaluateTransducerExpression (Select splitter) = select (evaluateSplitterExpression splitter)
evaluateTransducerExpression (If splitter f1 f2) =
ifs (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)
evaluateTransducerExpression (While splitter filter) =
evaluateTransducerExpression filter `while` evaluateSplitterExpression splitter
evaluateTransducerExpression (ForEach splitter f1 f2) =
foreach (evaluateSplitterExpression splitter) (evaluateTransducerExpression f1) (evaluateTransducerExpression f2)
evaluateSplitterExpression :: Typeable x => SplitterExpression x -> Splitter IO x
evaluateSplitterExpression (PrimitiveSplitter _ splitter) = splitter
evaluateSplitterExpression (FollowedBy s1 s2) = evaluateSplitterExpression s1 `followedBy` evaluateSplitterExpression s2
evaluateSplitterExpression (And s1 s2) = evaluateSplitterExpression s1 >& evaluateSplitterExpression s2
evaluateSplitterExpression (Or s1 s2) = evaluateSplitterExpression s1 >| evaluateSplitterExpression s2
evaluateSplitterExpression (ZipWithAnd s1 s2) = evaluateSplitterExpression s1 && evaluateSplitterExpression s2
evaluateSplitterExpression (ZipWithOr s1 s2) = evaluateSplitterExpression s1 || evaluateSplitterExpression s2
evaluateSplitterExpression (Not splitter) = snot (evaluateSplitterExpression splitter)
evaluateSplitterExpression (Nested s1 s2) = evaluateSplitterExpression s1 `nestedIn` evaluateSplitterExpression s2
evaluateSplitterExpression (Having s1 s2) = evaluateSplitterExpression s1 `having` evaluateSplitterExpression s2
evaluateSplitterExpression (HavingOnly s1 s2) = evaluateSplitterExpression s1 `havingOnly` evaluateSplitterExpression s2
evaluateSplitterExpression (Between s1 s2) = evaluateSplitterExpression s1 `between` evaluateSplitterExpression s2
evaluateSplitterExpression (BetweenInclusive s1 s2) = evaluateSplitterExpression s1 ... evaluateSplitterExpression s2
evaluateSplitterExpression (First splitter) = first (evaluateSplitterExpression splitter)
evaluateSplitterExpression (Last splitter) = last (evaluateSplitterExpression splitter)
evaluateSplitterExpression (Prefix splitter) = prefix (evaluateSplitterExpression splitter)
evaluateSplitterExpression (Suffix splitter) = suffix (evaluateSplitterExpression splitter)
specialize :: Typeable x => TypeTag x -> Parser TaggedExpression -> Parser TaggedExpression
specialize tag parser = do e <- parser
return (case e
of GenericInputExpression g -> g tag
_ -> e)
combineTransducers :: (forall x y. (Typeable x, Typeable y)
=> TypeTag x -> TypeTag y -> TransducerExpression x y -> TransducerExpression x y
-> TransducerExpression x y)
-> TaggedExpression -> TaggedExpression -> TaggedExpression
combineTransducers combinator e1 e2 =
case (e1, e2)
of (TaggedTransducer tag1 tag2 t1, TaggedTransducer tag1' tag2' t2) ->
case typecast2 tag1' tag2' tag1 tag2 t2
of Just t2' -> TaggedTransducer tag1 tag2 (combinator tag1 tag2 t1 t2')
Nothing -> TypeErrorExpression tag2' tag2 (show t1)
(GenericInputExpression ge, TaggedTransducer tag1 _ _) -> combineTransducers combinator (ge tag1) e2
(TaggedTransducer tag1 _ _, GenericInputExpression ge) -> combineTransducers combinator e1 (ge tag1)
(GenericInputExpression g1, GenericInputExpression g2)
-> GenericInputExpression (\tag-> combineTransducers combinator (g1 tag) (g2 tag))
(TypeErrorExpression{}, _) -> e1
(_, TypeErrorExpression{}) -> e2
foldPipeline :: [TaggedExpression] -> TaggedExpression
foldPipeline list = foldl1 combine list
where combine :: TaggedExpression -> TaggedExpression -> TaggedExpression
combine (TaggedProducer tag p) (TaggedTransducer tag1 tag2 t)
= trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' t)) p
combine (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)
= trycast tag2 tag1' (\t1'-> TaggedTransducer tag1 tag2' (TransducerPipe t1' t2)) t1
combine p@(TaggedProducer tag _) (GenericInputExpression ge) = combine p (ge tag)
combine (GenericInputExpression ge) other = GenericInputExpression (\tag-> combine (ge tag) other)
combine t@(TaggedTransducer tag1 tag2 _) (GenericInputExpression ge) = combine t (ge tag2)
combine e@TypeErrorExpression{} _ = e
combine _ e@TypeErrorExpression{} = e
parseExpression :: String -> Either Int (TaggedExpression, [Char], Int)
parseExpression s = case parse partialExpressionParser "" s of
Left error -> Left (sourceLine (errorPos error))
Right result -> Right result
lexer = (makeTokenParser emptyDef{commentLine= "#"}){stringLiteral= stringLexemeParser}
partialExpressionParser :: Parser (TaggedExpression, [Char], Int)
partialExpressionParser = do whiteSpace lexer
t <- expressionParser
rest <- getInput
pos <- getPosition
return (t, rest, sourceLine pos - 1)
expressionParser :: Parser TaggedExpression
expressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser
whiteSpace lexer
transducers <- many (try (char '|' >> whiteSpace lexer >> transducerPrimaryParser))
let tpt = foldPipeline (tp:transducers)
whiteSpace lexer
option tpt (liftM ((,) tpt) (try (char '|' >> whiteSpace lexer >> specialize tag consumerPrimaryParser))
>>= \(TaggedTransducer tag1 tag2 transducer, TaggedConsumer tag' consumer)
-> return (trycast tag tag' (\p'-> TaggedCommand (VoidPipe p' consumer)) producer))
producerExpressionParser :: Parser TaggedExpression
producerExpressionParser = do tp@(TaggedProducer tag producer) <- producerPrimaryParser
whiteSpace lexer
(try (do char '|'
whiteSpace lexer
TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser
return (trycast tag tag1 (\p'-> TaggedProducer tag2 (ProducerPipe p' transducer)) producer))
<|>
return tp)
consumerExpressionParser :: Parser TaggedExpression
consumerExpressionParser = try consumerForkParser
<|>
do TaggedTransducer tag1 tag2 transducer <- transducerExpressionParser
whiteSpace lexer
char '|'
TaggedConsumer tag' consumer <- consumerForkParser
return (trycast tag' tag2 (TaggedConsumer tag1 . ConsumerPipe transducer) consumer)
consumerForkParser :: Parser TaggedExpression
consumerForkParser = do tc@(TaggedConsumer tag first) <- consumerPrimaryParser
whiteSpace lexer
(try (do symbol lexer "tee"
TaggedConsumer tag' rest <- consumerForkParser
return (trycast tag tag' (\first'-> TaggedConsumer tag' (Tee first' rest)) first))
<|>
return tc)
voidPrimaryParser = try (symbol lexer "exit" >> return Exit)
<|> liftM NativeVoidCommand nativeCommand
producerPrimaryParser :: Parser TaggedExpression
producerPrimaryParser = try (do char '('
whiteSpace lexer
(try (do command <- nativeCommand
whiteSpace lexer
char ')'
whiteSpace lexer
char '>'
return (TaggedProducer CharTag (NativeProducerCommand command)))
<|>
do source <- producerExpressionParser
whiteSpace lexer
char ')'
return source))
<|> try (nativeSourceParser "cat")
-- <|> try (nativeSourceParser "echo")
<|> try (do symbol lexer "echo"
string <- parameterParser True
return (TaggedProducer CharTag $
PrimitiveProducer ("echo " ++ string) (\sink-> putList string sink >> return ())))
<|> try (symbol lexer "stdin" >> return (TaggedProducer CharTag StdInSource))
<|> nativeSourceParser "ls"
nativeSourceParser :: String -> Parser TaggedExpression
nativeSourceParser command = do symbol lexer command
params <- nativeCommand
return (TaggedProducer CharTag (NativeProducerCommand (command ++ " " ++ params)))
consumerPrimaryParser :: Parser TaggedExpression
consumerPrimaryParser = try (do symbol lexer ">>"
file <- parameterParser True
return (TaggedConsumer CharTag (FileAppendSink file)))
<|>
try (do symbol lexer ">"
symbol lexer "("
command <- nativeCommand
whiteSpace lexer
symbol lexer ")"
return (TaggedConsumer CharTag (NativeConsumerCommand command)))
<|>
try (do symbol lexer ">"
file <- parameterParser True
return (TaggedConsumer CharTag (FileSink file)))
<|>
try (do symbol lexer "null"
return (GenericInputExpression ((\tag-> TaggedConsumer tag SuppressingConsumer))))
<|>
do symbol lexer "error"
message <- (try (parameterParser True) <|> return "Error sink reached!")
return (GenericInputExpression (\tag-> TaggedConsumer tag (ErrorSink message)))
transducerExpressionParser :: Parser TaggedExpression
transducerExpressionParser = do first <- transducerPrimaryParser
(try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "|" >> transducerPrimaryParser))
return (foldPipeline (first:rest)))
<|>
try (do rest <- many1 (try (whiteSpace lexer >> symbol lexer "><" >> transducerPrimaryParser))
return (foldr1 (combineTransducers (const $ const TransducerJoin)) (first:rest)))
<|>
return first)
where tagged :: (forall x y. (Typeable x, Typeable y)
=> TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)
-> TaggedExpression -> TaggedExpression -> TaggedExpression
tagged combinator (TaggedTransducer tag1 tag2 t1) (TaggedTransducer tag1' tag2' t2)
= case typecast2 tag1 tag2 tag1' tag2' t1 of Just t1' -> TaggedTransducer tag1' tag2' (combinator t1' t2)
Nothing -> TypeErrorExpression tag1 tag1' (show t1)
splitterExpressionParser :: Parser TaggedExpression
splitterExpressionParser = do first@(TaggedSplitter tag one) <- splitterPrimaryParser
whiteSpace lexer
(try (do rest <- many1 (try (symbol lexer ">," >> splitterPrimaryParser))
return (foldr1 (tagged FollowedBy) (first:rest)))
<|>
try (do rest <- many1 (try (symbol lexer ">|" >> splitterPrimaryParser))
return (foldr1 (tagged Or) (first:rest)))
<|>
try (do rest <- many1 (try (symbol lexer ">&" >> splitterPrimaryParser))
return (foldr1 (tagged And) (first:rest)))
<|>
try (do rest <- many1 (try (symbol lexer "||" >> splitterPrimaryParser))
return (foldr1 (tagged ZipWithOr) (first:rest)))
<|>
try (do rest <- many1 (try (symbol lexer "&&" >> splitterPrimaryParser))
return (foldr1 (tagged ZipWithAnd) (first:rest)))
<|>
try (do rest <- many1 (try (symbol lexer "..." >> splitterPrimaryParser))
return (foldr1 (tagged BetweenInclusive) (first:rest)))
<|>
try (do symbol lexer "having"
TaggedSplitter tag' other <- splitterPrimaryParser
return (trycast tag tag' (\one'-> TaggedSplitter tag' (Having one' other)) one))
<|>
try (do symbol lexer "having-only"
TaggedSplitter tag' other <- splitterPrimaryParser
return (trycast tag tag' (\one'-> TaggedSplitter tag' (HavingOnly one' other)) one))
<|>
return first)
where tagged :: (forall x. Typeable x => SplitterExpression x -> SplitterExpression x -> SplitterExpression x)
-> TaggedExpression -> TaggedExpression -> TaggedExpression
tagged combinator (TaggedSplitter tag1 s1) (TaggedSplitter tag2 s2)
= trycast tag1 tag2 (\s1'-> TaggedSplitter tag2 (combinator s1' s2)) s1
transducerPrimaryParser :: Parser TaggedExpression
transducerPrimaryParser = try (do symbol lexer "("
filter <- transducerExpressionParser
symbol lexer ")"
return filter)
<|>
try (do symbol lexer "id"
return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "id" asis))))
<|>
try (do symbol lexer "suppress"
return (GenericInputExpression (\tag-> TaggedTransducer tag tag (PrimitiveTransducer "suppress" suppress))))
<|>
try (do symbol lexer "uppercase"
return (TaggedTransducer CharTag CharTag (PrimitiveTransducer "uppercase" uppercase)))
<|>
try (do symbol lexer "count"
return (GenericInputExpression (\tag-> TaggedTransducer tag IntTag (PrimitiveTransducer "count" count))))
<|>
try (do symbol lexer "show"
return (TaggedTransducer IntTag (ListTag CharTag) (PrimitiveTransducer "show" toString)))
<|>
try (do symbol lexer "concatenate"
return (GenericInputExpression $
\tag-> case tag
of ListTag tag'
-> TaggedTransducer tag tag' (PrimitiveTransducer "concatenate" concatenate)
_ -> TypeErrorExpression tag (ListTag AnyTag) "concatenate"))
<|>
try (do symbol lexer "group"
return (GenericInputExpression $
\tag-> TaggedTransducer tag (ListTag tag) (PrimitiveTransducer "group" group)))
<|>
try (do symbol lexer "prepend"
prefix <- parameterParser True
return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("prepend " ++ prefix) (prepend prefix))))
<|>
try (do symbol lexer "append"
suffix <- parameterParser True
return (TaggedTransducer CharTag CharTag (PrimitiveTransducer ("append " ++ suffix) (append suffix))))
<|>
try (do symbol lexer "substitute"
replacement <- parameterParser True
return (TaggedTransducer CharTag CharTag
(PrimitiveTransducer ("substitute " ++ replacement) (substitute replacement))))
<|>
try (do symbol lexer "select"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedTransducer tag tag (Select splitter)))
<|>
try (do symbol lexer "if"
TaggedSplitter tag splitter <- splitterExpressionParser
whiteSpace lexer
symbol lexer "then"
true <- transducerExpressionParser
false <- (try (symbol lexer "else" >> transducerExpressionParser)
<|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))
symbol lexer "end"
option "" (symbol lexer "if")
return (combineBranches (If splitter) tag true false))
<|>
try (do symbol lexer "while"
TaggedSplitter tag splitter <- splitterExpressionParser
whiteSpace lexer
symbol lexer "do"
TaggedTransducer tag' tag'' body <- transducerExpressionParser
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "while")
return (case (typecast tag tag' splitter, typecast tag'' tag' body)
of (Just test, Just body) -> TaggedTransducer tag' tag' (While test body)))
<|>
try (do symbol lexer "foreach"
TaggedSplitter tag splitter <- splitterExpressionParser
whiteSpace lexer
symbol lexer "then"
trueBranch <- transducerExpressionParser
whiteSpace lexer
falseBranch <- (try (symbol lexer "else" >> transducerExpressionParser)
<|> return (TaggedTransducer tag tag (PrimitiveTransducer "id" asis)))
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "foreach")
return (combineBranches (ForEach splitter) tag trueBranch falseBranch))
<|>
liftM (TaggedTransducer CharTag CharTag . NativeTransducerCommand) nativeCommand
combineBranches :: forall x. Typeable x
=> (forall y. Typeable y => TransducerExpression x y -> TransducerExpression x y -> TransducerExpression x y)
-> TypeTag x -> TaggedExpression -> TaggedExpression -> TaggedExpression
combineBranches combinator tag b1 b2 =
case (b1, b2)
of (TaggedTransducer tag1 tag2 true, TaggedTransducer tag1' tag2' false) ->
case (typecast2 tag1 tag2 tag tag2 true, typecast2 tag1' tag2' tag tag2 false)
of (Just true', Just false') -> TaggedTransducer tag tag2 (combinator true' false')
(Nothing, _) -> TypeErrorExpression tag1 tag (show true)
(_, Nothing) -> TypeErrorExpression tag2' tag2 (show true)
(GenericInputExpression ge, _) -> combineBranches combinator tag (ge tag) b2
(_, GenericInputExpression ge) -> combineBranches combinator tag b1 (ge tag)
(TypeErrorExpression{}, _) -> b1
(_, TypeErrorExpression{}) -> b2
splitterPrimaryParser :: Parser TaggedExpression
splitterPrimaryParser = try (do symbol lexer "("
splitter <- splitterExpressionParser
symbol lexer ")"
return splitter)
<|>
try (do symbol lexer ">!"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedSplitter tag (Not splitter)))
<|>
try (do symbol lexer "prefix"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedSplitter tag (Prefix splitter)))
<|>
try (do symbol lexer "suffix"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedSplitter tag (Suffix splitter)))
<|>
try (do symbol lexer "first"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedSplitter tag (First splitter)))
<|>
try (do symbol lexer "last"
TaggedSplitter tag splitter <- splitterPrimaryParser
return (TaggedSplitter tag (Last splitter)))
<|>
try (do symbol lexer "whitespace"
return (TaggedSplitter CharTag (PrimitiveSplitter "whitespace" whitespace)))
<|>
try (do symbol lexer "line"
return (TaggedSplitter CharTag (PrimitiveSplitter "line" line)))
<|>
try (do symbol lexer "letters"
return (TaggedSplitter CharTag (PrimitiveSplitter "letters" letters)))
<|>
try (do symbol lexer "digits"
return (TaggedSplitter CharTag (PrimitiveSplitter "digits" digits)))
<|>
try (do symbol lexer "substring"
part <- parameterParser True
return (TaggedSplitter CharTag (PrimitiveSplitter ("substring " ++ part) (substring part))))
<|>
do symbol lexer "nested"
TaggedSplitter tag1 core <- splitterExpressionParser
whiteSpace lexer
symbol lexer "in"
TaggedSplitter tag2 shell <- splitterExpressionParser
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "nested")
return (trycast tag1 tag2 (\core'-> TaggedSplitter tag2 (Nested core' shell)) core)
<|>
do symbol lexer "between"
TaggedSplitter tag1 left <- splitterExpressionParser
whiteSpace lexer
symbol lexer "and"
TaggedSplitter tag2 right <- splitterExpressionParser
whiteSpace lexer
symbol lexer "end"
option "" (symbol lexer "between")
return (trycast tag1 tag2 (\left'-> TaggedSplitter tag2 (Between left' right)) left)
nativeCommand :: Parser String
nativeCommand = do parts <- many (try (lexeme lexer (parameterParser False)))
return (concat (intersperse " " parts))
parameterParser :: Bool -> Parser String
parameterParser normalize = do chars <- many (noneOf " \t\n'\"`\\()[]{}<>|&")
(do try (string "\\n")
rest <- (parameterParser normalize <|> return "")
return (chars ++ '\n' : rest)
<|>
do try (string "\\t")
rest <- (parameterParser normalize <|> return "")
return (chars ++ '\t' : rest)
<|>
do next <- escape
rest <- (parameterParser normalize <|> return "")
return (chars ++ next : rest)
<|>
do quote <- oneOf "'\"`"
string <- many (noneOf (quote : "\\") <|> escape)
char quote
rest <- (parameterParser normalize <|> return "")
return (chars ++ (if normalize then string else quote : (string ++ [quote])) ++ rest)
<|>
do try (char '(')
whiteSpace lexer
inside <- nativeCommand
char ')'
rest <- (parameterParser normalize <|> return "")
return (chars ++ '(' : inside ++ ')' : rest)
<|>
do try (char '[')
whiteSpace lexer
inside <- nativeCommand
char ']'
rest <- parameterParser normalize
return (chars ++ '[' : inside ++ ']' : rest)
<|>
do try (char '{')
whiteSpace lexer
inside <- nativeCommand
char '}'
rest <- (parameterParser normalize <|> return "")
return (chars ++ '{' : inside ++ '}' : rest)
<|>
do when (null chars) pzero
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]))