Python support using Core

.travis.yml

@@ -37,6 +37,7 @@ script:
 - cabal new-build
 - cabal new-run semantic:test
 - cabal new-run semantic-core:spec
+- cabal new-run semantic-core:doctest
 # parse-examples is disabled because it slaughters our CI
 # - cabal new-run semantic:parse-examples
 

cabal.project

@@ -1,4 +1,4 @@
-packages: . semantic-core
+packages: . semantic-core semantic-python
 
 jobs: $ncpus
 

semantic-core/semantic-core.cabal

@@ -3,16 +3,17 @@ cabal-version:       2.4
 name:                semantic-core
 version:             0.0.0.0
 synopsis:            Semantic core intermediate language
--- description:
-homepage:            https://github.com/github/semantic-core
--- bug-reports:
+description:         Core intermediate language for program analysis using abstract definitional interpretation.
+homepage:            https://github.com/github/semantic/tree/master/semantic-core#readme
+bug-reports:         https://github.com/github/semantic/issues
 license:             MIT
 license-file:        LICENSE
-author:              Rob Rix
-maintainer:          robrix@github.com
--- copyright:
+author:              The Semantic authors
+maintainer:          opensource+semantic@github.com
+copyright:           (c) 2019 GitHub, Inc.
 category:            Language
 build-type:          Simple
+stability:           alpha
 extra-source-files:  README.md
 
 tested-with:         GHC == 8.6.4
@@ -46,14 +47,24 @@ library
                      , prettyprinter-ansi-terminal ^>= 1.1.1
                      , recursion-schemes           ^>= 5.1
                      , semigroupoids               ^>= 5.3
+                     , text                        ^>= 1.2.3.1
                      , transformers                ^>= 0.5.6
                      , trifecta                    ^>= 2
                      , unordered-containers        ^>= 0.2.10
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:         -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations
-  if (impl(ghc >= 8.6))
-    ghc-options:       -Wno-star-is-type
+  ghc-options:
+    -Weverything
+    -Wno-missing-local-signatures
+    -Wno-missing-import-lists
+    -Wno-implicit-prelude
+    -Wno-safe
+    -Wno-unsafe
+    -Wno-name-shadowing
+    -Wno-monomorphism-restriction
+    -Wno-missed-specialisations
+    -Wno-all-missed-specialisations
+    -Wno-star-is-type
 
 test-suite doctest
   type:                exitcode-stdio-1.0

semantic-core/src/Analysis/Concrete.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, RecordWildCards, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
 module Analysis.Concrete
 ( Concrete(..)
 , concrete
@@ -29,6 +29,7 @@ import           Data.Loc
 import qualified Data.Map as Map
 import           Data.Monoid (Alt(..))
 import           Data.Name
+import           Data.Text (Text, pack)
 import           Prelude hiding (fail)
 
 type Precise = Int
@@ -41,7 +42,7 @@ data Concrete
   = Closure Loc Name Core.Core Precise
   | Unit
   | Bool Bool
-  | String String
+  | String Text
   | Obj Frame
   deriving (Eq, Ord, Show)
 
@@ -60,7 +61,7 @@ type Heap = IntMap.IntMap Concrete
 
 -- | Concrete evaluation of a term to a value.
 --
---   >>> snd (concrete [File (Loc "bool" emptySpan) (Core.Bool True)])
+--   >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.Bool True)]))
 --   [Right (Bool True)]
 concrete :: [File Core.Core] -> (Heap, [File (Either (Loc, String) Concrete)])
 concrete
@@ -184,28 +185,32 @@ heapValueGraph h = heapGraph (const id) (const fromAddr) h
 heapAddressGraph :: Heap -> G.Graph (EdgeType, Precise)
 heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,) . either Edge Slot)
 
-addressStyle :: Heap -> G.Style (EdgeType, Precise) String
+addressStyle :: Heap -> G.Style (EdgeType, Precise) Text
 addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
-  where vertex (_, addr) = maybe (show addr <> " = ?") (((show addr <> " = ") <>) . fromConcrete) (IntMap.lookup addr heap)
+  where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
         edgeAttributes _ (Slot name,         _) = ["label" G.:= fromName name]
         edgeAttributes _ (Edge Core.Import,  _) = ["color" G.:= "blue"]
         edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"]
         edgeAttributes _ _                      = []
         fromConcrete = \case
           Unit ->  "()"
-          Bool b -> show b
-          String s -> show s
+          Bool b -> pack $ show b
+          String s -> pack $ show s
           Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
           Obj _ -> "{}"
-        showPos (Pos l c) = show l <> ":" <> show c
+        showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
         fromName (User s)  = s
         fromName (Gen sym) = fromGensym sym
-        fromName (Path p)  = show p
+        fromName (Path p)  = pack $ show p
         fromGensym (Root s) = s
-        fromGensym (ss :/ (s, i)) = fromGensym ss <> "." <> s <> show i
+        fromGensym (ss :/ (s, i)) = fromGensym ss <> "." <> s <> pack (show i)
 
 data EdgeType
   = Edge Core.Edge
   | Slot Name
   | Value Concrete
   deriving (Eq, Ord, Show)
