diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -20,7 +20,7 @@ -version = "transf-0.5" +version = "transf-0.8" header = "Usage: transf [options]\n" ++ "Usage: transf [options] files...\n" ++ "\n" ++ @@ -46,9 +46,9 @@ runFilter _ = transform stdin stdout transform fin fout = do - res <- runTransf $ do + res <- runTF $ do input <- liftIO $ hGetContents fin - output <- runTransformation (censorT <> printT <> evalT <> musicT) input + output <- runTransf' (printT <> evalT <> musicT) input liftIO $ hPutStr fout output case res of Left e -> putStrLn $ "Error: " ++ e diff --git a/src/Text/Transf.hs b/src/Text/Transf.hs --- a/src/Text/Transf.hs +++ b/src/Text/Transf.hs @@ -2,8 +2,36 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Text.Transf -- ( - -- ) +module Text.Transf ( + Line, + Lines, + RelativePath, + + -- * Combinators + Transf, + newTransf, + namedTransf, + readFile, + writeFile, + eval, + eval', + inform, + + -- ** Runing transformations + runTransf, + runTransf', + + -- * TF monad + TFT, + TF, + runTFT, + runTF, + + -- * Predefined transformations + printT, + evalT, + musicT, +) where import Prelude hiding (mapM, readFile, writeFile) @@ -16,105 +44,150 @@ import Data.Typeable import Data.Hashable import Data.Maybe -import Language.Haskell.Interpreter +import Language.Haskell.Interpreter hiding (eval) import System.IO (hPutStr, stderr) import System.Process import Numeric -import Music.Prelude.StringQuartet +import Music.Prelude.Basic import qualified Prelude import qualified Data.List as List +import qualified Data.Char as Char -- | A line of text. type Line = String +-- | Multiple-line text. +type Lines = String + -- | A relative file path. type RelativePath = FilePath --- |  -newtype Transf a = Transf { getTransf :: - ErrorT String IO a - } +-- | Transformer version of 'TF'. +newtype TFT m a = TFT { runTFT :: ErrorT String m a } deriving (Monad, MonadPlus, MonadError String, MonadIO) -runTransf :: Transf a -> IO (Either String a) -runTransf = runErrorT . getTransf +-- | The 'TF' monad defines the context of a transformation function. +-- Think of it as a restricted version of 'IO' or 'STM'. +type TF = TFT IO +runTF :: TF a -> IO (Either String a) +runTF = runErrorT . runTFT + -- | Read a file. -readFile :: RelativePath -> Transf String +readFile :: RelativePath -> TF String readFile path = do input <- liftIO $ try $ Prelude.readFile path case input of Left e -> throwError $ "readFile: " ++ show (e::SomeException) Right a -> return a --- appendFile :: RelativePath -> String -> Transf () +-- appendFile :: RelativePath -> String -> TF () -writeFile :: RelativePath -> String -> Transf () +-- | Write to a file. +writeFile :: RelativePath -> String -> TF () writeFile path str = liftIO $ Prelude.writeFile path str -interp :: Typeable a => String -> Transf a -interp str = do +-- | Evaluate a Haskell expression. +eval :: Typeable a => String -> TF a +eval = eval' ["Prelude", "Music.Prelude.Basic"] + +-- | Evaluate a Haskell expression. +eval' :: Typeable a => [String] -> String -> TF a +eval' imps str = do res <- liftIO $ runInterpreter $ do - setImports ["Prelude", "Music.Prelude.StringQuartet"] + setImports imps interpret str infer case res of - Left e -> throwError $ "interp: " ++ show e + Left e -> throwError $ "eval: " ++ show e Right a -> return a -data Transformation +-- | Write to the standard error stream. +inform :: String -> TF () +inform m = liftIO $ hPutStr stderr $ m ++ "\n" + +-- | A transformation function, or transformation for short. +data Transf = CompTrans { - decomp :: [Transformation] + decomp :: [Transf] } | SingTrans { guard :: (Line -> Bool, Line -> Bool), - function :: Line -> Transf Line + function :: Lines -> TF Lines } -instance Semigroup Transformation where +instance Semigroup Transf where a <> b = CompTrans [a,b] -censorT :: Transformation -censorT = SingTrans ((== "```censor"), (== "```")) $ \input -> do - liftIO $ hPutStr stderr "Censoring!\n" - return "(censored)" +-- | Create a new transformation. +newTransf :: (Line -> Bool) -> (Line -> Bool) -> (Lines -> TF Lines) -> Transf +newTransf b e = SingTrans (b, e) -printT :: Transformation -printT = SingTrans ((== "```print"), (== "```")) $ \input -> do - liftIO $ hPutStr stderr "Passing through!\n" +-- | Create a new transformation. +-- +-- This transformation processes everything in between lines containing +-- +-- > ~~~name +-- > ~~~ +-- +-- or alternatively +-- +-- > ```name +-- > ``` +-- +-- where @name@ is the name of the transformation. +-- +namedTransf :: String -> (Lines -> TF Lines) -> Transf +namedTransf name f = newTransf (namedGuard name) (namedGuard "") f + +namedGuard :: String -> String -> Bool +namedGuard name = namedGuardWithPrefix "```" name `or'` namedGuardWithPrefix "~~~" name + +namedGuardWithPrefix :: String -> String -> String -> Bool +namedGuardWithPrefix prefix name = (== (prefix ++ name)) . trimEnd + + +printT :: Transf +printT = namedTransf "print" $ \input -> do return input -evalT :: Transformation -evalT = SingTrans ((== "```eval"), (== "```")) $ \input -> do - liftIO $ hPutStr stderr "Evaluating!\n" - interp input +evalT :: Transf +evalT = namedTransf "eval" $ \input -> do + eval input -musicT :: Transformation -musicT = SingTrans ((== "```music"), (== "```")) $ \input -> do +musicT :: Transf +musicT = namedTransf "music" $ \input -> do let name = showHex (abs $ hash input) "" - liftIO $ hPutStr stderr "Interpreting music!\n" - music <- interp input :: Transf (Score Note) + music <- eval input :: TF (Score Note) liftIO $ writeLy (name++".ly") music - liftIO $ runCommand $ "lilypond -f png "++name++".ly" - return $ "![Output]("++name++".png)" + liftIO $ system $ "lilypond -f png -dresolution=300 "++name++".ly" + liftIO $ system $ "convert -transparent white -resize 30% "++name++".png "++name++"x.png" + return $ "![]("++name++"x.png)" + -- -resize 30% +-- | Run a transformation with the given error handler and input. +runTransf :: Transf -> (String -> IO String) -> String -> IO String +runTransf t handler input = do + res <- runTF $ runTransf' t input + case res of + Left e -> handler e + Right a -> return a -runTransformation :: Transformation -> String -> Transf String -runTransformation (CompTrans []) as = return as -runTransformation (CompTrans (t:ts)) as = do - bs <- runTransformation t as - runTransformation (CompTrans ts) bs +runTransf' :: Transf -> String -> TF String +runTransf' (CompTrans []) as = return as + +runTransf' (CompTrans (t:ts)) as = do + bs <- runTransf' t as + runTransf' (CompTrans ts) bs -runTransformation (SingTrans (start,stop) f) as = do +runTransf' (SingTrans (start,stop) f) as = do let bs = (sections start stop . lines) as :: [([Line], Maybe [Line])] let cs = fmap (first unlines . second (fmap unlines)) bs :: [(String, Maybe String)] - ds <- mapM (secondM (mapM f)) cs :: Transf [(String, Maybe String)] - return $ concatMap (\(a, b) -> a ++ fromMaybe b ++ "\n") ds - - + ds <- mapM (secondM (mapM f)) cs :: TF [(String, Maybe String)] + return $ concatMap (\(a, b) -> a ++ fromMaybe [] b ++ "\n") ds -- | Separate the sections delimited by the separators from their context. Returns @@ -138,9 +211,14 @@ first f (a, b) = (f a, b) second f (a, b) = (a, f b) +trimEnd :: String -> String +trimEnd = List.dropWhileEnd Char.isSpace + secondM :: Monad m => (a -> m b) -> (c, a) -> m (c, b) secondM f (a, b) = do b' <- f b return (a, b') - +or' :: (a -> Bool) -> (a -> Bool) -> a -> Bool +or' p q x = p x || q x + diff --git a/transf.cabal b/transf.cabal --- a/transf.cabal +++ b/transf.cabal @@ -1,6 +1,6 @@ name: transf -version: 0.7 +version: 0.8 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund