{-# 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 (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL)
import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..))

-- | 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]