Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 4fdcef9

Browse files
author
Rick Winfrey
authored
Merge branch 'master' into update-php-assignment
2 parents 1d03fae + 6c31189 commit 4fdcef9

File tree

35 files changed

+325
-319
lines changed

35 files changed

+325
-319
lines changed

‎.gitattributes‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,4 @@
22
test/fixtures linguist-vendored
33
test/repos linguist-vendored
44
vendor linguist-vendored
5+
*.protobuf.bin binary

‎semantic.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ common dependencies
6464
, scientific ^>= 0.3.6.2
6565
, safe-exceptions ^>= 0.1.7.0
6666
, semilattices ^>= 0.0.0.3
67+
, shelly >= 1.5 && <2
6768
, text ^>= 1.2.3.1
6869
, these >= 0.7 && <1
6970
, unix ^>= 2.7.2.2
@@ -270,6 +271,7 @@ library
270271
-- Serialization
271272
, Serializing.Format
272273
, Serializing.SExpression
274+
, Serializing.SExpression.Precise
273275
, Tags.Taggable
274276
, Tags.Tagging
275277
-- Custom Prelude
@@ -307,7 +309,6 @@ library
307309
, reducers ^>= 3.12.3
308310
, semigroupoids ^>= 5.3.2
309311
, servant ^>= 0.15
310-
, shelly >= 1.5 && <2
311312
, split ^>= 0.2.3.3
312313
, stm-chans ^>= 3.0.0.4
313314
, template-haskell ^>= 2.14
@@ -393,6 +394,7 @@ test-suite test
393394
, tasty-golden ^>= 2.3.2
394395
, tasty-hedgehog ^>= 1.0.0.1
395396
, tasty-hspec ^>= 1.1.5.1
397+
, tasty-hunit ^>= 0.10.0.2
396398
, HUnit ^>= 1.6.0.0
397399
, leancheck >= 0.8 && <1
398400
, temporary ^>= 1.3

‎src/Data/Blob.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module Data.Blob
55
, Blob(..)
66
, Blobs(..)
77
, blobLanguage
8+
, NoLanguageForBlob (..)
89
, blobPath
910
, makeBlob
1011
, decodeBlobs

