{-# 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
import Language.PureScript.Names hiding (Name)
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]