module Text.Transf (
Line,
Lines,
RelativePath,
Context,
ContextT,
runContext,
runContextT,
Transform,
transform,
runTransform,
readFile,
writeFile,
inform,
eval,
evalWith,
addPost,
printT,
evalT,
musicT,
MusicOpts(..),
musicT',
haskellT,
evalHaskellT,
musicHaskellT,
musicHaskellT',
musicExtraT,
) where
import Prelude hiding (mapM, readFile, writeFile)
import Control.Applicative
import Control.Exception
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Writer hiding ((<>))
import Control.Monad.Error
import Control.Monad.Plus
import Numeric
import Data.Maybe
import Data.Default
import Data.Semigroup
import Data.Traversable
import Data.Typeable
import Data.Hashable
import System.IO (hPutStr, hPutStrLn, stderr)
import System.Process
import Language.Haskell.Interpreter hiding (eval)
import qualified Prelude
import qualified Data.List as List
import qualified Data.Char as Char
import qualified Data.Traversable as Traversable
type Line = String
type Lines = String
type RelativePath = FilePath
newtype Post m = Post [ContextT m ()]
deriving (Monoid)
post :: ContextT m () -> Post m
post = Post . return
type PrimContextT m = ErrorT String (WriterT (Post m) m)
newtype ContextT m a = ContextT { runContextT_ :: PrimContextT m a }
deriving ( Functor, Monad, MonadIO, MonadPlus, Applicative,
Alternative, MonadError String, MonadWriter (Post m) )
type Context = ContextT IO
runContext :: Context a -> IO (Either String a)
runContext x = do
(r, Post posts) <- runC x
parallel_ (fmap ignoreErrorsAndPost posts)
return r
where
runC = runWriterT . runErrorT . runContextT_
runContextT :: Monad m => ContextT m a -> m (Either String a)
runContextT = runContextT' True
runContextT' :: Monad m => Bool -> ContextT m a -> m (Either String a)
runContextT' recur x = do
(r, Post posts) <- runC x
if recur then runContextT' False (sequence_ posts) else return (return ())
return r
where
runC = runWriterT . runErrorT . runContextT_
ignoreErrorsAndPost :: ContextT IO a -> IO ()
ignoreErrorsAndPost x = (runWriterT . runErrorT . runContextT_) x >> return ()
data Transform
= CompTrans {
decomp :: [Transform]
}
| SingTrans {
delimiters :: (Line -> Bool, Line -> Bool),
function :: Lines -> Context Lines
}
doTrans (SingTrans _ f) = f
instance Semigroup Transform where
a <> b = CompTrans [a,b]
instance Monoid Transform where
mempty = CompTrans []
mappend = (<>)
newTransform :: (Line -> Bool) -> (Line -> Bool) -> (Lines -> Context Lines) -> Transform
newTransform b e = SingTrans (b, e)
namedFence :: String -> String -> Bool
namedFence name = namedFenceWithPrefix "```" name `oneOf` namedFenceWithPrefix "~~~" name
namedFenceWithPrefix :: String -> String -> String -> Bool
namedFenceWithPrefix prefix name = (== (prefix ++ name)) . trimEnd
transform :: String -> (Lines -> Context Lines) -> Transform
transform name = newTransform (namedFence name) (namedFence "")
runTransformIO :: Transform -> (String -> IO String) -> String -> IO String
runTransformIO t handler input = do
res <- runContext $ runTransform t input
case res of
Left e -> handler e
Right a -> return a
runTransform :: Transform -> String -> Context String
runTransform = go
where
go (CompTrans []) as = return as
go (CompTrans (t:ts)) as = do
bs <- go t as
go (CompTrans ts) bs
go (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 <- Traversable.mapM (secondM (Traversable.mapM f)) cs :: Context [(String, Maybe String)]
return $ concatMap (\(a, b) -> a ++ fromMaybe [] b ++ "\n") ds
readFile :: RelativePath -> Context String
readFile path = do
input <- liftIO $ try $ Prelude.readFile path
case input of
Left e -> throwError $ "readFile: " ++ show (e::SomeException)
Right a -> return a
writeFile :: RelativePath -> String -> Context ()
writeFile path str = liftIO $ Prelude.writeFile path str
eval :: Typeable a => String -> Context a
eval = evalWith["Prelude", "Music.Prelude.Basic"]
evalWith :: Typeable a => [String] -> String -> Context a
evalWith imps str = do
res <- liftIO $ runInterpreter $ do
set [languageExtensions := [OverloadedStrings, NoMonomorphismRestriction]]
setImportsimps
interpret str infer
case res of
Left e -> throwError $ "Could not evaluate: " ++ str ++ "\n" ++ showIE e
Right a -> return a
where
showIE (WontCompile xs) = " " ++ List.intercalate "\n " (fmap errMsg xs)
showIE (UnknownError x) = x
showIE (NotAllowed x) = x
showIE (GhcException x) = x
inform :: String -> Context ()
inform m = liftIO $ hPutStr stderr $ m ++ "\n"
addPost :: Context () -> Context ()
addPost = tell . post
printT :: Transform
printT = transform "print" $ \input -> inform input >> return ""
evalT :: Transform
evalT = transform "eval" $ \input -> do
(exit, out, err) <- liftIO $ readProcessWithExitCode "runhaskell2" [] input
inform err
return out
data MusicOpts = MusicOpts {
format :: String,
resolution :: Int,
resize :: Int,
prelude :: String
}
instance Default MusicOpts where def = MusicOpts {
format = "png",
resolution = 200,
resize = 45,
prelude = "basic"
}
musicT :: Transform
musicT = musicT' def
musicT' :: MusicOpts -> Transform
musicT' opts = transform "music" $ \input -> do
let prel = prelude opts
let name = showHex (abs $ hash input) ""
currentFile <- liftIO $ tryMaybe $ Prelude.readFile (name++".music")
unless (currentFile == Just input) $ do
writeFile (name++".music") input
liftIO $ void $ readProcess "music2ly" ["--prelude", prel, "-o", name++".ly", name++".music"] ""
liftIO $ void $ readProcess "music2midi" ["--prelude", prel, "-o", name++".mid", name++".music"] ""
let makeLy = do
(exit, out, err) <- readProcessWithExitCode "lilypond" [
"-f", format opts,
"-dresolution=" ++ show (resolution opts) ++ "", name++".ly"
] mempty
hPutStr stderr out
hPutStr stderr err
return ()
let makePng = when (format opts == "png") $ void $ system $
"convert -transparent white -resize "
++ show (resize opts) ++"% "
++ name ++".png "
++ name ++ "x.png"
addPost (liftIO $makeLy >> makePng)
let playText = "<div class='haskell-music-listen'><a href='"++name++".mid'>[listen]</a></div>"
let ending = if format opts == "png" then "x" else ""
return $ playText ++ "\n\n" ++ "![](" ++ name ++ ending ++ "." ++ format opts ++ ")"
musicExtraT :: Transform
musicExtraT = transform "music-extra" $ \_ -> return txt
where
txt = "<script src=\"js/jasmid/stream.js\"></script>\n" ++
"<script src=\"js/jasmid/midifile.js\"></script>\n" ++
"<script src=\"js/jasmid/replayer.js\"></script>\n" ++
"<script src=\"js/midi.js\"></script>\n" ++
"<script src=\"js/Base64.js\" type=\"text/javascript\"></script>\n" ++
"<script src=\"js/base64binary.js\" type=\"text/javascript\"></script>\n" ++
"<script src=\"js/main.js\" type=\"text/javascript\"></script>\n"
haskellT :: Transform
haskellT = transform "haskell" $ \input ->
return $ "```haskell\n" ++ input ++ "\n```"
musicHaskellT :: Transform
musicHaskellT = musicHaskellT' def
musicHaskellT' :: MusicOpts -> Transform
musicHaskellT' opts = transform "music+haskell" $ \input -> do
let begin = "<div class='haskell-music'>"
let end = "</div>"
musicRes <- doTrans (musicT' opts) input
haskellRes <- doTrans haskellT input
return $ begin ++ "\n\n" ++ musicRes ++ "\n\n" ++ haskellRes ++ "\n\n" ++ end
evalHaskellT :: Transform
evalHaskellT = transform "eval+haskell" $ \input -> do
evalRes <- doTrans evalT input
haskellRes <- doTrans haskellT input
return $ "\n\n" ++ evalRes ++ "\n\n" ++ haskellRes ++ "\n\n"
sections :: (a -> Bool) -> (a -> Bool) -> [a] -> [([a], Maybe [a])]
sections start stop as = case (bs,cs) of
([], []) -> []
(bs, []) -> [(bs, Nothing)]
(bs, [c]) -> [(bs, Nothing)]
(bs, cs) -> (bs, Just $ tail cs) : sections start stop (drop skip as)
where
(bs,cs) = sections1 start stop as
skip = length bs + length cs + 1
sections1 :: (a -> Bool) -> (a -> Bool) -> [a] -> ([a],[a])
sections1 start stop as =
(takeWhile (not . start) as, takeWhile (not . stop) $ dropWhile (not . start) as)
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')
oneOf :: (a -> Bool) -> (a -> Bool) -> a -> Bool
oneOf p q x = p x ||q x
parallel_ :: [IO ()] -> IO ()
parallel_ = foldb concurrently_ (return ())
concurrently_ :: IO a -> IO b -> IO ()
concurrently_ = concurrentlyWith (\x y -> ())
concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c
concurrentlyWith f x y = uncurry f <$> x `concurrently` y
foldb :: (a -> a -> a) -> a -> [a] -> a
foldb f z [] = z
foldb f z [x] = x
foldb f z xs = let (as,bs) = split xs
in foldb f z as `f` foldb f z bs
where
split xs = (take n xs, drop n xs) where n = length xs `div` 2
tryMaybe :: IO a -> IO (Maybe a)
tryMaybe action = do
r <- try action
return $case r of
Left e -> let e' = (e::SomeException) in Nothing
Right x -> Just x