packages feed

laika (empty) → 0.1.0

raw patch · 9 files changed

+559/−0 lines, 9 filesdep +attoparsecdep +base-preludedep +eithersetup-changed

Dependencies added: attoparsec, base-prelude, either, laika, record, system-fileio, system-filepath, template-haskell, text, transformers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -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")+
+ demo/template.html.laika view
@@ -0,0 +1,16 @@+<p>Hello, {name/original}!</p>++<p>+  This is your day to change the history of the mankind! From now on we will call you {name/primary}.+</p>++<p>+  You'll be the first animal to travel on the Earth orbit. You will be followed by:+  {followers:}+  <ul>+    {.:}+    <li>{name}, the follower of {../../../name/primary}</li>+    {:}+  </ul>+  {:}+</p>
+ laika.cabal view
@@ -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 +  <https://github.com/nikita-volkov/record first-class records>.+  .+  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 <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+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
+ library/Laika.hs view
@@ -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+    '&'  -> "&amp;"+    '\\' -> "&#92;"+    '"'  -> "&quot;"+    '\'' -> "&#39;"+    '<'  -> "&lt;"+    '>'  -> "&gt;"+    h    -> TL.singleton h
+ library/Laika/Lexer.hs view
@@ -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+
+ library/Laika/Parser.hs view
@@ -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 }|]+
+ library/Laika/Prelude.hs view
@@ -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