{- HLINT ignore "Avoid lambda using `infix`" -}

{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Patterns for types and type search.
-}

module Stan.Pattern.Type
    ( -- * Type
      PatternType (..)

      -- * eDSL
    , (|->)
    , (|::)

      -- * Common 'PatternType's
    , listPattern
    , nonEmptyPattern
    , listFunPattern
    , integerPattern
    , naturalPattern

      -- ** Textual types
    , charPattern
    , stringPattern
    , textPattern

      -- * Foldable patterns
    , foldableTypesPatterns
    , foldableMethodsPatterns
    ) where

import Stan.NameMeta (NameMeta (..), baseNameFrom, ghcPrimNameFrom, primTypeMeta, textNameFrom)
import Stan.Pattern.Edsl (PatternBool (..))


{- | Query pattern used to search types in HIE AST.
-}
data PatternType
    {- | Argument, type or constructor:

    +---------------------+---------------------------------------------------------------------+
    | @a@                 | @PatternName (NameMeta ... \"a\") []@                               |
    +---------------------+---------------------------------------------------------------------+
    | @[a]@               | @PatternName (NameMeta ... \"[]\") [aPattern]@                      |
    +---------------------+---------------------------------------------------------------------+
    | @Either Int String@ | @PatternName (NameMeta ... \"Either\") [intPattern, stringPattern]@ |
    +---------------------+---------------------------------------------------------------------+
    -}
    = PatternTypeName !NameMeta ![PatternType]
    -- | Function pattern.
    | PatternTypeFun !PatternType !PatternType
    -- | Type wildcard, matches anything.
    | PatternTypeAnything
    -- | Choice between patterns. Should match either of them.
    | PatternTypeOr !PatternType !PatternType
    -- | Union of patterns. Should match both of them.
    | PatternTypeAnd !PatternType !PatternType
    -- | Negation of pattern. Should match everything except this pattern.
    | PatternTypeNeg !PatternType
    deriving stock (Int -> PatternType -> ShowS
[PatternType] -> ShowS
PatternType -> String
(Int -> PatternType -> ShowS)
-> (PatternType -> String)
-> ([PatternType] -> ShowS)
-> Show PatternType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatternType] -> ShowS
$cshowList :: [PatternType] -> ShowS
show :: PatternType -> String
$cshow :: PatternType -> String
showsPrec :: Int -> PatternType -> ShowS
$cshowsPrec :: Int -> PatternType -> ShowS
Show, PatternType -> PatternType -> Bool
(PatternType -> PatternType -> Bool)
-> (PatternType -> PatternType -> Bool) -> Eq PatternType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatternType -> PatternType -> Bool
$c/= :: PatternType -> PatternType -> Bool
== :: PatternType -> PatternType -> Bool
$c== :: PatternType -> PatternType -> Bool
Eq)

instance PatternBool PatternType where
    (?) :: PatternType
    ? :: PatternType
(?) = PatternType
PatternTypeAnything

    neg :: PatternType -> PatternType
    neg :: PatternType -> PatternType
neg = PatternType -> PatternType
PatternTypeNeg

    (|||) :: PatternType -> PatternType -> PatternType
    ||| :: PatternType -> PatternType -> PatternType
(|||) = PatternType -> PatternType -> PatternType
PatternTypeOr

    (&&&) :: PatternType -> PatternType -> PatternType
    &&& :: PatternType -> PatternType -> PatternType
(&&&) = PatternType -> PatternType -> PatternType
PatternTypeAnd

-- | Short operator alias for 'PatternFun'.
infixr 4 |->
(|->) :: PatternType -> PatternType -> PatternType
|-> :: PatternType -> PatternType -> PatternType
(|->) = PatternType -> PatternType -> PatternType
PatternTypeFun

-- | Short operator alias for 'PatternTypeName'.
infix 5 |::
(|::) :: NameMeta -> [PatternType] -> PatternType
|:: :: NameMeta -> [PatternType] -> PatternType
(|::) = NameMeta -> [PatternType] -> PatternType
PatternTypeName

-- | 'PatternType' for list @[a]@ or @'String'@.
listPattern :: PatternType
listPattern :: PatternType
listPattern =
    NameMeta
listNameMeta NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?) ]
    PatternType -> PatternType -> PatternType
forall a. PatternBool a => a -> a -> a
|||
    "String" Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.Base" NameMeta -> [PatternType] -> PatternType
|:: []
  where
    listNameMeta :: NameMeta
    listNameMeta :: NameMeta
listNameMeta = Text -> NameMeta
primTypeMeta "[]"