+
+
+-- $setup
+-- >>> :seti -XOverloadedStrings

semantic-core/src/Analysis/Eval.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, LambdaCase, RankNTypes, RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, RankNTypes, RecordWildCards #-}
 module Analysis.Eval
 ( eval
 , prog1
@@ -21,6 +21,7 @@ import Data.Functor
 import Data.Loc
 import Data.Maybe (fromJust)
 import Data.Name
+import Data.Text (Text)
 import GHC.Stack
 import Prelude hiding (fail)
 
@@ -207,8 +208,8 @@ data Analysis address value m = Analysis
   , unit        :: m value
   , bool        :: Bool -> m value
   , asBool      :: value -> m Bool
-  , string      :: String -> m value -- FIXME: Text
-  , asString    :: value -> m String
+  , string      :: Text -> m value
+  , asString    :: value -> m Text
   , frame       :: m value
   , edge        :: Edge -> address -> m ()
   , (...)       :: forall a . address -> m a -> m a

semantic-core/src/Analysis/FlowInsensitive.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-}
 module Analysis.FlowInsensitive
 ( Heap
 , FrameId(..)

semantic-core/src/Analysis/ImportGraph.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}
 module Analysis.ImportGraph
 ( ImportGraph
 , importGraph
@@ -22,9 +22,10 @@ import           Data.Loc
 import qualified Data.Map as Map
 import           Data.Name
 import qualified Data.Set as Set
+import           Data.Text (Text)
 import           Prelude hiding (fail)
 
-type ImportGraph = Map.Map FilePath (Set.Set FilePath)
+type ImportGraph = Map.Map Text (Set.Set Text)
 
 data Value = Value
   { valueSemi  :: Semi
@@ -41,7 +42,7 @@ instance Monoid Value where
 data Semi
   = Closure Loc Name Core.Core Name
   -- FIXME: Bound String values.
-  | String String
+  | String Text
   | Abstract
   deriving (Eq, Ord, Show)
 
@@ -98,7 +99,7 @@ importGraphAnalysis = Analysis{..}
         asBool _ = pure True <|> pure False
         string s = pure (Value (String s) mempty)
         asString (Value (String s) _) = pure s
-        asString _ = pure ""
+        asString _ = pure mempty
         frame = pure mempty
         edge Core.Import (Path to) = do
           Loc{locPath=from} <- ask

semantic-core/src/Analysis/Typecheck.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, LambdaCase, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
 module Analysis.Typecheck
 ( Monotype (..)
 , Meta
@@ -160,7 +160,7 @@ typecheckingAnalysis = Analysis{..}
         bool _ = pure MBool
         asBool b = unify MBool b >> pure True <|> pure False
         string _ = pure MString
-        asString s = unify MString s $> ""
+        asString s = unify MString s $> mempty
         frame = fail "unimplemented"
         edge _ _ = pure ()
         _ ... m = m

semantic-core/src/Data/Core.hs

@@ -20,6 +20,7 @@ import           Data.Foldable (foldl')
 import           Data.Loc
 import           Data.Name
 import           Data.Stack
+import           Data.Text (Text)
 import           GHC.Stack
 
 data Edge = Lexical | Import
@@ -36,7 +37,7 @@ data Core
   | Unit
   | Bool Bool
   | If Core Core Core
-  | String String -- FIXME: Text
+  | String Text
   -- | Load the specified file (by path).
   | Load Core
   | Edge Edge Core

semantic-core/src/Data/Core/Parser.hs

@@ -14,6 +14,7 @@ import           Data.Core
 import           Data.Name
 import           Data.Semigroup
 import           Data.String
+import           Data.Text (pack)
 import qualified Text.Parser.Token as Token
 import qualified Text.Parser.Token.Highlight as Highlight
 import           Text.Trifecta hiding (ident)
@@ -94,7 +95,7 @@ lvalue = choice
 name :: (TokenParsing m, Monad m) => m Name
 name = choice [regular, strpath] <?> "name" where
   regular = User <$> identifier
-  strpath = Path <$> between (symbolic '"') (symbolic '"') (some $ noneOf "\"")
+  strpath = Path . pack <$> between (symbolic '"') (symbolic '"') (some $ noneOf "\"")
 
 lit :: (TokenParsing m, Monad m) => m Core
 lit = let x `given` n = x <$ reserved n in choice
@@ -112,4 +113,3 @@ lambda = Lam <$ lambduh <*> name <* arrow <*> core <?> "lambda" where
 
 ident :: (Monad m, TokenParsing m) => m Core
 ident = Var <$> name <?> "identifier"
-

semantic-core/src/Data/Loc.hs

@@ -16,12 +16,13 @@ import Control.Effect.Error
 import Control.Effect.Fail
 import Control.Effect.Reader
 import Control.Effect.Sum
+import Data.Text (Text, pack)
 import Data.Text.Prettyprint.Doc (Pretty (..))
 import GHC.Stack
 import Prelude hiding (fail)
 
 data Loc = Loc
-  { locPath :: !FilePath
+  { locPath :: !Text
   , locSpan :: {-# UNPACK #-} !Span
   }
   deriving (Eq, Ord, Show)
@@ -58,7 +59,7 @@ stackLoc cs = case getCallStack cs of
   _             -> Nothing
 
 fromGHCSrcLoc :: SrcLoc -> Loc
-fromGHCSrcLoc SrcLoc{..} = Loc srcLocFile (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
+fromGHCSrcLoc SrcLoc{..} = Loc (pack srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))
 
 
 runFailWithLoc :: FailWithLocC m a -> m (Either (Loc, String) a)

semantic-core/src/Data/Name.hs

@@ -26,11 +26,12 @@ import           Control.Monad.IO.Class
 import qualified Data.Char as Char
 import           Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
+import           Data.Text as Text (Text, any, unpack)
 import           Data.Text.Prettyprint.Doc (Pretty (..))
 import qualified Data.Text.Prettyprint.Doc as Pretty
 
 -- | User-specified and -relevant names.
-type User = String
+type User = Text
 
 -- | The type of namespaced actions, i.e. actions occurring within some outer name.
 --
@@ -47,7 +48,7 @@ data Name
   --   This should be used for names which the user provided and which other code (other functions, other modules, other packages) could call, e.g. declaration names.
   | User User
   -- | A variable name represented as the path to a source file. Used for loading modules at a specific name.
-  | Path FilePath
+  | Path Text
   deriving (Eq, Ord, Show)
 
 instance Pretty Name where
@@ -56,14 +57,14 @@ instance Pretty Name where
     User n -> pretty n
     Path p -> pretty (show p)
 
-reservedNames :: HashSet User
+reservedNames :: HashSet String
 reservedNames = [ "#true", "#false", "let", "#frame", "if", "then", "else"
                 , "lexical", "import", "#unit", "load"]
 
 -- | Returns true if any character would require quotation or if the
 -- name conflicts with a Core primitive.
 needsQuotation :: User -> Bool
-needsQuotation u = HashSet.member u reservedNames || any (not . isSimpleCharacter) u
+needsQuotation u = HashSet.member (unpack u) reservedNames || Text.any (not . isSimpleCharacter) u
 
 -- | A ‘simple’ character is, loosely defined, a character that is compatible
 -- with identifiers in most ASCII-oriented programming languages. This is defined
@@ -76,30 +77,30 @@ isSimpleCharacter = \case
   c    -> Char.isAlphaNum c
 
 data Gensym
-  = Root String
-  | Gensym :/ (String, Int)
+  = Root Text
+  | Gensym :/ (Text, Int)
   deriving (Eq, Ord, Show)
 
 instance Pretty Gensym where
   pretty = \case
     Root s      -> pretty s
     p :/ (n, x) -> Pretty.hcat [pretty p, "/", pretty n, "^", pretty x]
 
-(//) :: Gensym -> String -> Gensym
+(//) :: Gensym -> Text -> Gensym
 root // s = root :/ (s, 0)
 
 infixl 6 //
 
-gensym :: (Carrier sig m, Member Naming sig) => String -> m Gensym
+gensym :: (Carrier sig m, Member Naming sig) => Text -> m Gensym
 gensym s = send (Gensym s pure)
 
-namespace :: (Carrier sig m, Member Naming sig) => String -> m a -> m a
+namespace :: (Carrier sig m, Member Naming sig) => Text -> m a -> m a
 namespace s m = send (Namespace s m pure)
 
 
 data Naming m k
-  = Gensym String (Gensym -> k)
-  | forall a . Namespace String (m a) (a -> k)
+  = Gensym Text (Gensym -> k)
+  | forall a . Namespace Text (m a) (a -> k)
 
 deriving instance Functor (Naming m)
 

semantic-core/test/Doctest.hs

@@ -9,4 +9,4 @@ main :: IO ()
 main = do
   args <- getArgs
   autogen <- fmap (<> "/build/doctest/autogen") <$> lookupEnv "HASKELL_DIST_DIR"
-  doctest (maybe id ((:) . ("-i" <>)) autogen ("-isrc" : "--fast" : if null args then ["src"] else args))
+  doctest (maybe id ((:) . ("-i" <>)) autogen ("-isemantic-code/src" : "--fast" : if null args then ["semantic-core/src"] else args))

semantic-core/test/Generators.hs

@@ -24,7 +24,7 @@ import Data.Name
 -- interesting property as they parse regardless.
 name :: MonadGen m => m Name
 name = Gen.prune (User <$> names) where
-  names = Gen.string (Range.linear 1 10) Gen.lower
+  names = Gen.text (Range.linear 1 10) Gen.lower
 
 boolean :: MonadGen m => m Core
 boolean = Bool <$> Gen.bool

semantic-core/test/Spec.hs

@@ -25,7 +25,7 @@ true, false :: Core
 true  = Bool True
 false = Bool False
 
-instance IsString Name where fromString = User
+instance IsString Name where fromString = User . fromString
 
 parseEither :: Trifecta.Parser a -> String -> Either String a
 parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Trifecta.parseString (p <* Trifecta.eof) mempty