{- 
    Copyright 2008-2009 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 #-}

module Main where

import Prelude hiding (appendFile, interact, last, sequence)
import Data.List (intersperse, partition)
import Data.Char (isAlphaNum)
import Data.Maybe (fromJust)
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import Control.Monad (liftM, when)
import Control.Monad.Trans (lift)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.String as Parsec
import Text.Parsec hiding (count, parse)
import Text.Parsec.String hiding (Parser)
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.Configuration (Component, atomic, showComponentTree, usingThreads, with)
import Control.Concurrent.Coroutine
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
import Control.Concurrent.SCC.Components hiding ((&&), (||))
import Control.Concurrent.SCC.Combinators (JoinableComponentPair)
import qualified Control.Concurrent.SCC.Components as Combinators
import qualified Control.Concurrent.SCC.XML as XML

data Expression where
   -- Compiled expressions
   Compiled         :: TypeTag x -> Component 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
   -- ProducerComponent constructs
   FromList         :: String -> Expression
   FileProducer     :: String -> Expression
   StdInProducer    :: Expression
   -- ConsumerComponent constructs
   FileConsumer     :: String -> Expression
   FileAppend       :: String -> Expression
   Suppress         :: Expression
   ErrorConsumer    :: String -> Expression
   -- TransducerComponent constructs
   Select           :: Expression -> Expression
   While            :: Expression -> Expression -> Expression
   ExecuteTransducer :: Expression
   IdentityTransducer :: Expression
   Count            :: Expression
   Concatenate      :: Expression
   Group            :: Expression
   Unparse          :: Expression
   Uppercase        :: Expression
   ShowTransducer   :: Expression
   -- SplitterComponent constructs
   EverythingSplitter :: Expression
   NothingSplitter  :: Expression
   WhitespaceSplitter :: Expression
   LineSplitter     :: Expression
   LetterSplitter   :: Expression
   DigitSplitter    :: Expression
   MarkedSplitter   :: 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
   -- XML PrimitiveComponents
   XMLTokenParser    :: Expression
   XMLAttribute      :: Expression
   XMLAttributeName  :: Expression
   XMLAttributeValue :: Expression
   XMLElement        :: Expression
   XMLElementContent :: Expression
   XMLElementName    :: Expression
   XMLElementHavingTag  :: Expression -> Expression
   XMLHavingText     :: Expression -> Expression -> Expression
   XMLHavingOnlyText :: Expression -> 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 _ ExecuteTransducer rest = "execute" ++ rest
   showsPrec _ IdentityTransducer rest = "id" ++ rest
   showsPrec _ Count rest = "count" ++ rest
   showsPrec _ Concatenate rest = "concatenate" ++ rest
   showsPrec _ Group rest = "group" ++ rest
   showsPrec _ Unparse rest = "unparse" ++ 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 _ MarkedSplitter rest = "marked" ++ rest
   showsPrec _ OneSplitter rest = "one" ++ rest
   showsPrec _ (SubstringSplitter s) rest = "substring " ++ shows s (' ' : rest)
   showsPrec _ XMLTokenParser rest = "XML.parse" ++ rest
   showsPrec _ XMLElement rest = "XML.element" ++ rest
   showsPrec _ XMLAttribute rest = "XML.attribute" ++ rest
   showsPrec _ XMLAttributeName rest = "XML.attribute-name" ++ rest
   showsPrec _ XMLAttributeValue rest = "XML.attribute-value" ++ rest
   showsPrec _ XMLElementContent rest = "XML.element-content" ++ rest
   showsPrec _ XMLElementName rest = "XML.element-name" ++ rest
   showsPrec p (XMLElementHavingTag s) rest = "XML.element-having-tag " ++ showsPrec 4 s (' ' : rest)
   showsPrec p (XMLHavingText s1 s2) rest = showsPrec 4 s1 (" XML.having-text " ++ showsPrec 4 s2 rest)
   showsPrec p (XMLHavingOnlyText s1 s2) rest = showsPrec 4 s1 (" XML.having-only-text " ++ showsPrec 4 s2 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 :: Show x => TypeTag x
   CharTag :: TypeTag Char
   IntTag  :: TypeTag Integer
   XMLTokenTag :: TypeTag XML.Token
   EitherTag :: TypeTag x -> TypeTag y -> TypeTag (Either x y)
   ListTag  :: TypeTag x -> TypeTag [x]
   MaybeTag  :: TypeTag x -> TypeTag (Maybe x)
   PairTag :: TypeTag x -> TypeTag y -> TypeTag (x, y)
   MarkupTag :: TypeTag x -> TypeTag y -> TypeTag (Markup x y)
   
   -- Streaming component type tags
   ComponentTag  :: TypeTag x -> TypeTag (Component x)
   CommandTag    :: TypeTag (Performer IO ())
   ConsumerTag   :: TypeTag x -> TypeTag (Consumer IO x ())
   ProducerTag   :: TypeTag x -> TypeTag (Producer IO x ())
   SplitterTag   :: forall x b. TypeTag x -> TypeTag b -> TypeTag (Splitter IO x b)
   TransducerTag :: TypeTag x -> TypeTag y -> TypeTag (Transducer IO x y)
   GenericInputTag :: (TypeTag x -> TypeTag y) -> TypeTag y

instance Show (TypeTag x) where
   show AnyTag = "Any"
   show UnitTag = "()"
   show CharTag = "Char"
   show IntTag = "Int"
   show XMLTokenTag = "XML.Token"
   show (ListTag x) = '[' : shows x "]"
   show (MaybeTag x) = "Maybe " ++ show x
   show (EitherTag x y) = "Either " ++ shows x (" " ++ show y)
   show (MarkupTag x y) = "Markup " ++ shows x (" " ++ show y)
   show (PairTag x y) = "(" ++ shows x (", " ++ shows y ")")
   show (ComponentTag c) = show c
   show CommandTag  = "Command"
   show (ConsumerTag x) = "Consumer " ++ show x
   show (ProducerTag x) = "Producer " ++ show x
   show (SplitterTag x b) = "Splitter " ++ shows x (" " ++ show b)
   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 CComponent c x = CComponent (c (Component x))

data CList c a = CList (c [a])
data CMaybe c a = CMaybe (c (Maybe a))
data CFlip c b a = CFlip (c a b)
data CEL c a d = CEL (c (Either d a))
data CER c a d = CER (c (Either a d))
data CML c a d = CML (c (Markup d a))
data CMR c a d = CMR (c (Markup a d))
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))
data CSL c a d = CSL (c (Splitter IO d a))
data CSR c a d = CSR (c (Splitter 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 XMLTokenTag XMLTokenTag x = Just x
typecast (ListTag a) (ListTag b) x = fmap (\(CList y)-> y) (typecast a b (CList x))
typecast (MaybeTag a) (MaybeTag b) x = fmap (\(CMaybe y)-> y) (typecast a b (CMaybe x))
typecast (EitherTag (ra::TypeTag a0) (rb::TypeTag b0)) (EitherTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
    let g = (typecast ra ra' :: (CEL c b0)  a0 -> Maybe ((CEL c b0) a0'))
        h = (typecast rb rb' :: (CER c a0') b0 -> Maybe ((CER c a0') b0'))
    in case g (CEL x) of Just (CEL x') -> case h (CER x') of Just (CER y') -> Just y'
                         Nothing -> Nothing
typecast (MarkupTag (ra::TypeTag a0) (rb::TypeTag b0)) (MarkupTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x =
    let g = (typecast ra ra' :: (CML c b0)  a0 -> Maybe ((CML c b0) a0'))
        h = (typecast rb rb' :: (CMR c a0') b0 -> Maybe ((CMR c a0') b0'))
    in case g (CML x) of Just (CML x') -> case h (CMR x') of Just (CMR y') -> Just y'
                         Nothing -> Nothing
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'
                        Nothing -> Nothing

typecast (ComponentTag a) (ComponentTag b) x = fmap (\(CComponent y)-> y) (typecast a b (CComponent x))
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 (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 Nothing -> Nothing
                          Just (CTL x') -> case h (CTR x') of Nothing -> Nothing
                                                              Just (CTR y') -> Just y'
typecast (SplitterTag (ra::TypeTag a0) (rb::TypeTag b0)) (SplitterTag (ra'::TypeTag a0') (rb'::TypeTag b0')) x
   = let g = (typecast ra ra' :: (CSL c b0)  a0 -> Maybe ((CSL c b0) a0'))
         h = (typecast rb rb' :: (CSR c a0') b0 -> Maybe ((CSR c a0') b0'))
     in case g (CSL x) of Just (CSL x') -> case h (CSR x') of Just (CSR y') -> Just y'
                          Nothing -> Nothing
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

tryComponentCast :: forall a b. TypeTag a -> TypeTag b -> Component a -> Expression -> (Component b -> Expression)
                 -> Expression
tryComponentCast tag1 tag2 = trycast (ComponentTag tag1) (ComponentTag tag2)

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) || 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) = perform $ with $ adjust options command
execute options (Compiled (ProducerTag CharTag) producer) =
   liftM fst (runCoroutine (pipe
                                (produce $ with $ adjust options producer)
                                (consume $ with toStdOut)))
   >> hFlush stdout
execute options (Compiled tag _) = hPutStrLn stderr ("Expecting a command or a ProducerComponent Char, received a " ++ show tag)

adjust Flags{threadCount= Just threads} component = usingThreads component threads
adjust _ component = component

compile :: 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 -> tryComponentCast tag (ProducerTag tag2) p left $
                                                  \p'-> Compiled CommandTag (p' >-> c)
                 Compiled (TransducerTag tag2 tag3) t -> tryComponentCast 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 -> tryComponentCast tag3 (ConsumerTag tag2) c right $
                                                  \c'-> Compiled (ConsumerTag tag1) (t >-> c')
                 Compiled tag@(TransducerTag tag3 tag4) t2 -> tryComponentCast tag (TransducerTag tag2 tag4) t2 right $
                                                              \t2'-> Compiled (TransducerTag tag1 tag4) (t >-> t2')
                 e@TypeError{} -> e
                 Compiled tag _ -> TypeError tag (TransducerTag tag2 AnyTag) right
        Compiled tag _ -> TypeError tag (ProducerTag AnyTag) left
        e@TypeError{} -> e
compile UnitTag (NativeCommand command)
   = Compiled (ProducerTag CharTag) $
     atomic command ioCost $ Producer $
     \sink-> do (Nothing, Just stdout, Nothing, pid)
                   <- lift (Process.createProcess (Process.shell command){Process.std_out= Process.CreatePipe})
                produce (with $ 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) (atomic "putList" 1 $ Producer $
                                                                     \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)
                                                    (atomic command ioCost $ Transducer f)
   where f source sink = do (Just stdin, Just stdout, Nothing, pid)
                               <- lift (Process.createProcess
                                           (Process.shell command){Process.std_in= Process.CreatePipe,
                                                                   Process.std_out= Process.CreatePipe})
                            lift (hSetBuffering stdin NoBuffering
                                  >> hSetBuffering stdout NoBuffering)
                            interleave source stdin pid stdout sink
                            return []
         interleave :: forall a1 a2 d. (AncestorFunctor a1 d, AncestorFunctor a2 d) =>
                       Source IO a1 Char -> Handle -> Process.ProcessHandle -> Handle -> Sink IO a2 Char
                    -> Coroutine d IO ()
         interleave source stdin pid stdout sink = interleave1
            where interleave1 = get source
                                >>= maybe
                                       (lift (hClose stdin) >> interleaveEnd)
                                       (\x-> lift (Process.getProcessExitCode pid)
                                             >>= maybe
                                                    (lift (hPutChar stdin x) >> interleave2)
                                                    (const interleave2))
                  interleave2 = canPut sink
                                >>= flip when (lift (hReady stdout)
                                               >>= flip when (lift (hGetChar stdout)
                                                              >>= put sink
                                                              >> return ())
                                               >> interleave1)
                  interleaveEnd = canPut sink
                                  >>= flip when (lift (hIsEOF stdout)
                                                 >>= cond
                                                        (lift $ hClose stdout)
                                                        (lift (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 AnyTag) 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 tryComponentCast tag2 tag2' t body (\t'-> Compiled tag2' (while t' s))
compile inputTag (FollowedBy left right) = combineSplitters followedBy inputTag PairTag left right
compile inputTag (And left right) = combineSplitters (>&) inputTag PairTag left right
compile inputTag (Or left right) = combineSplitters (>|) inputTag EitherTag left right
compile inputTag (ZipWithAnd left right) = combineSplitters (Combinators.&&) inputTag PairTag left right
compile inputTag (ZipWithOr left right) = combineSplitters (Combinators.||) inputTag EitherTag 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 MaybeTag splitter
compile inputTag (EndOf splitter) = wrapSplitter' endOf inputTag MaybeTag 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 ExecuteTransducer
   = Compiled (TransducerTag CharTag CharTag) (atomic "execute" ioCost $ Transducer execute)
     where execute :: forall a1 a2 d. OpenTransducer IO a1 a2 d Char Char
           execute source sink = do let (source' :: Source IO d Char) = liftSource source
                                    ((), command) <- pipe (pour source') getList
                                    (Nothing, Just stdout, Nothing, pid)
                                       <- lift (Process.createProcess
                                                   (Process.shell command){Process.std_out= Process.CreatePipe})
                                    produce (with $ fromHandle stdout True) sink
                                    return []

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 t@(MarkupTag t1 t2) Unparse = Compiled (TransducerTag t t2) unparse
compile inputTag Unparse
   = TypeError (TransducerTag (MarkupTag AnyTag AnyTag) AnyTag) (TransducerTag inputTag AnyTag) Unparse
compile CharTag Uppercase = Compiled (TransducerTag CharTag CharTag) uppercase
compile inputTag Uppercase = TypeError (TransducerTag CharTag CharTag) (TransducerTag inputTag AnyTag) Uppercase
compile inputTag@CharTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag@IntTag ShowTransducer = Compiled (TransducerTag inputTag (ListTag CharTag)) toString
compile inputTag@(MarkupTag XMLTokenTag CharTag) 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 UnitTag) everything
compile inputTag NothingSplitter = Compiled (SplitterTag inputTag UnitTag) nothing
compile inputTag WhitespaceSplitter = Compiled (SplitterTag CharTag UnitTag) whitespace
compile inputTag LineSplitter = Compiled (SplitterTag CharTag UnitTag) line
compile inputTag LetterSplitter = Compiled (SplitterTag CharTag UnitTag) letters
compile inputTag DigitSplitter = Compiled (SplitterTag CharTag UnitTag) digits
compile inputTag MarkedSplitter = Compiled (SplitterTag (MarkupTag AnyTag AnyTag) UnitTag) marked
compile inputTag OneSplitter = Compiled (SplitterTag inputTag UnitTag) one
compile CharTag (SubstringSplitter part) = Compiled (SplitterTag CharTag UnitTag) (substring part)
compile inputTag e@SubstringSplitter{} = TypeError (SplitterTag CharTag UnitTag) (SplitterTag inputTag UnitTag) e
compile CharTag XMLTokenParser = Compiled (TransducerTag CharTag (MarkupTag XMLTokenTag CharTag)) xmlParseTokens
compile t@(MarkupTag XMLTokenTag CharTag) XMLElement = Compiled (SplitterTag t UnitTag) xmlElement
compile t@(MarkupTag XMLTokenTag CharTag) XMLAttribute = Compiled (SplitterTag t UnitTag) xmlAttribute
compile t@(MarkupTag XMLTokenTag CharTag) XMLAttributeName = Compiled (SplitterTag t UnitTag) xmlAttributeName
compile t@(MarkupTag XMLTokenTag CharTag) XMLAttributeValue = Compiled (SplitterTag t UnitTag) xmlAttributeValue
compile t@(MarkupTag XMLTokenTag CharTag) XMLElementContent = Compiled (SplitterTag t UnitTag) xmlElementContent
compile t@(MarkupTag XMLTokenTag CharTag) XMLElementName = Compiled (SplitterTag t UnitTag) xmlElementName
compile t@(MarkupTag XMLTokenTag CharTag) (XMLElementHavingTag s) = wrapConcreteSplitter xmlElementHavingTag t s
compile t@(MarkupTag XMLTokenTag CharTag) (XMLHavingText left right)
   = combineSplittersOfDifferentTypes xmlHavingText t CharTag left right
compile t@(MarkupTag XMLTokenTag CharTag) (XMLHavingOnlyText left right)
   = combineSplittersOfDifferentTypes xmlHavingOnlyText t CharTag left right

compile inputTag expression = error ("Cannot compile " ++ show expression ++ " with input " ++ show inputTag)

compileJoin :: forall t.
               (forall t1 t2 t3 m x y c1 c2 c3. JoinableComponentPair t1 t2 t3 m x y c1 c2 c3 => Component c1 -> Component c2 -> Component 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)
           -> tryComponentCast tag2 tag1 p2 e2 (\p2'-> Compiled tag1 (combinator p1 p2'))
        (Compiled tag1@ConsumerTag{} c1, Compiled tag2@ConsumerTag{} c2)
           -> tryComponentCast tag2 tag1 c2 e2 (\c2'-> Compiled tag1 (combinator c1 c2'))
        (Compiled tag1@TransducerTag{} t1, Compiled tag2@TransducerTag{} t2)
           -> tryComponentCast 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 tryComponentCast 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 tryComponentCast 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 tryComponentCast 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 tryComponentCast 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. 
                (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b) ->
                TypeTag x -> Expression -> Expression
