-----------------------------------------------------------------------------
--
-- Module      : Language.PureScript.Ide.CaseSplit
-- Description : Casesplitting and adding function clauses
-- Copyright   : Christoph Hegemann 2016
-- License     : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability   : experimental
--
-- |
-- Casesplitting and adding function clauses
-----------------------------------------------------------------------------

module Language.PureScript.Ide.CaseSplit
       ( WildcardAnnotations()
       , explicitAnnotations
       , noAnnotations
       , makePattern
       , addClause
       , caseSplit
       ) where

import           Protolude                     hiding (Constructor)

import qualified Data.List.NonEmpty            as NE
import qualified Data.Map                      as M
import qualified Data.Text                     as T
import qualified Language.PureScript           as P
import qualified Language.PureScript.CST       as CST

import           Language.PureScript.Externs
import           Language.PureScript.Ide.Error
import           Language.PureScript.Ide.State
import           Language.PureScript.Ide.Types

type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType])

newtype WildcardAnnotations = WildcardAnnotations Bool

explicitAnnotations :: WildcardAnnotations
explicitAnnotations :: WildcardAnnotations
explicitAnnotations = Bool -> WildcardAnnotations
WildcardAnnotations Bool
True

noAnnotations :: WildcardAnnotations
noAnnotations :: WildcardAnnotations
noAnnotations = Bool -> WildcardAnnotations
WildcardAnnotations Bool
False

type DataType = ([(Text, Maybe P.SourceType, P.Role)], [(P.ProperName 'P.ConstructorName, [P.SourceType])])

caseSplit
  :: (Ide m, MonadError IdeError m)
  => Text
  -> m [Constructor]
caseSplit :: forall (m :: * -> *).
(Ide m, MonadError IdeError m) =>
Text -> m [Constructor]
caseSplit Text
q = do
  SourceType
type' <- forall (m :: * -> *). MonadError IdeError m => Text -> m SourceType
parseType' Text
q
  (ProperName 'TypeName
tc, [SourceType]
args) <- forall (m :: * -> *) a.
MonadError IdeError m =>
Type a -> m (ProperName 'TypeName, [Type a])
splitTypeConstructor SourceType
type'
  ([(Text, Maybe SourceType, Role)]
typeVars, [Constructor]
ctors) <- forall (m :: * -> *).
(Ide m, MonadError IdeError m) =>
ProperName 'TypeName
-> m ([(Text, Maybe SourceType, Role)], [Constructor])
findTypeDeclaration ProperName 'TypeName
tc
  let applyTypeVars :: SourceType -> SourceType
applyTypeVars = forall a. (Type a -> Type a) -> Type a -> Type a
P.everywhereOnTypes (forall a. [(Text, Type a)] -> Type a -> Type a
P.replaceAllTypeVars (forall a b. [a] -> [b] -> [(a, b)]
zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
name, Maybe SourceType
_, Role
_) -> Text
name) [(Text, Maybe SourceType, Role)]
typeVars) [SourceType]
args))
  let appliedCtors :: [Constructor]
appliedCtors = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SourceType -> SourceType
applyTypeVars)) [Constructor]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Constructor]
appliedCtors

findTypeDeclaration
  :: (Ide m, MonadError IdeError m)
  => P.ProperName 'P.TypeName
  -> m DataType
findTypeDeclaration :: forall (m :: * -> *).
(Ide m, MonadError IdeError m) =>
ProperName 'TypeName
-> m ([(Text, Maybe SourceType, Role)], [Constructor])
findTypeDeclaration ProperName 'TypeName
q = do
  ModuleMap ExternsFile
efs <- forall (m :: * -> *). Ide m => m (ModuleMap ExternsFile)
getExternFiles
  ModuleMap ExternsFile
efs' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe ModuleMap ExternsFile
efs (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) ModuleMap ExternsFile
efs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Ide m => m (Maybe (ModuleName, ExternsFile))
cachedRebuild
  let m :: Maybe ([(Text, Maybe SourceType, Role)], [Constructor])
m = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ProperName 'TypeName
-> ExternsFile
-> First ([(Text, Maybe SourceType, Role)], [Constructor])
findTypeDeclaration' ProperName 'TypeName
q) ModuleMap ExternsFile
efs'
  case Maybe ([(Text, Maybe SourceType, Role)], [Constructor])
m of
    Just ([(Text, Maybe SourceType, Role)], [Constructor])
mn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Maybe SourceType, Role)], [Constructor])
mn
    Maybe ([(Text, Maybe SourceType, Role)], [Constructor])
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError Text
"Not Found")

findTypeDeclaration'
  :: P.ProperName 'P.TypeName
  -> ExternsFile
  -> First DataType
