{-# LANGuAGE CPP #-}

{- 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 ... \"List\") [aPattern]@ (after GHC 9.6)    |
    |                     | @PatternName (NameMeta ... \"[]\") [aPattern]@   (before GHC 9.6)   |
    +---------------------+---------------------------------------------------------------------+
    | @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
$cshowsPrec :: Int -> PatternType -> ShowS
showsPrec :: Int -> PatternType -> ShowS
$cshow :: PatternType -> String
show :: PatternType -> String
$cshowList :: [PatternType] -> ShowS
showList :: [PatternType] -> ShowS
Show, PatternType -> PatternType -> Bool
(PatternType -> PatternType -> Bool)
-> (PatternType -> PatternType -> Bool) -> Eq PatternType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PatternType -> PatternType -> Bool
== :: PatternType -> PatternType -> Bool
$c/= :: PatternType -> PatternType -> Bool
/= :: 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
|||
    Text
"String" Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"GHC.Base" NameMeta -> [PatternType] -> PatternType
|:: []
  where
    listNameMeta :: NameMeta
#if __GLASGOW_HASKELL__ < 906
    listNameMeta = primTypeMeta "[]"
#elif __GLASGOW_HASKELL__ >= 906
    listNameMeta :: NameMeta
listNameMeta = Text -> NameMeta
primTypeMeta Text
"List"
#endif

-- | 'PatternType' for 'NonEmpty'.
nonEmptyPattern :: PatternType
nonEmptyPattern :: PatternType
nonEmptyPattern = Text
"NonEmpty" Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"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
(?)

-- The source for integerPattern and naturalPattern varies depending on the GHC
-- version
#if __GLASGOW_HASKELL__ < 900

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

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

#elif __GLASGOW_HASKELL__ >= 900

-- | 'PatternType' for 'Integer'.
integerPattern :: PatternType
integerPattern :: PatternType
integerPattern = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
"Integer"
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
"GHC.Num.Integer"
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"ghc-bignum"
    } NameMeta -> [PatternType] -> PatternType
|:: []

-- | 'PatternType' for 'Natural'.
naturalPattern :: PatternType
naturalPattern :: PatternType
naturalPattern = NameMeta
    { nameMetaName :: Text
nameMetaName       = Text
"Natural"
    , nameMetaModuleName :: ModuleName
nameMetaModuleName = ModuleName
"GHC.Num.Natural"
    , nameMetaPackage :: Text
nameMetaPackage    = Text
"ghc-bignum"
    } NameMeta -> [PatternType] -> PatternType
|:: []

#endif

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

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

-- | 'PatternType' for 'Text'.
textPattern :: PatternType
textPattern :: PatternType
textPattern = Text
"Text" Text -> ModuleName -> NameMeta
`textNameFrom` ModuleName
"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 = Text
"Maybe" Text -> ModuleName -> NameMeta
`baseNameFrom` ModuleName
"GHC.Maybe" NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?) ]

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

-- | 'PatternType' for pair @(,)@.
pairPattern :: PatternType
#if __GLASGOW_HASKELL__ < 908
pairPattern :: PatternType
pairPattern = Text
"(,)" Text -> ModuleName -> NameMeta
`ghcPrimNameFrom` ModuleName
ghcTuple NameMeta -> [PatternType] -> PatternType
|:: [ PatternType
forall a. PatternBool a => a
(?), PatternType
forall a. PatternBool a => a
(?) ]
#elif __GLASGOW_HASKELL__ >= 908
pairPattern = "Tuple2" `ghcPrimNameFrom` ghcTuple |:: [ (?), (?) ]
#endif
  where
#if __GLASGOW_HASKELL__ < 906
    ghcTuple = "GHC.Tuple"
#elif __GLASGOW_HASKELL__ >= 906
    ghcTuple :: ModuleName
ghcTuple = ModuleName
"GHC.Tuple.Prim"
#endif

{- | 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 Text
"fold"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` (\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 Text
"foldMap"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldMap'" NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldr"    NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldr'"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldl"    NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldl'"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldr1"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"foldl1"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"toList"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"null"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"length"   NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"elem"     NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \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 Text
"maximum"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"minimum"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"sum"      NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    , Text -> NameMeta
method Text
"product"  NameMeta
-> (PatternType -> PatternType)
-> (NameMeta, PatternType -> PatternType)
forall a b. a -> b -> (a, b)
`ofType` \PatternType
t -> PatternType
t PatternType -> PatternType -> PatternType
|-> PatternType
forall a. PatternBool a => a
(?)
    ]
  where
    ofType :: a -> b -> (a, b)
    ofType :: forall a b. a -> b -> (a, b)
ofType = (,)

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