wrapSplitter combinator inputTag expression
   = case compile inputTag expression
     of Compiled tag@(SplitterTag tx tb) splitter -> Compiled (SplitterTag tx tb) (combinator splitter)
        Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
        e@TypeError{} -> e

wrapConcreteSplitter :: forall x.
                        (forall b. SplitterComponent IO x b -> SplitterComponent IO x b) ->
                        TypeTag x -> Expression -> Expression
wrapConcreteSplitter combinator inputTag expression
   = case compile inputTag expression
     of Compiled tag@(SplitterTag tx tb) splitter ->
           tryComponentCast tag (SplitterTag inputTag tb) splitter expression $
                   \s'-> Compiled (SplitterTag inputTag tb) (combinator s')
        Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
        e@TypeError{} -> e

wrapConcreteSplitter' :: forall x y.
                         (forall b. SplitterComponent IO x b -> SplitterComponent IO y ()) ->
                         TypeTag x -> TypeTag y -> Expression -> Expression
wrapConcreteSplitter' combinator inputTag outputTag expression
   = case compile inputTag expression
     of Compiled tag@(SplitterTag tx tb) splitter ->
           tryComponentCast tag (SplitterTag inputTag tb) splitter expression $
                            \s'-> Compiled (SplitterTag outputTag UnitTag) (combinator s')
        Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
        e@TypeError{} -> e