findTypeDeclaration' :: ProperName 'TypeName
-> ExternsFile
-> First ([(Text, Maybe SourceType, Role)], [Constructor])
findTypeDeclaration' ProperName 'TypeName
t ExternsFile{[DeclarationRef]
[ExternsDeclaration]
[ExternsTypeFixity]
[ExternsFixity]
[ExternsImport]
Text
SourceSpan
ModuleName
efSourceSpan :: ExternsFile -> SourceSpan
efDeclarations :: ExternsFile -> [ExternsDeclaration]
efTypeFixities :: ExternsFile -> [ExternsTypeFixity]
efFixities :: ExternsFile -> [ExternsFixity]
efImports :: ExternsFile -> [ExternsImport]
efExports :: ExternsFile -> [DeclarationRef]
efModuleName :: ExternsFile -> ModuleName
efVersion :: ExternsFile -> Text
efSourceSpan :: SourceSpan
efDeclarations :: [ExternsDeclaration]
efTypeFixities :: [ExternsTypeFixity]
efFixities :: [ExternsFixity]
efImports :: [ExternsImport]
efExports :: [DeclarationRef]
efModuleName :: ModuleName
efVersion :: Text
..} =
  forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case
            EDType ProperName 'TypeName
tn SourceType
_ (P.DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
typeVars [Constructor]
ctors)
              | ProperName 'TypeName
tn forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
t -> forall a. a -> Maybe a
Just ([(Text, Maybe SourceType, Role)]
typeVars, [Constructor]
ctors)
            ExternsDeclaration
_ -> forall a. Maybe a
Nothing) [ExternsDeclaration]
efDeclarations

splitTypeConstructor :: (MonadError IdeError m) =>
                        P.Type a -> m (P.ProperName 'P.TypeName, [P.Type a])
splitTypeConstructor :: forall (m :: * -> *) a.
MonadError IdeError m =>
Type a -> m (ProperName 'TypeName, [Type a])
splitTypeConstructor = forall {f :: * -> *} {a}.
MonadError IdeError f =>
[Type a] -> Type a -> f (ProperName 'TypeName, [Type a])
go []
  where
    go :: [Type a] -> Type a -> f (ProperName 'TypeName, [Type a])
go [Type a]
acc (P.TypeApp a
_ Type a
ty Type a
arg) = [Type a] -> Type a -> f (ProperName 'TypeName, [Type a])
go (Type a
arg forall a. a -> [a] -> [a]
: [Type a]
acc) Type a
ty
    go [Type a]
acc (P.TypeConstructor a
_ Qualified (ProperName 'TypeName)
tc) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Qualified a -> a
P.disqualify Qualified (ProperName 'TypeName)
tc, [Type a]
acc)
    go [Type a]
_ Type a
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError Text
"Failed to read TypeConstructor")

prettyCtor :: WildcardAnnotations -> Constructor -> Text
prettyCtor :: WildcardAnnotations -> Constructor -> Text
prettyCtor WildcardAnnotations
_ (ProperName 'ConstructorName
ctorName, []) = forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ConstructorName
ctorName
prettyCtor WildcardAnnotations
wsa (ProperName 'ConstructorName
ctorName, [SourceType]
ctorArgs) =
  Text
"(" forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ConstructorName
ctorName forall a. Semigroup a => a -> a -> a
<> Text
" "
  forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. WildcardAnnotations -> Type a -> Text
prettyPrintWildcard WildcardAnnotations
wsa) [SourceType]
ctorArgs) forall a. Semigroup a => a -> a -> a
<> Text
")"

prettyPrintWildcard :: WildcardAnnotations -> P.Type a -> Text
prettyPrintWildcard :: forall a. WildcardAnnotations -> Type a -> Text
prettyPrintWildcard (WildcardAnnotations Bool
True) = forall a. Type a -> Text
prettyWildcard
prettyPrintWildcard (WildcardAnnotations Bool
False) = forall a b. a -> b -> a
const Text
"_"

prettyWildcard :: P.Type a -> Text
prettyWildcard :: forall a. Type a -> Text
prettyWildcard Type a
t = Text
"( _ :: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.strip (String -> Text
T.pack (forall a. Int -> Type a -> String
P.prettyPrintTypeAtom forall a. Bounded a => a
maxBound Type a
t)) forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Constructs Patterns to insert into a sourcefile
makePattern :: Text -- ^ Current line
            -> Int -- ^ Begin of the split
            -> Int -- ^ End of the split
            -> WildcardAnnotations -- ^ Whether to explicitly type the splits
            -> [Constructor] -- ^ Constructors to split
            -> [Text]
makePattern :: Text
-> Int -> Int -> WildcardAnnotations -> [Constructor] -> [Text]
makePattern Text
t Int
x Int
y WildcardAnnotations
wsa = Text -> Text -> [Constructor] -> [Text]
makePattern' (Int -> Text -> Text
T.take Int
x Text
t) (Int -> Text -> Text
T.drop Int
y Text
t)
  where
    makePattern' :: Text -> Text -> [Constructor] -> [Text]
makePattern' Text
lhs Text
rhs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Constructor
ctor -> Text
lhs forall a. Semigroup a => a -> a -> a
<> WildcardAnnotations -> Constructor -> Text
prettyCtor WildcardAnnotations
wsa Constructor
ctor forall a. Semigroup a => a -> a -> a
<> Text
rhs)

addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text]
addClause :: forall (m :: * -> *).
MonadError IdeError m =>
Text -> WildcardAnnotations -> m [Text]
addClause Text
s WildcardAnnotations
wca = do
  (Ident
fName, SourceType
fType) <- forall (m :: * -> *).
MonadError IdeError m =>
Text -> m (Ident, SourceType)
parseTypeDeclaration' Text
s
  let args :: [SourceType]
args = forall a. Type a -> [Type a]
splitFunctionType SourceType
fType
      template :: Text
template = Ident -> Text
P.runIdent Ident
fName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<>
        [Text] -> Text
T.unwords (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. WildcardAnnotations -> Type a -> Text
prettyPrintWildcard WildcardAnnotations
wca) [SourceType]
args) forall a. Semigroup a => a -> a -> a
<>
        Text
" = ?" forall a. Semigroup a => a -> a -> a
<> (Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
P.runIdent forall a b. (a -> b) -> a -> b
$ Ident
fName)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
s, Text
template]

parseType' :: (MonadError IdeError m) =>
              Text -> m P.SourceType
parseType' :: forall (m :: * -> *). MonadError IdeError m => Text -> m SourceType
parseType' Text
s =
  case forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser Parser (Type ())
CST.parseType forall a b. (a -> b) -> a -> b
$ Text -> [LexResult]
CST.lex Text
s of
    Right ([ParserWarning], Type ())
type' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. String -> Type a -> SourceType
CST.convertType String
"<purs-ide>" forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ([ParserWarning], Type ())
type'
    Left NonEmpty ParserError
err ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError (Text
"Parsing the splittype failed with:"
                                forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show NonEmpty ParserError
err))

parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.SourceType)
parseTypeDeclaration' :: forall (m :: * -> *).
MonadError IdeError m =>
Text -> m (Ident, SourceType)
parseTypeDeclaration' Text
s =
  let x :: Either (NonEmpty ParserError) [Declaration]
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. String -> Declaration a -> [Declaration]
CST.convertDeclaration String
"<purs-ide>" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        forall a b. (a -> b) -> a -> b
$ forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser Parser (Declaration ())
CST.parseDecl
        forall a b. (a -> b) -> a -> b
$ Text -> [LexResult]
CST.lex Text
s
  in
    case Either (NonEmpty ParserError) [Declaration]
x of
      Right [P.TypeDeclaration TypeDeclarationData
td] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDeclarationData -> (Ident, SourceType)
P.unwrapTypeDeclaration TypeDeclarationData
td)
      Right [Declaration]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError Text
"Found a non-type-declaration")
      Left NonEmpty ParserError
errs ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError (Text
"Parsing the type signature failed with: "
                                   forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (ParserError -> String
CST.prettyPrintErrorMessage forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty ParserError
errs)))

splitFunctionType :: P.Type a -> [P.Type a]
splitFunctionType :: forall a. Type a -> [Type a]
splitFunctionType Type a
t = forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Type a]
arguments
  where
    arguments :: Maybe [Type a]
arguments = forall a. [a] -> Maybe [a]
initMay [Type a]
splitted
    splitted :: [Type a]
splitted = forall a. Type a -> [Type a]
splitType' Type a
t
    splitType' :: Type a -> [Type a]
splitType' (P.ForAll a
_ Text
_ Maybe (Type a)
_ Type a
t' Maybe SkolemScope
_) = Type a -> [Type a]
splitType' Type a
t'
    splitType' (P.ConstrainedType a
_ Constraint a
_ Type a
t') = Type a -> [Type a]
splitType' Type a
t'
    splitType' (P.TypeApp a
_ (P.TypeApp a
_ Type a
t' Type a
lhs) Type a
rhs)
          | forall a b. Type a -> Type b -> Bool
P.eqType Type a
t' SourceType
P.tyFunction = Type a
lhs forall a. a -> [a] -> [a]
: Type a -> [Type a]
splitType' Type a
rhs
    splitType' Type a
t' = [Type a
t']