-
Notifications
You must be signed in to change notification settings - Fork 12
/
Base.hs
607 lines (521 loc) · 21.6 KB
/
Base.hs
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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
{-# LANGUAGE DeriveDataTypeable,OverloadedStrings,PatternGuards, NamedFieldPuns #-}
-- |
-- Module : Language.Haskell.BuildWrapper.GHC
-- Author : JP Moresmau
-- Copyright : (c) JP Moresmau 2011
-- License : BSD3
--
-- Maintainer : jpmoresmau@gmail.com
-- Stability : beta
-- Portability : portable
--
-- Data types, State Monad, utility functions
module Language.Haskell.BuildWrapper.Base where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Data
import Data.Aeson
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as M
import qualified Data.Vector as V
import qualified Data.Set as S
import System.Directory
import System.FilePath
import Data.List (isPrefixOf, isInfixOf)
import Data.Maybe (catMaybes)
-- | State type
type BuildWrapper=StateT BuildWrapperState IO
-- | the state we keep
data BuildWrapperState=BuildWrapperState{
tempFolder::String -- ^ name of temporary folder
,cabalPath::FilePath -- ^ path to the cabal executable
,cabalFile::FilePath -- ^ path of the project cabal file
,verbosity::Verbosity -- ^ verbosity of logging
,cabalFlags::String -- ^ flags to pass cabal
,cabalOpts::[String] -- ^ extra arguments to cabal configure
}
-- | status of notes: error or warning
data BWNoteStatus=BWError | BWWarning
deriving (Show,Read,Eq)
instance ToJSON BWNoteStatus where
toJSON = toJSON . drop 2 . show
instance FromJSON BWNoteStatus where
parseJSON (String t) =return $ read $ T.unpack $ T.append "BW" t
parseJSON _= mzero
-- | location of a note/error
data BWLocation=BWLocation {
bwl_src::FilePath -- ^ source file
,bwl_line::Int -- ^ line
,bwl_col::Int -- ^ column
}
deriving (Show,Read,Eq)
instance ToJSON BWLocation where
toJSON (BWLocation s l c)=object ["f" .= s, "l" .= l , "c" .= c]
instance FromJSON BWLocation where
parseJSON (Object v) =BWLocation <$>
v .: "f" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
-- | a note on a source file
data BWNote=BWNote {
bwn_status :: BWNoteStatus -- ^ status of the note
,bwn_title :: String -- ^ message
,bwn_location :: BWLocation -- ^ where the note is
}
deriving (Show,Read,Eq)
isBWNoteError :: BWNote -> Bool
isBWNoteError bw=(bwn_status bw) == BWError
instance ToJSON BWNote where
toJSON (BWNote s t l)= object ["s" .= s, "t" .= t, "l" .= l]
instance FromJSON BWNote where
parseJSON (Object v) =BWNote <$>
v .: "s" <*>
v .: "t" <*>
v .: "l"
parseJSON _= mzero
-- | simple type encapsulating the fact the operations return along with notes generated on files
type OpResult a=(a,[BWNote])
-- | result: success + files impacted
data BuildResult=BuildResult Bool [FilePath]
deriving (Show,Read,Eq)
instance ToJSON BuildResult where
toJSON (BuildResult b fps)= object ["r" .= b, "fps" .= map toJSON fps]
instance FromJSON BuildResult where
parseJSON (Object v) =BuildResult <$>
v .: "r" <*>
v .: "fps"
parseJSON _= mzero
-- | which cabal file to use operations
data WhichCabal=
Source -- ^ use proper file
| Target -- ^ use temporary file that was saved in temp folder
deriving (Show,Read,Eq,Enum,Data,Typeable)
-- | type of elements for the outline
data OutlineDefType =
Class |
Data |
Family |
Function |
Pattern |
Syn |
Type |
Instance |
Field |
Constructor |
Splice
deriving (Show,Read,Eq,Ord,Enum)
instance ToJSON OutlineDefType where
toJSON = toJSON . show
instance FromJSON OutlineDefType where
parseJSON (String s) =return $ read $ T.unpack s
parseJSON _= mzero
-- | Location inside a file, the file is known and doesn't need to be repeated
data InFileLoc=InFileLoc {ifl_line::Int -- ^ line
,ifl_column::Int -- ^ column
}
deriving (Show,Read,Eq,Ord)
-- | Span inside a file, the file is known and doesn't need to be repeated
data InFileSpan=InFileSpan {ifs_start::InFileLoc -- ^ start location
,ifs_end::InFileLoc -- ^ end location
}
deriving (Show,Read,Eq,Ord)
instance ToJSON InFileSpan where
toJSON (InFileSpan (InFileLoc sr sc) (InFileLoc er ec))
| sr==er = if ec==sc+1
then toJSON $ map toJSON [sr,sc]
else toJSON $ map toJSON [sr,sc,ec]
| otherwise = toJSON $ map toJSON [sr,sc,er,ec]
instance FromJSON InFileSpan where
parseJSON (Array v) =do
let
l=V.length v
case l of
2->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v0 (v1+1))
3->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
Success v2 = fromJSON (v V.! 2)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v0 v2)
4->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
Success v2 = fromJSON (v V.! 2)
Success v3 = fromJSON (v V.! 3)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v2 v3)
_ -> mzero
parseJSON _= mzero
-- | construct a file span
mkFileSpan :: Int -- ^ start line
-> Int -- ^ start column
-> Int -- ^ end line
-> Int -- ^ end column
-> InFileSpan
mkFileSpan sr sc er ec=InFileSpan (InFileLoc sr sc) (InFileLoc er ec)
-- | element of the outline result
data OutlineDef = OutlineDef
{ od_name :: T.Text -- ^ name
,od_type :: [OutlineDefType] -- ^ types: can have several to combine
,od_loc :: InFileSpan -- ^ span in source
,od_children :: [OutlineDef] -- ^ children (constructors...)
,od_signature :: Maybe T.Text -- ^ type signature if any
,od_comment :: Maybe T.Text -- ^ comment if any
}
deriving (Show,Read,Eq,Ord)
-- | constructs an OutlineDef with no children and no type signature
mkOutlineDef :: T.Text -- ^ name
-> [OutlineDefType] -- ^ types: can have several to combine
-> InFileSpan -- ^ span in source
-> OutlineDef
mkOutlineDef n t l= mkOutlineDefWithChildren n t l []
-- | constructs an OutlineDef with children and no type signature
mkOutlineDefWithChildren :: T.Text -- ^ name
-> [OutlineDefType] -- ^ types: can have several to combine
-> InFileSpan -- ^ span in source
-> [OutlineDef] -- ^ children (constructors...)
-> OutlineDef
mkOutlineDefWithChildren n t l c= OutlineDef n t l c Nothing Nothing
instance ToJSON OutlineDef where
toJSON (OutlineDef n tps l c ts d)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c, "s" .= ts, "d" .= d]
instance FromJSON OutlineDef where
parseJSON (Object v) =OutlineDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c" <*>
v .: "s" <*>
v .: "d"
parseJSON _= mzero
-- | Lexer token
data TokenDef = TokenDef {
td_name :: T.Text -- ^ type of token
,td_loc :: InFileSpan -- ^ location
}
deriving (Show,Eq)
instance ToJSON TokenDef where
toJSON (TokenDef n s)=
object [n .= s]
instance FromJSON TokenDef where
parseJSON (Object o) |
((a,b):[])<-M.toList o,
Success v0 <- fromJSON b=return $ TokenDef a v0
parseJSON _= mzero
-- | Type of import/export directive
data ImportExportType = IEVar -- ^ Var
| IEAbs -- ^ Abs
| IEThingAll -- ^ import/export everything
| IEThingWith -- ^ specific import/export list
| IEModule -- ^ reexport module
deriving (Show,Read,Eq,Ord,Enum)
instance ToJSON ImportExportType where
toJSON = toJSON . show
instance FromJSON ImportExportType where
parseJSON (String s) =return $ read $ T.unpack s
parseJSON _= mzero
-- | definition of export
data ExportDef = ExportDef {
e_name :: T.Text -- ^ name
,e_type :: ImportExportType -- ^ type
,e_loc :: InFileSpan -- ^ location in source file
,e_children :: [T.Text] -- ^ children (constructor names, etc.)
} deriving (Show,Eq)
instance ToJSON ExportDef where
toJSON (ExportDef n t l c)= object ["n" .= n , "t" .= t, "l" .= l, "c" .= map toJSON c]
instance FromJSON ExportDef where
parseJSON (Object v) =ExportDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
-- | definition of an import element
data ImportSpecDef = ImportSpecDef {
is_name :: T.Text -- ^ name
,is_type :: ImportExportType -- ^ type
,is_loc :: InFileSpan -- ^ location in source file
,is_children :: [T.Text] -- ^ children (constructor names, etc.)
} deriving (Show,Eq)
instance ToJSON ImportSpecDef where
toJSON (ImportSpecDef n t l c)= object ["n" .= n , "t" .= t, "l" .= l, "c" .= map toJSON c]
instance FromJSON ImportSpecDef where
parseJSON (Object v) =ImportSpecDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
-- | definition of an import statement
data ImportDef = ImportDef {
i_module :: T.Text -- ^ module name
,i_package :: Maybe T.Text -- ^ package name
,i_loc :: InFileSpan -- ^ location in source file
,i_qualified :: Bool -- ^ is the import qualified
,i_hiding :: Bool -- ^ is the import element list for hiding or exposing
,i_alias :: T.Text -- ^ alias name
,i_children :: Maybe [ImportSpecDef] -- ^ specific import elements
} deriving (Show,Eq)
instance ToJSON ImportDef where
toJSON (ImportDef m p l q h a c)= object ["m" .= m , "p" .= p, "l" .= l, "q" .= q, "h" .= h, "a" .= a, "c" .= c]
instance FromJSON ImportDef where
parseJSON (Object v) =ImportDef <$>
v .: "m" <*>
v .: "p" <*>
v .: "l" <*>
v .: "q" <*>
v .: "h" <*>
v .: "a" <*>
v .: "c"
parseJSON _= mzero
-- | complete result for outline
data OutlineResult = OutlineResult {
or_outline :: [OutlineDef] -- ^ outline contents
,or_exports :: [ExportDef] -- ^ exports
,or_imports :: [ImportDef] -- ^ imports
}
deriving (Show,Eq)
instance ToJSON OutlineResult where
toJSON (OutlineResult o e i)= object ["o" .= map toJSON o,"e" .= map toJSON e,"i" .= map toJSON i]
instance FromJSON OutlineResult where
parseJSON (Object v) =OutlineResult <$>
v .: "o" <*>
v .: "e" <*>
v .: "i"
parseJSON _= mzero
-- | build flags for a specific file
data BuildFlags = BuildFlags {
bf_ast :: [String] -- ^ flags for GHC
,bf_preproc :: [String] -- ^ flags for preprocessor
,bf_modName :: Maybe String -- ^ module name if known
}
deriving (Show,Read,Eq,Data,Typeable)
instance ToJSON BuildFlags where
toJSON (BuildFlags ast preproc modName)= object ["a" .= map toJSON ast, "p" .= map toJSON preproc, "m" .= toJSON modName]
instance FromJSON BuildFlags where
parseJSON (Object v)=BuildFlags <$>
v .: "a" <*>
v .: "p" <*>
v .: "m"
parseJSON _= mzero
data ThingAtPoint = ThingAtPoint {
tapName :: String,
tapModule :: Maybe String,
tapType :: Maybe String,
tapQType :: Maybe String,
tapHType :: Maybe String,
tapGType :: Maybe String
}
deriving (Show,Read,Eq,Data,Typeable)
instance ToJSON ThingAtPoint where
toJSON (ThingAtPoint name modu stype qtype htype gtype)=object ["Name" .= name, "Module" .= modu, "Type" .= stype, "QType" .= qtype, "HType" .= htype, "GType" .= gtype]
instance FromJSON ThingAtPoint where
parseJSON (Object v)=ThingAtPoint <$>
v .: "Name" <*>
v .: "Module" <*>
v .: "Type" <*>
v .: "QType" <*>
v .: "HType" <*>
v .: "GType"
parseJSON _= mzero
-- | get the full path for the temporary directory
getFullTempDir :: BuildWrapper FilePath
getFullTempDir = do
cf<-gets cabalFile
temp<-gets tempFolder
let dir=takeDirectory cf
return (dir </> temp)
-- | get the full path for the temporary dist directory (where cabal will write its output)
getDistDir :: BuildWrapper FilePath
getDistDir = do
temp<-getFullTempDir
return (temp </> "dist")
-- | get full path in temporary folder for source file (i.e. where we're going to write the temporary contents of an edited file)
getTargetPath :: FilePath -- ^ relative path of source file
-> BuildWrapper FilePath
getTargetPath src=do
temp<-getFullTempDir
let path=temp </> src
liftIO $ createDirectoryIfMissing True (takeDirectory path)
return path
-- | get the full, canonicalized path of a source
canonicalizeFullPath :: FilePath -- ^ relative path of source file
-> BuildWrapper FilePath
canonicalizeFullPath fp =do
full<-getFullSrc fp
ex<-liftIO $ doesFileExist full -- on OSX with GHC 7.0, canonicalizePath fails on non existing paths, so let's be defensive
if ex
then liftIO $ canonicalizePath full
else return full
-- | get the full path of a source
getFullSrc :: FilePath -- ^ relative path of source file
-> BuildWrapper FilePath
getFullSrc src=do
cf<-gets cabalFile
let dir=takeDirectory cf
return (dir </> src)
-- | copy a file from the normal folders to the temp folder
copyFromMain :: Bool -- ^ copy even if temp file is newer
-> FilePath -- ^ relative path of source file
-> BuildWrapper(Maybe FilePath) -- ^ return Just the file if copied, Nothing if no copy was done
copyFromMain force src=do
fullSrc<-getFullSrc src
fullTgt<-getTargetPath src
exSrc<-liftIO $ doesFileExist fullSrc
if exSrc
then do
moreRecent<-liftIO $ isSourceMoreRecent fullSrc fullTgt
if force || moreRecent
then do
liftIO $ copyFile fullSrc fullTgt
return $ Just src
else return Nothing
else return Nothing
isSourceMoreRecent :: FilePath -> FilePath -> IO Bool
isSourceMoreRecent fullSrc fullTgt=do
ex<-doesFileExist fullTgt
if not ex
then return True
else
do modSrc <- getModificationTime fullSrc
modTgt <- getModificationTime fullTgt
return (modSrc >= modTgt)
-- | replace relative file path by module name
fileToModule :: FilePath -> String
fileToModule fp=map rep (dropExtension fp)
where rep '/' = '.'
rep '\\' = '.'
rep a = a
-- | Verbosity settings
data Verbosity = Silent | Normal | Verbose | Deafening
deriving (Show, Read, Eq, Ord, Enum, Bounded,Data,Typeable)
-- | component in cabal file
data CabalComponent
= CCLibrary
{ cc_buildable :: Bool -- ^ is the library buildable
} -- ^ library
| CCExecutable
{ cc_exe_name :: String -- ^ executable name
, cc_buildable :: Bool -- ^ is the executable buildable
} -- ^ executable
| CCTestSuite
{ cc_test_name :: String -- ^ test suite name
, cc_buildable :: Bool -- ^ is the test suite buildable
} -- ^ test suite
deriving (Eq, Show)
instance ToJSON CabalComponent where
toJSON (CCLibrary b)= object ["Library" .= b]
toJSON (CCExecutable e b)= object ["Executable" .= b,"e" .= e]
toJSON (CCTestSuite t b)= object ["TestSuite" .= b,"t" .= t]
instance FromJSON CabalComponent where
parseJSON (Object v)
| Just b <- M.lookup "Library" v =CCLibrary <$> parseJSON b
| Just b <- M.lookup "Executable" v =CCExecutable <$> v .: "e" <*> parseJSON b
| Just b <- M.lookup "TestSuite" v =CCTestSuite <$> v .: "t" <*> parseJSON b
| otherwise = mzero
parseJSON _= mzero
cabalComponentName :: CabalComponent -> String
cabalComponentName CCLibrary{}=""
cabalComponentName CCExecutable{cc_exe_name}=cc_exe_name
cabalComponentName CCTestSuite{cc_test_name}=cc_test_name
-- | a cabal package
data CabalPackage=CabalPackage {
cp_name::String -- ^ name of package
,cp_version::String -- ^ version
,cp_exposed::Bool -- ^ is the package exposed or hidden
,cp_dependent::[CabalComponent] -- ^ components in the cabal file that use this package
,cp_modules::[String] -- ^ all modules. We keep all modules so that we can try to open non exposed but imported modules directly
}
deriving (Eq, Show)
instance ToJSON CabalPackage where
toJSON (CabalPackage n v e d em)=object ["n" .= n,"v" .= v, "e" .= e, "d" .= map toJSON d, "m" .= map toJSON em]
instance FromJSON CabalPackage where
parseJSON (Object v) =CabalPackage <$>
v .: "n" <*>
v .: "v" <*>
v .: "e" <*>
v .: "d" <*>
v .: "m"
parseJSON _= mzero
data LoadContents = SingleFile {
lmFile :: FilePath
,lmModule :: String
}
| MultipleFile {
lmFiles :: [(FilePath,String)]
}
getLoadFiles :: LoadContents -> [(FilePath,String)]
getLoadFiles SingleFile{lmFile=f,lmModule=m}=[(f,m)]
getLoadFiles MultipleFile{lmFiles=fs}=fs
-- | http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents topdir = do
names <- getDirectoryContents topdir
let properNames = filter (not . isPrefixOf ".") names
paths <- forM properNames $ \name -> do
let path = topdir </> name
isDirectory <- doesDirectoryExist path
if isDirectory
then getRecursiveContents path
else return [path]
return (concat paths)
deleteGhosts :: [FilePath] -> BuildWrapper [FilePath]
deleteGhosts copied=do
root<-getFullSrc ""
temp<-getFullTempDir
fs<-liftIO $ getRecursiveContents temp
let copiedS=S.fromList copied
del<-liftIO $ mapM (deleteIfGhost root temp copiedS) fs
return $ catMaybes del
where
deleteIfGhost :: FilePath -> FilePath -> S.Set FilePath -> FilePath -> IO (Maybe FilePath)
deleteIfGhost rt tmp cs f=do
let rel=makeRelative tmp f
if "dist" `isPrefixOf` rel || S.member rel cs
then return Nothing
else do
let fullSrc=rt </> rel
ex<-doesFileExist fullSrc
if ex
then return Nothing
else do
removeFile (tmp </> f)
return $ Just rel
-- | debug method: fromJust with a message to display when we get Nothing
fromJustDebug :: String -> Maybe a -> a
fromJustDebug s Nothing=error ("fromJust:" ++ s)
fromJustDebug _ (Just a)=a
-- | remove a base directory from a string representing a full path
removeBaseDir :: FilePath -> String -> String
removeBaseDir base_dir = loop
where
loop [] = []
loop str =
let (prefix, rest) = splitAt n str
in
if base_dir_sep == prefix -- found an occurrence?
then loop rest -- yes: drop it
else head str : loop (tail str) -- no: keep looking
n = length base_dir_sep
base_dir_sep=base_dir ++ [pathSeparator]
nubOrd :: Ord a => [a] -> [a]
nubOrd=S.toList . S.fromList
formatJSON :: String -> String
formatJSON s=snd $ foldl f (0,"") s
where
f (i,s) '['=((i+4),s ++ "\n" ++(map (const ' ') [0 .. i]) ++ "[")
f (i,s) ']' =((i-4),s ++ "\n" ++(map (const ' ') [0 .. i]) ++ "]")
f (i,s) c =(i,s++[c])
data Usage = Usage {
usPackage::Maybe T.Text,
usModule::T.Text,
usName::T.Text,
usType::Bool,
usLoc::Value
}
deriving (Show,Eq)