‎src/Data/Handle.hs‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE GADTs #-}
1+
{-# LANGUAGE DeriveAnyClass, GADTs #-}
22

33
module Data.Handle
44
( Handle (..)
@@ -11,14 +11,15 @@ module Data.Handle
1111
, readBlobPairsFromHandle
1212
, readFromHandle
1313
, openFileForReading
14+
, InvalidJSONException (..)
1415
) where
1516

1617
import Prologue
1718

19+
import Control.Exception (throw)
1820
import Data.Aeson
1921
import qualified Data.ByteString.Lazy as BL
2022
import qualified Data.ByteString.Lazy.Char8 as BLC
21-
import System.Exit
2223
import qualified System.IO as IO
2324

2425
import Data.Blob
@@ -58,9 +59,14 @@ readPathsFromHandle (ReadHandle h) = liftIO $ fmap BLC.unpack . BLC.lines <$> BL
5859
readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
5960
readBlobPairsFromHandle = fmap blobs <$> readFromHandle
6061

62+
newtype InvalidJSONException = InvalidJSONException String
63+
deriving (Eq, Show, Exception)
64+
65+
-- | Read JSON-encoded data from a 'Handle'. Throws
66+
-- 'InvalidJSONException' on parse failure.
6167
readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
6268
readFromHandle (ReadHandle h) = do
6369
input <- liftIO $ BL.hGetContents h
6470
case eitherDecode input of
65-
Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
71+
Left e -> throw (InvalidJSONException e)
6672
Right d -> pure d

‎src/Semantic/Util.hs‎

Lines changed: 25 additions & 127 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
{-# LANGUAGE CPP, ConstraintKinds, Rank2Types, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
2-
{-# OPTIONS_GHC -Wno-missing-signatures -O0 #-}
1+
{-# LANGUAGE CPP, ConstraintKinds, PartialTypeSignatures, Rank2Types, ScopedTypeVariables, TypeFamilies,
2+
TypeOperators #-}
3+
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-partial-type-signatures -O0 #-}
34
module Semantic.Util
45
( evalGoProject
56
, evalPHPProject
@@ -10,6 +11,7 @@ module Semantic.Util
1011
, mergeErrors
1112
, reassociate
1213
, parseFile
14+
, parseFileQuiet
1315
) where
1416

1517
import Prelude hiding (readFile)
@@ -30,6 +32,7 @@ import Data.Blob.IO
3032
import Data.Graph (topologicalSort)
3133
import qualified Data.Language as Language
3234
import Data.List (uncons)
35+
import Data.Location
3336
import Data.Project hiding (readFile)
3437
import Data.Quieterm (Quieterm, quieterm)
3538
import Data.Sum (weaken)
@@ -47,70 +50,11 @@ import Semantic.Task
4750
import System.Exit (die)
4851
import System.FilePath.Posix (takeDirectory)
4952

50-
import Data.Location
51-
52-
-- The type signatures in these functions are pretty gnarly, but these functions
53-
-- are hit sufficiently often in the CLI and test suite so as to merit avoiding
54-
-- the overhead of repeated type inference. If you have to hack on these functions,
55-
-- it's recommended to remove all the type signatures and add them back when you
56-
-- are done (type holes in GHCi will help here).
57-
58-
justEvaluating :: Evaluator
59-
term
60-
Precise
61-
(Value term Precise)
62-
(ResumableC
63-
(BaseError (ValueError term Precise))
64-
(ResumableC
65-
(BaseError (AddressError Precise (Value term Precise)))
66-
(ResumableC
67-
(BaseError ResolutionError)
68-
(ResumableC
69-
(BaseError
70-
(EvalError term Precise (Value term Precise)))
71-
(ResumableC
72-
(BaseError (HeapError Precise))
73-
(ResumableC
74-
(BaseError (ScopeError Precise))
75-
(ResumableC
76-
(BaseError
77-
(UnspecializedError
78-
Precise (Value term Precise)))
79-
(ResumableC
80-
(BaseError
81-
(LoadError
82-
Precise
83-
(Value term Precise)))
84-
(FreshC
85-
(StateC
86-
(ScopeGraph
87-
Precise)
88-
(StateC
89-
(Heap
90-
Precise
91-
Precise
92-
(Value
93-
term
94-
Precise))
95-
(TraceByPrintingC
96-
(LiftC
97-
IO)))))))))))))
98-
result
99-
-> IO
100-
(Heap Precise Precise (Value term Precise),
101-
(ScopeGraph Precise,
102-
Either
103-
(SomeError
104-
(Sum
105-
'[BaseError (ValueError term Precise),
106-
BaseError (AddressError Precise (Value term Precise)),
107-
BaseError ResolutionError,
108-
BaseError (EvalError term Precise (Value term Precise)),
109-
BaseError (HeapError Precise),
110-
BaseError (ScopeError Precise),
111-
BaseError (UnspecializedError Precise (Value term Precise)),
112-
BaseError (LoadError Precise (Value term Precise))]))
113-
result))
53+
justEvaluating :: Evaluator term Precise (Value term Precise) _ result
54+
-> IO ( Heap Precise Precise (Value term Precise),
55+
( ScopeGraph Precise
56+
, Either (SomeError (Sum _)) result)
57+
)
11458
justEvaluating
11559
= runM
11660
. runEvaluator
@@ -128,75 +72,27 @@ justEvaluating
12872
. runAddressError
12973
. runValueError
13074

131-
type FileEvaluator syntax =
75+
type FileEvaluator err syntax =
13276
[FilePath]
13377
-> IO
134-
(Heap
135-
Precise
136-
Precise
137-
(Value
138-
(Quieterm (Sum syntax) Location) Precise),
139-
(ScopeGraph Precise,
140-
Either
141-
(SomeError
142-
(Sum
143-
'[BaseError
144-
(ValueError
145-
(Quieterm (Sum syntax) Location)
146-
Precise),
147-
BaseError
148-
(AddressError
149-
Precise
150-
(Value
151-
(Quieterm
152-
(Sum syntax) Location)
153-
Precise)),
154-
BaseError ResolutionError,
155-
BaseError
156-
(EvalError
157-
(Quieterm (Sum syntax) Location)
158-
Precise
159-
(Value
160-
(Quieterm
161-
(Sum syntax) Location)
162-
Precise)),
163-
BaseError (HeapError Precise),
164-
BaseError (ScopeError Precise),
165-
BaseError
166-
(UnspecializedError
167-
Precise
168-
(Value
169-
(Quieterm
170-
(Sum syntax) Location)
171-
Precise)),
172-
BaseError
173-
(LoadError
174-
Precise
175-
(Value
176-
(Quieterm
177-
(Sum syntax) Location)
178-
Precise))]))
179-
(ModuleTable
180-
(Module
181-
(ModuleResult
182-
Precise
183-
(Value
184-
(Quieterm (Sum syntax) Location)
185-
Precise))))))
78+
( Heap Precise Precise (Value (Quieterm (Sum syntax) Location) Precise),
79+
( ScopeGraph Precise
80+
, Either (SomeError (Sum err))
81+
(ModuleTable (Module (ModuleResult Precise (Value (Quieterm (Sum syntax) Location) Precise))))))
18682

187-
evalGoProject :: FileEvaluator Language.Go.Assignment.Syntax
83+
evalGoProject :: FileEvaluator _ Language.Go.Assignment.Syntax
18884
evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser
18985

190-
evalRubyProject :: FileEvaluator Language.Ruby.Assignment.Syntax
86+
evalRubyProject :: FileEvaluator _ Language.Ruby.Assignment.Syntax
19187
evalRubyProject = justEvaluating <=< evaluateProject (Proxy @'Language.Ruby) rubyParser
19288

193-
evalPHPProject :: FileEvaluator Language.PHP.Assignment.Syntax
89+
evalPHPProject :: FileEvaluator _ Language.PHP.Assignment.Syntax
19490
evalPHPProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser
19591

196-
evalPythonProject :: FileEvaluator Language.Python.Assignment.Syntax
197-
evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser
92+
evalPythonProject :: FileEvaluator _ Language.Python.Assignment.Syntax
93+
evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser
19894

199-
evalTypeScriptProject :: FileEvaluator Language.TypeScript.Assignment.Syntax
95+
evalTypeScriptProject :: FileEvaluator _ Language.TypeScript.Assignment.Syntax
20096
evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser
20197

20298
evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger statter ->
@@ -218,11 +114,13 @@ evaluateProject' session proxy parser paths = do
218114
(evaluate proxy (runDomainEffects (evalTerm withTermSpans)) modules)))))))
219115
either (die . displayException) pure res
220116

