{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Constants.TH
( declare
, mod
, cls, clss
, dty
, nty, ntys
, ty, tys
, var, vars
, prefixWith
, asIdent
, asPair
, asString
) where
import Protolude hiding (Type, mod)
import Control.Lens (over, _head)
import Control.Monad.Trans.RWS (RWS, execRWS)
import Control.Monad.Trans.Writer (Writer, execWriter)
import Control.Monad.Writer.Class (tell)
import Data.String (String)
import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL)
import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..))
declare :: Writer (Q [Dec]) () -> Q [Dec]
declare :: Writer (Q [Dec]) () -> Q [Dec]
declare = forall w a. Writer w a -> w
execWriter
mod :: String -> ModDecs -> Writer (Q [Dec]) ()
mod :: String -> ModDecs -> Writer (Q [Dec]) ()
mod String
mnStr ModDecs
inner = do
let mn :: Name
mn = String -> Name
mkModuleName String
mnStr
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn Name
mn [t| ModuleName |] [p| ModuleName $(litP $ stringL mnStr) |]
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS ModDecs
inner (Name
mn, String
"", []) ()
cls :: String -> ModDecs
cls :: String -> ModDecs
cls String
cn = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
mn, String
prefix, [VarToDec]
_) -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Q Type -> VarToDec
mkPnPat [t| 'ClassName |] Name
mn String
prefix String
cn
clss :: [String] -> ModDecs
clss :: [String] -> ModDecs
clss = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> ModDecs
cls
dty :: String -> [String] -> ModDecs
dty :: String -> [String] -> ModDecs
dty String
dn [String]
ctors = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
mn, String
prefix, [VarToDec]
_) -> do
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Q Type -> VarToDec
mkPnPat [t| 'TypeName |] Name
mn String
prefix String
dn
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Type -> VarToDec
mkPnPat [t| 'ConstructorName |] Name
mn forall a b. (a -> b) -> a -> b
$ String
"C_" forall a. Semigroup a => a -> a -> a
<> String
prefix) [String]
ctors
nty :: String -> ModDecs
nty :: String -> ModDecs
nty String
tn = String -> [String] -> ModDecs
dty String
tn [String
tn]
ntys :: [String] -> ModDecs
ntys :: [String] -> ModDecs
ntys = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> ModDecs
nty
ty :: String -> ModDecs
ty :: String -> ModDecs
ty String
tn = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
mn, String
prefix, [VarToDec]
_) -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Q Type -> VarToDec
mkPnPat [t| 'TypeName |] Name
mn String
prefix String
tn
tys :: [String] -> ModDecs
tys :: [String] -> ModDecs
tys = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> ModDecs
ty
var :: String -> ModDecs
var :: String -> ModDecs
var String
nm = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Name
mn, String
prefix, [VarToDec]
vtds) -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\VarToDec
f -> VarToDec
f Name
mn String
prefix String
nm) [VarToDec]
vtds
vars :: [String] -> ModDecs
vars :: [String] -> ModDecs
vars = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> ModDecs
var
asPair :: ModDecs -> ModDecs
asPair :: ModDecs -> ModDecs
asPair = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall a b. VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec])
addToVars VarToDec
mkPairDec
asIdent :: ModDecs -> ModDecs
asIdent :: ModDecs -> ModDecs
asIdent = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall a b. VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec])
addToVars VarToDec
mkIdentDec
asString :: ModDecs -> ModDecs
asString :: ModDecs -> ModDecs
asString = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall a b. VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec])
addToVars VarToDec
mkStringDec
prefixWith :: String -> ModDecs -> ModDecs
prefixWith :: String -> ModDecs -> ModDecs
prefixWith = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c. String -> (a, String, c) -> (a, String, c)
applyPrefix
type ModDecs = RWS (Name, String, [VarToDec]) (Q [Dec]) () ()
type VarToDec = Name -> String -> String -> Q [Dec]
addToVars :: VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec])
addToVars :: forall a b. VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec])
addToVars VarToDec
f (a
a, b
b, [VarToDec]
fs) = (a
a, b
b, VarToDec
f forall a. a -> [a] -> [a]
: [VarToDec]
fs)
applyPrefix :: String -> (a, String, c) -> (a, String, c)
applyPrefix :: forall a c. String -> (a, String, c) -> (a, String, c)
applyPrefix String
prefix (a
a, String
prefix', c
c) = (a
a, String -> String -> String
camelAppend String
prefix' String
prefix, c
c)
cap :: String -> String
cap :: String -> String
cap = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper
camelAppend :: String -> String -> String
camelAppend :: String -> String -> String
camelAppend String
l String
r = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l then String
r else String
l forall a. Semigroup a => a -> a -> a
<> String -> String
cap String
r
mkModuleName :: String -> Name
mkModuleName :: String -> Name
mkModuleName = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"M_" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\case Char
'.' -> Char
'_'; Char
other -> Char
other)
mkPrefixedName :: String -> String -> String -> Name
mkPrefixedName :: String -> String -> String -> Name
mkPrefixedName String
tag String
prefix = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
tag forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
camelAppend String
prefix
mkPnPat :: Q Type -> VarToDec
mkPnPat :: Q Type -> VarToDec
mkPnPat Q Type
pnType Name
mn String
prefix String
str = Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String -> String
cap String
prefix forall a. Semigroup a => a -> a -> a
<> String
str)
[t| Qualified (ProperName $pnType) |]
[p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) |]
mkIdentDec :: VarToDec
mkIdentDec :: VarToDec
mkIdentDec Name
mn String
prefix String
str = Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn (String -> String -> String -> Name
mkPrefixedName String
"I_" String
prefix String
str)
[t| Qualified Ident |]
[p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |]
mkPairDec :: VarToDec
mkPairDec :: VarToDec
mkPairDec Name
mn String
prefix String
str = Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn (String -> String -> String -> Name
mkPrefixedName String
"P_" String
prefix String
str)
[t| forall a. (Eq a, IsString a) => (ModuleName, a) |]
[p| ($(conP mn []), $(litP $ stringL str)) |]
mkStringDec :: VarToDec
mkStringDec :: VarToDec
mkStringDec Name
_ String
prefix String
str = Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn (String -> String -> String -> Name
mkPrefixedName String
"S_" String
prefix String
str)
[t| forall a. (Eq a, IsString a) => a |]
(forall (m :: * -> *). Quote m => Lit -> m Pat
litP forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
str)
typedPatSyn :: Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn :: Name -> Q Type -> Q Pat -> Q [Dec]
typedPatSyn Name
nm Q Type
t Q Pat
p = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD Name
nm Q Type
t, forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD Name
nm (forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn []) forall (m :: * -> *). Quote m => m PatSynDir
implBidir Q Pat
p]