transf 0.7 → 0.8
raw patch · 3 files changed
+131/−53 lines, 3 files
Files
- src/Main.hs +3/−3
- src/Text/Transf.hs +127/−49
- transf.cabal +1/−1
src/Main.hs view
@@ -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
src/Text/Transf.hs view
@@ -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 +
transf.cabal view
@@ -1,6 +1,6 @@ name: transf-version: 0.7+version: 0.8 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund <hans@hanshoglund.se>