wrapSplitter' :: forall x c.
                (forall x b. SplitterComponent IO x b -> SplitterComponent IO x (c b)) ->
                TypeTag x -> (forall b. TypeTag b -> TypeTag (c b)) -> Expression -> Expression
wrapSplitter' combinator inputTag constructor expression
   = case compile inputTag expression
     of Compiled tag@(SplitterTag tx tb) splitter -> Compiled (SplitterTag tx (constructor tb)) (combinator splitter)
        Compiled tag _ -> TypeError tag (SplitterTag inputTag AnyTag) expression
        e@TypeError{} -> e

wrapProducerIntoTransducer :: forall x.
                              (ProducerComponent IO x () -> TransducerComponent IO x x) -> TypeTag x -> Expression -> Expression
wrapProducerIntoTransducer combinator inputTag expression
   = case compile inputTag expression
     of Compiled tag@ProducerTag{} p
           -> tryComponentCast 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.
                                     (forall y r. ProducerComponent IO y r -> TransducerComponent 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

combineSplitters :: forall x c.
                    (forall x b1 b2. SplitterComponent IO x b1 -> SplitterComponent IO x b2 -> SplitterComponent IO x (c b1 b2))
                       -> TypeTag x -> (forall b1 b2. TypeTag b1 -> TypeTag b2 -> TypeTag (c b1 b2))
                       -> Expression -> Expression -> Expression
combineSplitters combinator inputTag constructor left right
   = case (compile inputTag left, compile inputTag right)
     of (Compiled tag1@(SplitterTag x1 b1) s1, Compiled tag2@(SplitterTag x2 b2) s2)
           -> tryComponentCast tag2 (SplitterTag x1 b2) s2 right $
              \s2'-> Compiled (SplitterTag x1 (constructor b1 b2)) (combinator s1 s2')
        (e@TypeError{}, _) -> e
        (_, e@TypeError{}) -> e
        (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
        (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right

combineSplittersOfSameType :: forall x.
                              (forall x b. SplitterComponent IO x b -> SplitterComponent IO x b -> SplitterComponent IO x b)
                           -> 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)
           -> tryComponentCast tag2 tag1 s2 right (\s2'-> Compiled tag1 (combinator s1 s2'))
        (e@TypeError{}, _) -> e
        (_, e@TypeError{}) -> e
        (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
        (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right

combineSplittersOfDifferentTypes :: forall x1 x2.
                                    (forall b1 b2. SplitterComponent IO x1 b1 -> SplitterComponent IO x2 b2 -> SplitterComponent IO x1 b1)
                                 -> TypeTag x1 -> TypeTag x2 -> Expression -> Expression -> Expression
combineSplittersOfDifferentTypes combinator tag1 tag2 left right
   = case (compile tag1 left, compile tag2 right)
     of (Compiled tag1'@(SplitterTag _ b1) s1, Compiled tag2'@(SplitterTag _ b2) s2)
           -> tryComponentCast tag1' (SplitterTag tag1 b1) s1 left $
              \s1'-> tryComponentCast tag2' (SplitterTag tag2 b2) s2 right $
                     \s2'-> Compiled (SplitterTag tag1 b1) (combinator s1' s2')
        (e@TypeError{}, _) -> e
        (_, e@TypeError{}) -> e
        (Compiled tag1 _, Compiled tag2@SplitterTag{} _) -> TypeError tag1 tag2 left
        (Compiled tag1@SplitterTag{} _, Compiled tag2 _) -> TypeError tag2 tag1 right

combineTransducersOfSameType :: forall x.
                                (forall x y. TransducerComponent IO x y -> TransducerComponent IO x y -> TransducerComponent 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)
           -> tryComponentCast tag2 tag1 t2 right (\t2'-> Compiled tag1 (combinator t1 t2'))

combineSplitterAndBranches :: forall x.
                              (forall x b cc. Branching cc IO x [x] => SplitterComponent IO x b -> Component cc -> Component cc -> Component 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)
           -> tryComponentCast tag2 (ConsumerTag tag1) t true $
              \t'-> tryComponentCast 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)
           -> tryComponentCast tag2 tag1 t true $
              \t'-> tryComponentCast 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 tryComponentCast tag2 tag2' t true $
                    \t'-> tryComponentCast 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 tryComponentCast tag2 tag2' t true $
                    \t'-> tryComponentCast 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 tryComponentCast tag2 (ConsumerTag tag1) t true $
                    \t'-> tryComponentCast tag3 tag3' f false $
                             \f'-> Compiled tag3' (combinator s (consumeBy t') f')
        (Compiled (SplitterTag tag1 _) s, Compiled tag2@(TransducerTag tag2a tag2b) t, Compiled tag3@ProducerTag{} f)
           -> let tag2' = TransducerTag tag1 tag2b
              in tryComponentCast tag2 tag2' t true $
                    \t'-> tryComponentCast tag3 (ProducerTag tag2b) f false $
                             \f'-> Compiled tag2' (combinator s t' (substitute f'))
        (Compiled (SplitterTag tag1 _) s, Compiled tag2@ProducerTag{} t, Compiled tag3@(TransducerTag tag3a tag3b) f)
           -> let tag3' = TransducerTag tag1 tag3b
              in tryComponentCast tag2 (ProducerTag tag3b) t true $
                    \t'-> tryComponentCast tag3 tag3' f false $
                             \f'-> Compiled tag3' (combinator s (substitute t') f')
        (Compiled (SplitterTag tag1 _) s, Compiled tag2@(ConsumerTag tag2a) t, Compiled tag3@(ProducerTag tag3a) f)
           -> tryComponentCast tag2 (ConsumerTag tag1) t true $
                 \t'-> Compiled (TransducerTag tag1 tag3a) (combinator s (consumeBy t') (substitute f))
        (Compiled (SplitterTag tag1 _) s, Compiled tag2@(ProducerTag tag2a) t, Compiled tag3@(ConsumerTag tag3a) f)
           -> tryComponentCast tag3 (ConsumerTag tag1) f true $
                 \f'-> Compiled (TransducerTag tag1 tag2a) (combinator s (substitute t) (consumeBy 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 AnyTag) splitter

