diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,45 @@ +MIT License + +Copyright (c) 2016 Kadzuya OKAMOTO, http://www.arow.info + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +This project contains many codes from Michael Snoyman's [shakespearen template](http://hackage.haskell.org/package/shakespeare). +Here is the original copyright notice for shakespearen template: + +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/heterocephalus.cabal b/heterocephalus.cabal new file mode 100644 --- /dev/null +++ b/heterocephalus.cabal @@ -0,0 +1,53 @@ +name: heterocephalus +version: 0.1.0.0 +synopsis: A flexible and type safe template engine for Haskell. +description: Please see README.md +homepage: https://github.com/arowM/heterocephalus#readme +license: MIT +license-file: LICENSE +author: Kadzuya Okamoto +maintainer: arow.okamoto+github@gmail.com +copyright: 2016 Kadzuya Okamoto +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Text.Heterocephalus + other-modules: Text.Hamlet.Parse + , Text.Heterocephalus.Parse + build-depends: base >= 4.7 && < 5 + , blaze-html + , blaze-markup + , containers + , parsec + , shakespeare + , template-haskell + , text + default-language: Haskell2010 + +test-suite heterocephalus-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , heterocephalus + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctest.hs + build-depends: base + , Glob + , doctest + , heterocephalus + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/arowM/heterocephalus diff --git a/src/Text/Hamlet/Parse.hs b/src/Text/Hamlet/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hamlet/Parse.hs @@ -0,0 +1,740 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +module Text.Hamlet.Parse + ( Result (..) + , Content (..) + , Doc (..) + , parseDoc + , HamletSettings (..) + , defaultHamletSettings + , xhtmlHamletSettings + , CloseStyle (..) + , Binding (..) + , NewlineStyle (..) + , specialOrIdent + , DataConstr (..) + , Module (..) + ) + where + +import Text.Shakespeare.Base +import Control.Applicative ((<$>), Applicative (..)) +import Control.Monad +import Control.Arrow +import Data.Char (isUpper) +import Data.Data +import Text.ParserCombinators.Parsec hiding (Line) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe (mapMaybe, fromMaybe, isNothing) +import Language.Haskell.TH.Syntax (Lift (..)) + +data Result v = Error String | Ok v + deriving (Show, Eq, Read, Data, Typeable) +instance Monad Result where + return = Ok + Error s >>= _ = Error s + Ok v >>= f = f v + fail = Error +instance Functor Result where + fmap = liftM +instance Applicative Result where + pure = return + (<*>) = ap + +data Content = ContentRaw String + | ContentVar Deref + | ContentUrl Bool Deref -- ^ bool: does it include params? + | ContentEmbed Deref + | ContentMsg Deref + | ContentAttrs Deref + deriving (Show, Eq, Read, Data, Typeable) + +data Line = LineForall Deref Binding + | LineIf Deref + | LineElseIf Deref + | LineElse + | LineWith [(Deref, Binding)] + | LineMaybe Deref Binding + | LineNothing + | LineCase Deref + | LineOf Binding + | LineTag + { _lineTagName :: String + , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] + , _lineContent :: [Content] + , _lineClasses :: [(Maybe Deref, [Content])] + , _lineAttrs :: [Deref] + , _lineNoNewline :: Bool + } + | LineContent [Content] Bool -- ^ True == avoid newlines + deriving (Eq, Show, Read) + +parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) +parseLines set s = + case parse parser s s of + Left e -> Error $ show e + Right x -> Ok x + where + parser = do + mnewline <- parseNewline + let set' = + case mnewline of + Nothing -> + case hamletNewlines set of + DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } + _ -> set + Just n -> set { hamletNewlines = n } + res <- many (parseLine set') + return (mnewline, set', res) + + parseNewline = + (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> + return Nothing + parseNewline' = + (try (string "always") >> return (Just AlwaysNewlines)) <|> + (try (string "never") >> return (Just NoNewlines)) <|> + (try (string "text") >> return (Just NewlinesText)) + + eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + +parseLine :: HamletSettings -> Parser (Int, Line) +parseLine set = do + ss <- fmap sum $ many ((char ' ' >> return 1) <|> + (char '\t' >> fail "Tabs are not allowed in Hamlet indentation")) + x <- doctype <|> + doctypeDollar <|> + comment <|> + ssiInclude <|> + htmlComment <|> + doctypeRaw <|> + backslash <|> + controlIf <|> + controlElseIf <|> + (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> + controlMaybe <|> + (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> + controlForall <|> + controlWith <|> + controlCase <|> + controlOf <|> + angle <|> + invalidDollar <|> + (eol' >> return (LineContent [] True)) <|> + (do + (cs, avoidNewLines) <- content InContent + isEof <- (eof >> return True) <|> return False + if null cs && ss == 0 && isEof + then fail "End of Hamlet template" + else return $ LineContent cs avoidNewLines) + return (ss, x) + where + eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + eol = eof <|> eol' + doctype = do + try $ string "!!!" >> eol + return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True + doctypeDollar = do + _ <- try $ string "$doctype " + name <- many $ noneOf "\r\n" + eol + case lookup name $ hamletDoctypeNames set of + Nothing -> fail $ "Unknown doctype name: " ++ name + Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True + + doctypeRaw = do + x <- try $ string "" + x <- many nonComments + eol + return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables? + nonComments = (many1 $ noneOf "\r\n<") <|> (do + _ <- char '<' + (do + _ <- try $ string "!--" + _ <- manyTill anyChar $ try $ string "-->" + return "") <|> return "<") + backslash = do + _ <- char '\\' + (eol >> return (LineContent [ContentRaw "\n"] True)) + <|> (uncurry LineContent <$> content InContent) + controlIf = do + _ <- try $ string "$if" + spaces + x <- parseDeref + _ <- spaceTabs + eol + return $ LineIf x + controlElseIf = do + _ <- try $ string "$elseif" + spaces + x <- parseDeref + _ <- spaceTabs + eol + return $ LineElseIf x + binding = do + y <- identPattern + spaces + _ <- string "<-" + spaces + x <- parseDeref + _ <- spaceTabs + return (x,y) + bindingSep = char ',' >> spaceTabs + controlMaybe = do + _ <- try $ string "$maybe" + spaces + (x,y) <- binding + eol + return $ LineMaybe x y + controlForall = do + _ <- try $ string "$forall" + spaces + (x,y) <- binding + eol + return $ LineForall x y + controlWith = do + _ <- try $ string "$with" + spaces + bindings <- (binding `sepBy` bindingSep) `endBy` eol + return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] + controlCase = do + _ <- try $ string "$case" + spaces + x <- parseDeref + _ <- spaceTabs + eol + return $ LineCase x + controlOf = do + _ <- try $ string "$of" + spaces + x <- identPattern + _ <- spaceTabs + eol + return $ LineOf x + content cr = do + x <- many $ content' cr + case cr of + InQuotes -> void $ char '"' + NotInQuotes -> return () + NotInQuotesAttr -> return () + InContent -> eol + return (cc $ map fst x, any snd x) + where + cc [] = [] + cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c + cc (a:b) = a : cc b + content' cr = contentHash <|> contentAt <|> contentCaret + <|> contentUnder + <|> contentReg' cr + contentHash = do + x <- parseHash + case x of + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentVar deref, False) + contentAt = do + x <- parseAt + return $ case x of + Left str -> (ContentRaw str, null str) + Right (s, y) -> (ContentUrl y s, False) + contentCaret = do + x <- parseCaret + case x of + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentEmbed deref, False) + contentUnder = do + x <- parseUnder + case x of + Left str -> return (ContentRaw str, null str) + Right deref -> return (ContentMsg deref, False) + contentReg' x = (flip (,) False) <$> contentReg x + contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" + contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" + contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" + contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r" + tagAttribValue notInQuotes = do + cr <- (char '"' >> return InQuotes) <|> return notInQuotes + fst <$> content cr + tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes + tagCond = do + d <- between (char ':') (char ':') parseDeref + tagClass (Just d) <|> tagAttrib (Just d) + tagClass x = do + clazz <- char '.' >> tagAttribValue NotInQuotes + let hasHash (ContentRaw s) = any (== '#') s + hasHash _ = False + if any hasHash clazz + then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?" + else return (TagClass (x, clazz)) + tagAttrib cond = do + s <- many1 $ noneOf " \t=\r\n><" + v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing + return $ TagAttrib (cond, s, v) + + tagAttrs = do + _ <- char '*' + d <- between (char '{') (char '}') parseDeref + return $ TagAttribs d + + tag' = foldr tag'' ("div", [], [], []) + tag'' (TagName s) (_, y, z, as) = (s, y, z, as) + tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) + tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) + tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) + tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) + + ident :: Parser Ident + ident = do + i <- many1 (alphaNum <|> char '_' <|> char '\'') + white + return (Ident i) + "identifier" + + parens = between (char '(' >> white) (char ')' >> white) + + brackets = between (char '[' >> white) (char ']' >> white) + + braces = between (char '{' >> white) (char '}' >> white) + + comma = char ',' >> white + + atsign = char '@' >> white + + equals = char '=' >> white + + white = skipMany $ char ' ' + + wildDots = string ".." >> white + + isVariable (Ident (x:_)) = not (isUpper x) + isVariable (Ident []) = error "isVariable: bad identifier" + + isConstructor (Ident (x:_)) = isUpper x + isConstructor (Ident []) = error "isConstructor: bad identifier" + + identPattern :: Parser Binding + identPattern = gcon True <|> apat + where + apat = choice + [ varpat + , gcon False + , parens tuplepat + , brackets listpat + ] + + varpat = do + v <- try $ do v <- ident + guard (isVariable v) + return v + option (BindVar v) $ do + atsign + b <- apat + return (BindAs v b) + "variable" + + gcon :: Bool -> Parser Binding + gcon allowArgs = do + c <- try $ do c <- dataConstr + return c + choice + [ record c + , fmap (BindConstr c) (guard allowArgs >> many apat) + , return (BindConstr c []) + ] + "constructor" + + dataConstr = do + p <- dcPiece + ps <- many dcPieces + return $ toDataConstr p ps + + dcPiece = do + x@(Ident y) <- ident + guard $ isConstructor x + return y + + dcPieces = do + _ <- char '.' + dcPiece + + toDataConstr x [] = DCUnqualified $ Ident x + toDataConstr x (y:ys) = + go (x:) y ys + where + go front next [] = DCQualified (Module $ front []) (Ident next) + go front next (rest:rests) = go (front . (next:)) rest rests + + record c = braces $ do + (fields, wild) <- option ([], False) $ go + return (BindRecord c fields wild) + where + go = (wildDots >> return ([], True)) + <|> (do x <- recordField + (xs,wild) <- option ([],False) (comma >> go) + return (x:xs,wild)) + + recordField = do + field <- ident + p <- option (BindVar field) -- support punning + (equals >> identPattern) + return (field,p) + + tuplepat = do + xs <- identPattern `sepBy` comma + return $ case xs of + [x] -> x + _ -> BindTuple xs + + listpat = BindList <$> identPattern `sepBy` comma + + angle = do + _ <- char '<' + name' <- many $ noneOf " \t.#\r\n!>" + let name = if null name' then "div" else name' + xs <- many $ try ((many $ oneOf " \t\r\n") >> + (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) + _ <- many $ oneOf " \t\r\n" + _ <- char '>' + (c, avoidNewLines) <- content InContent + let (tn, attr, classes, attrsd) = tag' $ TagName name : xs + if '/' `elem` tn + then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." + else return $ LineTag tn attr c classes attrsd avoidNewLines + +data TagPiece = TagName String + | TagIdent [Content] + | TagClass (Maybe Deref, [Content]) + | TagAttrib (Maybe Deref, String, Maybe [Content]) + | TagAttribs Deref + deriving Show + +data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent + +data Nest = Nest Line [Nest] + +nestLines :: [(Int, Line)] -> [Nest] +nestLines [] = [] +nestLines ((i, l):rest) = + let (deeper, rest') = span (\(i', _) -> i' > i) rest + in Nest l (nestLines deeper) : nestLines rest' + +data Doc = DocForall Deref Binding [Doc] + | DocWith [(Deref, Binding)] [Doc] + | DocCond [(Deref, [Doc])] (Maybe [Doc]) + | DocMaybe Deref Binding [Doc] (Maybe [Doc]) + | DocCase Deref [(Binding, [Doc])] + | DocContent Content + deriving (Show, Eq, Read, Data, Typeable) + +nestToDoc :: HamletSettings -> [Nest] -> Result [Doc] +nestToDoc _set [] = Ok [] +nestToDoc set (Nest (LineForall d i) inside:rest) = do + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + Ok $ DocForall d i inside' : rest' +nestToDoc set (Nest (LineWith dis) inside:rest) = do + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + Ok $ DocWith dis inside' : rest' +nestToDoc set (Nest (LineIf d) inside:rest) = do + inside' <- nestToDoc set inside + (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest + rest'' <- nestToDoc set rest' + Ok $ DocCond ifs el : rest'' +nestToDoc set (Nest (LineMaybe d i) inside:rest) = do + inside' <- nestToDoc set inside + (nothing, rest') <- + case rest of + Nest LineNothing ninside:x -> do + ninside' <- nestToDoc set ninside + return (Just ninside', x) + _ -> return (Nothing, rest) + rest'' <- nestToDoc set rest' + Ok $ DocMaybe d i inside' nothing : rest'' +nestToDoc set (Nest (LineCase d) inside:rest) = do + let getOf (Nest (LineOf x) insideC) = do + insideC' <- nestToDoc set insideC + Ok (x, insideC') + getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard." + cases <- mapM getOf inside + rest' <- nestToDoc set rest + Ok $ DocCase d cases : rest' +nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do + let attrFix (x, y, z) = (x, y, [(Nothing, z)]) + let takeClass (a, "class", b) = Just (a, fromMaybe [] b) + takeClass _ = Nothing + let clazzes = classes ++ mapMaybe takeClass attrs + let notClass (_, x, _) = x /= "class" + let noclass = filter notClass attrs + let attrs' = + case clazzes of + [] -> map attrFix noclass + _ -> (testIncludeClazzes clazzes, "class", map (second Just) clazzes) + : map attrFix noclass + let closeStyle = + if not (null content) || not (null inside) + then CloseSeparate + else hamletCloseStyle set tn + let end = case closeStyle of + CloseSeparate -> + DocContent $ ContentRaw $ "" + _ -> DocContent $ ContentRaw "" + seal = case closeStyle of + CloseInside -> DocContent $ ContentRaw "/>" + _ -> DocContent $ ContentRaw ">" + start = DocContent $ ContentRaw $ "<" ++ tn + attrs'' = concatMap attrToContent attrs' + newline' = DocContent $ ContentRaw + $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + Ok $ start + : attrs'' + ++ map (DocContent . ContentAttrs) attrsD + ++ seal + : map DocContent content + ++ inside' + ++ end + : newline' + : rest' +nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do + inside' <- nestToDoc set inside + rest' <- nestToDoc set rest + let newline' = DocContent $ ContentRaw + $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } + nextIsContent = + case (inside, rest) of + ([], Nest LineContent{} _:_) -> True + ([], Nest LineTag{} _:_) -> True + _ -> False + Ok $ map DocContent content ++ newline':inside' ++ rest' +nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" +nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" +nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing" +nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)" + +compressDoc :: [Doc] -> [Doc] +compressDoc [] = [] +compressDoc (DocForall d i doc:rest) = + DocForall d i (compressDoc doc) : compressDoc rest +compressDoc (DocWith dis doc:rest) = + DocWith dis (compressDoc doc) : compressDoc rest +compressDoc (DocMaybe d i doc mnothing:rest) = + DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing) + : compressDoc rest +compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest) + | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest +compressDoc (DocCond x y:rest) = + DocCond (map (second compressDoc) x) (compressDoc `fmap` y) + : compressDoc rest +compressDoc (DocCase d cs:rest) = + DocCase d (map (second compressDoc) cs) : compressDoc rest +compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest +compressDoc ( DocContent (ContentRaw x) + : DocContent (ContentRaw y) + : rest + ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest +compressDoc (DocContent x:rest) = DocContent x : compressDoc rest + +parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc]) +parseDoc set s = do + (mnl, set', ls) <- parseLines set s + let notEmpty (_, LineContent [] _) = False + notEmpty _ = True + let ns = nestLines $ filter notEmpty ls + ds <- nestToDoc set' ns + return (mnl, compressDoc ds) + +attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] +attrToContent (Just cond, k, v) = + [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] +attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] +attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] +attrToContent (Nothing, k, [(Nothing, Just v)]) = + DocContent (ContentRaw (' ' : k ++ "=\"")) + : map DocContent v + ++ [DocContent $ ContentRaw "\""] +attrToContent (Nothing, k, v) = -- only for class + DocContent (ContentRaw (' ' : k ++ "=\"")) + : concatMap go (init v) + ++ go' (last v) + ++ [DocContent $ ContentRaw "\""] + where + go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] + go (Just b, x) = + [ DocCond + [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] + Nothing + ] + go' (Nothing, x) = maybe [] (map DocContent) x + go' (Just b, x) = + [ DocCond + [(b, maybe [] (map DocContent) x)] + Nothing + ] + +-- | Settings for parsing of a hamlet document. +data HamletSettings = HamletSettings + { + -- | The value to replace a \"!!!\" with. Do not include the trailing + -- newline. + hamletDoctype :: String + -- | Should we add newlines to the output, making it more human-readable? + -- Useful for client-side debugging but may alter browser page layout. + , hamletNewlines :: NewlineStyle + -- | How a tag should be closed. Use this to switch between HTML, XHTML + -- or even XML output. + , hamletCloseStyle :: String -> CloseStyle + -- | Mapping from short names in \"$doctype\" statements to full doctype. + , hamletDoctypeNames :: [(String, String)] + } + +data NewlineStyle = NoNewlines -- ^ never add newlines + | NewlinesText -- ^ add newlines between consecutive text lines + | AlwaysNewlines -- ^ add newlines everywhere + | DefaultNewlineStyle + deriving Show + +instance Lift NewlineStyle where + lift NoNewlines = [|NoNewlines|] + lift NewlinesText = [|NewlinesText|] + lift AlwaysNewlines = [|AlwaysNewlines|] + lift DefaultNewlineStyle = [|DefaultNewlineStyle|] + +instance Lift (String -> CloseStyle) where + lift _ = [|\s -> htmlCloseStyle s|] + +instance Lift HamletSettings where + lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|] + + +-- See the html specification for a list of all void elements: +-- https://www.w3.org/TR/html/syntax.html#void-elements +htmlEmptyTags :: Set String +htmlEmptyTags = Set.fromAscList + [ "area" + , "base" + , "basefont" -- not html 5 + , "br" + , "col" + , "embed" + , "frame" -- not html 5 + , "hr" + , "img" + , "input" + , "isindex" -- not html 5 + , "keygen" + , "link" + , "meta" + , "param" + , "source" + , "track" + , "wbr" + ] + +-- | Defaults settings: HTML5 doctype and HTML-style empty tags. +defaultHamletSettings :: HamletSettings +defaultHamletSettings = HamletSettings "" DefaultNewlineStyle htmlCloseStyle doctypeNames + +xhtmlHamletSettings :: HamletSettings +xhtmlHamletSettings = + HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames + where + doctype = + "" + +htmlCloseStyle :: String -> CloseStyle +htmlCloseStyle s = + if Set.member s htmlEmptyTags + then NoClose + else CloseSeparate + +xhtmlCloseStyle :: String -> CloseStyle +xhtmlCloseStyle s = + if Set.member s htmlEmptyTags + then CloseInside + else CloseSeparate + +data CloseStyle = NoClose | CloseInside | CloseSeparate + +parseConds :: HamletSettings + -> ([(Deref, [Doc])] -> [(Deref, [Doc])]) + -> [Nest] + -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest]) +parseConds set front (Nest LineElse inside:rest) = do + inside' <- nestToDoc set inside + Ok (front [], Just inside', rest) +parseConds set front (Nest (LineElseIf d) inside:rest) = do + inside' <- nestToDoc set inside + parseConds set (front . (:) (d, inside')) rest +parseConds _ front rest = Ok (front [], Nothing, rest) + +doctypeNames :: [(String, String)] +doctypeNames = + [ ("5", "") + , ("html", "") + , ("1.1", "") + , ("strict", "") + ] + +data Binding = BindVar Ident + | BindAs Ident Binding + | BindConstr DataConstr [Binding] + | BindTuple [Binding] + | BindList [Binding] + | BindRecord DataConstr [(Ident, Binding)] Bool + deriving (Eq, Show, Read, Data, Typeable) + +data DataConstr = DCQualified Module Ident + | DCUnqualified Ident + deriving (Eq, Show, Read, Data, Typeable) + +newtype Module = Module [String] + deriving (Eq, Show, Read, Data, Typeable) + +spaceTabs :: Parser String +spaceTabs = many $ oneOf " \t" + +-- | When using conditional classes, it will often be a single class, e.g.: +-- +-- >
+-- +-- If isHome is False, we do not want any class attribute to be present. +-- However, due to combining multiple classes together, the most obvious +-- implementation would produce a class="". The purpose of this function is to +-- work around that. It does so by checking if all the classes on this tag are +-- optional. If so, it will only include the class attribute if at least one +-- conditional is true. +testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref +testIncludeClazzes cs + | any (isNothing . fst) cs = Nothing + | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs + +-- | This funny hack is to allow us to refer to the 'or' function without +-- requiring the user to have it in scope. See how this function is used in +-- Text.Hamlet. +specialOrIdent :: Ident +specialOrIdent = Ident "__or__hamlet__special" diff --git a/src/Text/Heterocephalus.hs b/src/Text/Heterocephalus.hs new file mode 100644 --- /dev/null +++ b/src/Text/Heterocephalus.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Text.Heterocephalus + ( + -- * Core functions + compile + , compileFile + + -- * low-level + , compileFromString + ) where + +import Data.Char (isDigit) +import qualified Data.Foldable as F +import Data.List (intercalate) +import Data.Text (Text, pack) +import qualified Data.Text.Lazy as TL +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax hiding (Module) +import Text.Blaze.Html (toHtml) +import Text.Blaze.Internal (preEscapedText) +import Text.Hamlet +import Text.Hamlet.Parse + hiding (defaultHamletSettings, parseDoc, HamletSettings) +import Text.Shakespeare.Base + +import Text.Heterocephalus.Parse (parseDoc) + +{- $setup + >>> :set -XTemplateHaskell -XQuasiQuotes + >>> import Text.Blaze.Html.Renderer.String +-} + +{-| Heterocephalus quasi-quoter. + + >>> renderHtml (let as = ["a", "b"] in [compile|sample %{ forall a <- as }key: #{a}, %{ endforall }|] "") + "sample key: a, key: b, " + + >>> renderHtml (let num=2 in [compile|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|] "") + "2 is even number." + -} +compile :: QuasiQuoter +compile = compileWithSettings hamletRules defaultHamletSettings + +{-| Compile a template file. +-} +compileFile :: FilePath -> Q Exp +compileFile = compileFileWithSettings hamletRules defaultHamletSettings + +compileWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter +compileWithSettings hr set = + QuasiQuoter + { quoteExp = compileFromString hr set + , quotePat = error "not used" + , quoteType = error "not used" + , quoteDec = error "not used" + } + +compileFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp +compileFileWithSettings qhr set fp = do + qAddDependentFile fp + contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp + compileFromString qhr set contents + +compileFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp +compileFromString qhr set s = do + hr <- qhr + hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s + +docFromString :: HamletSettings -> String -> [Doc] +docFromString _ s = + case parseDoc s of + Error s' -> error s' + Ok d -> d + + +-- ============================================== +-- Codes from Text.Hamlet that is not exposed +-- ============================================== + +docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp +docsToExp env hr scope docs = do + exps <- mapM (docToExp env hr scope) docs + case exps of + [] -> [|return ()|] + [x] -> return x + _ -> return $ DoE $ map NoBindS exps + +unIdent :: Ident -> String +unIdent (Ident s) = s + +bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) +bindingPattern (BindAs i@(Ident s) b) = do + name <- newName s + (pattern, scope) <- bindingPattern b + return (AsP name pattern, (i, VarE name) : scope) +bindingPattern (BindVar i@(Ident s)) + | s == "_" = return (WildP, []) + | all isDigit s = do return (LitP $ IntegerL $ read s, []) + | otherwise = do + name <- newName s + return (VarP name, [(i, VarE name)]) +bindingPattern (BindTuple is) = do + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (TupP patterns, concat scopes) +bindingPattern (BindList is) = do + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (ListP patterns, concat scopes) +bindingPattern (BindConstr con is) = do + (patterns, scopes) <- fmap unzip $ mapM bindingPattern is + return (ConP (mkConName con) patterns, concat scopes) +bindingPattern (BindRecord con fields wild) = do + let f (Ident field, b) = do + (p, s) <- bindingPattern b + return ((mkName field, p), s) + (patterns, scopes) <- fmap unzip $ mapM f fields + (patterns1, scopes1) <- + if wild + then bindWildFields con $ map fst fields + else return ([], []) + return + (RecP (mkConName con) (patterns ++ patterns1), concat scopes ++ scopes1) + +mkConName :: DataConstr -> Name +mkConName = mkName . conToStr + +conToStr :: DataConstr -> String +conToStr (DCUnqualified (Ident x)) = x +conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] + +-- Wildcards bind all of the unbound fields to variables whose name +-- matches the field name. +-- +-- For example: data R = C { f1, f2 :: Int } +-- C {..} is equivalent to C {f1=f1, f2=f2} +-- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2} +-- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a} +bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]) +bindWildFields conName fields = do + fieldNames <- recordToFieldNames conName + let available n = nameBase n `notElem` map unIdent fields + let remainingFields = filter available fieldNames + let mkPat n = do + e <- newName (nameBase n) + return ((n, VarP e), (Ident (nameBase n), VarE e)) + fmap unzip $ mapM mkPat remainingFields + +-- Important note! reify will fail if the record type is defined in the +-- same module as the reify is used. This means quasi-quoted Hamlet +-- literals will not be able to use wildcards to match record types +-- defined in the same module. +recordToFieldNames :: DataConstr -> Q [Name] +recordToFieldNames conStr + -- use 'lookupValueName' instead of just using 'mkName' so we reify the + -- data constructor and not the type constructor if their names match. + = do + Just conName <- lookupValueName $ conToStr conStr + DataConI _ _ typeName <- reify conName + TyConI (DataD _ _ _ _ cons _) <- reify typeName + [fields] <- return [fields | RecC name fields <- cons, name == conName] + return [fieldName | (fieldName, _, _) <- fields] + +docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp +docToExp env hr scope (DocForall list idents inside) = do + let list' = derefToExp scope list + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope + mh <- [|F.mapM_|] + inside' <- docsToExp env hr scope' inside + let lam = LamE [pat] inside' + return $ mh `AppE` lam `AppE` list' +docToExp env hr scope (DocWith [] inside) = do + inside' <- docsToExp env hr scope inside + return $ inside' +docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do + let deref' = derefToExp scope deref + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope + inside' <- docToExp env hr scope' (DocWith dis inside) + let lam = LamE [pat] inside' + return $ lam `AppE` deref' +docToExp env hr scope (DocMaybe val idents inside mno) = do + let val' = derefToExp scope val + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope + inside' <- docsToExp env hr scope' inside + let inside'' = LamE [pat] inside' + ninside' <- + case mno of + Nothing -> [|Nothing|] + Just no -> do + no' <- docsToExp env hr scope no + j <- [|Just|] + return $ j `AppE` no' + mh <- [|maybeH|] + return $ mh `AppE` val' `AppE` inside'' `AppE` ninside' +docToExp env hr scope (DocCond conds final) = do + conds' <- mapM go conds + final' <- + case final of + Nothing -> [|Nothing|] + Just f -> do + f' <- docsToExp env hr scope f + j <- [|Just|] + return $ j `AppE` f' + ch <- [|condH|] + return $ ch `AppE` ListE conds' `AppE` final' + where + go :: (Deref, [Doc]) -> Q Exp + go (d, docs) = do + let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d + docs' <- docsToExp env hr scope docs + return $ TupE [d', docs'] +docToExp env hr scope (DocCase deref cases) = do + let exp_ = derefToExp scope deref + matches <- mapM toMatch cases + return $ CaseE exp_ matches + where + toMatch :: (Binding, [Doc]) -> Q Match + toMatch (idents, inside) = do + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope + insideExp <- docsToExp env hr scope' inside + return $ Match pat (NormalB insideExp) [] +docToExp env hr v (DocContent c) = contentToExp env hr v c + +contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp +contentToExp _ hr _ (ContentRaw s) = do + os <- [|preEscapedText . pack|] + let s' = LitE $ StringL s + return $ hrFromHtml hr `AppE` (os `AppE` s') +contentToExp _ hr scope (ContentVar d) = do + str <- [|toHtml|] + return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d) +contentToExp env hr scope (ContentUrl hasParams d) = + case urlRender env of + Nothing -> error "URL interpolation used, but no URL renderer provided" + Just wrender -> + wrender $ \render -> do + let render' = return render + ou <- + if hasParams + then [|\(u, p) -> $(render') u p|] + else [|\u -> $(render') u []|] + let d' = derefToExp scope d + pet <- [|toHtml|] + return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d')) +contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d +contentToExp env hr scope (ContentMsg d) = + case msgRender env of + Nothing -> + error "Message interpolation used, but no message renderer provided" + Just wrender -> + wrender $ \render -> + return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d) +contentToExp _ hr scope (ContentAttrs d) = do + html <- [|attrsToHtml . toAttributes|] + return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d) + +type QueryParameters = [(Text, Text)] + +data VarExp msg url + = EPlain Html + | EUrl url + | EUrlParam (url, QueryParameters) + | EMixin (HtmlUrl url) + | EMixinI18n (HtmlUrlI18n msg url) + | EMsg msg + +instance Show (VarExp msg url) where + show (EPlain _) = "EPlain" + show (EUrl _) = "EUrl" + show (EUrlParam _) = "EUrlParam" + show (EMixin _) = "EMixin" + show (EMixinI18n _) = "EMixinI18n" + show (EMsg _) = "EMsg" diff --git a/src/Text/Heterocephalus/Parse.hs b/src/Text/Heterocephalus/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/Heterocephalus/Parse.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Text.Heterocephalus.Parse where + +import Control.Monad +import Data.Char (isUpper) +import Data.Data +import Text.Parsec.Prim (Parsec) +import Text.ParserCombinators.Parsec hiding (Line) +import Text.Shakespeare.Base + +import Text.Hamlet.Parse hiding (parseDoc) + +data Control + = ControlForall Deref Binding + | ControlEndForall + | ControlIf Deref + | ControlElseIf Deref + | ControlElse + | ControlEndIf + | NoControl Content + deriving (Show, Eq, Read, Data, Typeable) + +type UserParser a = Parsec String a + +docFromString :: String -> [Doc] +docFromString s = + case parseDoc s of + Error s' -> error s' + Ok d -> d + +parseDoc :: String -> Result [Doc] +parseDoc s = do + controls <- concat <$> mapM parseLineControl (lines s) + return $ controlsToDocs controls + +controlsToDocs :: [Control] -> [Doc] +controlsToDocs [] = [] +controlsToDocs (ControlForall d b:cs) = + let (inner, rest) = parseReps 0 cs + in (DocForall d b $ controlsToDocs inner) : controlsToDocs rest +controlsToDocs (ControlIf d:cs) = + let (inner, el, rest) = parseConds 0 cs + in DocCond [(d, controlsToDocs inner)] (fmap controlsToDocs el) : + controlsToDocs rest +controlsToDocs (NoControl c:cs) = DocContent c : controlsToDocs cs +controlsToDocs cs = error $ "Parse error: " ++ show cs + +-- TODO parse elseif +parseConds :: Int -> [Control] -> ([Control], Maybe [Control], [Control]) +parseConds _ [] = error "No endif found" +parseConds depth (x:xs') + | depth < 0 = + error "A `endif` keyword without any corresponding `if` was found." + | depth == 0 && isEndIf x = ([], Nothing, xs') + | depth == 0 && isElse x = + let (ys, may, zs) = parseConds depth xs' + in case may of + Nothing -> ([], Just ys, zs) + Just _ -> + error "A `if` clause can not have more than one `else` keyword." + | isEndIf x = + let (ys, may, zs) = parseConds (depth - 1) xs' + in (x : ys, may, zs) + | isIf x = + let (ys, may, zs) = parseConds (depth + 1) xs' + in (x : ys, may, zs) + | otherwise = + let (ys, may, zs) = parseConds depth xs' + in (x : ys, may, zs) + where + isIf (ControlIf _) = True + isIf _ = False + isEndIf ControlEndIf = True + isEndIf _ = False + isElse ControlElse = True + isElse _ = False + +parseReps :: Int -> [Control] -> ([Control], [Control]) +parseReps _ [] = error "No endforall found" +parseReps depth (x:xs') + | depth < 0 = + error "A `endforall` keyword without any corresponding `for` was found." + | depth == 0 && isEndForall x = ([], xs') + | isEndForall x = + let (ys, zs) = parseReps (depth - 1) xs' + in (x : ys, zs) + | isForall x = + let (ys, zs) = parseReps (depth + 1) xs' + in (x : ys, zs) + | otherwise = + let (ys, zs) = parseReps depth xs' + in (x : ys, zs) + where + isEndForall ControlEndForall = True + isEndForall _ = False + isForall (ControlForall _ _) = True + isForall _ = False + +parseLineControl :: String -> Result [Control] +parseLineControl s = + case parse lineControl s s of + Left e -> Error $ show e + Right x -> Ok x + +lineControl :: UserParser () [Control] +lineControl = manyTill control $ try eof >> return () + +control :: UserParser () Control +control = controlHash <|> controlCaret <|> controlPercent <|> controlReg + where + controlPercent = do + x <- parsePercent + case x of + Left str -> return (NoControl $ ContentRaw str) + Right ctrl -> return ctrl + controlHash = do + x <- parseHash + return . NoControl $ + case x of + Left str -> ContentRaw str + Right deref -> ContentVar deref + controlCaret = do + x <- parseCaret + return . NoControl $ + case x of + Left str -> ContentRaw str + Right deref -> ContentEmbed deref + controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%^\r\n") + +parsePercent :: UserParser () (Either String Control) +parsePercent = parseControl '%' + +parseControl :: Char -> UserParser () (Either String Control) +parseControl c = do + _ <- char c + (char '\\' >> return (Left [c])) <|> + (do ctrl <- + between (char '{') (char '}') $ do + spaces + x <- parseControl' + spaces + return x + return $ Right ctrl) <|> + return (Left [c]) + + +parseControl' :: UserParser () Control +parseControl' = + try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElseIf <|> + try parseElse <|> + try parseEndIf + where + parseForall = do + _ <- try $ string "forall" + spaces + (x, y) <- binding + return $ ControlForall x y + parseEndForall = do + _ <- try $ string "endforall" + return $ ControlEndForall + parseIf = do + _ <- try $ string "if" + spaces + x <- parseDeref + return $ ControlIf x + parseElseIf = do + _ <- try $ string "elseif" + spaces + x <- parseDeref + return $ ControlElseIf x + parseElse = do + _ <- try $ string "else" + return $ ControlElse + parseEndIf = do + _ <- try $ string "endif" + return $ ControlEndIf + binding = do + y <- identPattern + spaces + _ <- string "<-" + spaces + x <- parseDeref + _ <- spaceTabs + return (x, y) + spaceTabs :: Parser String + spaceTabs = many $ oneOf " \t" + ident :: Parser Ident + ident = + do i <- many1 (alphaNum <|> char '_' <|> char '\'') + white + return (Ident i) "identifier" + parens = between (char '(' >> white) (char ')' >> white) + brackets = between (char '[' >> white) (char ']' >> white) + braces = between (char '{' >> white) (char '}' >> white) + comma = char ',' >> white + atsign = char '@' >> white + equals = char '=' >> white + white = skipMany $ char ' ' + wildDots = string ".." >> white + isVariable (Ident (x:_)) = not (isUpper x) + isVariable (Ident []) = error "isVariable: bad identifier" + isConstructor (Ident (x:_)) = isUpper x + isConstructor (Ident []) = error "isConstructor: bad identifier" + identPattern :: Parser Binding + identPattern = gcon True <|> apat + where + apat = choice [varpat, gcon False, parens tuplepat, brackets listpat] + varpat = + do v <- + try $ do + v <- ident + guard (isVariable v) + return v + option (BindVar v) $ do + atsign + b <- apat + return (BindAs v b) "variable" + gcon :: Bool -> Parser Binding + gcon allowArgs = + do c <- + try $ do + c <- dataConstr + return c + choice + [ record c + , fmap (BindConstr c) (guard allowArgs >> many apat) + , return (BindConstr c []) + ] "constructor" + dataConstr = do + p <- dcPiece + ps <- many dcPieces + return $ toDataConstr p ps + dcPiece = do + x@(Ident y) <- ident + guard $ isConstructor x + return y + dcPieces = do + _ <- char '.' + dcPiece + toDataConstr x [] = DCUnqualified $ Ident x + toDataConstr x (y:ys) = go (x :) y ys + where + go front next [] = DCQualified (Module $ front []) (Ident next) + go front next (rest:rests) = go (front . (next :)) rest rests + record c = + braces $ do + (fields, wild) <- option ([], False) $ go + return (BindRecord c fields wild) + where + go = + (wildDots >> return ([], True)) <|> + (do x <- recordField + (xs, wild) <- option ([], False) (comma >> go) + return (x : xs, wild)) + recordField = do + field <- ident + p <- + option + (BindVar field) -- support punning + (equals >> identPattern) + return (field, p) + tuplepat = do + xs <- identPattern `sepBy` comma + return $ + case xs of + [x] -> x + _ -> BindTuple xs + listpat = BindList <$> identPattern `sepBy` comma diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,17 @@ +module Main where + +import Data.Monoid ((<>)) +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doDocTest + +doDocTest :: [String] -> IO () +doDocTest options = doctest $ options <> ghcExtensions + +ghcExtensions :: [String] +ghcExtensions = + [ "-XTemplateHaskell" + , "-XQuasiQuotes" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"