├── Setup.hs
├── test
    ├── Spec.hs
    └── Doctest.hs
├── templates
    └── sample.txt
├── CONTRIBUTING.md
├── .gitignore
├── .github
    ├── FUNDING.yml
    └── workflows
    │   └── test.yaml
├── stack-lts-lower.yaml.lock
├── CHANGELOG.md
├── src
    └── Text
    │   ├── Heterocephalus
    │       ├── Parse
    │       │   ├── Option.hs
    │       │   ├── Doc.hs
    │       │   └── Control.hs
    │       └── Parse.hs
    │   ├── Hamlet
    │       └── Parse.hs
    │   └── Heterocephalus.hs
├── stack-lts-10.yaml
├── stack.yaml
├── LICENSE
├── stack-lts-lower.yaml
├── heterocephalus.cabal
└── README.md


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 | 


--------------------------------------------------------------------------------
/templates/sample.txt:
--------------------------------------------------------------------------------
1 | sample
2 | %{ forall a <- as }
3 | key: #{a},
4 | %{ endforall }
5 | 


--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
1 | How to Contribute to this Repository?
2 | =====================================
3 | 
4 | Feel free to open an issue or a pull-request.
5 | 


--------------------------------------------------------------------------------
/test/Doctest.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import Data.Monoid ((<>))
 4 | import System.FilePath.Glob (glob)
 5 | import Test.DocTest (doctest)
 6 | 
 7 | main :: IO ()
 8 | -- main = glob "src/**/*.hs" >>= doDocTest
 9 | main = return ()
10 | 
11 | doDocTest :: [String] -> IO ()
12 | doDocTest options = doctest $ options <> ghcExtensions
13 | 
14 | ghcExtensions :: [String]
15 | ghcExtensions =
16 |     [ "-XTemplateHaskell"
17 |     , "-XQuasiQuotes"
18 |     ]
19 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | stack.yaml.lock
 2 | stack-lts-10.yaml.lock
 3 | ### https://raw.github.com/github/gitignore/2664dad61f3fda7755acc70ceb5aac4b1e956981/Global/Vim.gitignore
 4 | 
 5 | # swap
 6 | [._]*.s[a-w][a-z]
 7 | [._]s[a-w][a-z]
 8 | # session
 9 | Session.vim
10 | # temporary
11 | .netrwhist
12 | *~
13 | # auto-generated tag files
14 | tags
15 | 
16 | 
17 | ### https://raw.github.com/github/gitignore/2664dad61f3fda7755acc70ceb5aac4b1e956981/Haskell.gitignore
18 | 
19 | dist
20 | dist-*
21 | cabal-dev
22 | *.o
23 | *.hi
24 | *.chi
25 | *.chs.h
26 | *.dyn_o
27 | *.dyn_hi
28 | .hpc
29 | .hsenv
30 | .cabal-sandbox/
31 | cabal.sandbox.config
32 | *.prof
33 | *.aux
34 | *.hp
35 | *.eventlog
36 | .stack-work/
37 | cabal.project.local
38 | 
39 | 
40 | 


--------------------------------------------------------------------------------
/.github/FUNDING.yml:
--------------------------------------------------------------------------------
 1 | # These are supported funding model platforms
 2 | 
 3 | github: [arowM] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
 4 | patreon: # Replace with a single Patreon username
 5 | open_collective: # Replace with a single Open Collective username
 6 | ko_fi: # Replace with a single Ko-fi username
 7 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
 8 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
 9 | liberapay: # Replace with a single Liberapay username
10 | issuehunt: # Replace with a single IssueHunt username
11 | otechie: # Replace with a single Otechie username
12 | lfx_crowdfunding: # Replace with a single LFX Crowdfunding project-name e.g., cloud-foundry
13 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
14 | 


--------------------------------------------------------------------------------
/stack-lts-lower.yaml.lock:
--------------------------------------------------------------------------------
 1 | # This file was autogenerated by Stack.
 2 | # You should not edit this file by hand.
 3 | # For more information, please see the documentation at:
 4 | #   https://docs.haskellstack.org/en/stable/lock_files
 5 | 
 6 | packages:
 7 | - completed:
 8 |     hackage: template-haskell-compat-v0208-0.1.9@sha256:abba2d89c500b0ad6259f42be07c1a59d331970624de7e0600ba62738e2c0115,1523
 9 |     pantry-tree:
10 |       size: 295
11 |       sha256: 6ccef12b43fd6561c5e74f618e4eb9200c44966127144a5056d42d1d1378118b
12 |   original:
13 |     hackage: template-haskell-compat-v0208-0.1.9@sha256:abba2d89c500b0ad6259f42be07c1a59d331970624de7e0600ba62738e2c0115,1523
14 | snapshots:
15 | - completed:
16 |     size: 590100
17 |     url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml
18 |     sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68
19 |   original: lts-18.28
20 | 


--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
 1 | Change Log
 2 | ==========
 3 | 
 4 | Version 1.0.5.7 (2022-07-13)
 5 | ----------------
 6 | 
 7 | Support GHC 9.2
 8 | 
 9 | Version 1.0.5.0 (2017-06-05)
10 | ----------------
11 | 
12 | ### New features
13 | 
14 | * Add settings to be able to change the character used to deliminate control statements #18
15 | 
16 | ### Document updates
17 | 
18 | * Fixed small spelling/grammars on readme #19
19 | 
20 | Version 1.0.4.0 (2017-02-07)
21 | ----------------
22 | 
23 | ### New features
24 | 
25 | * Expose htmlSetting and textSetting
26 | 
27 | Version 1.0.3.0 (2017-01-24)
28 | ----------------
29 | 
30 | ### New features
31 | 
32 | * Add `case` control statement
33 | 
34 | Version 1.0.2.0 (2016-12-13)
35 | ----------------------------
36 | 
37 | #### New features
38 | 
39 | * Add `compileTextFileWith` and `compileHtmlFileWith` to inject extra variables
40 | * Add `ScopeM` type for specifying extra template variables
41 | * Add `setDefault` and `overwrite` for constructing `ScopeM`
42 | 


--------------------------------------------------------------------------------
/src/Text/Heterocephalus/Parse/Option.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE FlexibleContexts #-}
 3 | 
 4 | module Text.Heterocephalus.Parse.Option where
 5 | 
 6 | import Control.Monad.Reader (MonadReader, reader)
 7 | 
 8 | data ParseOptions = ParseOptions
 9 |   { parseOptionsControlPrefix :: Char
10 |   , parseOptionsVariablePrefix :: Char
11 |   }
12 | 
13 | -- | Default set of parser options.
14 | --
15 | -- Sets 'parseOptionsControlPrefix' to @\'%\'@  and
16 | -- 'parseOptionsVariablePrefix' to @\'#\'@.
17 | defaultParseOptions :: ParseOptions
18 | defaultParseOptions = createParseOptions '%' '#'
19 | 
20 | createParseOptions
21 |   :: Char  -- ^ The control prefix.
22 |   -> Char  -- ^ The variable prefix.
23 |   -> ParseOptions
24 | createParseOptions controlPrefix varPrefix = ParseOptions
25 |   { parseOptionsControlPrefix = controlPrefix
26 |   , parseOptionsVariablePrefix = varPrefix
27 |   }
28 | 
29 | getControlPrefix :: MonadReader ParseOptions m => m Char
30 | getControlPrefix = reader parseOptionsControlPrefix
31 | 
32 | getVariablePrefix :: MonadReader ParseOptions m => m Char
33 | getVariablePrefix = reader parseOptionsVariablePrefix
34 | 