parseExpression :: String -> Either Int (Expression, [Char], Int)
parseExpression s = case Parsec.parse partialExpressionParser "" s of
   Left error -> Left (sourceLine (errorPos error))
   Right result -> Right result

lexer = (makeTokenParser language) {stringLiteral= stringLexemeParser}

language = emptyDef{commentLine= "#",
                    identLetter= satisfy (\char-> isAlphaNum char || char == '-' || char == '_'),
                    reservedOpNames= ["...", ">!", ">", ">&", ">,", ">>", ">|", "|", "||", ";", "&"],
                    reservedNames= ["append", "concatenate", "count", "digits", "do",
                                    "else", "end", "error", "exit", "everything", "first", "foreach",
                                    "group", "having", "having-only", "id", "if", "in",
                                    "last", "letters", "line", "marked", "nested", "nothing", "prefix", "prepend",
                                    "select", "show", "stdin", "substitute", "substring", "suffix", "suppress",
                                    "then", "unparse", "uppercase", "while", "whitespace",
                                    "XML.parse-tags", "XML.serialize-tags",
                                    "XML.element", "XML.element-content", "XML.element-having-tag",
                                    "XML.element-name", "XML.having-text"]}

reservedTokens = reservedOpNames language ++ reservedNames language

partialExpressionParser :: Parsec.Parser (Expression, [Char], Int)
partialExpressionParser = do whiteSpace lexer
                             t <- expressionParser
                             whiteSpace lexer
                             rest <- getInput
                             pos <- getPosition
                             return (t, rest, sourceLine pos - 1)

