heterocephalus (empty) → 0.1.0.0
raw patch · 8 files changed
+1408/−0 lines, 8 filesdep +Globdep +basedep +blaze-htmlsetup-changed
Dependencies added: Glob, base, blaze-html, blaze-markup, containers, doctest, heterocephalus, parsec, shakespeare, template-haskell, text
Files
- LICENSE +45/−0
- Setup.hs +2/−0
- heterocephalus.cabal +53/−0
- src/Text/Hamlet/Parse.hs +740/−0
- src/Text/Heterocephalus.hs +276/−0
- src/Text/Heterocephalus/Parse.hs +273/−0
- test/Doctest.hs +17/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ heterocephalus.cabal view
@@ -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
+ src/Text/Hamlet/Parse.hs view
@@ -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 "<!"+ y <- many $ noneOf "\r\n"+ eol+ return $ LineContent [ContentRaw $ concat [x, y, "\n"]] True++ invalidDollar = do+ _ <- char '$'+ fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash."+ comment = do+ _ <- try $ string "$#"+ _ <- many $ noneOf "\r\n"+ eol+ return $ LineContent [] True+ ssiInclude = do+ x <- try $ string "<!--#"+ y <- many $ noneOf "\r\n"+ eol+ return $ LineContent [ContentRaw $ x ++ y] False+ htmlComment = do+ _ <- try $ string "<!--"+ _ <- manyTill anyChar $ 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 $ "</" ++ tn ++ ">"+ _ -> 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 "<!DOCTYPE html>" DefaultNewlineStyle htmlCloseStyle doctypeNames++xhtmlHamletSettings :: HamletSettings+xhtmlHamletSettings =+ HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames+ where+ doctype =+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " +++ "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"++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", "<!DOCTYPE html>")+ , ("html", "<!DOCTYPE html>")+ , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")+ , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")+ ]++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.:+--+-- > <div :isHome:.homepage>+--+-- 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"
+ src/Text/Heterocephalus.hs view
@@ -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"
+ src/Text/Heterocephalus/Parse.hs view
@@ -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
+ test/Doctest.hs view
@@ -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"+ ]
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"