content: {-# 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 = execWriter
  
  -- | Declare a module.
  mod :: String -> ModDecs -> Writer (Q [Dec]) ()
  mod mnStr inner = do
    -- pattern M_Data_Foo :: ModuleName
    -- pattern M_Data_Foo = ModuleName "Data.Foo"
    let mn = mkModuleName mnStr
    tell $ typedPatSyn mn [t| ModuleName |] [p| ModuleName $(litP $ stringL mnStr) |]
    tell $ snd $ execRWS inner (mn, "", []) ()
  
  -- | Declare a type class. The resulting pattern will use the name of the class
  -- and have type `Qualified (ProperName 'ClassName)`.
  cls :: String -> ModDecs
  cls cn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'ClassName |] mn prefix cn
  
  -- | Declare a list of type classes; shorthand for repeatedly calling `cls`.
  clss :: [String] -> ModDecs
  clss = traverse_ 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 dn ctors = ask >>= \(mn, prefix, _) -> do
    tell $ mkPnPat [t| 'TypeName |] mn prefix dn
    tell $ map fold $ traverse (mkPnPat [t| 'ConstructorName |] mn $ "C_" <> prefix) 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 tn = dty tn [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 = traverse_ nty
  
  -- | Declare a type. The resulting pattern will use the name of the type and have
  -- type `Qualified (ProperName 'TypeName)`.
  ty :: String -> ModDecs
  ty tn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'TypeName |] mn prefix tn
  
  -- | Declare a list of types; shorthand for repeatedly calling `ty`.
  tys :: [String] -> ModDecs
  tys = traverse_ 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 nm = ask >>= \(mn, prefix, vtds) -> tell $ foldMap (\f -> f mn prefix nm) vtds
  
  -- | Declare a list of variables; shorthand for repeatedly calling `var`.
  vars :: [String] -> ModDecs
  vars = traverse_ 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 = local $ addToVars mkPairDec
  
  -- | For every variable declared within, cerate a pattern synonym prefixed
  -- with "I_" having type `Qualified Ident`.
  asIdent :: ModDecs -> ModDecs
  asIdent = local $ addToVars 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 = local $ addToVars 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 = local . 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 f (a, b, fs) = (a, b, f : fs)
  
  applyPrefix :: String -> (a, String, c) -> (a, String, c)
  applyPrefix prefix (a, prefix', c) = (a, camelAppend prefix' prefix, c)
  
  cap :: String -> String
  cap = over _head toUpper
  
  camelAppend :: String -> String -> String
  camelAppend l r = if null l then r else l <> cap r
  
  -- "Data.Foo" -> M_Data_Foo
  mkModuleName :: String -> Name
  mkModuleName = mkName . ("M_" <>) . map (\case '.' -> '_'; other -> other)
  
  -- "I_" -> "fn" -> "foo" -> I_fnFoo
  -- "I_" -> ""   -> "foo" -> I_foo
  mkPrefixedName :: String -> String -> String -> Name
  mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend 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 pnType mn prefix str = typedPatSyn (mkName $ cap prefix <> 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 mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix 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 mn prefix str = typedPatSyn (mkPrefixedName "P_" prefix 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 _ prefix str = typedPatSyn (mkPrefixedName "S_" prefix str)
    [t| forall a. (Eq a, IsString a) => a |]
    (litP $ stringL str)
  
  typedPatSyn :: Name -> Q Type -> Q Pat -> Q [Dec]
  typedPatSyn nm t p = sequence [patSynSigD nm t, patSynD nm (prefixPatSyn []) implBidir p]
  