-- | 'PatternType' for 'NonEmpty'.
nonEmptyPattern :: PatternType
nonEmptyPattern :: PatternType
nonEmptyPattern = "NonEmpty" Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.Base" NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?) ]

-- | 'PatternType' for @[a] -> _@ or @String -> _@.
listFunPattern :: PatternType
listFunPattern :: PatternType
listFunPattern = PatternType
listPattern PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)

-- | 'PatternType' for 'Integer'.
integerPattern :: PatternType
integerPattern :: PatternType
integerPattern = $WNameMeta :: Text -> ModuleName -> Text -> NameMeta
NameMeta
    { nameMetaName :: Text
nameMetaName       = "Integer"
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = "GHC.Integer.Type"
    , nameMetaPackage :: Text
nameMetaPackage    = "integer-wired-in"
    } NameMeta -> [PatternType] -> PatternType
|:: []

-- | 'PatternType' for 'Natural'.
naturalPattern :: PatternType
naturalPattern :: PatternType
naturalPattern = "Natural" Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.Natural" NameMeta -> [PatternType] -> PatternType
|:: []

charPattern :: PatternType
charPattern :: PatternType
charPattern = Text -> NameMeta
primTypeMeta "Char" NameMeta -> [PatternType] -> PatternType
|:: []

-- | 'PatternType' for 'String'.
stringPattern :: PatternType
stringPattern :: PatternType
stringPattern = "String" Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.Base" NameMeta -> [PatternType] -> PatternType
|:: []

-- | 'PatternType' for 'Text'.
textPattern :: PatternType
textPattern :: PatternType
textPattern = "Text" Text -> ModuleName -> NameMeta
`textNameFrom` "Data.Text.Internal" NameMeta -> [PatternType] -> PatternType
|:: []

----------------------------------------------------------------------------
-- Section of Foldable patterns
----------------------------------------------------------------------------

-- | List of types for @STAN-0207@.
foldableTypesPatterns :: NonEmpty PatternType
foldableTypesPatterns :: NonEmpty PatternType
foldableTypesPatterns = PatternType
maybePattern PatternType -> [PatternType] -> NonEmpty PatternType
forall a. a -> [a] -> NonEmpty a
:| [PatternType
eitherPattern, PatternType
pairPattern]

-- | 'PatternType' for 'Maybe'
maybePattern :: PatternType
maybePattern :: PatternType
maybePattern = "Maybe" Text -> ModuleName -> NameMeta
`baseNameFrom` "GHC.Maybe" NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?) ]

-- | 'PatternType' for 'Either'
eitherPattern :: PatternType
eitherPattern :: PatternType
eitherPattern = "Either" Text -> ModuleName -> NameMeta
`baseNameFrom` "Data.Either" NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?), PatternType
forall a. PatternBool a => a
(?) ]

-- | 'PatternType' for pair @(,)@.
pairPattern :: PatternType
pairPattern :: PatternType
pairPattern = "(,)" Text -> ModuleName -> NameMeta
`ghcPrimNameFrom` "GHC.Tuple" NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?), PatternType
forall a. PatternBool a => a
(?) ]

{- | Type patterns for the 'Foldable' typeclass methods. Represented
as a non-empty list of pairs:

* Method name
* Function from type to pattern (where things like 'Maybe', 'Either'
  should be)
-}
foldableMethodsPatterns :: NonEmpty (NameMeta, PatternType -> PatternType)
foldableMethodsPatterns :: NonEmpty (NameMeta, PatternType -> PatternType)
foldableMethodsPatterns =
      Text -> NameMeta
method "fold"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` (\t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)) (NameMeta, PatternType -> PatternType)
-> [(NameMeta, PatternType -> PatternType)]
-> NonEmpty (NameMeta, PatternType -> PatternType)
forall a. a -> [a] -> NonEmpty a
:|
    [ Text -> NameMeta
method "foldMap"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldMap'" NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldr"    NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldr'"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldl"    NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldl'"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldr1"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "foldl1"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "toList"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "null"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "length"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "elem"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
forall a. PatternBool a => a
(?) PatternType -> PatternType -> PatternType
|-> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "maximum"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "minimum"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "sum"      NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method "product"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \t :: PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    ]
  where
    ofType :: a -> b -> (a, b)
    ofType :: a -> b -> (a, b)
ofType = (,)

    method :: Text -> NameMeta
    method :: Text -> NameMeta
method name :: Text
name = Text
name Text -> ModuleName -> NameMeta
`baseNameFrom` "Data.Foldable"