module Text.QuasiMake (Chunk (..), getChunks) where
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
import Language.Haskell.Meta (parseExp)
import Data.Attoparsec.Text
import qualified Data.Text as T
import Data.Text (Text)
import Data.Char
import Data.Monoid
import Control.Applicative
instance Lift Text where
lift = litE . stringL . T.unpack
data Chunk
= T Text
| E Char Text
deriving (Show, Eq)
class Textish a where
toText :: a -> Text
instance Textish Text where
toText x = x
instance Textish [Char] where
toText x = T.pack x
instance Show a => Textish a where
toText x = T.pack (show x)
getChunks :: Text -> [Chunk]
getChunks i = case parseOnly parser (T.strip i) of
Right m -> m
_ -> error "Unclosed parenthesis."
where
parenthesis '(' = True
parenthesis ')' = True
parenthesis _ = False
parseExpression :: Int -> Parser [Text]
parseExpression level = do
expr <- takeTill parenthesis
paren <- anyChar
case paren of
')' | level <= 0 -> return [expr]
| otherwise -> do
next <- parseExpression (level 1)
return ([expr, ")"] ++ next)
'(' -> do
next <- parseExpression (level + 1)
return ([expr, "("] ++ next)
_ -> return [expr, T.singleton paren]
parser :: Parser [Chunk]
parser = fmap concat $ flip manyTill endOfInput $ do
text <- takeTill (\c -> elem c "@$")
end <- atEnd
if end
then return [T text]
else do
delim <- anyChar
next <- anyChar
case next of
'(' -> do
expr <- T.concat <$> parseExpression 0
return [T text, E delim expr]
c | c == delim -> do
return [T (text <> T.singleton delim)]
| otherwise -> do
name <- takeTill (\c -> not (isAlphaNum c || c == '_') )
return [T text, E delim (T.cons next name)]