expressionParser :: Parsec.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 :: Parsec.Parser Expression
stepParser = do head <- termParser
                whiteSpace lexer
                tail <- many (try (char '|' >> whiteSpace lexer >> termParser))
                return (foldr1 Pipe (head:tail))

termParser :: Parsec.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))
                    <|>
                    liftM (XMLHavingOnlyText first) (try (symbol lexer "XML.having-only-text" >> prefixTermParser))
                    <|>
                    liftM (XMLHavingText first) (try (symbol lexer "XML.having-text" >> prefixTermParser))
                   )

prefixTermParser :: Parsec.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)
   <|> try (symbol lexer "XML.element-having-tag" >> liftM XMLElementHavingTag prefixTermParser)
   <|> primaryParser

primaryParser :: Parsec.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 "concatenate" >> return Concatenate)
   <|> try (symbol lexer "count" >> return Count)
   <|> try (symbol lexer "digits" >> return DigitSplitter)
   <|> try (symbol lexer "everything" >> return EverythingSplitter)
   <|> try (symbol lexer "execute" >> return ExecuteTransducer)
   <|> try (symbol lexer "group" >> return Group)
   <|> try (symbol lexer "id" >> return IdentityTransducer)
   <|> try (symbol lexer "letters" >> return LetterSplitter)
   <|> try (symbol lexer "line" >> return LineSplitter)
   <|> try (symbol lexer "marked" >> return MarkedSplitter)
   <|> try (symbol lexer "nothing" >> return NothingSplitter)
   <|> try (symbol lexer "one" >> return OneSplitter)
   <|> try (symbol lexer "show" >> return ShowTransducer)
   <|> try (symbol lexer "uppercase" >> return Uppercase)
   <|> try (symbol lexer "unparse" >> return Unparse)
   <|> try (symbol lexer "whitespace" >> return WhitespaceSplitter)
   <|> try (symbol lexer "XML.attribute-name" >> return XMLAttributeName)
   <|> try (symbol lexer "XML.attribute-value" >> return XMLAttributeValue)
   <|> try (symbol lexer "XML.attribute" >> return XMLAttribute)
   <|> try (symbol lexer "XML.element-content" >> return XMLElementContent)
   <|> try (symbol lexer "XML.element-name" >> return XMLElementName)
   <|> try (symbol lexer "XML.element" >> return XMLElement)
   <|> try (symbol lexer "XML.parse" >> return XMLTokenParser)
   <|> 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 -> Parsec.Parser Expression
nativeSourceParser command = do symbol lexer command
                                params <- nativeCommand False
                                return (NativeCommand (command ++ " " ++ params))

nativeCommand :: Bool -> Parsec.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 -> Parsec.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 :: Parsec.Parser Char
escape = do char '\\'
            escaped <- anyChar
            return (case escaped of 'n' -> '\n'
                                    'r' -> '\r'
                                    't' -> '\t'
                                    _ -> escaped)

stringLexemeParser :: Parsec.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]))