{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Heterocephalus
(
compileTextFile
, compileTextFileWith
, compileTextFileWithDefault
, compileHtmlFile
, compileHtmlFileWith
, compileHtmlFileWithDefault
, compileText
, compileHtml
, ScopeM
, setDefault
, overwrite
, HeterocephalusSetting(..)
, textSetting
, htmlSetting
, ParseOptions(..)
, defaultParseOptions
, createParseOptions
, DefaultScope
, compile
, compileWith
, compileWithDefault
, compileFile
, compileFileWith
, compileFileWithDefault
, compileFromString
, compileFromStringWithDefault
) where
#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((<$>), (<*>), Applicative(..))
import Data.Monoid (Monoid, mempty, mappend)
#endif
import Control.Monad (forM)
import Data.Char (isDigit)
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Foldable as F
import Data.List (intercalate)
import qualified Data.Semigroup as Sem
import Data.String (IsString(..))
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH.Lib (ExpQ, varE)
import Language.Haskell.TH.Quote
(QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType)
#if MIN_VERSION_template_haskell(2,9,0)
import Language.Haskell.TH.Syntax
(Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),
Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,
newName, qAddDependentFile, qRunIO, reify)
#else
import Language.Haskell.TH.Syntax
#endif
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Internal (preEscapedText)
import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH)
import Text.Hamlet.Parse
(Binding(..), DataConstr(..), Module(Module), specialOrIdent)
import Text.Shakespeare.Base
(Deref, Ident(..), Scope, derefToExp, readUtf8File)
import Text.Heterocephalus.Parse
(Doc(..), Content(..), ParseOptions(..), createParseOptions,
defaultParseOptions, docFromString)
compileTextFile :: FilePath -> Q Exp
compileTextFile :: FilePath -> Q Exp
compileTextFile = HeterocephalusSetting -> FilePath -> Q Exp
compileFile HeterocephalusSetting
textSetting
compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
compileTextFileWith fp :: FilePath
fp scopeM :: ScopeM ()
scopeM = ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith ScopeM ()
scopeM HeterocephalusSetting
textSetting FilePath
fp
compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileTextFileWithDefault fp :: FilePath
fp scope :: DefaultScope
scope = DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault DefaultScope
scope HeterocephalusSetting
textSetting FilePath
fp
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile fp :: FilePath
fp = FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault FilePath
fp []
compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
compileHtmlFileWith fp :: FilePath
fp scopeM :: ScopeM ()
scopeM = ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith ScopeM ()
scopeM HeterocephalusSetting
htmlSetting FilePath
fp
compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault fp :: FilePath
fp scope :: DefaultScope
scope = DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault DefaultScope
scope HeterocephalusSetting
htmlSetting FilePath
fp
compileText :: QuasiQuoter
compileText :: QuasiQuoter
compileText = HeterocephalusSetting -> QuasiQuoter
compile HeterocephalusSetting
textSetting
compileHtml :: QuasiQuoter
compileHtml :: QuasiQuoter
compileHtml = HeterocephalusSetting -> QuasiQuoter
compile HeterocephalusSetting
htmlSetting
compile :: HeterocephalusSetting -> QuasiQuoter
compile :: HeterocephalusSetting -> QuasiQuoter
compile = DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault []
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith scopeM :: ScopeM ()
scopeM set :: HeterocephalusSetting
set =
QuasiQuoter :: (FilePath -> Q Exp)
-> (FilePath -> Q Pat)
-> (FilePath -> Q Type)
-> (FilePath -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: FilePath -> Q Exp
quoteExp = ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWith ScopeM ()
scopeM HeterocephalusSetting
set
, quotePat :: FilePath -> Q Pat
quotePat = FilePath -> FilePath -> Q Pat
forall a. HasCallStack => FilePath -> a
error "not used"
, quoteType :: FilePath -> Q Type
quoteType = FilePath -> FilePath -> Q Type
forall a. HasCallStack => FilePath -> a
error "not used"
, quoteDec :: FilePath -> Q [Dec]
quoteDec = FilePath -> FilePath -> Q [Dec]
forall a. HasCallStack => FilePath -> a
error "not used"
}
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault scope :: DefaultScope
scope set :: HeterocephalusSetting
set =
QuasiQuoter :: (FilePath -> Q Exp)
-> (FilePath -> Q Pat)
-> (FilePath -> Q Type)
-> (FilePath -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: FilePath -> Q Exp
quoteExp = DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWithDefault DefaultScope
scope HeterocephalusSetting
set
, quotePat :: FilePath -> Q Pat
quotePat = FilePath -> FilePath -> Q Pat
forall a. HasCallStack => FilePath -> a
error "not used"
, quoteType :: FilePath -> Q Type
quoteType = FilePath -> FilePath -> Q Type
forall a. HasCallStack => FilePath -> a
error "not used"
, quoteDec :: FilePath -> Q [Dec]
quoteDec = FilePath -> FilePath -> Q [Dec]
forall a. HasCallStack => FilePath -> a
error "not used"
}
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile = DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault []
compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith scopeM :: ScopeM ()
scopeM set :: HeterocephalusSetting
set fp :: FilePath
fp = do
FilePath -> Q ()
forall (m :: * -> *). Quasi m => FilePath -> m ()
qAddDependentFile FilePath
fp
FilePath
contents <- (Text -> FilePath) -> Q Text -> Q FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
TL.unpack (Q Text -> Q FilePath) -> Q Text -> Q FilePath
forall a b. (a -> b) -> a -> b
$ IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
readUtf8File FilePath
fp
ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWith ScopeM ()
scopeM HeterocephalusSetting
set FilePath
contents
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault scope' :: DefaultScope
scope' set :: HeterocephalusSetting
set fp :: FilePath
fp = do
FilePath -> Q ()
forall (m :: * -> *). Quasi m => FilePath -> m ()
qAddDependentFile FilePath
fp
FilePath
contents <- (Text -> FilePath) -> Q Text -> Q FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
TL.unpack (Q Text -> Q FilePath) -> Q Text -> Q FilePath
forall a b. (a -> b) -> a -> b
$ IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
readUtf8File FilePath
fp
DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWithDefault DefaultScope
scope' HeterocephalusSetting
set FilePath
contents
compileFromString :: HeterocephalusSetting -> String -> Q Exp
compileFromString :: HeterocephalusSetting -> FilePath -> Q Exp
compileFromString = DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWithDefault []
compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWith scopeM :: ScopeM ()
scopeM set :: HeterocephalusSetting
set s :: FilePath
s = do
[(Ident, Exp)]
defScope' <-
DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
defScope (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(ident :: Ident
ident, qexp :: Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Q Exp -> Q Exp
overwriteScope Ident
ident Q Exp
qexp
[(Ident, Exp)]
owScope' <-
DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
owScope (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(ident :: Ident
ident, qexp :: Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
qexp
HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set ([(Ident, Exp)]
owScope' [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
defScope') ([Doc] -> Q Exp) -> [Doc] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseOptions -> FilePath -> [Doc]
docFromString (HeterocephalusSetting -> ParseOptions
parseOptions HeterocephalusSetting
set) FilePath
s
where
(defDList :: DefaultDList
defDList, owDList :: DefaultDList
owDList) = ScopeM () -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM ()
scopeM
defScope :: DefaultScope
defScope = DefaultDList -> DefaultScope
forall a. DList a -> [a]
DList.toList DefaultDList
defDList
owScope :: DefaultScope
owScope = DefaultDList -> DefaultScope
forall a. DList a -> [a]
DList.toList DefaultDList
owDList
compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFromStringWithDefault scope' :: DefaultScope
scope' set :: HeterocephalusSetting
set s :: FilePath
s = do
[(Ident, Exp)]
scope <-
DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
scope' (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(ident :: Ident
ident, qexp :: Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Q Exp -> Q Exp
overwriteScope Ident
ident Q Exp
qexp
HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope ([Doc] -> Q Exp) -> [Doc] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseOptions -> FilePath -> [Doc]
docFromString (HeterocephalusSetting -> ParseOptions
parseOptions HeterocephalusSetting
set) FilePath
s
overwriteScope :: Ident -> Q Exp -> Q Exp
overwriteScope :: Ident -> Q Exp -> Q Exp
overwriteScope (Ident str :: FilePath
str) qexp :: Q Exp
qexp = do
Maybe Name
mName <- FilePath -> Q (Maybe Name)
lookupValueName FilePath
str
case Maybe Name
mName of
Just x :: Name
x -> Name -> Q Exp
varE Name
x
Nothing -> Q Exp
qexp
data HeterocephalusSetting = HeterocephalusSetting
{ HeterocephalusSetting -> Q Exp
escapeExp :: Q Exp
, HeterocephalusSetting -> ParseOptions
parseOptions :: ParseOptions
}
htmlSetting :: HeterocephalusSetting
htmlSetting :: HeterocephalusSetting
htmlSetting = HeterocephalusSetting :: Q Exp -> ParseOptions -> HeterocephalusSetting
HeterocephalusSetting
{ escapeExp :: Q Exp
escapeExp = [|toHtml|]
, parseOptions :: ParseOptions
parseOptions = ParseOptions
defaultParseOptions
}
textSetting :: HeterocephalusSetting
textSetting :: HeterocephalusSetting
textSetting = HeterocephalusSetting :: Q Exp -> ParseOptions -> HeterocephalusSetting
HeterocephalusSetting
{ escapeExp :: Q Exp
escapeExp = [|preEscapedToMarkup|]
, parseOptions :: ParseOptions
parseOptions = ParseOptions
defaultParseOptions
}
type DefaultScope = [(Ident, Q Exp)]
type DefaultDList = DList (Ident, Q Exp)
type OverwriteDList = DList (Ident, Q Exp)
data ScopeM a
= SetDefault Ident ExpQ (ScopeM a)
| Overwrite Ident ExpQ (ScopeM a)
| PureScopeM a
runScopeM :: ScopeM a -> (DefaultDList, OverwriteDList)
runScopeM :: ScopeM a -> (DefaultDList, DefaultDList)
runScopeM (SetDefault ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next) =
let (defaults :: DefaultDList
defaults, overwrites :: DefaultDList
overwrites) = ScopeM a -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM a
next
in (DefaultDList -> (Ident, Q Exp) -> DefaultDList
forall a. DList a -> a -> DList a
DList.snoc DefaultDList
defaults (Ident
ident, Q Exp
qexp), DefaultDList
overwrites)
runScopeM (Overwrite ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next) =
let (defaults :: DefaultDList
defaults, overwrites :: DefaultDList
overwrites) = ScopeM a -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM a
next
in (DefaultDList
defaults, DefaultDList -> (Ident, Q Exp) -> DefaultDList
forall a. DList a -> a -> DList a
DList.snoc DefaultDList
overwrites (Ident
ident, Q Exp
qexp))
runScopeM (PureScopeM _) =
(DefaultDList
forall a. Monoid a => a
mempty, DefaultDList
forall a. Monoid a => a
mempty)
instance Sem.Semigroup (ScopeM ()) where
a :: ScopeM ()
a <> :: ScopeM () -> ScopeM () -> ScopeM ()
<> b :: ScopeM ()
b = ScopeM ()
a ScopeM () -> ScopeM () -> ScopeM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScopeM ()
b
instance Monoid (ScopeM ()) where
mempty :: ScopeM ()
mempty = () -> ScopeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if !(MIN_VERSION_base(4,11,0))
mappend = (Sem.<>)
#endif
instance Functor ScopeM where
fmap :: (a -> b) -> ScopeM a -> ScopeM b
fmap f :: a -> b
f (SetDefault ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next) =
Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ScopeM a
next
fmap f :: a -> b
f (Overwrite ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next) =
Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ScopeM a
next
fmap f :: a -> b
f (PureScopeM x :: a
x) =
b -> ScopeM b
forall a. a -> ScopeM a
PureScopeM (b -> ScopeM b) -> b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
instance Applicative ScopeM where
pure :: a -> ScopeM a
pure = a -> ScopeM a
forall a. a -> ScopeM a
PureScopeM
SetDefault ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM (a -> b)
next <*> :: ScopeM (a -> b) -> ScopeM a -> ScopeM b
<*> f :: ScopeM a
f =
Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM (a -> b)
next ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScopeM a
f
Overwrite ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM (a -> b)
next <*> f :: ScopeM a
f =
Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM (a -> b)
next ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScopeM a
f
PureScopeM g :: a -> b
g <*> f :: ScopeM a
f = ScopeM a
f ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> ScopeM b
forall a. a -> ScopeM a
PureScopeM (b -> ScopeM b) -> (a -> b) -> a -> ScopeM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g)
instance Monad ScopeM where
#if MIN_VERSION_base(4,9,0)
#else
return = PureScopeM
#endif
SetDefault ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next >>= :: ScopeM a -> (a -> ScopeM b) -> ScopeM b
>>= f :: a -> ScopeM b
f = Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM a
next ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ScopeM b
f
Overwrite ident :: Ident
ident qexp :: Q Exp
qexp next :: ScopeM a
next >>= f :: a -> ScopeM b
f = Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM a
next ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ScopeM b
f
PureScopeM a :: a
a >>= f :: a -> ScopeM b
f = a -> ScopeM b
f a
a
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault ident :: Ident
ident qexp :: Q Exp
qexp = Ident -> Q Exp -> ScopeM () -> ScopeM ()
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM () -> ScopeM ()) -> ScopeM () -> ScopeM ()
forall a b. (a -> b) -> a -> b
$ () -> ScopeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite ident :: Ident
ident qexp :: Q Exp
qexp = Ident -> Q Exp -> ScopeM () -> ScopeM ()
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM () -> ScopeM ()) -> ScopeM () -> ScopeM ()
forall a b. (a -> b) -> a -> b
$ () -> ScopeM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance IsString Ident where
fromString :: FilePath -> Ident
fromString = FilePath -> Ident
Ident
docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp
docsToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp set :: HeterocephalusSetting
set scope :: [(Ident, Exp)]
scope docs :: [Doc]
docs = do
[Exp]
exps <- (Doc -> Q Exp) -> [Doc] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HeterocephalusSetting -> [(Ident, Exp)] -> Doc -> Q Exp
docToExp HeterocephalusSetting
set [(Ident, Exp)]
scope) [Doc]
docs
case [Exp]
exps of
[] -> [|return ()|]
[x :: Exp
x] -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
_ -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS [Exp]
exps
docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp
docToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> Doc -> Q Exp
docToExp set :: HeterocephalusSetting
set scope :: [(Ident, Exp)]
scope (DocForall list :: Deref
list idents :: Binding
idents inside :: [Doc]
inside) = do
let list' :: Exp
list' = [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
list
(pat :: Pat
pat, extraScope :: [(Ident, Exp)]
extraScope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
idents
let scope' :: [(Ident, Exp)]
scope' = [(Ident, Exp)]
extraScope [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scope
Exp
mh <- [|F.mapM_|]
Exp
inside' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope' [Doc]
inside
let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Exp
list'
docToExp set :: HeterocephalusSetting
set scope :: [(Ident, Exp)]
scope (DocCond conds :: [(Deref, [Doc])]
conds final :: Maybe [Doc]
final) = do
[Exp]
conds' <- ((Deref, [Doc]) -> Q Exp) -> [(Deref, [Doc])] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Deref, [Doc]) -> Q Exp
go [(Deref, [Doc])]
conds
Exp
final' <-
case Maybe [Doc]
final of
Nothing -> [|Nothing|]
Just f :: [Doc]
f -> do
Exp
f' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope [Doc]
f
Exp
j <- [|Just|]
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
f'
Exp
ch <- [|condH|]
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
ch Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
conds' Exp -> Exp -> Exp
`AppE` Exp
final'
where
go :: (Deref, [Doc]) -> Q Exp
go :: (Deref, [Doc]) -> Q Exp
go (d :: Deref
d, docs :: [Doc]
docs) = do
let d' :: Exp
d' = [(Ident, Exp)] -> Deref -> Exp
derefToExp ((Ident
specialOrIdent, Name -> Exp
VarE 'or) (Ident, Exp) -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. a -> [a] -> [a]
: [(Ident, Exp)]
scope) Deref
d
Exp
docs' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope [Doc]
docs
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TupE [Exp
d', Exp
docs']
docToExp set :: HeterocephalusSetting
set scope :: [(Ident, Exp)]
scope (DocCase deref :: Deref
deref cases :: [(Binding, [Doc])]
cases) = do
let exp_ :: Exp
exp_ = [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
deref
[Match]
matches <- ((Binding, [Doc]) -> Q Match) -> [(Binding, [Doc])] -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
exp_ [Match]
matches
where
toMatch :: (Binding, [Doc]) -> Q Match
toMatch :: (Binding, [Doc]) -> Q Match
toMatch (idents :: Binding
idents, inside :: [Doc]
inside) = do
(pat :: Pat
pat, extraScope :: [(Ident, Exp)]
extraScope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
idents
let scope' :: [(Ident, Exp)]
scope' = [(Ident, Exp)]
extraScope [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scope
Exp
insideExp <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope' [Doc]
inside
Match -> Q Match
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
insideExp) []
docToExp set :: HeterocephalusSetting
set v :: [(Ident, Exp)]
v (DocContent c :: Content
c) = HeterocephalusSetting -> [(Ident, Exp)] -> Content -> Q Exp
contentToExp HeterocephalusSetting
set [(Ident, Exp)]
v Content
c
contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
contentToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> Content -> Q Exp
contentToExp _ _ (ContentRaw s :: FilePath
s) = do
Exp
os <- [|preEscapedText . pack|]
let s' :: Exp
s' = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Lit
StringL FilePath
s
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
os Exp -> Exp -> Exp
`AppE` Exp
s'
contentToExp set :: HeterocephalusSetting
set scope :: [(Ident, Exp)]
scope (ContentVar d :: Deref
d) = do
Exp
str <- HeterocephalusSetting -> Q Exp
escapeExp HeterocephalusSetting
set
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
str Exp -> Exp -> Exp
`AppE` [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
d
unIdent :: Ident -> String
unIdent :: Ident -> FilePath
unIdent (Ident s :: FilePath
s) = FilePath
s
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern (BindAs i :: Ident
i@(Ident s :: FilePath
s) b :: Binding
b) = do
Name
name <- FilePath -> Q Name
newName FilePath
s
(pattern :: Pat
pattern, scope :: [(Ident, Exp)]
scope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
b
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat -> Pat
AsP Name
name Pat
pattern, (Ident
i, Name -> Exp
VarE Name
name) (Ident, Exp) -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. a -> [a] -> [a]
: [(Ident, Exp)]
scope)
bindingPattern (BindVar i :: Ident
i@(Ident s :: FilePath
s))
| FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "_" = (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit FilePath
s = do (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ FilePath -> Integer
forall a. Read a => FilePath -> a
read FilePath
s, [])
| Bool
otherwise = do
Name
name <- FilePath -> Q Name
newName FilePath
s
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat
VarP Name
name, [(Ident
i, Name -> Exp
VarE Name
name)])
bindingPattern (BindTuple is :: [Binding]
is) = do
(patterns :: [Pat]
patterns, scopes :: [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
TupP [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
bindingPattern (BindList is :: [Binding]
is) = do
(patterns :: [Pat]
patterns, scopes :: [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
ListP [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
bindingPattern (BindConstr con :: DataConstr
con is :: [Binding]
is) = do
(patterns :: [Pat]
patterns, scopes :: [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
ConP (DataConstr -> Name
mkConName DataConstr
con) [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
bindingPattern (BindRecord con :: DataConstr
con fields :: [(Ident, Binding)]
fields wild :: Bool
wild) = do
let f :: (Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)])
f (Ident field :: FilePath
field, b :: Binding
b) = do
(p :: Pat
p, s :: [(Ident, Exp)]
s) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
b
((Name, Pat), [(Ident, Exp)]) -> Q ((Name, Pat), [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> Name
mkName FilePath
field, Pat
p), [(Ident, Exp)]
s)
(patterns :: [(Name, Pat)]
patterns, scopes :: [[(Ident, Exp)]]
scopes) <- ([((Name, Pat), [(Ident, Exp)])]
-> ([(Name, Pat)], [[(Ident, Exp)]]))
-> Q [((Name, Pat), [(Ident, Exp)])]
-> Q ([(Name, Pat)], [[(Ident, Exp)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), [(Ident, Exp)])]
-> ([(Name, Pat)], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), [(Ident, Exp)])]
-> Q ([(Name, Pat)], [[(Ident, Exp)]]))
-> Q [((Name, Pat), [(Ident, Exp)])]
-> Q ([(Name, Pat)], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)]))
-> [(Ident, Binding)] -> Q [((Name, Pat), [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)])
f [(Ident, Binding)]
fields
(patterns1 :: [(Name, Pat)]
patterns1, scopes1 :: [(Ident, Exp)]
scopes1) <-
if Bool
wild
then DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields DataConstr
con ([Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]))
-> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Ident) -> [(Ident, Binding)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Binding) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Binding)]
fields
else ([(Name, Pat)], [(Ident, Exp)])
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
(Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return
(Name -> [(Name, Pat)] -> Pat
RecP (DataConstr -> Name
mkConName DataConstr
con) ([(Name, Pat)]
patterns [(Name, Pat)] -> [(Name, Pat)] -> [(Name, Pat)]
forall a. [a] -> [a] -> [a]
++ [(Name, Pat)]
patterns1), [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scopes1)
mkConName :: DataConstr -> Name
mkConName :: DataConstr -> Name
mkConName = FilePath -> Name
mkName (FilePath -> Name)
-> (DataConstr -> FilePath) -> DataConstr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConstr -> FilePath
conToStr
conToStr :: DataConstr -> String
conToStr :: DataConstr -> FilePath
conToStr (DCUnqualified (Ident x :: FilePath
x)) = FilePath
x
conToStr (DCQualified (Module xs :: [FilePath]
xs) (Ident x :: FilePath
x)) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "." ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
xs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
x]
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields conName :: DataConstr
conName fields :: [Ident]
fields = do
[Name]
fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
let available :: Name -> Bool
available n :: Name
n = Name -> FilePath
nameBase Name
n FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Ident -> FilePath) -> [Ident] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> FilePath
unIdent [Ident]
fields
let remainingFields :: [Name]
remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
let mkPat :: Name -> Q ((Name, Pat), (Ident, Exp))
mkPat n :: Name
n = do
Name
e <- FilePath -> Q Name
newName (Name -> FilePath
nameBase Name
n)
((Name, Pat), (Ident, Exp)) -> Q ((Name, Pat), (Ident, Exp))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, Name -> Pat
VarP Name
e), (FilePath -> Ident
Ident (Name -> FilePath
nameBase Name
n), Name -> Exp
VarE Name
e))
([((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], [(Ident, Exp)]))
-> Q [((Name, Pat), (Ident, Exp))]
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], [(Ident, Exp)])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), (Ident, Exp))]
-> Q ([(Name, Pat)], [(Ident, Exp)]))
-> Q [((Name, Pat), (Ident, Exp))]
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall a b. (a -> b) -> a -> b
$ (Name -> Q ((Name, Pat), (Ident, Exp)))
-> [Name] -> Q [((Name, Pat), (Ident, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q ((Name, Pat), (Ident, Exp))
mkPat [Name]
remainingFields
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames conStr :: DataConstr
conStr
= do
Just conName :: Name
conName <- FilePath -> Q (Maybe Name)
lookupValueName (FilePath -> Q (Maybe Name)) -> FilePath -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DataConstr -> FilePath
conToStr DataConstr
conStr
#if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ typeName :: Name
typeName <- Name -> Q Info
reify Name
conName
TyConI (DataD _ _ _ _ cons :: [Con]
cons _) <- Name -> Q Info
reify Name
typeName
#else
DataConI _ _ typeName _ <- reify conName
TyConI (DataD _ _ _ cons _) <- reify typeName
#endif
[fields :: [VarBangType]
fields] <- [[VarBangType]] -> Q [[VarBangType]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[VarBangType]
fields | RecC name :: Name
name fields :: [VarBangType]
fields <- [Con]
cons, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
conName]
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
fieldName | (fieldName :: Name
fieldName, _, _) <- [VarBangType]
fields]
type QueryParameters = [(Text, Text)]
data VarExp msg url
= EPlain Html
| EUrl url
| EUrlParam (url, QueryParameters)
| EMixin (HtmlUrl url)
| EMixinI18n (HtmlUrlI18n msg url)
| EMsg msg
instance Show (VarExp msg url) where
show :: VarExp msg url -> FilePath
show (EPlain _) = "EPlain"
show (EUrl _) = "EUrl"
show (EUrlParam _) = "EUrlParam"
show (EMixin _) = "EMixin"
show (EMixinI18n _) = "EMixinI18n"
show (EMsg _) = "EMsg"