forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathUtil.hs
More file actions
147 lines (123 loc) · 5.19 KB
/
Util.hs
File metadata and controls
147 lines (123 loc) · 5.19 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Ide.Util
-- Description : Generally useful functions and conversions
-- Copyright : Christoph Hegemann 2016
-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability : experimental
--
-- |
-- Generally useful functions
-----------------------------------------------------------------------------
module Language.PureScript.Ide.Util
( identifierFromIdeDeclaration
, unwrapMatch
, unwrapPositioned
, unwrapPositionedRef
, completionFromMatch
, encodeT
, decodeT
, discardAnn
, withEmptyAnn
, valueOperatorAliasT
, typeOperatorAliasT
, prettyTypeT
, properNameT
, identT
, opNameT
, ideReadFile
, module Language.PureScript.Ide.Logging
) where
import Protolude hiding (decodeUtf8,
encodeUtf8)
import Control.Lens hiding ((&), op)
import Data.Aeson
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.Types
import System.IO.UTF8 (readUTF8FileT)
identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration d = case d of
IdeDeclValue v -> v ^. ideValueIdent . identT
IdeDeclType t -> t ^. ideTypeName . properNameT
IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT
IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT
IdeDeclTypeClass tc -> tc ^. ideTCName . properNameT
IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName
IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName
IdeDeclKind name -> P.runProperName name
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn
withEmptyAnn = IdeDeclarationAnn emptyAnn
unwrapMatch :: Match a -> a
unwrapMatch (Match (_, ed)) = ed
completionFromMatch :: Match IdeDeclarationAnn -> Completion
completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
Completion {..}
where
(complIdentifier, complExpandedType) = case decl of
IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)
IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)
IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)
IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)
IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class")
IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
(P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
(P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)
IdeDeclKind k -> (P.runProperName k, "kind")
complModule = P.runModuleName m
complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)
complLocation = annLocation ann
complDocumentation = Nothing
showFixity p a r o =
let asso = case a of
P.Infix -> "infix"
P.Infixl -> "infixl"
P.Infixr -> "infixr"
in T.unwords [asso, show p, r, "as", P.runOpName o]
valueOperatorAliasT
:: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
valueOperatorAliasT i =
P.showQualified (either P.runIdent P.runProperName) i
typeOperatorAliasT
:: P.Qualified (P.ProperName 'P.TypeName) -> Text
typeOperatorAliasT i =
P.showQualified P.runProperName i
encodeT :: (ToJSON a) => a -> Text
encodeT = TL.toStrict . decodeUtf8 . encode
decodeT :: (FromJSON a) => Text -> Maybe a
decodeT = decode . encodeUtf8 . TL.fromStrict
unwrapPositioned :: P.Declaration -> P.Declaration
unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x
unwrapPositioned x = x
unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
unwrapPositionedRef x = x
properNameT :: Iso' (P.ProperName a) Text
properNameT = iso P.runProperName P.ProperName
identT :: Iso' P.Ident Text
identT = iso P.runIdent P.Ident
opNameT :: Iso' (P.OpName a) Text
opNameT = iso P.runOpName P.OpName
ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
ideReadFile fp = do
contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp))
either
(\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))
pure
contents
prettyTypeT :: P.Type -> Text
prettyTypeT =
T.unwords
. map T.strip
. T.lines
. T.pack
. P.prettyPrintTypeWithUnicode