{-# LANGUAGE TemplateHaskell #-}
-- | This module implements an eDSL for compactly declaring pattern synonyms
-- representing known PureScript modules and their members.
--
-- The following example assumes this module is imported qualified as TH and
-- the BlockArguments extension is used, both of which I recommend.
--
-- > $(TH.declare do
-- >   TH.mod "Data.Foo" do
-- >     TH.ty "SomeType"
-- >     TH.asIdent do
-- >       TH.var "someVariable"
-- >   )
--
-- will become:
--
-- > pattern M_Data_Foo :: ModuleName
-- > pattern M_Data_Foo = ModuleName "Data.Foo"
-- >
-- > pattern SomeType :: Qualified (ProperName 'TypeName)
-- > pattern SomeType = Qualified (ByModuleName M_Data_Foo) (ProperName "SomeType")
-- >
-- > pattern I_someVariable :: Qualified Ident
-- > pattern I_someVariable = Qualified (ByModuleName M_Data_Foo) (Ident "someVariable")
--
-- All pattern synonyms must start with an uppercase letter. To prevent
-- namespace collisions, different types of pattern are distinguished by a sort
-- of Hungarian notation convention:
--
-- @
--   SomeType   -- a type or class name
--   C_Ctor     -- a constructor name
--   I_name     -- a Qualified Ident
--   M_Data_Foo -- a module name
--   P_name     -- a (module name, polymorphic string) pair
--   S_name     -- a lone polymorphic string (this doesn't contain any module information)
-- @
--
-- I_, P_, and S_ patterns are all optional and have to be enabled with
-- `asIdent`, `asPair`, and `asString` modifiers respectively.
--
-- Finally, to disambiguate between identifiers with the same name (such as
-- Data.Function.apply and Data.Apply.apply), the `prefixWith` modifier will
-- modify the names of the patterns created within it.
--
-- > TH.mod "Data.Function" do
-- >   TH.prefixWith "function" do
-- >     TH.asIdent do
-- >       TH.var "apply"
-- 
-- results in:
--
-- > pattern I_functionApply :: Qualified Ident
-- > pattern I_functionApply = Qualified (ByModuleName (M_Data_Function) (Ident "apply")
--
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)

-- | Generate pattern synonyms corresponding to the provided PureScript
-- declarations.
declare :: Writer (Q [Dec]) () -> Q [Dec]
declare :: Writer (Q [Dec]) () -> Q [Dec]
declare = forall w a. Writer w a -> w
execWriter

-- | Declare a module.
mod :: String -> ModDecs -> Writer (Q [Dec]) ()
mod :: String -> ModDecs -> Writer (Q [Dec]) ()
mod String
mnStr ModDecs
inner = do
  -- pattern M_Data_Foo :: ModuleName
  -- pattern M_Data_Foo = ModuleName "Data.Foo"
  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
"", []) ()

-- | Declare a type class. The resulting pattern will use the name of the class
-- and have type `Qualified (ProperName 'ClassName)`.
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

-- | Declare a list of type classes; shorthand for repeatedly calling `cls`.
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

-- | Declare a data type, given the name of the type and a list of constructor
-- names. A pattern will be created using the name of the type and have type
-- `Qualified (ProperName 'TypeName)`. A pattern will also be created for each
-- constructor prefixed with "C_", having type `Qualified (ProperName
-- 'ConstructorName)`.
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

-- | Declare a data type with a singular constructor named the same as the
-- type, as is commonly the case with newtypes (but this does not require the
-- type to be a newtype in reality). Shorthand for calling `dty`.
nty :: String -> ModDecs
nty :: String -> ModDecs
nty String
tn = String -> [String] -> ModDecs
dty String
tn [String
tn]

-- | Declare a list of data types with singular constructors; shorthand for
-- repeatedly calling `nty`, which itself is shorthand for `dty`.
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

-- | Declare a type. The resulting pattern will use the name of the type and have
-- type `Qualified (ProperName 'TypeName)`.
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

-- | Declare a list of types; shorthand for repeatedly calling `ty`.
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

-- | Declare a variable, function, named instance, or generally a lower-case
-- value member of a module. The patterns created depend on which of `asPair`,
-- `asIdent`, or `asString` are used in the enclosing context.
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

-- | Declare a list of variables; shorthand for repeatedly calling `var`.
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

-- | For every variable declared within, create a pattern synonym prefixed
-- with "P_" having type `forall a. (Eq a, IsString a) => (ModuleName, a)`.
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

-- | For every variable declared within, cerate a pattern synonym prefixed
-- with "I_" having type `Qualified Ident`.
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

-- | For every variable declared within, cerate a pattern synonym prefixed
-- with "S_" having type `forall a. (Eq a, IsString a) => a`.
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

-- | Prefix the names of all enclosed declarations with the provided string, to
-- prevent collisions with other identifiers. For example,
-- `prefixWith "function"` would turn `I_apply` into `I_functionApply`, and
-- `C_Example` into `C_FunctionExample`.
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

-- Internals start here

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

-- "Data.Foo" -> M_Data_Foo
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)

-- "I_" -> "fn" -> "foo" -> I_fnFoo
-- "I_" -> ""   -> "foo" -> I_foo
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

-- 'TypeName -> M_Data_Foo -> "Function" -> "Foo" ->
--   pattern FunctionFoo :: Qualified (ProperName 'TypeName)
--   pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo")
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)) |]

-- M_Data_Foo -> "function" -> "foo" ->
--   pattern I_functionFoo :: Qualified Ident
--   pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo")
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)) |]

-- M_Data_Foo -> "function" -> "foo" ->
--   pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a)
--   pattern P_functionFoo = (M_Data_Foo, "foo")
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)) |]

-- _ -> "function" -> "foo" ->
--   pattern S_functionFoo :: forall a. (Eq a, IsString a) => a
--   pattern S_functionFoo = "foo"
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]