--------------------------------------------------------------------------------
/src/Text/Heterocephalus/Parse.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE DeriveDataTypeable #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | {-# LANGUAGE FlexibleInstances #-}
 5 | {-# LANGUAGE LambdaCase #-}
 6 | {-# LANGUAGE TemplateHaskell #-}
 7 | 
 8 | module Text.Heterocephalus.Parse
 9 |   ( module Text.Heterocephalus.Parse
10 |   , module Text.Heterocephalus.Parse.Control
11 |   , module Text.Heterocephalus.Parse.Doc
12 |   , module Text.Heterocephalus.Parse.Option
13 |   ) where
14 | 
15 | import Text.Heterocephalus.Parse.Control (Content(..), parseLineControl)
16 | import Text.Heterocephalus.Parse.Doc
17 |        (Doc(..), parseDocFromControls)
18 | import Text.Heterocephalus.Parse.Option
19 |        (ParseOptions(..), createParseOptions, defaultParseOptions)
20 | 
21 | docFromString :: ParseOptions -> String -> [Doc]
22 | docFromString opts s =
23 |   case parseDoc opts s of
24 |     Left s' -> error s'
25 |     Right d -> d
26 | 
27 | parseDoc :: ParseOptions -> String -> Either String [Doc]
28 | parseDoc opts s = do
29 |   controls <- parseLineControl opts s
30 |   case parseDocFromControls controls of
31 |     Left parseError -> Left $ show parseError
32 |     Right docs -> Right docs
33 | 


--------------------------------------------------------------------------------
/src/Text/Hamlet/Parse.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# LANGUAGE FlexibleContexts #-}
 3 | {-# LANGUAGE TemplateHaskell #-}
 4 | {-# LANGUAGE FlexibleInstances #-}
 5 | module Text.Hamlet.Parse
 6 |     ( Binding (..)
 7 |     , specialOrIdent
 8 |     , DataConstr (..)
 9 |     , Module (..)
10 |     )
11 |     where
12 | 
13 | import Data.Data (Data)
14 | import Data.Typeable (Typeable)
15 | import Text.Shakespeare.Base (Ident(..))
16 | 
17 | data Binding = BindVar Ident
18 |              | BindAs Ident Binding
19 |              | BindConstr DataConstr [Binding]
20 |              | BindTuple [Binding]
21 |              | BindList [Binding]
22 |              | BindRecord DataConstr [(Ident, Binding)] Bool
23 |     deriving (Eq, Show, Read, Data, Typeable)
24 | 
25 | data DataConstr = DCQualified Module Ident
26 |                 | DCUnqualified Ident
27 |     deriving (Eq, Show, Read, Data, Typeable)
28 | 
29 | newtype Module = Module [String]
30 |     deriving (Eq, Show, Read, Data, Typeable)
31 | 
32 | -- | This funny hack is to allow us to refer to the 'or' function without
33 | -- requiring the user to have it in scope. See how this function is used in
34 | -- Text.Hamlet.
35 | specialOrIdent :: Ident
36 | specialOrIdent = Ident "__or__hamlet__special"
37 | 


--------------------------------------------------------------------------------
/.github/workflows/test.yaml:
--------------------------------------------------------------------------------
 1 | name: test
 2 | on:
 3 |   - pull_request
 4 | jobs:
 5 |   test:
 6 |     runs-on: ${{ matrix.os }}
 7 |     strategy:
 8 |       matrix:
 9 |         ghc: ['8.10.7', '9.0.2', '9.2.2', 'latest']
10 |         os: [ubuntu-latest, macOS-latest, windows-latest]
11 |         cabal: ['3.4', '3.6', 'latest']
12 |         exclude:
13 |           - ghc: 9.2.2
14 |             cabal: 3.4
15 |           - ghc: latest
16 |             cabal: 3.4
17 |     name: Haskell GHC ${{ matrix.ghc }} sample
18 |     steps:
19 |       - name: Cache Cabal build artifacts
20 |         uses: actions/cache@v2
21 |         with:
22 |           path: |
23 |             ${{ steps.setup-haskell-build-env.outputs.cabal-store }}
24 |             dist-newstyle
25 |           key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
26 |           restore-keys: |
27 |             ${{ runner.os }}-cabal-${{ matrix.ghc }}
28 |       - uses: actions/checkout@v3
29 |       - name: Setup Haskell
30 |         uses: haskell/actions/setup@v2
31 |         with:
32 |           ghc-version: ${{ matrix.ghc }}
33 |           cabal-version: ${{ matrix.cabal }}
34 |       - name: Build & test
35 |         run: |
36 |           cabal v2-build
37 |           cabal v2-test --enable-test
38 | 


--------------------------------------------------------------------------------
/stack-lts-10.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | #  name: custom-snapshot
17 | #  location: "./custom-snapshot.yaml"
18 | resolver: lts-10.10
19 | 
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | #    git: https://github.com/commercialhaskell/stack.git
28 | #    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | #   extra-dep: true
31 | #  subdirs:
32 | #  - auto-update
33 | #  - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - '.'
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | extra-deps: []
43 | 
44 | # Override default flag values for local packages and extra-deps
45 | flags: {}
46 | 
47 | # Extra package databases containing global packages
48 | extra-package-dbs: []
49 | 
50 | # Control whether we use the GHC we find on the path
51 | # system-ghc: true
52 | #
53 | # Require a specific version of stack, using version ranges
54 | # require-stack-version: -any # Default
55 | # require-stack-version: ">=1.2"
56 | #
57 | # Override the architecture used by stack, especially useful on Windows
58 | # arch: i386
59 | # arch: x86_64
60 | #
61 | # Extra directories used by stack for building
62 | # extra-include-dirs: [/path/to/dir]
63 | # extra-lib-dirs: [/path/to/dir]
64 | #
65 | # Allow a newer minor version of GHC than the snapshot specifies
66 | # compiler-check: newer-minor
67 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | #  name: custom-snapshot
17 | #  location: "./custom-snapshot.yaml"
18 | resolver: nightly-2022-07-10
19 | 
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | #    git: https://github.com/commercialhaskell/stack.git
28 | #    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | #   extra-dep: true
31 | #  subdirs:
32 | #  - auto-update
33 | #  - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - '.'
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | extra-deps: []
43 | 
44 | # Override default flag values for local packages and extra-deps
45 | flags: {}
46 | 
47 | # Extra package databases containing global packages
48 | extra-package-dbs: []
49 | 
50 | # Control whether we use the GHC we find on the path
51 | # system-ghc: true
52 | #
53 | # Require a specific version of stack, using version ranges
54 | # require-stack-version: -any # Default
55 | # require-stack-version: ">=1.2"
56 | #
57 | # Override the architecture used by stack, especially useful on Windows
58 | # arch: i386
59 | # arch: x86_64
60 | #
61 | # Extra directories used by stack for building
62 | # extra-include-dirs: [/path/to/dir]
63 | # extra-lib-dirs: [/path/to/dir]
64 | #
65 | # Allow a newer minor version of GHC than the snapshot specifies
66 | # compiler-check: newer-minor
67 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | MIT License
 2 | 
 3 | Copyright (c) 2016 Kadzuya OKAMOTO, http://www.arow.info
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 
23 | This project contains many codes from Michael Snoyman's [shakespearen template](http://hackage.haskell.org/package/shakespeare).
24 | Here is the original copyright notice for shakespearen template:
25 | 
26 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
27 | 
28 | Permission is hereby granted, free of charge, to any person obtaining
29 | a copy of this software and associated documentation files (the
30 | "Software"), to deal in the Software without restriction, including
31 | without limitation the rights to use, copy, modify, merge, publish,
32 | distribute, sublicense, and/or sell copies of the Software, and to
33 | permit persons to whom the Software is furnished to do so, subject to
34 | the following conditions:
35 | 
36 | The above copyright notice and this permission notice shall be
37 | included in all copies or substantial portions of the Software.
38 | 
39 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
40 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
41 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
42 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
43 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
44 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
45 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
46 | 


--------------------------------------------------------------------------------
/stack-lts-lower.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | #  name: custom-snapshot
17 | #  location: "./custom-snapshot.yaml"
18 | resolver: lts-18.28
19 | 
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | #    git: https://github.com/commercialhaskell/stack.git
28 | #    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | #   extra-dep: true
31 | #  subdirs:
32 | #  - auto-update
33 | #  - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - '.'
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | extra-deps:
43 | - template-haskell-compat-v0208-0.1.9@sha256:abba2d89c500b0ad6259f42be07c1a59d331970624de7e0600ba62738e2c0115,1523
44 | 
45 | # Override default flag values for local packages and extra-deps
46 | flags: {}
47 | 
48 | # Extra package databases containing global packages
49 | extra-package-dbs: []
50 | 
51 | # Control whether we use the GHC we find on the path
52 | # system-ghc: true
53 | #
54 | # Require a specific version of stack, using version ranges
55 | # require-stack-version: -any # Default
56 | # require-stack-version: ">=1.2"
57 | #
58 | # Override the architecture used by stack, especially useful on Windows
59 | # arch: i386
60 | # arch: x86_64
61 | #
62 | # Extra directories used by stack for building
63 | # extra-include-dirs: [/path/to/dir]
64 | # extra-lib-dirs: [/path/to/dir]
65 | #
66 | # Allow a newer minor version of GHC than the snapshot specifies
67 | # compiler-check: newer-minor
68 | 


--------------------------------------------------------------------------------
/heterocephalus.cabal:
--------------------------------------------------------------------------------
 1 | name:                heterocephalus
 2 | version:             1.0.5.7
 3 | synopsis:            A type-safe template engine for working with front end development tools
 4 | description:
 5 |     Recent front end development tools and languages are growing fast and have
 6 |     quite a complicated ecosystem. Few front end developers want to be forced
 7 |     use Shakespeare templates. Instead, they would rather use @node@-friendly
 8 |     engines such that @pug@, @slim@, and @haml@. However, in using these
 9 |     template engines, we lose the compile-time variable interpolation and type
10 |     checking from Shakespeare.
11 |     .
12 |     Heterocephalus is intended for use with another feature rich template
13 |     engine and provides a way to interpolate server side variables into a
14 |     precompiled template file with @forall@, @if@, and @case@ statements.
15 | 
16 | homepage:            https://github.com/arowM/heterocephalus#readme
17 | license:             MIT
18 | license-file:        LICENSE
19 | author:              Kadzuya Okamoto
20 | maintainer:          arow.okamoto+github@gmail.com
21 | copyright:           2016 Kadzuya Okamoto
22 | category:            Web
23 | build-type:          Simple
24 | extra-source-files:  templates/*.txt
25 |                      README.md
26 |                      CHANGELOG.md
27 | cabal-version:       >=1.10
28 | 
29 | library
30 |   hs-source-dirs:      src
31 |   exposed-modules:     Text.Heterocephalus
32 |   other-modules:       Text.Hamlet.Parse
33 |                      , Text.Heterocephalus.Parse
34 |                      , Text.Heterocephalus.Parse.Control
35 |                      , Text.Heterocephalus.Parse.Doc
36 |                      , Text.Heterocephalus.Parse.Option
37 |   build-depends:       base >= 4.14.3.0 && < 5
38 |                      , blaze-html >= 0.9.1.2
39 |                      , blaze-markup >= 0.8.2.8
40 |                      , containers >= 0.6.4.1
41 |                      , dlist >= 1.0
42 |                      , mtl >= 2.2.2
43 |                      , parsec >= 3.1.14.0
44 |                      , shakespeare >= 2.0.26
45 |                      , template-haskell >= 2.16.0.0
46 |                      , template-haskell-compat-v0208 >= 0.1.7
47 |                      , text >= 1.2.4.1
48 |                      , transformers >= 0.5.6.2
49 |   ghc-options:         -Wall -Wcompat -Wnoncanonical-monad-instances
50 |   default-language:    Haskell2010
51 | 
52 | test-suite heterocephalus-test
53 |   type:                exitcode-stdio-1.0
54 |   hs-source-dirs:      test
55 |   main-is:             Spec.hs
56 |   build-depends:       base
57 |                      , heterocephalus
58 |   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
59 |   default-language:    Haskell2010
60 | 
61 | test-suite doctest
62 |   type:                exitcode-stdio-1.0
63 |   hs-source-dirs:      test
64 |   main-is:             Doctest.hs
65 |   build-depends:       base
66 |                      , Glob
67 |                      , doctest >= 0.10
68 |                      , heterocephalus
69 |   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
70 |   default-language:    Haskell2010
71 | 
72 | source-repository head
73 |   type:     git
74 |   location: https://github.com/arowM/heterocephalus
75 | 


--------------------------------------------------------------------------------
/src/Text/Heterocephalus/Parse/Doc.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE DeriveDataTypeable #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE FlexibleInstances #-}
  5 | {-# LANGUAGE LambdaCase #-}
  6 | {-# LANGUAGE TemplateHaskell #-}
  7 | 
  8 | module Text.Heterocephalus.Parse.Doc where
  9 | 
 10 | #if MIN_VERSION_base(4,9,0)
 11 | #else
 12 | import Control.Applicative ((*>), (<*), pure)
 13 | #endif
 14 | import Control.Monad (void)
 15 | import Data.Data (Data)
 16 | import Data.Typeable (Typeable)
 17 | import Text.Parsec
 18 |        (Parsec, ParseError, SourcePos, (<|>), eof, incSourceLine, many,
 19 |         many1, optional, optionMaybe, parse, tokenPrim)
 20 | import Text.Shakespeare.Base (Deref)
 21 | 
 22 | import Text.Hamlet.Parse
 23 | import Text.Heterocephalus.Parse.Control (Content(..), Control(..))
 24 | 
 25 | data Doc = DocForall Deref Binding [Doc]
 26 |          | DocCond [(Deref, [Doc])] (Maybe [Doc])
 27 |          | DocCase Deref [(Binding, [Doc])]
 28 |          | DocContent Content
 29 |     deriving (Data, Eq, Read, Show, Typeable)
 30 | 
 31 | type DocParser = Parsec [Control] ()
 32 | 
 33 | parseDocFromControls :: [Control] -> Either ParseError [Doc]
 34 | parseDocFromControls = parse (docsParser <* eof) ""
 35 | 
 36 | docsParser :: DocParser [Doc]
 37 | docsParser = many docParser
 38 | 
 39 | docParser :: DocParser Doc
 40 | docParser = forallDoc <|> condDoc <|> caseDoc <|> contentDoc
 41 | 
 42 | forallDoc :: DocParser Doc
 43 | forallDoc = do
 44 |   ControlForall deref binding <- forallControlStatement
 45 |   innerDocs <- docsParser
 46 |   void endforallControlStatement
 47 |   pure $ DocForall deref binding innerDocs
 48 | 
 49 | condDoc :: DocParser Doc
 50 | condDoc = do
 51 |   ControlIf ifDeref <- ifControlStatement
 52 |   ifInnerDocs <- docsParser
 53 |   elseIfs <- condElseIfs
 54 |   maybeElseInnerDocs <- optionMaybe $ elseControlStatement *> docsParser
 55 |   void endifControlStatement
 56 |   let allConds = (ifDeref, ifInnerDocs) : elseIfs
 57 |   pure $ DocCond allConds maybeElseInnerDocs
 58 | 
 59 | caseDoc :: DocParser Doc
 60 | caseDoc = do
 61 |   ControlCase caseDeref <- caseControlStatement
 62 |   -- Ignore a single, optional NoControl statement (with whitespace that will be
 63 |   -- ignored).
 64 |   optional contentDoc
 65 |   caseOfs <- many1 $ do
 66 |     ControlCaseOf caseBinding <- caseOfControlStatement
 67 |     innerDocs <- docsParser
 68 |     pure (caseBinding, innerDocs)
 69 |   void endcaseControlStatement
 70 |   pure $ DocCase caseDeref caseOfs
 71 | 
 72 | contentDoc :: DocParser Doc
 73 | contentDoc = primControlStatement $ \case
 74 |   NoControl content -> Just $ DocContent content
 75 |   _ -> Nothing
 76 | 
 77 | condElseIfs :: DocParser [(Deref, [Doc])]
 78 | condElseIfs = many $ do
 79 |   ControlElseIf elseIfDeref <- elseIfControlStatement
 80 |   elseIfInnerDocs <- docsParser
 81 |   pure (elseIfDeref, elseIfInnerDocs)
 82 | 
 83 | ifControlStatement :: DocParser Control
 84 | ifControlStatement = primControlStatement $ \case
 85 |   ControlIf deref -> Just $ ControlIf deref
 86 |   _ -> Nothing
 87 | 
 88 | elseIfControlStatement :: DocParser Control
 89 | elseIfControlStatement = primControlStatement $ \case
 90 |   ControlElseIf deref -> Just $ ControlElseIf deref
 91 |   _ -> Nothing
 92 | 
 93 | elseControlStatement :: DocParser Control
 94 | elseControlStatement = primControlStatement $ \case
 95 |   ControlElse -> Just ControlElse
 96 |   _ -> Nothing
 97 | 
 98 | endifControlStatement :: DocParser Control
 99 | endifControlStatement = primControlStatement $ \case
100 |   ControlEndIf -> Just ControlEndIf
101 |   _ -> Nothing
102 | 
103 | caseControlStatement :: DocParser Control
104 | caseControlStatement = primControlStatement $ \case
105 |   ControlCase deref -> Just $ ControlCase deref
106 |   _ -> Nothing
107 | 
108 | caseOfControlStatement :: DocParser Control
109 | caseOfControlStatement = primControlStatement $ \case
110 |   ControlCaseOf binding -> Just $ ControlCaseOf binding
111 |   _ -> Nothing
112 | 
113 | endcaseControlStatement :: DocParser Control
114 | endcaseControlStatement = primControlStatement $ \case
115 |   ControlEndCase -> Just ControlEndCase
116 |   _ -> Nothing
117 | 
118 | forallControlStatement :: DocParser Control
119 | forallControlStatement = primControlStatement $ \case
120 |   ControlForall deref binding -> Just $ ControlForall deref binding
121 |   _ -> Nothing
122 | 
123 | endforallControlStatement :: DocParser Control
124 | endforallControlStatement = primControlStatement $ \case
125 |   ControlEndForall -> Just ControlEndForall
126 |   _ -> Nothing
127 | 
128 | primControlStatement :: (Control -> Maybe x)-> DocParser x
129 | primControlStatement = tokenPrim show incSourcePos
130 | 
131 | incSourcePos :: SourcePos -> a -> b -> SourcePos
132 | incSourcePos sourcePos _ _ = incSourceLine sourcePos 1
133 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | [![test](https://github.com/arowM/heterocephalus/actions/workflows/test.yaml/badge.svg)](https://github.com/arowM/heterocephalus/actions/workflows/test.yaml)
  2 | [![Hackage](https://img.shields.io/hackage/v/heterocephalus.svg)](https://hackage.haskell.org/package/heterocephalus)
  3 | [![Stackage LTS](http://stackage.org/package/heterocephalus/badge/lts)](http://stackage.org/lts/package/heterocephalus)
  4 | [![Stackage Nightly](http://stackage.org/package/heterocephalus/badge/nightly)](http://stackage.org/nightly/package/heterocephalus)
  5 | 
  6 | ![hetero-mini](https://cloud.githubusercontent.com/assets/1481749/20267445/2a9da33e-aabe-11e6-8aa7-88e36f0a8d5d.jpg)
  7 | 
  8 | # Heterocephalus template engine
  9 | 
 10 | A type-safe template engine for working with popular front end development tools.
 11 | 
 12 | Any PRs are welcome, even for documentation fixes.  (The main author of this library is not an English native.)
 13 | 
 14 | * [Who should use this?](#who-should-use-this)
 15 | * [Features](#features)
 16 | * [Usage](#usage)
 17 | * [Checking behaviours in `ghci`](#checking-behaviours-in-ghci)
 18 | * [Syntax](#syntax)
 19 | * [Why "heterocephalus"?](#why-heterocephalus)
 20 | 
 21 | ## Who should use this?
 22 | 
 23 | If you are planning to use Haskell with recent web front-end tools like gulp,
 24 | webpack, npm, etc, then this library can help you!
 25 | 
 26 | There are many Haskell template engines today.
 27 | [Shakespeare](http://hackage.haskell.org/package/shakespeare) is great because
 28 | it checks template variables at compile time.  Using Shakespeare, it's not
 29 | possible for the template file to cause a runtime-error.
 30 | 
 31 | Shakespeare provides its own original ways of writing HTML
 32 | ([Hamlet](https://hackage.haskell.org/package/shakespeare/docs/Text-Hamlet.html)),
 33 | CSS
 34 | ([Cassius](https://hackage.haskell.org/package/shakespeare/docs/Text-Cassius.html)
 35 | /
 36 | [Lucius](https://hackage.haskell.org/package/shakespeare/docs/Text-Lucius.html)),
 37 | and JavaScript
 38 | ([Julius](https://hackage.haskell.org/package/shakespeare-2.0.11.2/docs/Text-Julius.html)).
 39 | If you use these original markup languages, it is possible to use control
 40 | statements like `forall` (for looping), `if` (for conditionals), and `case`
 41 | (for case-splitting).
 42 | 
 43 | However, if you're using any other markup language (like
 44 | [pug](https://pugjs.org), [slim](http://slim-lang.com/),
 45 | [haml](http://haml.info/), normal HTML, normal CSS, etc), Shakespeare only
 46 | provides you with the
 47 | [Text.Shakespeare.Text](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html)
 48 | module.  This gives you variable interpolation, but no control statements like
 49 | `forall`, `if`, or `case`.
 50 | 
 51 | [`Haiji`](https://hackage.haskell.org/package/haiji) is another interesting
 52 | library.  It has all the features we require, but its templates take a very
 53 | [long time to compile](https://github.com/blueimpact/kucipong/pull/7) with
 54 | GHC >= 7.10.
 55 | 
 56 | Heterocephalus fills this missing niche. It gives you variable interpolation
 57 | along with control statements that can be used with any markup language.  Its
 58 | compile times are reasonable.
 59 | 
 60 | ## Features
 61 | 
 62 | Here are the main features of this module.
 63 | 
 64 | * __DO__ ensure that all interpolated variables are in scope
 65 | 
 66 | * __DO__ ensure that all interpolated variables have proper types for the template
 67 | 
 68 | * __DO__ expand the template literal on compile time
 69 | 
 70 | * __DO__ provide a way to use `forall`, `if`, and `case` statments in the template
 71 | 
 72 |     `Text.Shakespeare.Text.text` has a way to do variable interpolation, but no
 73 |     way to use these types of control statements.
 74 | 
 75 | * __DO NOT__ enforce that templates obey a peculiar syntax
 76 | 
 77 |     Shakespeare templates make you use their original style (Hamlet, Cassius,
 78 |     Lucius, Julius, etc).  The
 79 |     [`Text.Shakespeare.Text.text`](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html#v:text)
 80 |     function does not require you to use any particular style, but it does not
 81 |     have control statements like `forall`, `if` and `case`.
 82 | 
 83 |     This makes it impossible to use Shakespeare with another template engine
 84 |     such as `pug` in front end side.  It is not suitable for recent rich front
 85 |     end tools.
 86 | 
 87 | * __DO NOT__ have a long compile time
 88 | 
 89 |     `haiji` is another awesome template library. It has many of our required
 90 |     features, but it takes too long to compile when used with ghc >= 7.10.
 91 | 
 92 | * __DO NOT__ provide unneeded control statements
 93 | 
 94 |     Other template engines like [EDE](https://hackage.haskell.org/package/ede)
 95 |     provide rich control statements like importing external files.
 96 |     Heterocephalus does not provide control statements like this because it is
 97 |     meant to be used with a rich front-end template engine (like pug, slim,
 98 |     etc).
 99 | 
100 | ## Usage
101 | 
102 | You can compile external template files with the following four functions:
103 | 
104 | * `compileTextFile`: A basic function that embeds variables without escaping and without default values.
105 | * `compileTextFileWithDefault`: Same as `compileTextFile` but you can set default template values.
106 | * `compileHtmlFile`: Same as `compileTextFile` but all embeded variables are escaped for html.
107 | * `compileHtmlFileWithDefault`: Same as `compileHtmlFile` but you can set default template values.
108 | 
109 | For more details, see the [latest haddock
110 | document](https://www.stackage.org/haddock/nightly/heterocephalus/Text-Heterocephalus.html).
111 | 
112 | ## Checking behaviours in `ghci`
113 | 
114 | To check the behaviour, you can test in `ghci` as follows. Note that
115 | `compileText` and `compileHtml` are used for checking syntaxes.
116 | 
117 | ```haskell
118 | $ stack install heterocephalus  # Only first time
119 | $ stack repl --no-build --no-load
120 | Prelude> :m Text.Heterocephalus Text.Blaze.Renderer.String
121 | Prelude> :set -XTemplateHaskell -XQuasiQuotes
122 | Prelude> let a = 34; b = "<script>"; in renderMarkup [compileText|foo #{a} #{b}|]
123 | "foo 34 <script>"
124 | Prelude> let a = 34; b = "<script>"; in renderMarkup [compileHtml|foo #{a} #{b}|]
125 | "foo 34 &lt;script&gt;"
126 | ```
127 | 
128 | ## Syntax
129 | 
130 | The
131 | [Text.Heterocephalus](https://www.stackage.org/haddock/nightly/heterocephalus/Text-Heterocephalus.html)
132 | module provides two major features for use in template files: variable interpolation
133 | and control statements.
134 | 
135 | ### Variable interpolation
136 | 
137 | A Haskell variable can be embedded in the template file with the `#{foo}`
138 | syntax.  The value of the variable will be injected in at run time.
139 | 
140 | #### Basic usage
141 | 
142 | All of following are correct (this assumes that you have already declared the
143 | `var` variable in your Haskell program and it is in scope):
144 | 
145 | ```text
146 | #{ var }
147 | #{var}
148 | #{  var}
149 | #{var  }
150 | #{ var  }
151 | ```
152 | 
153 | The variable must be an instance of
154 | [`Text.Blaze.ToMarkup`](https://hackage.haskell.org/package/blaze-markup/docs/Text-Blaze.html#t:ToMarkup).
155 | 
156 | #### Advanced usage
157 | 
158 | You can use functions and data constructors as well.
159 | 
160 | ```text
161 | #{ even num }
162 | #{ num + 3 }
163 | #{ take 3 str }
164 | #{ maybe "" id (Just b) }
165 | ```
166 | 
167 | ### Control statements
168 | 
169 | Only two type of control statements are provided.
170 | 
171 | #### Forall
172 | 
173 | ```
174 | %{ forall x <- xs }
175 | #{x}
176 | %{ endforall }
177 | 
178 | %{ forall (k,v) <- kvs }
179 | #{k}: #{v}
180 | %{ endforall }
181 | ```
182 | 
183 | #### If
184 | 
185 | ```
186 | %{ if even num }
187 | #{num} is even number.
188 | %{ else }
189 | #{num} is odd number.
190 | %{ endif }
191 | ```
192 | 
193 | ```
194 | %{ if (num < 30) }
195 | #{ num } is less than 30.
196 | %{ elseif (num <= 60) }
197 | #{ num } is between 30 and 60.
198 | %{ else }
199 | #{ num } is over 60.
200 | %{ endif }
201 | ```
202 | 
203 | #### Case
204 | 
205 | ```
206 | %{ case maybeNum }
207 | %{ of Just 3 }
208 | num is 3.
209 | %{ of Just num }
210 | num is not 3, but #{num}.
211 | %{ of Nothing }
212 | num is not anything.
213 | %{ endcase }
214 | ```
215 | 
216 | ```
217 | %{ case nums }
218 | %{ of (:) n _ }
219 | first num is #{n}.
220 | %{ of [] }
221 | no nums.
222 | %{ endcase }
223 | ```
224 | 
225 | #### Why we do not provide `maybe` and `with`?
226 | 
227 | TODO
228 | 
229 | Discussions about this topic is on [issue #9](https://github.com/arowM/heterocephalus/issues/9).
230 | 
231 | ## Why "heterocephalus"?
232 | 
233 | "Heterocephalus" is the scientific name of the [naked mole-rat](https://en.wikipedia.org/wiki/Naked_mole-rat).
234 | 


--------------------------------------------------------------------------------
/src/Text/Heterocephalus/Parse/Control.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE DeriveDataTypeable #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE FlexibleInstances #-}
  5 | {-# LANGUAGE LambdaCase #-}
  6 | {-# LANGUAGE TemplateHaskell #-}
  7 | 
  8 | module Text.Heterocephalus.Parse.Control where
  9 | 
 10 | #if MIN_VERSION_base(4,9,0)
 11 | #else
 12 | import Control.Applicative ((<$>), (*>), (<*), pure)
 13 | #endif
 14 | import Control.Monad (guard, void)
 15 | import Control.Monad.Reader (Reader, runReaderT)
 16 | import Data.Char (isUpper)
 17 | import Data.Data (Data)
 18 | import Data.Functor (($>))
 19 | import Data.Functor.Identity (runIdentity)
 20 | import Data.Typeable (Typeable)
 21 | import Text.Parsec
 22 |        (Parsec, ParsecT, (<?>), (<|>), alphaNum, between, char, choice,
 23 |         eof, many, many1, manyTill, mkPT, noneOf, oneOf, option, optional,
 24 |         runParsecT, runParserT, sepBy, skipMany, spaces, string,
 25 |         try)
 26 | import Text.Shakespeare.Base
 27 |        (Ident(Ident), Deref, parseDeref, parseVar)
 28 | 
 29 | import Text.Hamlet.Parse
 30 | import Text.Heterocephalus.Parse.Option
 31 |        (ParseOptions, getControlPrefix, getVariablePrefix)
 32 | 
 33 | data Control
 34 |   = ControlForall Deref Binding
 35 |   | ControlEndForall
 36 |   | ControlIf Deref
 37 |   | ControlElse
 38 |   | ControlElseIf Deref
 39 |   | ControlEndIf
 40 |   | ControlCase Deref
 41 |   | ControlCaseOf Binding
 42 |   | ControlEndCase
 43 |   | NoControl Content
 44 |   deriving (Data, Eq, Read, Show, Typeable)
 45 | 
 46 | data Content = ContentRaw String
 47 |              | ContentVar Deref
 48 |     deriving (Data, Eq, Read, Show, Typeable)
 49 | 
 50 | type UserParser = ParsecT String () (Reader ParseOptions)
 51 | 
 52 | parseLineControl :: ParseOptions -> String -> Either String [Control]
 53 | parseLineControl opts s =
 54 |   let readerT = runParserT lineControl () "" s
 55 |       res = runIdentity $ runReaderT readerT opts
 56 |   in case res of
 57 |        Left e -> Left $ show e
 58 |        Right x -> Right x
 59 | 
 60 | lineControl :: UserParser [Control]
 61 | lineControl = manyTill control $ try eof >> return ()
 62 | 
 63 | control :: UserParser Control
 64 | control = noControlVariable <|> controlStatement <|> noControlRaw
 65 |   where
 66 |     controlStatement :: UserParser Control
 67 |     controlStatement = do
 68 |       x <- parseControlStatement
 69 |       case x of
 70 |         Left str -> return (NoControl $ ContentRaw str)
 71 |         Right ctrl -> return ctrl
 72 | 
 73 |     noControlVariable :: UserParser Control
 74 |     noControlVariable = do
 75 |       variablePrefix <- getVariablePrefix
 76 |       x <- identityToReader $ parseVar variablePrefix
 77 |       return . NoControl $
 78 |         case x of
 79 |           Left str -> ContentRaw str
 80 |           Right deref -> ContentVar deref
 81 | 
 82 |     noControlRaw :: UserParser Control
 83 |     noControlRaw = do
 84 |       controlPrefix <- getControlPrefix
 85 |       variablePrefix <- getVariablePrefix
 86 |       (NoControl . ContentRaw) <$>
 87 |         many (noneOf [controlPrefix, variablePrefix])
 88 | 
 89 | parseControlStatement :: UserParser (Either String Control)
 90 | parseControlStatement = do
 91 |   a <- parseControl
 92 |   optional eol
 93 |   return a
 94 |  where
 95 |   eol :: UserParser ()
 96 |   eol = void (char '\n') <|> void (string "\r\n")
 97 | 
 98 | parseControl :: UserParser (Either String Control)
 99 | parseControl = do
100 |   controlPrefix <- getControlPrefix
101 |   void $ char controlPrefix
102 |   let escape = char '\\' $> Left [controlPrefix]
103 |   escape <|>
104 |     (Right <$> parseControlBetweenBrackets) <|>
105 |     return (Left [controlPrefix])
106 | 
107 | parseControlBetweenBrackets :: UserParser Control
108 | parseControlBetweenBrackets =
109 |   between (char '{') (char '}') $ spaces *> parseControl' <* spaces
110 | 
111 | parseControl' :: UserParser Control
112 | parseControl' =
113 |   try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElseIf <|>
114 |   try parseElse <|>
115 |   try parseEndIf <|>
116 |   try parseCase <|>
117 |   try parseCaseOf <|>
118 |   try parseEndCase
119 |   where
120 |     parseForall :: UserParser Control
121 |     parseForall = do
122 |       string "forall" *> spaces
123 |       (x, y) <- binding
124 |       pure $ ControlForall x y
125 | 
126 |     parseEndForall :: UserParser Control
127 |     parseEndForall = string "endforall" $> ControlEndForall
128 | 
129 |     parseIf :: UserParser Control
130 |     parseIf =
131 |       string "if" *> spaces *> fmap ControlIf (identityToReader parseDeref)
132 | 
133 |     parseElseIf :: UserParser Control
134 |     parseElseIf =
135 |       string "elseif" *>
136 |       spaces *>
137 |       fmap ControlElseIf (identityToReader parseDeref)
138 | 
139 |     parseElse :: UserParser Control
140 |     parseElse = string "else" $> ControlElse
141 | 
142 |     parseEndIf :: UserParser Control
143 |     parseEndIf = string "endif" $> ControlEndIf
144 | 
145 |     parseCase :: UserParser Control
146 |     parseCase =
147 |       string "case" *>
148 |       spaces *>
149 |       fmap ControlCase (identityToReader parseDeref)
150 | 
151 |     parseCaseOf :: UserParser Control
152 |     parseCaseOf = string "of" *> spaces *> fmap ControlCaseOf identPattern
153 | 
154 |     parseEndCase :: UserParser Control
155 |     parseEndCase = string "endcase" $> ControlEndCase
156 | 
157 |     binding :: UserParser (Deref, Binding)
158 |     binding = do
159 |       y <- identPattern
160 |       spaces
161 |       _ <- string "<-"
162 |       spaces
163 |       x <- identityToReader parseDeref
164 |       _ <- spaceTabs
165 |       return (x, y)
166 | 
167 |     spaceTabs :: UserParser String
168 |     spaceTabs = many $ oneOf " \t"
169 | 
170 |     -- | Parse an indentifier.  This is an sequence of alphanumeric characters,
171 |     -- or an operator.
172 |     ident :: UserParser Ident
173 |     ident = do
174 |       i <- (many1 (alphaNum <|> char '_' <|> char '\'')) <|> try operator
175 |       white
176 |       return (Ident i) <?> "identifier"
177 | 
178 |     -- | Parse an operator.  An operator is a sequence of characters in
179 |     -- 'operatorList' in between parenthesis.
180 |     operator :: UserParser String
181 |     operator = do
182 |       oper <- between (char '(') (char ')') . many1 $ oneOf operatorList
183 |       pure $ oper
184 | 
185 |     operatorList :: String
186 |     operatorList = "!#$%&*+./<=>?@\\^|-~:"
187 | 
188 |     parens :: UserParser a -> UserParser a
189 |     parens = between (char '(' >> white) (char ')' >> white)
190 | 
191 |     brackets :: UserParser a -> UserParser a
192 |     brackets = between (char '[' >> white) (char ']' >> white)
193 | 
194 |     braces :: UserParser a -> UserParser a
195 |     braces = between (char '{' >> white) (char '}' >> white)
196 | 
197 |     comma :: UserParser ()
198 |     comma = char ',' >> white
199 | 
200 |     atsign :: UserParser ()
201 |     atsign = char '@' >> white
202 | 
203 |     equals :: UserParser ()
204 |     equals = char '=' >> white
205 | 
206 |     white :: UserParser ()
207 |     white = skipMany $ char ' '
208 | 
209 |     wildDots :: UserParser ()
210 |     wildDots = string ".." >> white
211 | 
212 |     -- | Return 'True' if 'Ident' is a variable.  Variables are defined as
213 |     -- starting with a lowercase letter.
214 |     isVariable :: Ident -> Bool
215 |     isVariable (Ident (x:_)) = not (isUpper x)
216 |     isVariable (Ident []) = error "isVariable: bad identifier"
217 | 
218 |     -- | Return 'True' if an 'Ident' is a constructor.  Constructors are
219 |     -- defined as either starting with an uppercase letter, or being an
220 |     -- operator.
221 |     isConstructor :: Ident -> Bool
222 |     isConstructor (Ident (x:_)) = isUpper x || elem x operatorList
223 |     isConstructor (Ident []) = error "isConstructor: bad identifier"
224 | 
225 |     -- | This function tries to parse an entire pattern binding with either
226 |     -- @'gcon' True@ or 'apat'.  For instance, in the pattern
227 |     -- @let Foo a b = ...@, this function tries to parse @Foo a b@ with 'gcon'.
228 |     -- In the pattern @let n = ...@, this function tries to parse @n@ with
229 |     -- 'apat'.
230 |     identPattern :: UserParser Binding
231 |     identPattern = gcon True <|> apat
232 |       where
233 |         apat :: UserParser Binding
234 |         apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]
235 | 
236 |         -- | Parse a variable in a pattern.  For instance in, in a pattern like
237 |         -- @let Just n = ...@, this function would be what is used to parse the
238 |         -- @n@.  This function also handles aliases with @\@@.
239 |         varpat :: UserParser Binding
240 |         varpat = do
241 |           v <-
242 |             try $ do
243 |               v <- ident
244 |               guard (isVariable v)
245 |               return v
246 |           option (BindVar v) $ do
247 |             atsign
248 |             b <- apat
249 |             return (BindAs v b) <?> "variable"
250 | 
251 |         -- | This function tries to parse an entire pattern binding.  For
252 |         -- instance, in the pattern @let Foo a b = ...@, this function tries to
253 |         -- parse @Foo a b@.
254 |         --
255 |         -- This function first tries to parse a data contructor (using
256 |         -- 'dataConstr').  In the example above, that would be like parsing
257 |         -- @Foo@.
258 |         --
259 |         -- Then, the function tries to do two different things.
260 |         --
261 |         -- 1. It tries to parse record syntax with 'record'.  In a pattern like
262 |         -- @let Foo{foo1 = 3, foo2 = "hello"} = ...@, it would parse the
263 |         -- @{foo1 = 3, foo2 = "hello"}@ part.
264 |         --
265 |         -- 2. If parsing the record syntax fails, it then tries to parse
266 |         -- many normal patterns with 'apat'.  In a pattern like
267 |         -- @let Foo a b = ...@, it would be like parsing the @a b@ part.
268 |         --
269 |         -- If that fails, then it just returns the original data contructor
270 |         -- with no arguments.
271 |         --
272 |         -- The 'Bool' argument determines whether or not it tries to parse
273 |         -- normal patterns in 2.  If the boolean argument is 'True', then it
274 |         -- tries parsing normal patterns in 2.  If the boolean argument is
275 |         -- 'False', then 2 is skipped altogether.
276 |         gcon :: Bool -> UserParser Binding
277 |         gcon allowArgs = do
278 |           c <- try dataConstr
279 |           choice
280 |             [ record c
281 |             , fmap (BindConstr c) (guard allowArgs >> many apat)
282 |             , return (BindConstr c [])
283 |             ] <?>
284 |             "constructor"
285 | 
286 |         -- | Parse a possibly qualified identifier using 'ident'.
287 |         dataConstr :: UserParser DataConstr
288 |         dataConstr = do
289 |           p <- dcPiece
290 |           ps <- many dcPieces
291 |           return $ toDataConstr p ps
292 | 
293 |         dcPiece :: UserParser String
294 |         dcPiece = do
295 |           x@(Ident y) <- ident
296 |           guard $ isConstructor x
297 |           return y
298 | 
299 |         dcPieces :: UserParser String
300 |         dcPieces = do
301 |           _ <- char '.'
302 |           dcPiece
303 | 
304 |         toDataConstr :: String -> [String] -> DataConstr
305 |         toDataConstr x [] = DCUnqualified $ Ident x
306 |         toDataConstr x (y:ys) = go (x :) y ys
307 |           where
308 |             go :: ([String] -> [String]) -> String -> [String] -> DataConstr
309 |             go front next [] = DCQualified (Module $ front []) (Ident next)
310 |             go front next (rest:rests) = go (front . (next :)) rest rests
311 | 
312 |         record :: DataConstr -> UserParser Binding
313 |         record c =
314 |           braces $ do
315 |             (fields, wild) <- option ([], False) go
316 |             return (BindRecord c fields wild)
317 |           where
318 |             go :: UserParser ([(Ident, Binding)], Bool)
319 |             go =
320 |               (wildDots >> return ([], True)) <|>
321 |               (do x <- recordField
322 |                   (xs, wild) <- option ([], False) (comma >> go)
323 |                   return (x : xs, wild))
324 | 
325 |         recordField :: UserParser (Ident, Binding)
326 |         recordField = do
327 |           field <- ident
328 |           p <-
329 |             option
330 |               (BindVar field) -- support punning
331 |               (equals >> identPattern)
332 |           return (field, p)
333 | 
334 |         tuplepat :: UserParser Binding
335 |         tuplepat = do
336 |           xs <- identPattern `sepBy` comma
337 |           return $
338 |             case xs of
339 |               [x] -> x
340 |               _ -> BindTuple xs
341 | 
342 |         listpat :: UserParser Binding
343 |         listpat = BindList <$> identPattern `sepBy` comma
344 | 
345 | identityToReader :: Parsec String () a -> UserParser a
346 | identityToReader p =
347 |   mkPT $ pure . fmap (pure . runIdentity) . runIdentity . runParsecT p
348 | 


--------------------------------------------------------------------------------
/src/Text/Heterocephalus.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE TemplateHaskell #-}
  3 | {-# LANGUAGE TupleSections #-}
  4 | {-# LANGUAGE CPP #-}
  5 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  6 | 
  7 | {- |
  8 | Module      :  Text.Heterocephalus
  9 | 
 10 | Copyright   :  Kadzuya Okamoto 2016
 11 | License     :  MIT
 12 | 
 13 | Stability   :  experimental
 14 | Portability :  unknown
 15 | 
 16 | This module exports functions for working with frontend templates from Haskell.
 17 | -}
 18 | 
 19 | module Text.Heterocephalus
 20 |   (
 21 |   -- * Core functions
 22 |     compileTextFile
 23 |   , compileTextFileWith
 24 |   , compileTextFileWithDefault
 25 |   , compileHtmlFile
 26 |   , compileHtmlFileWith
 27 |   , compileHtmlFileWithDefault
 28 | 
 29 |   -- * QuasiQuoters
 30 |   , compileText
 31 |   , compileHtml
 32 | 
 33 |   -- * ScopeM
 34 |   , ScopeM
 35 |   , setDefault
 36 |   , overwrite
 37 | 
 38 |   -- * low-level
 39 |   , HeterocephalusSetting(..)
 40 |   , textSetting
 41 |   , htmlSetting
 42 |   , ParseOptions(..)
 43 |   , defaultParseOptions
 44 |   , createParseOptions
 45 |   , DefaultScope
 46 |   , compile
 47 |   , compileWith
 48 |   , compileWithDefault
 49 |   , compileFile
 50 |   , compileFileWith
 51 |   , compileFileWithDefault
 52 |   , compileFromString
 53 |   , compileFromStringWithDefault
 54 |   ) where
 55 | 
 56 | #if MIN_VERSION_base(4,9,0)
 57 | #else
 58 | import Control.Applicative ((<$>), (<*>), Applicative(..))
 59 | import Data.Monoid (Monoid, mempty, mappend)
 60 | #endif
 61 | import Control.Monad (forM)
 62 | import Data.Char (isDigit)
 63 | import Data.DList (DList)
 64 | import qualified Data.DList as DList
 65 | import qualified Data.Foldable as F
 66 | import Data.List (intercalate)
 67 | import qualified Data.Semigroup as Sem
 68 | import Data.String (IsString(..))
 69 | import Data.Text (Text, pack)
 70 | import qualified Data.Text.Lazy as TL
 71 | import Language.Haskell.TH.Lib (ExpQ, varE)
 72 | import Language.Haskell.TH.Quote
 73 |        (QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType)
 74 | #if MIN_VERSION_template_haskell(2,9,0)
 75 | import Language.Haskell.TH.Syntax
 76 |        (Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),
 77 |         Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,
 78 |         newName, qAddDependentFile, qRunIO, reify)
 79 | #else
 80 | import Language.Haskell.TH.Syntax
 81 | #endif
 82 | import TemplateHaskell.Compat.V0208
 83 | import Text.Blaze (preEscapedToMarkup)
 84 | import Text.Blaze.Html (toHtml)
 85 | import Text.Blaze.Internal (preEscapedText)
 86 | import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH)
 87 | import Text.Hamlet.Parse
 88 |        (Binding(..), DataConstr(..), Module(Module), specialOrIdent)
 89 | import Text.Shakespeare.Base
 90 |        (Deref, Ident(..), Scope, derefToExp, readUtf8File)
 91 | 
 92 | import Text.Heterocephalus.Parse
 93 |        (Doc(..), Content(..), ParseOptions(..), createParseOptions,
 94 |         defaultParseOptions, docFromString)
 95 | 
 96 | {- $setup
 97 |   >>> :set -XTemplateHaskell -XQuasiQuotes
 98 |   >>> import Text.Blaze.Renderer.String
 99 | -}
100 | 
101 | {-| A function to compile template file.
102 |   This function __DOES NOT__ escape template variables.
103 |   To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.
104 | 
105 |   >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileTextFile "templates/sample.txt"))
106 |   sample
107 |   key: <a>,
108 |   key: b,
109 |  -}
110 | compileTextFile :: FilePath -> Q Exp
111 | compileTextFile = compileFile textSetting
112 | 
113 | {-| Same as 'compileText' but allows the user to specify extra values for template parameters.
114 |   Values declared by 'overwrite' overwrites same name variables.
115 |   Values declared by 'setDefault' are overwritten by same name variables.
116 | 
117 | >>> :set -XOverloadedStrings
118 | >>> :{
119 | putStr $ renderMarkup (
120 |   let as = ["<a>", "b"]
121 |   in $(compileTextFileWith "templates/sample.txt" $ do
122 |     setDefault "as" [| ["foo", "bar"] |]
123 |   )
124 | )
125 | :}
126 | sample
127 | key: <a>,
128 | key: b,
129 | 
130 | >>> :{
131 | putStr $ renderMarkup (
132 |   let as = ["<a>", "b"]
133 |   in $(compileTextFileWith "templates/sample.txt" $ do
134 |     overwrite "as" [| ["foo", "bar"] |]
135 |   )
136 | )
137 | :}
138 | sample
139 | key: foo,
140 | key: bar,
141 | 
142 | >>> :{
143 | putStr $ renderMarkup (
144 |   let as = ["<a>", "b"]
145 |   in $(compileTextFileWith "templates/sample.txt" $ do
146 |     overwrite "as" [| ["bazbaz", "barbar"] |]
147 |     setDefault "as" [| ["foo", "bar"] |]
148 |     overwrite "as" [| ["baz", "foobar"] |]
149 |   )
150 | )
151 | :}
152 | sample
153 | key: baz,
154 | key: foobar,
155 |  -}
156 | compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
157 | compileTextFileWith fp scopeM = compileFileWith scopeM textSetting fp
158 | 
159 | {-| Same as 'compileText' but allows the user to specify default values for template parameters.
160 | 
161 | >>> :set -XOverloadedStrings
162 | >>> :{
163 | putStr $ renderMarkup (
164 |   let as = ["<a>", "b"]
165 |   in $(compileTextFileWithDefault "templates/sample.txt"
166 |     [("as", [| ["foo", "bar"] |])]
167 |   )
168 | )
169 | :}
170 | sample
171 | key: <a>,
172 | key: b,
173 | 
174 | >>> :{
175 | putStr $ renderMarkup (
176 |   $(compileTextFileWithDefault "templates/sample.txt"
177 |     [("as", [| ["foo", "bar"] |])]
178 |   )
179 | )
180 | :}
181 | sample
182 | key: foo,
183 | key: bar,
184 |  -}
185 | compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
186 | compileTextFileWithDefault fp scope = compileFileWithDefault scope textSetting fp
187 | 
188 | {-| Same as 'compileTextFile' but escapes template variables in HTML.
189 | 
190 |   >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileHtmlFile "templates/sample.txt"))
191 |   sample
192 |   key: &lt;a&gt;,
193 |   key: b,
194 |  -}
195 | compileHtmlFile :: FilePath -> Q Exp
196 | compileHtmlFile fp = compileHtmlFileWithDefault fp []
197 | 
198 | {-| Same as 'compileHtmlFile' but allows the user to specify extra values for template parameters.
199 |   Values declared by 'overwrite' overwrites same name variables.
200 |   Values declared by 'setDefault' are overwritten by same name variables.
201 | 
202 | >>> :set -XOverloadedStrings
203 | >>> :{
204 | putStr $ renderMarkup (
205 |   let as = ["<a>", "b"]
206 |   in $(compileHtmlFileWith "templates/sample.txt" $ do
207 |     setDefault "as" [| ["foo", "bar"] |]
208 |   )
209 | )
210 | :}
211 | sample
212 | key: &lt;a&gt;,
213 | key: b,
214 | 
215 | >>> :{
216 | putStr $ renderMarkup (
217 |   let as = ["<a>", "b"]
218 |   in $(compileHtmlFileWith "templates/sample.txt" $ do
219 |     overwrite "as" [| ["foo", "bar"] |]
220 |   )
221 | )
222 | :}
223 | sample
224 | key: foo,
225 | key: bar,
226 | 
227 | >>> :{
228 | putStr $ renderMarkup (
229 |   let as = ["<a>", "b"]
230 |   in $(compileHtmlFileWith "templates/sample.txt" $ do
231 |     overwrite "as" [| ["bazbaz", "barbar"] |]
232 |     setDefault "as" [| ["foo", "bar"] |]
233 |     overwrite "as" [| ["baz", "foobar"] |]
234 |   )
235 | )
236 | :}
237 | sample
238 | key: baz,
239 | key: foobar,
240 |  -}
241 | compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
242 | compileHtmlFileWith fp scopeM = compileFileWith scopeM htmlSetting fp
243 | 
244 | {-| Same as 'compileHtmlFile' but allows the user to specify default values for template parameters.
245 | 
246 | >>> :set -XOverloadedStrings
247 | :{
248 | putStr $ renderMarkup (
249 |   let as = ["<a>", "b"]
250 |   in $(compileHtmlFileWithDefault "templates/sample.txt"
251 |     [("as", [| ["foo", "bar"] |])]
252 |   )
253 | )
254 | :}
255 | sample
256 | key: &lt;a&gt;,
257 | key: b,
258 | 
259 | >>> :{
260 | putStr $ renderMarkup (
261 |   $(compileHtmlFileWithDefault "templates/sample.txt"
262 |     [("as", [| ["foo", "bar"] |])]
263 |   )
264 | )
265 | :}
266 | sample
267 | key: foo,
268 | key: bar,
269 |  -}
270 | compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
271 | compileHtmlFileWithDefault fp scope = compileFileWithDefault scope htmlSetting fp
272 | 
273 | {-| Heterocephalus quasi-quoter.
274 |   This function __DOES NOT__ escape template variables.
275 |   To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.
276 | 
277 |   >>> renderMarkup (let as = ["<a>", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
278 |   "sample key: <a>, key: b, "
279 | 
280 |   >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }an even number.%{ elseif (num > 100) }big.%{ else }an odd number.%{ endif }|])
281 |   "2 is an even number."
282 |  -}
283 | compileText :: QuasiQuoter
284 | compileText = compile textSetting
285 | 
286 | {-| Heterocephalus quasi-quoter for HTML.
287 |   Same as 'compileText' but this function does escape template variables in HTML.
288 | 
289 |   >>> renderMarkup (let as = ["<a>", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
290 |   "sample key: &lt;a&gt;, key: b, "
291 |  -}
292 | compileHtml :: QuasiQuoter
293 | compileHtml = compile htmlSetting
294 | 
295 | compile :: HeterocephalusSetting -> QuasiQuoter
296 | compile = compileWithDefault []
297 | 
298 | {-| QuasiQuoter.
299 |  -}
300 | compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
301 | compileWith scopeM set =
302 |   QuasiQuoter
303 |   { quoteExp = compileFromStringWith scopeM set
304 |   , quotePat = error "not used"
305 |   , quoteType = error "not used"
306 |   , quoteDec = error "not used"
307 |   }
308 | 
309 | {-| QuasiQuoter.
310 |  -}
311 | compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
312 | compileWithDefault scope set =
313 |   QuasiQuoter
314 |   { quoteExp = compileFromStringWithDefault scope set
315 |   , quotePat = error "not used"
316 |   , quoteType = error "not used"
317 |   , quoteDec = error "not used"
318 |   }
319 | 
320 | {-| Compile a template file.
321 | -}
322 | compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
323 | compileFile = compileFileWithDefault []
324 | 
325 | {-| Same as 'compileFile' but we can specify default scope.
326 | -}
327 | compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
328 | compileFileWith scopeM set fp = do
329 |   qAddDependentFile fp
330 |   contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
331 |   compileFromStringWith scopeM set contents
332 | 
333 | {-| Same as 'compileFile' but we can specify default scope.
334 | -}
335 | compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
336 | compileFileWithDefault scope' set fp = do
337 |   qAddDependentFile fp
338 |   contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
339 |   compileFromStringWithDefault scope' set contents
340 | 
341 | {-| Same as 'compileFile', but just compile the 'String' given.
342 | 
343 |   >>> let as = ["<a>", "b"]
344 |   >>> let template = "sample %{ forall a <- as }key: #{a}, %{ endforall }"
345 |   >>> renderMarkup $(compileFromString textSetting template)
346 |   "sample key: <a>, key: b, "
347 | 
348 |   >>> let as = ["<a>", "b"]
349 |   >>> let options = createParseOptions '|' '?'
350 |   >>> let setting = textSetting { parseOptions = options }
351 |   >>> let template = "sample |{ forall a <- as }key: ?{a}, |{ endforall }"
352 |   >>> renderMarkup $(compileFromString setting template)
353 |   "sample key: <a>, key: b, "
354 | -}
355 | compileFromString :: HeterocephalusSetting -> String -> Q Exp
356 | compileFromString = compileFromStringWithDefault []
357 | 
358 | compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
359 | compileFromStringWith scopeM set s = do
360 |   defScope' <-
361 |     forM defScope $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
362 |   owScope' <-
363 |     forM owScope $ \(ident, qexp) -> (ident, ) <$> qexp
364 |   docsToExp set (owScope' ++ defScope') $ docFromString (parseOptions set) s
365 |  where
366 |   (defDList, owDList) = runScopeM scopeM
367 |   defScope = DList.toList defDList
368 |   owScope = DList.toList owDList
369 | 
370 | compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
371 | compileFromStringWithDefault scope' set s = do
372 |   scope <-
373 |     forM scope' $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
374 |   docsToExp set scope $ docFromString (parseOptions set) s
375 | 
376 | overwriteScope :: Ident -> Q Exp -> Q Exp
377 | overwriteScope (Ident str) qexp = do
378 |   mName <- lookupValueName str
379 |   case mName of
380 |     Just x -> varE x
381 |     Nothing -> qexp
382 | 
383 | {-| Settings that are used when processing heterocephalus templates.
384 |  -}
385 | data HeterocephalusSetting = HeterocephalusSetting
386 |   { escapeExp :: Q Exp
387 |   -- ^ Template variables are passed to 'escapeExp' in the output.  This allows
388 |   -- things like escaping HTML entities.  (See 'htmlSetting'.)
389 |   , parseOptions :: ParseOptions
390 |   }
391 | 
392 | {-| A setting that escapes template variables for Html
393 | 
394 | This sets 'escapeExp' to 'toHtml'.
395 |  -}
396 | htmlSetting :: HeterocephalusSetting
397 | htmlSetting = HeterocephalusSetting
398 |   { escapeExp = [|toHtml|]
399 |   , parseOptions = defaultParseOptions
400 |   }
401 | 
402 | {-| A setting that DOES NOT escape template variables.
403 | 
404 | This sets 'escapeExp' to 'preEscapedToMarkup'.
405 |  -}
406 | textSetting :: HeterocephalusSetting
407 | textSetting = HeterocephalusSetting
408 |   { escapeExp = [|preEscapedToMarkup|]
409 |   , parseOptions = defaultParseOptions
410 |   }
411 | 
412 | type DefaultScope = [(Ident, Q Exp)]
413 | 
414 | type DefaultDList = DList (Ident, Q Exp)
415 | type OverwriteDList = DList (Ident, Q Exp)
416 | 
417 | {- | A type to handle extra scopes.
418 |    This is opaque type, so use 'setDefault' and 'overwrite'
419 |    to construct new 'ScopeM'.
420 |  -}
421 | data ScopeM a
422 |   = SetDefault Ident ExpQ (ScopeM a)
423 |   | Overwrite Ident ExpQ (ScopeM a)
424 |   | PureScopeM a
425 | 
426 | {- | Get default values and values to overwrite from 'ScopeM'.
427 |  -}
428 | runScopeM :: ScopeM a -> (DefaultDList, OverwriteDList)
429 | runScopeM (SetDefault ident qexp next) =
430 |   let (defaults, overwrites) = runScopeM next
431 |   in (DList.snoc defaults (ident, qexp), overwrites)
432 | runScopeM (Overwrite ident qexp next) =
433 |   let (defaults, overwrites) = runScopeM next
434 |   in (defaults, DList.snoc overwrites (ident, qexp))
435 | runScopeM (PureScopeM _) =
436 |   (mempty, mempty)
437 | 
438 | instance Sem.Semigroup (ScopeM ()) where
439 |   a <> b  = a >> b
440 | 
441 | instance Monoid (ScopeM ()) where
442 |   mempty = pure ()
443 | #if !(MIN_VERSION_base(4,11,0))
444 |   mappend = (Sem.<>)
445 | #endif
446 | 
447 | instance Functor ScopeM where
448 |   fmap f (SetDefault ident qexp next) =
449 |     SetDefault ident qexp $ fmap f next
450 |   fmap f (Overwrite ident qexp next) =
451 |     Overwrite ident qexp $ fmap f next
452 |   fmap f (PureScopeM x) =
453 |     PureScopeM $ f x
454 | 
455 | instance Applicative ScopeM where
456 |   pure = PureScopeM
457 |   SetDefault ident qexp next <*> f =
458 |     SetDefault ident qexp $ next <*> f
459 |   Overwrite ident qexp next <*> f =
460 |     Overwrite ident qexp $ next <*> f
461 |   PureScopeM g <*> f = f >>= (PureScopeM . g)
462 | 
463 | instance Monad ScopeM where
464 | #if MIN_VERSION_base(4,9,0)
465 | #else
466 |   return = PureScopeM
467 | #endif
468 |   SetDefault ident qexp next >>= f = SetDefault ident qexp $ next >>= f
469 |   Overwrite ident qexp next >>= f = Overwrite ident qexp $ next >>= f
470 |   PureScopeM a >>= f = f a
471 | 
472 | {-| Constructor for 'ScopeM'.
473 |   Values declared by this function are overwritten
474 |   by same name variables exits in scope of render function.
475 |  -}
476 | setDefault :: Ident -> Q Exp -> ScopeM ()
477 | setDefault ident qexp = SetDefault ident qexp $ pure ()
478 | 
479 | {-| Constructor for 'ScopeM'.
480 |   Values declared by this function overwrites
481 |   same name variables exits in scope of render function.
482 |  -}
483 | overwrite :: Ident -> Q Exp -> ScopeM ()
484 | overwrite ident qexp = Overwrite ident qexp $ pure ()
485 | 
486 | instance IsString Ident where
487 |   fromString = Ident
488 | 
489 | -- ==============================================
490 | --  Helper functions
491 | -- ==============================================
492 | 
493 | docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp
494 | docsToExp set scope docs = do
495 |   exps <- mapM (docToExp set scope) docs
496 |   case exps of
497 |     [] -> [|return ()|]
498 |     [x] -> return x
499 |     _ -> return $ doE $ map NoBindS exps
500 | 
501 | docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp
502 | docToExp set scope (DocForall list idents inside) = do
503 |   let list' = derefToExp scope list
504 |   (pat, extraScope) <- bindingPattern idents
505 |   let scope' = extraScope ++ scope
506 |   mh <- [|F.mapM_|]
507 |   inside' <- docsToExp set scope' inside
508 |   let lam = LamE [pat] inside'
509 |   return $ mh `AppE` lam `AppE` list'
510 | docToExp set scope (DocCond conds final) = do
511 |   conds' <- mapM go conds
512 |   final' <-
513 |     case final of
514 |       Nothing -> [|Nothing|]
515 |       Just f -> do
516 |         f' <- docsToExp set scope f
517 |         j <- [|Just|]
518 |         return $ j `AppE` f'
519 |   ch <- [|condH|]
520 |   return $ ch `AppE` ListE conds' `AppE` final'
521 |   where
522 |     go :: (Deref, [Doc]) -> Q Exp
523 |     go (d, docs) = do
524 |       let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d
525 |       docs' <- docsToExp set scope docs
526 |       return $ nonUnaryTupE [d', docs']
527 |       where
528 |         nonUnaryTupE :: [Exp] -> Exp
529 |         nonUnaryTupE es  = tupE es
530 | docToExp set scope (DocCase deref cases) = do
531 |     let exp_ = derefToExp scope deref
532 |     matches <- mapM toMatch cases
533 |     return $ CaseE exp_ matches
534 |   where
535 |     toMatch :: (Binding, [Doc]) -> Q Match
536 |     toMatch (idents, inside) = do
537 |         (pat, extraScope) <- bindingPattern idents
538 |         let scope' = extraScope ++ scope
539 |         insideExp <- docsToExp set scope' inside
540 |         return $ Match pat (NormalB insideExp) []
541 | docToExp set v (DocContent c) = contentToExp set v c
542 | 
543 | contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
544 | contentToExp _ _ (ContentRaw s) = do
545 |   os <- [|preEscapedText . pack|]
546 |   let s' = LitE $ StringL s
547 |   return $ os `AppE` s'
548 | contentToExp set scope (ContentVar d) = do
549 |   str <- escapeExp set
550 |   return $ str `AppE` derefToExp scope d
551 | 
552 | -- ==============================================
553 | -- Codes from Text.Hamlet that is not exposed
554 | -- ==============================================
555 | 
556 | unIdent :: Ident -> String
557 | unIdent (Ident s) = s
558 | 
559 | bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
560 | bindingPattern (BindAs i@(Ident s) b) = do
561 |   name <- newName s
562 |   (pattern, scope) <- bindingPattern b
563 |   return (AsP name pattern, (i, VarE name) : scope)
564 | bindingPattern (BindVar i@(Ident s))
565 |   | s == "_" = return (WildP, [])
566 |   | all isDigit s = do return (LitP $ IntegerL $ read s, [])
567 |   | otherwise = do
568 |     name <- newName s
569 |     return (VarP name, [(i, VarE name)])
570 | bindingPattern (BindTuple is) = do
571 |   (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
572 |   return (TupP patterns, concat scopes)
573 | bindingPattern (BindList is) = do
574 |   (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
575 |   return (ListP patterns, concat scopes)
576 | bindingPattern (BindConstr con is) = do
577 |   (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
578 | #if MIN_VERSION_template_haskell_compat_v0208(0,1,8)
579 |   {- 
580 |   Todo: Note, the use of conP below (note lowercase 'c') is from the package 'template-haskell-compat-v0208'.
581 |   This allows Heterocephalus to compile with GHC 9.2, as the ConP constructor takes an additional argument in GHC 9.2
582 |   Note however this _probably_ means there was some new extension or new syntax extension that GHC now allows post GHC 9.2
583 |   that we are not able to handle. As I (clintonmead@gmail.com) am just writing a PR to the library and don't fully understand it
584 |   (I'm making this PR just to make our current project build under GHC 9.2) there's probably some more work to be done here.
585 | 
586 |   The github issue relating to this is at https://github.com/arowM/heterocephalus/issues/32
587 |   -}
588 |   return (conP (mkConName con) patterns, concat scopes)
589 | #else
590 |   return (ConP (mkConName con) patterns, concat scopes)
591 | #endif
592 | bindingPattern (BindRecord con fields wild) = do
593 |   let f (Ident field, b) = do
594 |         (p, s) <- bindingPattern b
595 |         return ((mkName field, p), s)
596 |   (patterns, scopes) <- fmap unzip $ mapM f fields
597 |   (patterns1, scopes1) <-
598 |     if wild
599 |       then bindWildFields con $ map fst fields
600 |       else return ([], [])
601 |   return
602 |     (RecP (mkConName con) (patterns ++ patterns1), concat scopes ++ scopes1)
603 | 
604 | mkConName :: DataConstr -> Name
605 | mkConName = mkName . conToStr
606 | 
607 | conToStr :: DataConstr -> String
608 | conToStr (DCUnqualified (Ident x)) = x
609 | conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
610 | 
611 | -- Wildcards bind all of the unbound fields to variables whose name
612 | -- matches the field name.
613 | --
614 | -- For example: data R = C { f1, f2 :: Int }
615 | -- C {..}           is equivalent to   C {f1=f1, f2=f2}
616 | -- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
617 | -- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
618 | bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
619 | bindWildFields conName fields = do
620 |   fieldNames <- recordToFieldNames conName
621 |   let available n = nameBase n `notElem` map unIdent fields
622 |   let remainingFields = filter available fieldNames
623 |   let mkPat n = do
624 |         e <- newName (nameBase n)
625 |         return ((n, VarP e), (Ident (nameBase n), VarE e))
626 |   fmap unzip $ mapM mkPat remainingFields
627 | 
628 | -- Important note! reify will fail if the record type is defined in the
629 | -- same module as the reify is used. This means quasi-quoted Hamlet
630 | -- literals will not be able to use wildcards to match record types
631 | -- defined in the same module.
632 | recordToFieldNames :: DataConstr -> Q [Name]
633 | recordToFieldNames conStr
634 |   -- use 'lookupValueName' instead of just using 'mkName' so we reify the
635 |   -- data constructor and not the type constructor if their names match.
636 |  = do
637 |   Just conName <- lookupValueName $ conToStr conStr
638 | #if MIN_VERSION_template_haskell(2,11,0)
639 |   DataConI _ _ typeName         <- reify conName
640 |   TyConI (DataD _ _ _ _ cons _) <- reify typeName
641 | #else
642 |   DataConI _ _ typeName _     <- reify conName
643 |   TyConI (DataD _ _ _ cons _) <- reify typeName
644 | #endif
645 |   [fields] <- return [fields | RecC name fields <- cons, name == conName]
646 |   return [fieldName | (fieldName, _, _) <- fields]
647 | 
648 | type QueryParameters = [(Text, Text)]
649 | 
650 | data VarExp msg url
651 |   = EPlain Html
652 |   | EUrl url
653 |   | EUrlParam (url, QueryParameters)
654 |   | EMixin (HtmlUrl url)
655 |   | EMixinI18n (HtmlUrlI18n msg url)
656 |   | EMsg msg
657 | 
658 | instance Show (VarExp msg url) where
659 |   show (EPlain _) = "EPlain"
660 |   show (EUrl _) = "EUrl"
661 |   show (EUrlParam _) = "EUrlParam"
662 |   show (EMixin _) = "EMixin"
663 |   show (EMixinI18n _) = "EMixinI18n"
664 |   show (EMsg _) = "EMsg"
665 | 


--------------------------------------------------------------------------------