221-
parseFile :: Parser term -> FilePath -> IO term
117+
parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
222118
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
119+
parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
223120

224-
runTask' :: TaskEff a -> IO a
121+
runTask', runTaskQuiet :: TaskEff a -> IO a
225122
runTask' task = runTaskWithOptions debugOptions task >>= either (die . displayException) pure
123+
runTaskQuiet task = runTaskWithOptions defaultOptions task >>= either (die . displayException) pure
226124

227125
mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result
228126
mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right)

‎src/Serializing/SExpression/Precise.hs‎

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
2+
module Serializing.SExpression.Precise
3+
( serializeSExpression
4+
) where
5+
6+
import Data.ByteString.Builder
7+
import Data.Foldable (fold)
8+
import Data.List (intersperse)
9+
import Data.Text (Text)
10+
import GHC.Generics
11+
12+
serializeSExpression :: ToSExpression t => t -> Builder
13+
serializeSExpression t = toSExpression t 0 <> "\n"
14+
15+
16+
nl :: Int -> Builder
17+
nl n | n <= 0 = ""
18+
| otherwise = "\n"
19+
20+
pad :: Int -> Builder
21+
pad n = stringUtf8 (replicate (2 * n) ' ')
22+
23+
24+
class ToSExpression t where
25+
toSExpression :: t -> Int -> Builder
26+
27+
instance (ToSExpressionWithStrategy strategy t, strategy ~ ToSExpressionStrategy t) => ToSExpression t where
28+
toSExpression = toSExpressionWithStrategy @strategy undefined
29+
30+
31+
data Strategy = Generic | Show
32+
33+
type family ToSExpressionStrategy t :: Strategy where
34+
ToSExpressionStrategy Text = 'Show
35+
ToSExpressionStrategy _ = 'Generic
36+
37+
class ToSExpressionWithStrategy (strategy :: Strategy) t where
38+
toSExpressionWithStrategy :: proxy strategy -> t -> Int -> Builder
39+
40+
instance Show t => ToSExpressionWithStrategy 'Show t where
41+
toSExpressionWithStrategy _ t _ = stringUtf8 (show t)
42+
43+
instance (Generic t, GToSExpression (Rep t)) => ToSExpressionWithStrategy 'Generic t where
44+
toSExpressionWithStrategy _ t n = nl n <> pad n <> "(" <> fold (intersperse " " (gtoSExpression (from t) n)) <> ")"
45+
46+
47+
class GToSExpression f where
48+
gtoSExpression :: f (Int -> Builder) -> (Int -> [Builder])
49+
50+
instance GToSExpression f => GToSExpression (M1 D d f) where
51+
gtoSExpression = gtoSExpression . unM1
52+
53+
instance (GToSExpression f, GToSExpression g) => GToSExpression (f :+: g) where
54+
gtoSExpression (L1 l) = gtoSExpression l
55+
gtoSExpression (R1 r) = gtoSExpression r
56+
57+
instance (Constructor c, GToSExpression f) => GToSExpression (M1 C c f) where
58+
gtoSExpression m n = stringUtf8 (conName m) : gtoSExpression (unM1 m) (n + 1)
59+
60+
instance (GToSExpression f, GToSExpression g) => GToSExpression (f :*: g) where
61+
gtoSExpression (l :*: r) = gtoSExpression l <> gtoSExpression r
62+
63+
instance GToSExpression U1 where
64+
gtoSExpression _ _ = []
65+
66+
instance GToSExpression f => GToSExpression (M1 S s f) where
67+
gtoSExpression = gtoSExpression . unM1 -- FIXME: show the selector name, if any
68+
69+
instance ToSExpression k => GToSExpression (K1 R k) where
70+
gtoSExpression k = pure . toSExpression (unK1 k)

‎test/Analysis/Go/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import SpecHelpers
88

99

1010
spec :: (?session :: TaskSession) => Spec
11-
spec = parallel $ do
11+
spec = do
1212
describe "Go" $ do
1313
it "imports and wildcard imports" $ do
1414
(scopeGraph, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]

‎test/Analysis/PHP/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import SpecHelpers
99

1010

1111
spec :: (?session :: TaskSession) => Spec
12-
spec = parallel $ do
12+
spec = do
1313
describe "PHP" $ do
1414
xit "evaluates include and require" $ do
1515
(scopeGraph, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]

‎test/Analysis/Python/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import SpecHelpers
1010

1111

1212
spec :: (?session :: TaskSession) => Spec
13-
spec = parallel $ do
13+
spec = do
1414
describe "Python" $ do
1515
it "imports" $ do
1616
(scopeGraph, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]

‎test/Analysis/Ruby/Spec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ import SpecHelpers
1515

1616

1717
spec :: (?session :: TaskSession) => Spec
18-
spec = parallel $ do
18+
spec = do
1919
describe "Ruby" $ do
2020
it "evaluates require_relative" $ do
2121
(scopeGraph, (heap, res)) <- evaluate ["main.rb", "foo.rb"]

0 commit comments

Comments
 (0)