diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Nikita Volkov + +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/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import BasePrelude +import Record +import qualified Laika as Laika +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TLI +import qualified Data.Text.Lazy.Builder as TLB + + +main = + TLI.putStrLn $ TLB.toLazyText $ render $ model + +model = + [r| { + name = { primary = "Laika", original = "Kudryavka" }, + followers = Just [{ name = "Belka" }, { name = "Strelka" }] + } |] + +render = + $(Laika.file "demo/template.html.laika") + diff --git a/demo/template.html.laika b/demo/template.html.laika new file mode 100644 --- /dev/null +++ b/demo/template.html.laika @@ -0,0 +1,16 @@ +

Hello, {name/original}!

+ +

+ This is your day to change the history of the mankind! From now on we will call you {name/primary}. +

+ +

+ You'll be the first animal to travel on the Earth orbit. You will be followed by: + {followers:} +

+ {:} +

diff --git a/laika.cabal b/laika.cabal new file mode 100644 --- /dev/null +++ b/laika.cabal @@ -0,0 +1,104 @@ +name: + laika +version: + 0.1.0 +synopsis: + Minimalistic type-checked compile-time template engine +description: + The library integrates flawlessly with Haskell's new + . + . + It inherits a remarkable quality from the dogs however: + unlike most other template engines + at compile time it barks at you whenever you do anything wrong in your templates. + Hence the title (from Russian "lai" means "bark"). + Also it commemorates Laika, the hero dog, + which became the first animal to orbit Earth and died in space. +category: +homepage: + https://github.com/nikita-volkov/laika +bug-reports: + https://github.com/nikita-volkov/laika/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2015, Nikita Volkov +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 +extra-source-files: + demo/template.html.laika + + +source-repository head + type: + git + location: + git://github.com/nikita-volkov/laika.git + + +library + hs-source-dirs: + library + ghc-options: + -funbox-strict-fields + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + other-modules: + Laika.Prelude + Laika.Lexer + Laika.Parser + exposed-modules: + Laika + build-depends: + -- + template-haskell, + -- + system-filepath == 0.4.*, + system-fileio == 0.3.*, + -- + attoparsec >= 0.10 && < 0.13, + -- + text >= 1 && < 1.3, + -- + either >= 4.3 && < 4.4, + transformers >= 0.3 && < 0.5, + -- + record >= 0.1.1 && < 0.2, + base-prelude >= 0.1 && < 0.2 + + +-- Well, it's not a benchmark actually, +-- but in Cabal there's no better way to specify an executable, +-- which is not intended for distribution. +benchmark demo + type: + exitcode-stdio-1.0 + hs-source-dirs: + demo + main-is: + Main.hs + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + -ddump-splices + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + build-depends: + laika, + text, + record, + base-prelude diff --git a/library/Laika.hs b/library/Laika.hs new file mode 100644 --- /dev/null +++ b/library/Laika.hs @@ -0,0 +1,96 @@ +module Laika +( + file, +) +where + +import Laika.Prelude +import Language.Haskell.TH +import qualified Record.Types +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Laika.Parser as Parser + + +file :: FilePath -> Q Exp +file = + join . fmap (either fail return) . + fmap (join . fmap (renderingLambda [Arg])) . + runIO . Parser.run . + join . fmap (const (Parser.parseTemplate <* Parser.endOfInput)) . + Parser.load + + +type Path = + [PathSegment] + +data PathSegment = + Arg | Field Text + deriving (Eq, Show) + +resolvePath :: Path -> Parser.Path -> Either String Path +resolvePath p pp = + ($ view [l|segments|] pp) $ + ($ if view [l|absolute|] pp then [Arg] else p ) $ + foldM $ \p -> \case + Parser.Dot -> return p + Parser.DoubleDot -> case p of + h:t -> return t + _ -> Left $ "Attempt to step out a level from an empty path" + Parser.Identifier n -> return $ Field n : p + +renderingLambda :: Path -> Parser.Template -> Either String Exp +renderingLambda path = + fmap (LamE [VarP (mkName ("x" <> show depth))] . + AppE (VarE 'mconcat) . + ListE) . + traverse phraseExp + where + depth = + length $ filter (== Arg) $ path + phraseExp = + \case + Parser.Reference r -> + do + path' <- resolvePath path (view [l|path|] r) + return $ + bool id (AppE (AppE (VarE 'onLazyText) (VarE 'escapeHTML))) (view [l|escaped|] r) $ + pathValue path' + Parser.Block r -> + do + path' <- resolvePath path (view [l|path|] r) + lambda <- renderingLambda (Arg : path') (view [l|template|] r) + return $ AppE (AppE (VarE 'foldMap) lambda) (pathValue path') + Parser.Text t -> + pure $ + AppE (VarE 'TLB.fromText) $ + LitE (StringL (T.unpack t)) + +pathValue :: Path -> Exp +pathValue path = + foldr (\l r -> UInfixE l (VarE '($)) r) (VarE (mkName ("x" <> show argDepth))) . + map (AppE (VarE 'Record.Types.getField) . + SigE (ConE 'Record.Types.Field) . + AppT (ConT ''Record.Types.Field) . LitT . StrTyLit . T.unpack) . + foldMap (\case Field n -> pure n; _ -> empty) . + takeWhile (/= Arg) + $ path + where + argDepth = + length $ filter (== Arg) $ path + +onLazyText :: (TL.Text -> TL.Text) -> TLB.Builder -> TLB.Builder +onLazyText f = + TLB.fromLazyText . f . TLB.toLazyText + +escapeHTML :: TL.Text -> TL.Text +escapeHTML = + TL.concatMap $ \case + '&' -> "&" + '\\' -> "\" + '"' -> """ + '\'' -> "'" + '<' -> "<" + '>' -> ">" + h -> TL.singleton h diff --git a/library/Laika/Lexer.hs b/library/Laika/Lexer.hs new file mode 100644 --- /dev/null +++ b/library/Laika/Lexer.hs @@ -0,0 +1,168 @@ +module Laika.Lexer where + +import Laika.Prelude +import Data.Attoparsec.Text +import qualified Data.Text as T +import qualified Filesystem.Path.CurrentOS as FS +import qualified Filesystem as FS + + +-- * General parsing +------------------------- + +type Lexer = Parser + +run :: Lexer a -> Text -> Either String a +run p t = + onResult $ parse p t + where + onResult = + \case + Fail _ contexts message -> Left $ showString message . showString ". Contexts: " . + shows contexts $ "." + Done _ a -> Right a + Partial c -> onResult (c "") + +-- | +-- Run a lexer on a given input, +-- lifting its errors to the context lexer. +-- +-- Consider it a sublexer. +lexer :: Lexer a -> Text -> Lexer a +lexer p t = + either fail return $ + run p t + +complete :: Lexer a -> Lexer a +complete p = + p <* skipSpace <* endOfInput + +labeled :: String -> Lexer a -> Lexer a +labeled = + flip () + +-- | +-- This lexer does not consume any input. +shouldFail :: Lexer a -> Lexer () +shouldFail p = + optional p >>= maybe (return ()) (const empty) + +manyFollowedBy :: Lexer a -> Lexer b -> Lexer ([b], a) +manyFollowedBy a b = + (([],) <$> a) <|> + (\br (brl, ar) -> (br : brl, ar)) <$> b <*> manyFollowedBy a b + +escapedText :: [Char] -> Lexer Text +escapedText escapedChars = + T.pack <$> many1 (escapedChar <|> unescapedChar) + where + escapedChar = + char '\\' *> ((satisfy (inClass escapedChars)) <|> char '\\') + unescapedChar = + satisfy (notInClass escapedChars) + +-- * Path +------------------------- + +type Path = + [r|{ absolute :: Bool, segments :: [PathSegment] }|] + +data PathSegment = + Dot | DoubleDot | Identifier Text + deriving (Show) + +path :: Lexer Path +path = + labeled "path" $ do + absolute <- True <$ char '/' <|> pure False + segments <- sepBy1 segment (char '/') + return $ [r|{ absolute = absolute, segments = segments }|] + where + segment = + DoubleDot <$ string ".." <|> + Dot <$ char '.' <|> + Identifier <$> takeWhile1 (/= '/') + +-- * FilePath +------------------------- + +filePath :: Lexer FilePath +filePath = + FS.fromText <$> takeText + +-- * Reference +------------------------- + +type Reference = + [r|{ escaped :: Bool, path :: Path }|] + +reference :: Lexer Reference +reference = + labeled "reference" $ do + char '{' + skipSpace + e <- False <$ (asciiCI "unescaped" <* skipMany1 space) <|> + pure True + p <- lexer (complete path) =<< + ((char '"' *> escapedText ['"'] <* char '"') <|> + (escapedText ['}', ':'])) + skipSpace + char '}' + return $ [r|{ escaped = e, path = p }|] + +-- * Include +------------------------- + +include :: Lexer FilePath +include = + labeled "include" $ do + char '{' + skipSpace + asciiCI "include" + skipMany1 space + p <- lexer filePath =<< + ((char '"' *> escapedText ['"'] <* char '"') <|> + (escapedText ['}'])) + skipSpace + char '}' + return $ p + +-- * Block +------------------------- + +blockOpening :: Lexer Path +blockOpening = + labeled "blockOpening" $ do + char '{' + skipSpace + p <- lexer (complete path) =<< + ((char '"' *> escapedText ['"'] <* char '"') <|> + (escapedText [':'])) + skipSpace + char ':' + skipSpace + char '}' + return p + +-- * Template +------------------------- + +data Token = + Text Text | + Reference Reference | + BlockOpening Path | + BlockClosing | + Include FilePath + deriving (Show) + +tokens :: Lexer [Token] +tokens = + many chunk + where + chunk = + Text <$> escapedText ['{'] <|> + Reference <$> reference <|> + BlockOpening <$> blockOpening <|> + BlockClosing <$ (char '{' *> skipSpace *> char ':' *> skipSpace *> char '}') <|> + Include <$> include + diff --git a/library/Laika/Parser.hs b/library/Laika/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Laika/Parser.hs @@ -0,0 +1,114 @@ +module Laika.Parser where + +import Laika.Prelude hiding (lex) +import qualified Laika.Lexer as Lexer +import qualified Data.Text as T +import qualified Filesystem.Path.CurrentOS as FS +import qualified Filesystem as FS + + +type Parser = + StateT [Lexer.Token] (EitherT String IO) + +run :: Parser a -> IO (Either String a) +run = + runEitherT . + flip evalStateT [] + +lex :: Text -> Parser () +lex = + join . fmap (\l -> modify (l <>)) . + lift . hoistEither . Lexer.run (Lexer.complete Lexer.tokens) + +load :: FilePath -> Parser () +load p = + liftIO (FS.isFile p) >>= \case + False -> lift $ left $ showString "File not found: " $ show p + True -> liftIO (FS.readTextFile p) >>= lex + +parseTemplate :: Parser Template +parseTemplate = + do phrase <- Just <$> parsePhrase <|> pure Nothing + maybe (return []) (\x -> (x :) <$> parseTemplate) phrase + +parsePhrase :: Parser Phrase +parsePhrase = + getToken >>= \case + Lexer.BlockOpening path -> + do template <- parseTemplate + getToken >>= \case + Lexer.BlockClosing -> return () + _ -> lift $ left $ "Unclosed block" + return $ + let path' = convertPath path + in Block [r|{ path = path', template = template }|] + Lexer.BlockClosing -> + lift $ left $ "Unexpected block closing" + Lexer.Include path -> + do load path + parsePhrase + Lexer.Reference ref -> + return $ Reference $ convertReference ref + Lexer.Text t -> + return $ Text t + +getToken :: Parser Lexer.Token +getToken = + StateT $ \case + h : t -> return (h, t) + _ -> left $ "No tokens left" + +shouldFail :: Parser a -> Parser () +shouldFail p = + optional p >>= maybe (return ()) (const empty) + +endOfInput :: Parser () +endOfInput = + optional getToken >>= + maybe (return ()) + (\t -> lift $ left $ "Not all tokens got parsed. Stopped at: " <> show t) + +convertPath :: Lexer.Path -> Path +convertPath lp = + let absolute = view [l|absolute|] lp + segments = map convertPathSegment $ view [l|segments|] lp + in [r|{ absolute = absolute, segments = segments }|] + where + convertPathSegment = + \case + Lexer.Dot -> Dot + Lexer.DoubleDot -> DoubleDot + Lexer.Identifier t -> Identifier t + +convertReference :: Lexer.Reference -> Reference +convertReference lr = + let escaped = view [l|escaped|] lr + path = convertPath $ view [l|path|] lr + in [r|{ escaped = escaped, path = path }|] + + +-- * Model +------------------------- + +type Template = + [Phrase] + +data Phrase = + Text Text | + Reference Reference | + Block Block + deriving (Show) + +type Reference = + [r|{ escaped :: Bool, path :: Path }|] + +type Path = + [r|{ absolute :: Bool, segments :: [PathSegment] }|] + +data PathSegment = + Dot | DoubleDot | Identifier Text + deriving (Show) + +type Block = + [r|{ path :: Path, template :: Template }|] + diff --git a/library/Laika/Prelude.hs b/library/Laika/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Laika/Prelude.hs @@ -0,0 +1,15 @@ +module Laika.Prelude +( + module Exports, +) +where + +import BasePrelude as Exports hiding (FilePath, left, right) +import Record as Exports +import Record.Lens as Exports +import Filesystem.Path as Exports (FilePath) +import Data.Text as Exports (Text) +import Control.Monad.Trans.Either as Exports +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.State as Exports