-- |

module Language.PureScript.Ide.CaseSplit

( WildcardAnnotations()

, explicitAnnotations

, noAnnotations

, makePattern

, addClause

, caseSplit

) where

import Protolude hiding (Constructor)

import qualified Data.Text as T

import qualified Language.PureScript as P

import Language.PureScript.Externs

import Language.PureScript.Ide.Error

import Language.PureScript.Ide.State

import Language.PureScript.Ide.Types

import Language.PureScript.Ide.Util

import Text.Parsec as Parsec

import qualified Text.PrettyPrint.Boxes as Box

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

newtype WildcardAnnotations = WildcardAnnotations Bool

explicitAnnotations :: WildcardAnnotations

explicitAnnotations = WildcardAnnotations True

noAnnotations :: WildcardAnnotations

noAnnotations = WildcardAnnotations False

caseSplit :: (Ide m, MonadError IdeError m) =>

Text -> m [Constructor]

caseSplit q = do

type' <- parseType' q

(tc, args) <- splitTypeConstructor type'

(EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc

let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))

let appliedCtors = map (second (map applyTypeVars)) ctors

pure appliedCtors

findTypeDeclaration :: (Ide m, MonadError IdeError m) =>

P.ProperName 'P.TypeName -> m ExternsDeclaration

findTypeDeclaration q = do

efs <- getExternFiles

let m = getFirst $ foldMap (findTypeDeclaration' q) efs

case m of

Just mn -> pure mn

Nothing -> throwError (GeneralError "Not Found")

findTypeDeclaration' ::

P.ProperName 'P.TypeName

-> ExternsFile

-> First ExternsDeclaration

findTypeDeclaration' t ExternsFile{..} =

First $ find (\case

EDType tn _ _ -> tn == t

_ -> False) efDeclarations

splitTypeConstructor :: (MonadError IdeError m) =>

P.Type -> m (P.ProperName 'P.TypeName, [P.Type])

splitTypeConstructor = go []

where

go acc (P.TypeApp ty arg) = go (arg : acc) ty

go acc (P.TypeConstructor tc) = pure (P.disqualify tc, acc)

go _ _ = throwError (GeneralError "Failed to read TypeConstructor")

prettyCtor :: WildcardAnnotations -> Constructor -> Text

prettyCtor _ (ctorName, []) = P.runProperName ctorName

prettyCtor wsa (ctorName, ctorArgs) =

"("<> P.runProperName ctorName <> " "

<> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"

prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text

prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard

prettyPrintWildcard (WildcardAnnotations False) = const "_"

prettyWildcard :: P.Type -> Text

prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")"

-- | 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 t x y wsa = makePattern' (T.take x t) (T.drop y t)

where

makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)

addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text]

addClause s wca = do

(fName, fType) <- parseTypeDeclaration' s

let args = splitFunctionType fType

template = P.runIdent fName <> " " <>

T.unwords (map (prettyPrintWildcard wca) args) <>

" = ?" <> (T.strip . P.runIdent $ fName)

pure [s, template]

parseType' :: (MonadError IdeError m) =>

Text -> m P.Type

parseType' s =

case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of

Right type' -> pure type'

Left err ->

throwError (GeneralError ("Parsing the splittype failed with:"

<> show err))

parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type)

parseTypeDeclaration' s =

let x = do

ts <- P.lex "" (toS s)

P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts

in

case unwrapPositioned <$> x of

Right (P.TypeDeclaration i t) -> pure (i, t)

Right _ -> throwError (GeneralError "Found a non-type-declaration")

Left err ->

throwError (GeneralError ("Parsing the type signature failed with: "

<> toS (Box.render (P.prettyPrintParseError err))))

splitFunctionType :: P.Type -> [P.Type]

splitFunctionType t = fromMaybe [] arguments

where

arguments = initMay splitted

splitted = splitType' t

splitType' (P.ForAll _ t' _) = splitType' t'

splitType' (P.ConstrainedType _ t') = splitType' t'

splitType' (P.TypeApp (P.TypeApp t' lhs) rhs)

| t' == P.tyFunction = lhs : splitType' rhs

splitType' t' = [t']