heterocephalus 1.0.2.3 → 1.0.3.0
raw patch · 8 files changed
+546/−386 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−0
- README.md +45/−6
- heterocephalus.cabal +6/−3
- src/Text/Hamlet/Parse.hs +4/−19
- src/Text/Heterocephalus.hs +16/−5
- src/Text/Heterocephalus/Parse.hs +15/−353
- src/Text/Heterocephalus/Parse/Control.hs +321/−0
- src/Text/Heterocephalus/Parse/Doc.hs +132/−0
CHANGELOG.md view
@@ -1,6 +1,13 @@ Change Log ========== +Version 1.0.3.0 (2017-01-24)+----------------++### New features++* Add `case` control statement+ Version 1.0.2.0 (2016-12-13) ----------------------------
README.md view
@@ -37,7 +37,8 @@ and JavaScript ([Julius](https://hackage.haskell.org/package/shakespeare-2.0.11.2/docs/Text-Julius.html)). If you use these original markup languages, it is possible to use control-statements like `forall` (for looping) and `if` (for conditionals).+statements like `forall` (for looping), `if` (for conditionals), and `case`+(for case-splitting). However, if you're using any other markup language (like [pug](https://pugjs.org), [slim](http://slim-lang.com/),@@ -45,7 +46,7 @@ provides you with the [Text.Shakespeare.Text](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html) module. This gives you variable interpolation, but no control statements like-`forall` or `if`.+`forall`, `if`, or `case`. [`Haiji`](https://hackage.haskell.org/package/haiji) is another interesting library. It has all the features we require, but its templates take a very@@ -66,18 +67,18 @@ * __DO__ expand the template literal on compile time -* __DO__ provide a way to use `forall` and `if` in the template+* __DO__ provide a way to use `forall`, `if`, and `case` statments in the template `Text.Shakespeare.Text.text` has a way to do variable interpolation, but no way to use these types of control statements. -* __DO NOT__ enforce templates to obey a peculiar syntax+* __DO NOT__ enforce that templates obey a peculiar syntax Shakespeare templates make you use their original style (Hamlet, Cassius, Lucius, Julius, etc). The [`Text.Shakespeare.Text.text`](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html#v:text) function does not require you to use any particular style, but it does not- have control statements like `forall` and `if`.+ have control statements like `forall`, `if` and `case`. This makes it impossible to use Shakespeare with another template engine such as `pug` in front end side. It is not suitable for recent rich front@@ -93,7 +94,7 @@ Other template engines like [EDE](https://hackage.haskell.org/package/ede) provide rich control statements like importing external files. Heterocephalus does not provide control statements like this because it is- supposed to be used with a rich front-end template engine (like pug, slim,+ meant to be used with a rich front-end template engine (like pug, slim, etc). ## Usage@@ -188,6 +189,44 @@ #{num} is odd number. %{ endif } ```++```+%{ if (num < 30) }+#{ num } is less than 30.+%{ elseif (num <= 60) }+#{ num } is between 30 and 60.+%{ else }+#{ num } is over 60.+%{ endif }+```++#### Case++```+%{ case maybeNum }+%{ of Just 3 }+num is 3.+%{ of Just num }+num is not 3, but #{num}.+%{ of Nothing }+num is not anything.+%{ endif }+```++```+%{ case nums }+%{ of (:) n _ }+first num is #{n}.+%{ of [] }+no nums.+%{ endif }+```++#### Why we do not provide `maybe` and `with`?++TODO++Discussions about this topic is on [issue #9](https://github.com/arowM/heterocephalus/issues/9). ## Why "heterocephalus"?
heterocephalus.cabal view
@@ -1,17 +1,17 @@ name: heterocephalus-version: 1.0.2.3+version: 1.0.3.0 synopsis: A type-safe template engine for working with popular front end development tools description: Recent front end development tools and languages are growing fast and have quite a complicated ecosystem. Few front end developers want to be forced- use Shakespeare templates. Instead, they would rather use @node@ friendly+ use Shakespeare templates. Instead, they would rather use @node@-friendly engines such that @pug@, @slim@, and @haml@. However, in using these template engines, we lose the compile-time variable interpolation and type checking from Shakespeare. . Heterocephalus is intended for use with another feature rich template engine and provides a way to interpolate server side variables into a- precompiled template file with @forall@ and @if@ statements.+ precompiled template file with @forall@, @if@, and @case@ statements. homepage: https://github.com/arowM/heterocephalus#readme license: MIT@@ -31,6 +31,8 @@ exposed-modules: Text.Heterocephalus other-modules: Text.Hamlet.Parse , Text.Heterocephalus.Parse+ , Text.Heterocephalus.Parse.Control+ , Text.Heterocephalus.Parse.Doc build-depends: base >= 4.7 && < 5 , blaze-html >= 0.8 && < 0.9 , blaze-markup >= 0.7 && < 0.8@@ -40,6 +42,7 @@ , shakespeare >= 2.0 && < 2.1 , template-haskell >= 2.7 && < 3 , text >= 1.2 && < 1.3+ ghc-options: -Wall default-language: Haskell2010 test-suite heterocephalus-test
src/Text/Hamlet/Parse.hs view
@@ -3,31 +3,16 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Parse- ( Result (..)- , Binding (..)+ ( Binding (..) , specialOrIdent , DataConstr (..) , Module (..) ) where -import Text.Shakespeare.Base-import Control.Applicative (Applicative (..))-import Control.Monad-import Data.Data--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+import Data.Data (Data)+import Data.Typeable (Typeable)+import Text.Shakespeare.Base (Ident(..)) data Binding = BindVar Ident | BindAs Ident Binding
src/Text/Heterocephalus.hs view
@@ -67,9 +67,9 @@ (QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType) #if MIN_VERSION_template_haskell(2,9,0) import Language.Haskell.TH.Syntax- (Con(..), Dec(..), Exp(..), Info(..), Lit(..), Name(..), Pat(..),- Q, Stmt(..), lookupValueName, mkName, nameBase, newName,- qAddDependentFile, qRunIO, reify)+ (Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),+ Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,+ newName, qAddDependentFile, qRunIO, reify) #else import Language.Haskell.TH.Syntax #endif@@ -269,8 +269,8 @@ >>> renderMarkup (let as = ["<a>", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|]) "sample key: <a>, key: b, " - >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|])- "2 is even number."+ >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }an even number.%{ elseif (num > 100) }big.%{ else }an odd number.%{ endif }|])+ "2 is an even number." -} compileText :: QuasiQuoter compileText = compile textSetting@@ -486,6 +486,17 @@ let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d docs' <- docsToExp set scope docs return $ TupE [d', docs']+docToExp set 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 set scope' inside+ return $ Match pat (NormalB insideExp) [] docToExp set v (DocContent c) = contentToExp set v c contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
src/Text/Heterocephalus/Parse.hs view
@@ -2,366 +2,28 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -module Text.Heterocephalus.Parse where--#if MIN_VERSION_base(4,9,0)-#else-import Control.Applicative ((<$>))-#endif-import Control.Monad (guard, void)-import Data.Char (isUpper)-import Data.Data (Data)-import Data.Typeable (Typeable)-import Text.Parsec- (Parsec, (<?>), (<|>), alphaNum, between, char, choice, eof, many,- many1, manyTill, noneOf, oneOf, option, optional, parse, sepBy,- skipMany, spaces, string, try)-import Text.Shakespeare.Base- (Ident(Ident), Deref, parseDeref, parseHash)--import Text.Hamlet.Parse--data Control- = ControlForall Deref Binding- | ControlEndForall- | ControlIf Deref- | ControlElse- | ControlEndIf- | NoControl Content- deriving (Show, Eq, Read, Data, Typeable)--data Doc = DocForall Deref Binding [Doc]- | DocCond [(Deref, [Doc])] (Maybe [Doc])- | DocContent Content- deriving (Show, Eq, Read, Data, Typeable)--data Content = ContentRaw String- | ContentVar Deref- deriving (Show, Eq, Read, Data, Typeable)+module Text.Heterocephalus.Parse+ ( module Text.Heterocephalus.Parse+ , module Text.Heterocephalus.Parse.Control+ , module Text.Heterocephalus.Parse.Doc+ ) where -type UserParser = Parsec String ()+import Text.Heterocephalus.Parse.Control (Content(..), parseLineControl)+import Text.Heterocephalus.Parse.Doc+ (Doc(..), parseDocFromControls) docFromString :: String -> [Doc] docFromString s = case parseDoc s of- Error s' -> error s'- Ok d -> d+ Left s' -> error s'+ Right d -> d -parseDoc :: String -> Result [Doc]+parseDoc :: String -> Either String [Doc] parseDoc s = do controls <- parseLineControl 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---- | Parse conditional 'Control' statements (@if@, @else@, @endif@) into a--- three-tuple.------ TODO: parse elseif-parseConds- :: Int- -- ^ Current recursive depth of parsing conditional statements.- -> [Control]- -- ^ Input 'Control' statements. This should be every statement AFTER the- -- initial 'ControlIf' statement.- -> ([Control], Maybe [Control], [Control])- -- ^ Tuple with three different sets of 'Control' statements. The first- -- @['Control']@ is all of the statements under the @if@ block. The second- -- @'Maybe' ['Control']@ is all the control statements under the @else@- -- block. The third @['Control']@ is the rest of the 'Control' statements- -- after this conditional block.-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 :: Control -> Bool- isIf (ControlIf _) = True- isIf _ = False-- isEndIf :: Control -> Bool- isEndIf ControlEndIf = True- isEndIf _ = False-- isElse :: Control -> Bool- 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 :: Control -> Bool- isEndForall ControlEndForall = True- isEndForall _ = False-- isForall :: Control -> Bool- 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 <|> controlPercent <|> controlReg- where- controlPercent :: UserParser Control- controlPercent = do- x <- parsePercent- case x of- Left str -> return (NoControl $ ContentRaw str)- Right ctrl -> return ctrl-- controlHash :: UserParser Control- controlHash = do- x <- parseHash- return . NoControl $- case x of- Left str -> ContentRaw str- Right deref -> ContentVar deref-- controlReg :: UserParser Control- controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%")--parsePercent :: UserParser (Either String Control)-parsePercent = do- a <- parseControl '%'- optional eol- return a- where- eol :: UserParser ()- eol = void (char '\n') <|> void (string "\r\n")--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 parseElse <|>- try parseEndIf- where- parseForall :: UserParser Control- parseForall = do- _ <- try $ string "forall"- spaces- (x, y) <- binding- return $ ControlForall x y-- parseEndForall :: UserParser Control- parseEndForall = do- _ <- try $ string "endforall"- return $ ControlEndForall-- parseIf :: UserParser Control- parseIf = do- _ <- try $ string "if"- spaces- x <- parseDeref- return $ ControlIf x-- parseElse :: UserParser Control- parseElse = do- _ <- try $ string "else"- return $ ControlElse-- parseEndIf :: UserParser Control- parseEndIf = do- _ <- try $ string "endif"- return $ ControlEndIf-- binding :: UserParser (Deref, Binding)- binding = do- y <- identPattern- spaces- _ <- string "<-"- spaces- x <- parseDeref- _ <- spaceTabs- return (x, y)-- spaceTabs :: UserParser String- spaceTabs = many $ oneOf " \t"-- ident :: UserParser Ident- ident = do- i <- many1 (alphaNum <|> char '_' <|> char '\'')- white- return (Ident i) <?> "identifier"-- parens :: UserParser a -> UserParser a- parens = between (char '(' >> white) (char ')' >> white)-- brackets :: UserParser a -> UserParser a- brackets = between (char '[' >> white) (char ']' >> white)-- braces :: UserParser a -> UserParser a- braces = between (char '{' >> white) (char '}' >> white)-- comma :: UserParser ()- comma = char ',' >> white-- atsign :: UserParser ()- atsign = char '@' >> white-- equals :: UserParser ()- equals = char '=' >> white-- white :: UserParser ()- white = skipMany $ char ' '-- wildDots :: UserParser ()- wildDots = string ".." >> white-- isVariable :: Ident -> Bool- isVariable (Ident (x:_)) = not (isUpper x)- isVariable (Ident []) = error "isVariable: bad identifier"-- isConstructor :: Ident -> Bool- isConstructor (Ident (x:_)) = isUpper x- isConstructor (Ident []) = error "isConstructor: bad identifier"-- identPattern :: UserParser Binding- identPattern = gcon True <|> apat- where- apat :: UserParser Binding- apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]-- varpat :: UserParser Binding- 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 -> UserParser 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 :: UserParser DataConstr- dataConstr = do- p <- dcPiece- ps <- many dcPieces- return $ toDataConstr p ps-- dcPiece :: UserParser String- dcPiece = do- x@(Ident y) <- ident- guard $ isConstructor x- return y-- dcPieces :: UserParser String- dcPieces = do- _ <- char '.'- dcPiece-- toDataConstr :: String -> [String] -> DataConstr- toDataConstr x [] = DCUnqualified $ Ident x- toDataConstr x (y:ys) = go (x :) y ys- where- go :: ([String] -> [String]) -> String -> [String] -> DataConstr- go front next [] = DCQualified (Module $ front []) (Ident next)- go front next (rest:rests) = go (front . (next :)) rest rests-- record :: DataConstr -> UserParser Binding- record c =- braces $ do- (fields, wild) <- option ([], False) go- return (BindRecord c fields wild)- where- go :: UserParser ([(Ident, Binding)], Bool)- go =- (wildDots >> return ([], True)) <|>- (do x <- recordField- (xs, wild) <- option ([], False) (comma >> go)- return (x : xs, wild))-- recordField :: UserParser (Ident, Binding)- recordField = do- field <- ident- p <-- option- (BindVar field) -- support punning- (equals >> identPattern)- return (field, p)-- tuplepat :: UserParser Binding- tuplepat = do- xs <- identPattern `sepBy` comma- return $- case xs of- [x] -> x- _ -> BindTuple xs-- listpat :: UserParser Binding- listpat = BindList <$> identPattern `sepBy` comma+ case parseDocFromControls controls of+ Left parseError -> Left $ show parseError+ Right docs -> Right docs
+ src/Text/Heterocephalus/Parse/Control.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Text.Heterocephalus.Parse.Control where++#if MIN_VERSION_base(4,9,0)+#else+import Control.Applicative ((<$>), (*>), (<*), pure)+#endif+import Control.Monad (guard, void)+import Data.Char (isUpper)+import Data.Data (Data)+import Data.Functor (($>))+import Data.Typeable (Typeable)+import Text.Parsec+ (Parsec, (<?>), (<|>), alphaNum, between, char, choice, eof, many,+ many1, manyTill, noneOf, oneOf, option, optional, parse, sepBy,+ skipMany, spaces, string, try)+import Text.Shakespeare.Base+ (Ident(Ident), Deref, parseDeref, parseHash)++import Text.Hamlet.Parse++data Control+ = ControlForall Deref Binding+ | ControlEndForall+ | ControlIf Deref+ | ControlElse+ | ControlElseIf Deref+ | ControlEndIf+ | ControlCase Deref+ | ControlCaseOf Binding+ | ControlEndCase+ | NoControl Content+ deriving (Data, Eq, Read, Show, Typeable)++data Content = ContentRaw String+ | ContentVar Deref+ deriving (Data, Eq, Read, Show, Typeable)++type UserParser = Parsec String ()++parseLineControl :: String -> Either String [Control]+parseLineControl s =+ case parse lineControl s s of+ Left e -> Left $ show e+ Right x -> Right x++lineControl :: UserParser [Control]+lineControl = manyTill control $ try eof >> return ()++control :: UserParser Control+control = controlHash <|> controlPercent <|> controlReg+ where+ controlPercent :: UserParser Control+ controlPercent = do+ x <- parsePercent+ case x of+ Left str -> return (NoControl $ ContentRaw str)+ Right ctrl -> return ctrl++ controlHash :: UserParser Control+ controlHash = do+ x <- parseHash+ return . NoControl $+ case x of+ Left str -> ContentRaw str+ Right deref -> ContentVar deref++ controlReg :: UserParser Control+ controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%")++parsePercent :: UserParser (Either String Control)+parsePercent = do+ a <- parseControl '%'+ optional eol+ return a+ where+ eol :: UserParser ()+ eol = void (char '\n') <|> void (string "\r\n")++parseControl :: Char -> UserParser (Either String Control)+parseControl c = do+ _ <- char c+ let escape = char '\\' $> Left [c]+ escape <|> (Right <$> parseControlBetweenBrackets) <|> return (Left [c])++parseControlBetweenBrackets :: UserParser Control+parseControlBetweenBrackets =+ between (char '{') (char '}') $ spaces *> parseControl' <* spaces++parseControl' :: UserParser Control+parseControl' =+ try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElseIf <|>+ try parseElse <|>+ try parseEndIf <|>+ try parseCase <|>+ try parseCaseOf <|>+ try parseEndCase+ where+ parseForall :: UserParser Control+ parseForall = do+ string "forall" *> spaces+ (x, y) <- binding+ pure $ ControlForall x y++ parseEndForall :: UserParser Control+ parseEndForall = string "endforall" $> ControlEndForall++ parseIf :: UserParser Control+ parseIf = string "if" *> spaces *> fmap ControlIf parseDeref++ parseElseIf :: UserParser Control+ parseElseIf = string "elseif" *> spaces *> fmap ControlElseIf parseDeref++ parseElse :: UserParser Control+ parseElse = string "else" $> ControlElse++ parseEndIf :: UserParser Control+ parseEndIf = string "endif" $> ControlEndIf++ parseCase :: UserParser Control+ parseCase = string "case" *> spaces *> fmap ControlCase parseDeref++ parseCaseOf :: UserParser Control+ parseCaseOf = string "of" *> spaces *> fmap ControlCaseOf identPattern++ parseEndCase :: UserParser Control+ parseEndCase = string "endcase" $> ControlEndCase++ binding :: UserParser (Deref, Binding)+ binding = do+ y <- identPattern+ spaces+ _ <- string "<-"+ spaces+ x <- parseDeref+ _ <- spaceTabs+ return (x, y)++ spaceTabs :: UserParser String+ spaceTabs = many $ oneOf " \t"++ -- | Parse an indentifier. This is an sequence of alphanumeric characters,+ -- or an operator.+ ident :: UserParser Ident+ ident = do+ i <- (many1 (alphaNum <|> char '_' <|> char '\'')) <|> try operator+ white+ return (Ident i) <?> "identifier"++ -- | Parse an operator. An operator is a sequence of characters in+ -- 'operatorList' in between parenthesis.+ operator :: UserParser String+ operator = do+ oper <- between (char '(') (char ')') . many1 $ oneOf operatorList+ pure $ oper++ operatorList :: String+ operatorList = "!#$%&*+./<=>?@\\^|-~:"++ parens :: UserParser a -> UserParser a+ parens = between (char '(' >> white) (char ')' >> white)++ brackets :: UserParser a -> UserParser a+ brackets = between (char '[' >> white) (char ']' >> white)++ braces :: UserParser a -> UserParser a+ braces = between (char '{' >> white) (char '}' >> white)++ comma :: UserParser ()+ comma = char ',' >> white++ atsign :: UserParser ()+ atsign = char '@' >> white++ equals :: UserParser ()+ equals = char '=' >> white++ white :: UserParser ()+ white = skipMany $ char ' '++ wildDots :: UserParser ()+ wildDots = string ".." >> white++ -- | Return 'True' if 'Ident' is a variable. Variables are defined as+ -- starting with a lowercase letter.+ isVariable :: Ident -> Bool+ isVariable (Ident (x:_)) = not (isUpper x)+ isVariable (Ident []) = error "isVariable: bad identifier"++ -- | Return 'True' if an 'Ident' is a constructor. Constructors are+ -- defined as either starting with an uppercase letter, or being an+ -- operator.+ isConstructor :: Ident -> Bool+ isConstructor (Ident (x:_)) = isUpper x || elem x operatorList+ isConstructor (Ident []) = error "isConstructor: bad identifier"++ -- | This function tries to parse an entire pattern binding with either+ -- @'gcon' True@ or 'apat'. For instance, in the pattern+ -- @let Foo a b = ...@, this function tries to parse @Foo a b@ with 'gcon'.+ -- In the pattern @let n = ...@, this function tries to parse @n@ with+ -- 'apat'.+ identPattern :: UserParser Binding+ identPattern = gcon True <|> apat+ where+ apat :: UserParser Binding+ apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]++ -- | Parse a variable in a pattern. For instance in, in a pattern like+ -- @let Just n = ...@, this function would be what is used to parse the+ -- @n@. This function also handles aliases with @\@@.+ varpat :: UserParser Binding+ varpat = do+ v <-+ try $ do+ v <- ident+ guard (isVariable v)+ return v+ option (BindVar v) $ do+ atsign+ b <- apat+ return (BindAs v b) <?> "variable"++ -- | This function tries to parse an entire pattern binding. For+ -- instance, in the pattern @let Foo a b = ...@, this function tries to+ -- parse @Foo a b@.+ --+ -- This function first tries to parse a data contructor (using+ -- 'dataConstr'). In the example above, that would be like parsing+ -- @Foo@.+ --+ -- Then, the function tries to do two different things.+ --+ -- 1. It tries to parse record syntax with 'record'. In a pattern like+ -- @let Foo{foo1 = 3, foo2 = "hello"} = ...@, it would parse the+ -- @{foo1 = 3, foo2 = "hello"}@ part.+ --+ -- 2. If parsing the record syntax fails, it then tries to parse+ -- many normal patterns with 'apat'. In a pattern like+ -- @let Foo a b = ...@, it would be like parsing the @a b@ part.+ --+ -- If that fails, then it just returns the original data contructor+ -- with no arguments.+ --+ -- The 'Bool' argument determines whether or not it tries to parse+ -- normal patterns in 2. If the boolean argument is 'True', then it+ -- tries parsing normal patterns in 2. If the boolean argument is+ -- 'False', then 2 is skipped altogether.+ gcon :: Bool -> UserParser Binding+ gcon allowArgs = do+ c <- try dataConstr+ choice+ [ record c+ , fmap (BindConstr c) (guard allowArgs >> many apat)+ , return (BindConstr c [])+ ] <?>+ "constructor"++ -- | Parse a possibly qualified identifier using 'ident'.+ dataConstr :: UserParser DataConstr+ dataConstr = do+ p <- dcPiece+ ps <- many dcPieces+ return $ toDataConstr p ps++ dcPiece :: UserParser String+ dcPiece = do+ x@(Ident y) <- ident+ guard $ isConstructor x+ return y++ dcPieces :: UserParser String+ dcPieces = do+ _ <- char '.'+ dcPiece++ toDataConstr :: String -> [String] -> DataConstr+ toDataConstr x [] = DCUnqualified $ Ident x+ toDataConstr x (y:ys) = go (x :) y ys+ where+ go :: ([String] -> [String]) -> String -> [String] -> DataConstr+ go front next [] = DCQualified (Module $ front []) (Ident next)+ go front next (rest:rests) = go (front . (next :)) rest rests++ record :: DataConstr -> UserParser Binding+ record c =+ braces $ do+ (fields, wild) <- option ([], False) go+ return (BindRecord c fields wild)+ where+ go :: UserParser ([(Ident, Binding)], Bool)+ go =+ (wildDots >> return ([], True)) <|>+ (do x <- recordField+ (xs, wild) <- option ([], False) (comma >> go)+ return (x : xs, wild))++ recordField :: UserParser (Ident, Binding)+ recordField = do+ field <- ident+ p <-+ option+ (BindVar field) -- support punning+ (equals >> identPattern)+ return (field, p)++ tuplepat :: UserParser Binding+ tuplepat = do+ xs <- identPattern `sepBy` comma+ return $+ case xs of+ [x] -> x+ _ -> BindTuple xs++ listpat :: UserParser Binding+ listpat = BindList <$> identPattern `sepBy` comma
+ src/Text/Heterocephalus/Parse/Doc.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Text.Heterocephalus.Parse.Doc where++#if MIN_VERSION_base(4,9,0)+#else+import Control.Applicative ((*>), (<*), pure)+#endif+import Control.Monad (void)+import Data.Data (Data)+import Data.Typeable (Typeable)+import Text.Parsec+ (Parsec, ParseError, SourcePos, (<|>), eof, incSourceLine, many,+ many1, optional, optionMaybe, parse, tokenPrim)+import Text.Shakespeare.Base (Deref)++import Text.Hamlet.Parse+import Text.Heterocephalus.Parse.Control (Content(..), Control(..))++data Doc = DocForall Deref Binding [Doc]+ | DocCond [(Deref, [Doc])] (Maybe [Doc])+ | DocCase Deref [(Binding, [Doc])]+ | DocContent Content+ deriving (Data, Eq, Read, Show, Typeable)++type DocParser = Parsec [Control] ()++parseDocFromControls :: [Control] -> Either ParseError [Doc]+parseDocFromControls = parse (docsParser <* eof) ""++docsParser :: DocParser [Doc]+docsParser = many docParser++docParser :: DocParser Doc+docParser = forallDoc <|> condDoc <|> caseDoc <|> contentDoc++forallDoc :: DocParser Doc+forallDoc = do+ ControlForall deref binding <- forallControlStatement+ innerDocs <- docsParser+ void endforallControlStatement+ pure $ DocForall deref binding innerDocs++condDoc :: DocParser Doc+condDoc = do+ ControlIf ifDeref <- ifControlStatement+ ifInnerDocs <- docsParser+ elseIfs <- condElseIfs+ maybeElseInnerDocs <- optionMaybe $ elseControlStatement *> docsParser+ void endifControlStatement+ let allConds = (ifDeref, ifInnerDocs) : elseIfs+ pure $ DocCond allConds maybeElseInnerDocs++caseDoc :: DocParser Doc+caseDoc = do+ ControlCase caseDeref <- caseControlStatement+ -- Ignore a single, optional NoControl statement (with whitespace that will be+ -- ignored).+ optional contentDoc+ caseOfs <- many1 $ do+ ControlCaseOf caseBinding <- caseOfControlStatement+ innerDocs <- docsParser+ pure (caseBinding, innerDocs)+ void endcaseControlStatement+ pure $ DocCase caseDeref caseOfs++contentDoc :: DocParser Doc+contentDoc = primControlStatement $ \case+ NoControl content -> Just $ DocContent content+ _ -> Nothing++condElseIfs :: DocParser [(Deref, [Doc])]+condElseIfs = many $ do+ ControlElseIf elseIfDeref <- elseIfControlStatement+ elseIfInnerDocs <- docsParser+ pure (elseIfDeref, elseIfInnerDocs)++ifControlStatement :: DocParser Control+ifControlStatement = primControlStatement $ \case+ ControlIf deref -> Just $ ControlIf deref+ _ -> Nothing++elseIfControlStatement :: DocParser Control+elseIfControlStatement = primControlStatement $ \case+ ControlElseIf deref -> Just $ ControlElseIf deref+ _ -> Nothing++elseControlStatement :: DocParser Control+elseControlStatement = primControlStatement $ \case+ ControlElse -> Just ControlElse+ _ -> Nothing++endifControlStatement :: DocParser Control+endifControlStatement = primControlStatement $ \case+ ControlEndIf -> Just ControlEndIf+ _ -> Nothing++caseControlStatement :: DocParser Control+caseControlStatement = primControlStatement $ \case+ ControlCase deref -> Just $ ControlCase deref+ _ -> Nothing++caseOfControlStatement :: DocParser Control+caseOfControlStatement = primControlStatement $ \case+ ControlCaseOf binding -> Just $ ControlCaseOf binding+ _ -> Nothing++endcaseControlStatement :: DocParser Control+endcaseControlStatement = primControlStatement $ \case+ ControlEndCase -> Just ControlEndCase+ _ -> Nothing++forallControlStatement :: DocParser Control+forallControlStatement = primControlStatement $ \case+ ControlForall deref binding -> Just $ ControlForall deref binding+ _ -> Nothing++endforallControlStatement :: DocParser Control+endforallControlStatement = primControlStatement $ \case+ ControlEndForall -> Just ControlEndForall+ _ -> Nothing++primControlStatement :: (Control -> Maybe x)-> DocParser x+primControlStatement = tokenPrim show incSourcePos++incSourcePos :: SourcePos -> a -> b -> SourcePos+incSourcePos sourcePos _ _ = incSourceLine sourcePos 1