Merge branch 'master' into evaluate-ruby

.gitignore

@@ -13,6 +13,8 @@ dist-newstyle
 tmp/
 bin/
 
+/semanticd/test/current
+/semanticd/test/rover-example-config/semantic.log
 /test/fixtures/*/examples
 
 *.hp

semantic.cabal

@@ -84,6 +84,7 @@ library
                      , Data.Map.Monoidal
                      , Data.Patch
                      , Data.Project
+                     , Data.Quieterm
                      , Data.Range
                      , Data.Record
                      , Data.Semigroup.App

src/Control/Abstract/Heap.hs

@@ -10,7 +10,6 @@ module Control.Abstract.Heap
 , alloc
 , deref
 , assign
-, lookupOrAlloc
 , letrec
 , letrec'
 , variable

src/Control/Abstract/Primitive.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}
 module Control.Abstract.Primitive
   ( define
   , defineClass
@@ -5,6 +6,7 @@ module Control.Abstract.Primitive
   , builtInPrint
   , builtInExport
   , lambda
+  , Lambda(..)
   ) where
 
 import Control.Abstract.Context
@@ -60,17 +62,33 @@ defineNamespace name scope = define name $ do
   binds <- Env.head <$> locally (scope >> getEnv)
   namespace name Nothing binds
 
+-- | Construct a function from a Haskell function taking 'Name's as arguments.
+--
+-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected.
 lambda :: ( HasCallStack
-          , Member Fresh effects
-          , Member (Function address value) effects
+          , Lambda address value effects fn
           , Member (Reader ModuleInfo) effects
           , Member (Reader Span) effects
           )
-       => (Name -> Evaluator address value effects address)
+       => fn
        -> Evaluator address value effects value
-lambda body = withCurrentCallStack callStack $ do
-  var <- gensym
-  function [var] lowerBound (body var)
+lambda body = withCurrentCallStack callStack (lambda' [] body)
+
+-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'.
+class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where
+  lambda' :: [Name]
+          -> ty
+          -> Evaluator address value effects value
+
+instance (Member Fresh effects, Lambda address value effects ret) => Lambda address value effects (Name -> ret) where
+  lambda' vars body = do
+    var <- gensym
+    lambda' (var : vars) (body var)
+  {-# INLINE lambda' #-}
+
+instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where
+  lambda' vars body = function vars lowerBound body
+  {-# INLINE lambda' #-}
 
 builtInPrint :: ( AbstractValue address value effects
                 , HasCallStack

src/Data/Abstract/Evaluatable.hs

@@ -169,7 +169,7 @@ instance HasPrelude 'Ruby where
     define (name "puts") builtInPrint
 
     defineClass (name "Object") [] $ do
-      define (name "inspect") (lambda (const (box (string "<object>"))))
+      define (name "inspect") (lambda (box (string "<object>")))
 
 instance HasPrelude 'TypeScript where
   definePrelude _ =

src/Data/Quieterm.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
+module Data.Quieterm
+( Quieterm(..)
+, quieterm
+) where
+
+import Data.Abstract.Declarations (Declarations)
+import Data.Abstract.FreeVariables (FreeVariables)
+import Data.Functor.Classes
+import Data.Functor.Foldable
+import Data.Term
+import Text.Show (showListWith)
+
+newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) }
+  deriving (Declarations, FreeVariables)
+
+type instance Base (Quieterm syntax ann) = TermF syntax ann
+instance Functor syntax => Recursive   (Quieterm syntax ann) where project = unQuieterm
+instance Functor syntax => Corecursive (Quieterm syntax ann) where embed   =   Quieterm
+
+instance Eq1 syntax => Eq1 (Quieterm syntax) where
+  liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unQuieterm t1) (unQuieterm t2)
+
+instance (Eq1 syntax, Eq ann) => Eq (Quieterm syntax ann) where
+  (==) = eq1
+
+instance Ord1 syntax => Ord1 (Quieterm syntax) where
+  liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unQuieterm t1) (unQuieterm t2)
+
+instance (Ord1 syntax, Ord ann) => Ord (Quieterm syntax ann) where
+  compare = compare1
+
+instance Show1 syntax => Show1 (Quieterm syntax) where
+  liftShowsPrec _ _ = go where go d = liftShowsPrec go (showListWith (go 0)) d . termFOut . unQuieterm
+
+instance Show1 syntax => Show (Quieterm syntax ann) where
+  showsPrec = liftShowsPrec (const (const id)) (const id)
+
+quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann
+quieterm = cata Quieterm

src/Data/Syntax/Declaration.hs

@@ -256,9 +256,7 @@ instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeAlias where
   eval TypeAlias{..} = do
     name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier))
-    v <- subtermValue typeAliasKind
-    addr <- lookupOrAlloc name
-    assign addr v
+    addr <- subtermAddress typeAliasKind
     bind name addr
     pure (Rval addr)
 

src/Data/Syntax/Statement.hs

@@ -118,13 +118,11 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Assignment where
   eval Assignment{..} = do
     lhs <- subtermRef assignmentTarget
-    rhs <- subtermValue assignmentValue
+    rhs <- subtermAddress assignmentValue
 
     case lhs of
       LvalLocal nam -> do
-        addr <- lookupOrAlloc nam
-        assign addr rhs
-        bind nam addr
+        bind nam rhs
       LvalMember _ _ ->
         -- we don't yet support mutable object properties:
         pure ()
@@ -132,7 +130,7 @@ instance Evaluatable Assignment where
         -- the left hand side of the assignment expression is invalid:
         pure ()
 
-    rvalBox rhs
+    pure (Rval rhs)
 
 -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
 newtype PostIncrement a = PostIncrement a

src/Language/TypeScript/Syntax/TypeScript.hs

@@ -110,9 +110,7 @@ instance Evaluatable DefaultExport where
   eval (DefaultExport term) = do
     case declaredName term of
       Just name -> do
-        addr <- lookupOrAlloc name
-        v <- subtermValue term
-        assign addr v
+        addr <- subtermAddress term
         export name name Nothing
         bind name addr
       Nothing -> throwEvalError DefaultExportError

src/Rendering/Graph.hs

@@ -4,7 +4,7 @@ module Rendering.Graph
 , termStyle
 , diffStyle
 , ToTreeGraph(..)
-, Vertex(..)
+, TaggedVertex(..)
 , DiffTag(..)
 ) where
 
@@ -16,7 +16,6 @@ import Control.Monad.Effect.Reader
 import Data.Diff
 import Data.Graph
 import Data.Patch
-import Data.Semigroup.App
 import Data.String (IsString(..))
 import Data.Term
 import Prologue
@@ -24,53 +23,59 @@ import Prologue
 renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
 renderTreeGraph = simplify . runGraph . cata toTreeGraph
 
-runGraph :: Eff '[Fresh, Reader (Graph vertex)] (Graph vertex) -> Graph vertex
-runGraph = run . runReader mempty . runFresh 0
+runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex
+runGraph = run . runFresh 0 . runReader mempty
 
 
-termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (Vertex tag))) effs)
+termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs)
             => tag
-            -> TermF syntax ann (Eff effs (Graph (Vertex tag)))
-            -> Eff effs (Graph (Vertex tag))
-termAlgebra tag (In _ syntax) = do
+            -> TermF syntax ann (Eff effs (Graph (TaggedVertex tag)))
+            -> Eff effs (Graph (TaggedVertex tag))
+termAlgebra t (In _ syntax) = do
   i <- fresh
-  let root = vertex (Vertex i tag (constructorName syntax))
   parent <- ask
-  (parent `connect` root <>) <$> local (const root) (runAppMerge (foldMap AppMerge syntax))
+  let root = vertex (TaggedVertex i t (constructorName syntax))
+  subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
+  pure (parent `connect` root `overlay` subGraph)
 
-
-style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (Vertex tag) string
+style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (TaggedVertex tag) string
 style name tagAttributes = (defaultStyle (fromString . show . vertexId))
   { graphName = fromString (quote name)
   , vertexAttributes = vertexAttributes }
   where quote a = "\"" <> a <> "\""
-        vertexAttributes Vertex{..} = "label" := fromString vertexName : tagAttributes vertexTag
+        vertexAttributes TaggedVertex{..} = "label" := fromString vertexName : tagAttributes vertexTag
 
-termStyle :: (IsString string, Monoid string) => String -> Style (Vertex ()) string
+termStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex ()) string
 termStyle name = style name (const [])
 
-diffStyle :: (IsString string, Monoid string) => String -> Style (Vertex DiffTag) string
+diffStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex DiffTag) string
 diffStyle name = style name diffTagAttributes
   where diffTagAttributes Deleted  = ["color" := "red"]
         diffTagAttributes Inserted = ["color" := "green"]
+        diffTagAttributes Replaced = ["color" := "orange", "style" := "dashed"]
         diffTagAttributes _        = []
 
-data Vertex tag = Vertex { vertexId :: Int, vertexTag :: tag, vertexName :: String }
+data TaggedVertex tag = TaggedVertex { vertexId :: Int, vertexTag :: tag, vertexName :: String }
   deriving (Eq, Ord, Show)
 
-data DiffTag = Deleted | Inserted | Merged
+data DiffTag = Deleted | Inserted | Replaced | Merged
   deriving (Eq, Ord, Show)
 
 
 class ToTreeGraph vertex t | t -> vertex where
   toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
 
-instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex ()) (TermF syntax ann) where
   toTreeGraph = termAlgebra ()
 
-instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex DiffTag) (DiffF syntax ann1 ann2) where
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex DiffTag) (DiffF syntax ann1 ann2) where
   toTreeGraph d = case d of
     Merge t               -> termAlgebra Merged t
     Patch (Delete  t1)    ->          termAlgebra Deleted t1
     Patch (Insert     t2) ->                                     termAlgebra Inserted t2
-    Patch (Replace t1 t2) -> (<>) <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2
+    Patch (Replace t1 t2) -> do
+      i <- fresh
+      parent <- ask
+      let replace = vertex (TaggedVertex i Replaced "Replacement")
+      graph <- local (const replace) (overlay <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2)
+      pure (parent `connect` replace `overlay` graph)

src/Rendering/Renderer.hs

@@ -34,7 +34,7 @@ data DiffRenderer output where
   -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
   SExpressionDiffRenderer :: DiffRenderer Builder
   -- | Render to a 'ByteString' formatted as a DOT description of the diff.
-  DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag))
+  DOTDiffRenderer :: DiffRenderer (Graph (TaggedVertex DiffTag))
   -- | Render to a 'ByteString' formatted using the 'Show' instance.
   ShowDiffRenderer :: DiffRenderer Builder
 
@@ -50,7 +50,7 @@ data TermRenderer output where
   -- | Render to a list of symbols.
   SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON)
   -- | Render to a 'ByteString' formatted as a DOT description of the term.
-  DOTTermRenderer :: TermRenderer (Graph (Vertex ()))
+  DOTTermRenderer :: TermRenderer (Graph (TaggedVertex ()))
   -- | Render to a 'ByteString' formatted using the 'Show' instance.
   ShowTermRenderer :: TermRenderer Builder
 

src/Semantic/CLI.hs

@@ -6,8 +6,9 @@ module Semantic.CLI
 , Parse.runParse
 ) where
 
+import           Control.Monad.IO.Class
 import           Data.Language (ensureLanguage)
-import           Data.List (intercalate)
+import           Data.List (intercalate, uncons)
 import           Data.List.Split (splitWhen)
 import           Data.Project
 import           Options.Applicative hiding (style)
@@ -22,6 +23,7 @@ import qualified Semantic.Parse as Parse
 import qualified Semantic.Task as Task
 import qualified Semantic.Telemetry.Log as Log
 import           Semantic.Version
+import           System.FilePath
 import           Serializing.Format hiding (Options)
 import           Text.Read
 
@@ -36,21 +38,25 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
   where
     version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
     versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")"
-    description = fullDesc <> header "semantic -- Parse and diff semantically"
+    description = fullDesc <> header "semantic -- Semantic (syntax-aware) diffs, program analysis toolkit"
 
-    optionsParser = do
-      logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)]
-                          (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
-      requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id")
-      failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
-      pure $ Options logLevel requestId failOnWarning
+optionsParser :: Parser Options
+optionsParser = do
+  logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)]
+                      (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
+  requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id")
+  failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
+  pure $ Options logLevel requestId failOnWarning
 
-    argumentsParser = do
-      subparser <- hsubparser (diffCommand <> parseCommand <>  tsParseCommand <> graphCommand)
-      output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout)
-      pure $ subparser >>= Task.write output
+argumentsParser :: Parser (Task.TaskEff ())
+argumentsParser = do
+  subparser <- hsubparser (diffCommand <> parseCommand <>  tsParseCommand <> graphCommand)
+  output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout)
+  pure $ subparser >>= Task.write output
 
-    diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
+diffCommand :: Mod CommandFields (Task.TaskEff Builder)
+diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
+  where
     diffArgumentsParser = do
       renderer <- flag  (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
               <|> flag'                                        (Diff.runDiff JSONDiffRenderer)        (long "json"        <> help "Output JSON diff trees")
@@ -60,7 +66,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
       pure $ Task.readBlobPairs filesOrStdin >>= renderer
 
-    parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
+parseCommand :: Mod CommandFields (Task.TaskEff Builder)
+parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
+  where
     parseArgumentsParser = do
       renderer <- flag  (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
               <|> flag'                                          (Parse.runParse JSONTermRenderer)        (long "json"        <> help "Output JSON parse trees")
@@ -74,7 +82,12 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
       pure $ Task.readBlobs filesOrStdin >>= renderer
 
-    tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
+    -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span
+    symbolFieldsReader = eitherReader (Right . parseSymbolFields)
+
+tsParseCommand :: Mod CommandFields (Task.TaskEff Builder)
+tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
+  where
     tsParseArgumentsParser = do
       format <- flag  AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)")
             <|> flag'                 AST.JSON        (long "json"        <> help "Output JSON ASTs")
@@ -82,32 +95,45 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
       pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
 
-    graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module"))
-    graphArgumentsParser = do
-      graphType <- flag  Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
-               <|> flag'                   Graph.CallGraph   (long "calls"   <> help "Compute a call graph")
-      let style = Graph.style
-      includePackages <- switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module")
-      serializer <- flag (Task.serialize (DOT style)) (Task.serialize (DOT style)) (long "dot"  <> help "Output in DOT graph format (default)")
-                <|> flag'                             (Task.serialize JSON)        (long "json" <> help "Output JSON graph")
-                <|> flag'                             (Task.serialize Show)        (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
-      rootDir <- rootDirectoryOption
-      excludeDirs <- excludeDirsOption
-      File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE")
-      pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer
+graphCommand :: Mod CommandFields (Task.TaskEff Builder)
+graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module"))
+  where
+    graphArgumentsParser = makeGraphTask
+      <$> graphType
+      <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module")
+      <*> serializer
+      <*> (readProjectFromPaths <|> readProjectRecursively)
+    graphType =  flag  Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
+             <|> flag'                   Graph.CallGraph   (long "calls"   <> help "Compute a call graph")
+    serializer =  flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.style)) (long "dot"  <> help "Output in DOT graph format (default)")
+              <|> flag'                                   (Task.serialize JSON)              (long "json" <> help "Output JSON graph")
+              <|> flag'                                   (Task.serialize Show)              (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
+    readProjectFromPaths = makeReadProjectFromPathsTask
+      <$> option auto (long "language" <> help "The language for the analysis.")
+      <*> (   Just <$> some (strArgument (metavar "FILES..."))
+          <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
+    makeReadProjectFromPathsTask language maybePaths = do
+      paths <- maybeM (liftIO (many getLine)) maybePaths
+      blobs <- traverse IO.readBlob (flip File language <$> paths)
+      pure $! Project (takeDirectory (maybe "/" fst (uncons paths))) blobs language []
+    readProjectRecursively = makeReadProjectRecursivelyTask
+      <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
+      <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
+      <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE")
+    makeReadProjectRecursivelyTask rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs
+    makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer
 
-    rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
-    excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
-    filePathReader = eitherReader parseFilePath
+filePathReader :: ReadM File
+filePathReader = eitherReader parseFilePath
+  where
     parseFilePath arg = case splitWhen (== ':') arg of
-        [a, b] | (Just lang) <- readMaybe b >>= ensureLanguage -> Right (File a lang)
-               | (Just lang) <- readMaybe a >>= ensureLanguage -> Right (File b lang)
+        [a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang)
+               | Just lang <- readMaybe a >>= ensureLanguage -> Right (File b lang)
         [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path))
         args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
 
+options :: Eq a => [(String, a)] -> Mod OptionFields a -> Parser a
+options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))
+  where
     optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
-    options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))
     findOption options value = maybe "" fst (find ((== value) . snd) options)
-
-    -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span
-    symbolFieldsReader = eitherReader (Right . parseSymbolFields)

src/Semantic/Util.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE TypeFamilies, TypeOperators #-}
 {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-}
 module Semantic.Util where
 
@@ -18,13 +18,12 @@ import           Data.Abstract.Value.Concrete as Concrete
 import           Data.Abstract.Value.Type as Type
 import           Data.Blob
 import           Data.Coerce
-import           Data.Functor.Foldable
 import           Data.Graph (topologicalSort)
 import qualified Data.Language as Language
 import           Data.List (uncons)
 import           Data.Project hiding (readFile)
+import           Data.Quieterm (quieterm)
 import           Data.Sum (weaken)
-import           Data.Term
 import           Language.Haskell.HsColour
 import           Language.Haskell.HsColour.Colourise
 import           Parsing.Parser
@@ -36,7 +35,6 @@ import           Semantic.Task
 import           Semantic.Telemetry (LogQueue, StatQueue)
 import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
-import           Text.Show (showListWith)
 import           Text.Show.Pretty (ppShow)
 
 justEvaluating
@@ -53,28 +51,28 @@ justEvaluating
   . runAddressError
   . runValueError
 
-newtype UtilEff address a = UtilEff
-  { runUtilEff :: Eff '[ Function address (Value address (UtilEff address))
-                       , Exc (LoopControl address)
-                       , Exc (Return address)
-                       , Env address
-                       , Deref address (Value address (UtilEff address))
-                       , Allocator address (Value address (UtilEff address))
+newtype UtilEff a = UtilEff
+  { runUtilEff :: Eff '[ Function Precise (Value Precise UtilEff)
+                       , Exc (LoopControl Precise)
+                       , Exc (Return Precise)
+                       , Env Precise
+                       , Deref Precise (Value Precise UtilEff)
+                       , Allocator Precise (Value Precise UtilEff)
                        , Reader ModuleInfo
-                       , Modules address
-                       , Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
+                       , Modules Precise
+                       , Reader (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
                        , Reader Span
                        , Reader PackageInfo
-                       , Resumable (ValueError address (UtilEff address))
-                       , Resumable (AddressError address (Value address (UtilEff address)))
+                       , Resumable (ValueError Precise UtilEff)
+                       , Resumable (AddressError Precise (Value Precise UtilEff))
                        , Resumable ResolutionError
                        , Resumable EvalError
-                       , Resumable (EnvironmentError address)
-                       , Resumable (Unspecialized (Value address (UtilEff address)))
-                       , Resumable (LoadError address)
+                       , Resumable (EnvironmentError Precise)
+                       , Resumable (Unspecialized (Value Precise UtilEff))
+                       , Resumable (LoadError Precise)
                        , Trace
                        , Fresh
-                       , State (Heap address Latest (Value address (UtilEff address)))
+                       , State (Heap Precise Latest (Value Precise UtilEff))
                        , Lift IO
                        ] a
   }
@@ -126,7 +124,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
   package <- fmap quieterm <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
   modules <- topologicalSort <$> runImportGraphToModules proxy package
   trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
-  pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise))
+  pure (runTermEvaluator @_ @_ @(Value Precise UtilEff)
        (runReader (packageInfo package)
        (runReader (lowerBound @Span)
        (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
@@ -159,34 +157,5 @@ reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc
 reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right
 
 
-newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) }
-  deriving (Declarations, FreeVariables)
-
-type instance Base (Quieterm syntax ann) = TermF syntax ann
-instance Functor syntax => Recursive   (Quieterm syntax ann) where project = unQuieterm
-instance Functor syntax => Corecursive (Quieterm syntax ann) where embed   =   Quieterm
-
-instance Eq1 syntax => Eq1 (Quieterm syntax) where
-  liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unQuieterm t1) (unQuieterm t2)
-
-instance (Eq1 syntax, Eq ann) => Eq (Quieterm syntax ann) where
-  (==) = eq1
-
-instance Ord1 syntax => Ord1 (Quieterm syntax) where
-  liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unQuieterm t1) (unQuieterm t2)
-
-instance (Ord1 syntax, Ord ann) => Ord (Quieterm syntax ann) where
-  compare = compare1
-
-instance Show1 syntax => Show1 (Quieterm syntax) where
-  liftShowsPrec _ _ = go where go d = liftShowsPrec go (showListWith (go 0)) d . termFOut . unQuieterm
-
-instance Show1 syntax => Show (Quieterm syntax ann) where
-  showsPrec = liftShowsPrec (const (const id)) (const id)
-
-quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann
-quieterm = cata Quieterm
-
-
 prettyShow :: Show a => a -> IO ()
 prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow

test/SpecHelpers.hs

@@ -96,7 +96,7 @@ readFilePair :: Both FilePath -> IO BlobPair
 readFilePair paths = let paths' = fmap file paths in
                      runBothWith IO.readFilePair paths'
 
-type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
+type TestEvaluatingEffects = '[ Resumable (ValueError Precise UtilEff)
                               , Resumable (AddressError Precise Val)
                               , Resumable ResolutionError
                               , Resumable EvalError
@@ -108,7 +108,7 @@ type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
                               , State (Heap Precise Latest Val)
                               , Lift IO
                               ]
-type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise)
+type TestEvaluatingErrors = '[ ValueError Precise UtilEff
                              , AddressError Precise Val
                              , ResolutionError
                              , EvalError
@@ -137,9 +137,9 @@ testEvaluating
   . runEvalError
   . runResolutionError
   . runAddressError
-  . runValueError @_ @Precise @(UtilEff Precise)
+  . runValueError @_ @Precise @UtilEff
 
-type Val = Value Precise (UtilEff Precise)
+type Val = Value Precise UtilEff
 
 
 deNamespace :: Heap Precise (Cell Precise) (Value Precise term)