From e8ac13f09893b291c3b930f2a06582c5bb04ccd0 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Mon, 3 Jun 2019 16:09:47 -0400
Subject: [PATCH 1/8] Institute parser for Core.

I tried to pull the history from this patch over but I was not able to
figure out how to resolve conflicts from `git am`.
---
 semantic-core/semantic-core.cabal     |  24 +++---
 semantic-core/src/Data/Core/Parser.hs | 118 ++++++++++++++++++++++++++
 semantic-core/src/Data/Name.hs        |  20 ++++-
 3 files changed, 151 insertions(+), 11 deletions(-)
 create mode 100644 semantic-core/src/Data/Core/Parser.hs

diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal
index 5427b62511..a8955c373c 100644
--- a/semantic-core/semantic-core.cabal
+++ b/semantic-core/semantic-core.cabal
@@ -26,22 +26,26 @@ library
                      , Analysis.Typecheck
                      , Control.Effect.Readline
                      , Data.Core
+                     , Data.Core.Parser
                      , Data.File
                      , Data.Loc
                      , Data.Name
                      , Data.Stack
   -- other-modules:
   -- other-extensions:
-  build-depends:       algebraic-graphs ^>= 0.3
-                     , base             >= 4.11 && < 5
-                     , containers       ^>= 0.6
-                     , directory        ^>= 1.3
-                     , filepath         ^>= 1.4
-                     , fused-effects    ^>= 0.4
-                     , haskeline        ^>= 0.7.5
-                     , prettyprinter    ^>= 1.2.1
-                     , semigroupoids    ^>= 5.3
-                     , transformers     ^>= 0.5.6
+  build-depends:       algebraic-graphs     ^>= 0.3
+                     , base                 >= 4.11 && < 5
+                     , containers           ^>= 0.6
+                     , directory            ^>= 1.3
+                     , filepath             ^>= 1.4
+                     , fused-effects        ^>= 0.4
+                     , haskeline            ^>= 0.7.5
+                     , parsers              ^>= 0.12.10
+                     , prettyprinter        ^>= 1.2.1
+                     , semigroupoids        ^>= 5.3
+                     , 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
diff --git a/semantic-core/src/Data/Core/Parser.hs b/semantic-core/src/Data/Core/Parser.hs
new file mode 100644
index 0000000000..a00342766d
--- /dev/null
+++ b/semantic-core/src/Data/Core/Parser.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE ExplicitForAll, FlexibleInstances, LambdaCase, MultiParamTypeClasses, OverloadedLists,
+             ScopedTypeVariables #-}
+
+module Data.Core.Parser
+  ( module Text.Trifecta
+  , core
+  , lit
+  , expr
+  , lvalue
+  ) where
+
+-- Consult @doc/grammar.md@ for an EBNF grammar.
+
+import           Control.Applicative
+import qualified Data.Char as Char
+import           Data.Core
+import           Data.Name
+import           Data.Semigroup
+import           Data.String
+import qualified Text.Parser.Token as Token
+import qualified Text.Parser.Token.Highlight as Highlight
+import           Text.Trifecta hiding (ident)
+
+-- * Identifier styles and derived parsers
+
+validIdentifierStart :: Char -> Bool
+validIdentifierStart c = not (Char.isDigit c) && isSimpleCharacter c
+
+coreIdents :: TokenParsing m => IdentifierStyle m
+coreIdents = Token.IdentifierStyle
+  { _styleName              = "core"
+  , _styleStart             = satisfy validIdentifierStart
+  , _styleLetter            = satisfy isSimpleCharacter
+  , _styleReserved          = reservedNames
+  , _styleHighlight         = Highlight.Identifier
+  , _styleReservedHighlight = Highlight.ReservedIdentifier
+  }
+
+reserved :: (TokenParsing m, Monad m) => String -> m ()
+reserved = Token.reserve coreIdents
+
+identifier :: (TokenParsing m, Monad m, IsString s) => m s
+identifier = choice [quote, plain] <?> "identifier" where
+  plain = Token.ident coreIdents
+  quote = between (string "#{") (symbol "}") (fromString <$> some (noneOf "{}"))
+
+-- * Parsers (corresponding to EBNF)
+
+core :: (TokenParsing m, Monad m) => m Core
+core = expr
+
+expr :: (TokenParsing m, Monad m) => m Core
+expr = chainl1 atom go where
+  go = choice [ (:.) <$ dot
+              , (:$) <$ notFollowedBy dot
+              ]
+
+atom :: (TokenParsing m, Monad m) => m Core
+atom = choice
+  [ comp
+  , ifthenelse
+  , edge
+  , lit
+  , ident
+  , assign
+  , parens expr
+  ]
+
+comp :: (TokenParsing m, Monad m) => m Core
+comp = braces (sconcat <$> sepEndByNonEmpty expr semi)
+
+ifthenelse :: (TokenParsing m, Monad m) => m Core
+ifthenelse = If
+  <$ reserved "if"   <*> core
+  <* reserved "then" <*> core
+  <* reserved "else" <*> core
+  <?> "if-then-else statement"
+
+assign :: (TokenParsing m, Monad m) => m Core
+assign = (:=) <$> try (lvalue <* symbolic '=') <*> core
+
+edge :: (TokenParsing m, Monad m) => m Core
+edge = kw <*> expr where kw = choice [ Edge Lexical <$ reserved "lexical"
+                                     , Edge Import  <$ reserved "import"
+                                     , Load         <$ reserved "load"
+                                     ]
+
+lvalue :: (TokenParsing m, Monad m) => m Core
+lvalue = choice
+  [ Let <$ reserved "let" <*> name
+  , ident
+  , parens expr
+  ]
+
+-- * Literals
+
+name :: (TokenParsing m, Monad m) => m Name
+name = choice [regular, strpath] <?> "name" where
+  regular = User <$> identifier
+  strpath = Path <$> between (symbolic '"') (symbolic '"') (some $ noneOf "\"")
+
+lit :: (TokenParsing m, Monad m) => m Core
+lit = let x `given` n = x <$ reserved n in choice
+  [ Bool True  `given` "#true"
+  , Bool False `given` "#false"
+  , Unit       `given` "#unit"
+  , Frame      `given` "#frame"
+  , lambda
+  ] <?> "literal"
+
+lambda :: (TokenParsing m, Monad m) => m Core
+lambda = Lam <$ lambduh <*> name <* arrow <*> core <?> "lambda" where
+  lambduh = symbolic 'λ' <|> symbolic '\\'
+  arrow   = symbol "→"   <|> symbol "->"
+
+ident :: (Monad m, TokenParsing m) => m Core
+ident = Var <$> name <?> "identifier"
+
diff --git a/semantic-core/src/Data/Name.hs b/semantic-core/src/Data/Name.hs
index 9ae8cf17d1..0fc4ee02c3 100644
--- a/semantic-core/src/Data/Name.hs
+++ b/semantic-core/src/Data/Name.hs
@@ -1,8 +1,10 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, OverloadedStrings, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, OverloadedLists, OverloadedStrings,StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Data.Name
 ( User
 , Namespaced
 , Name(..)
+, reservedNames
+, isSimpleCharacter
 , Gensym(..)
 , (//)
 , gensym
@@ -20,6 +22,8 @@ import           Control.Effect.State
 import           Control.Effect.Sum
 import           Control.Monad.Fail
 import           Control.Monad.IO.Class
+import qualified Data.Char as Char
+import           Data.HashSet (HashSet)
 import           Data.Text.Prettyprint.Doc (Pretty (..))
 import qualified Data.Text.Prettyprint.Doc as Pretty
 
@@ -50,6 +54,20 @@ instance Pretty Name where
     User n -> pretty n
     Path p -> pretty (show p)
 
+reservedNames :: HashSet User
+reservedNames = [ "#true", "#false", "let", "#frame", "if", "then", "else"
+                , "lexical", "import", "#unit", "load"]
+
+-- | A ‘simple’ character is, loosely defined, a character that is compatible
+-- with identifiers in most ASCII-oriented programming languages. This is defined
+-- as the alphanumeric set plus @$@ and @_@.
+isSimpleCharacter :: Char -> Bool
+isSimpleCharacter = \case
+  '$'  -> True -- common in JS
+  '_'  -> True
+  '?'  -> True -- common in Ruby
+  c    -> Char.isAlphaNum c
+
 data Gensym
   = Root String
   | Gensym :/ (String, Int)

From 2b446df2259d55f0b36fdedd28b52f2c9bb9e2e1 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 10:54:39 -0400
Subject: [PATCH 2/8] Add pretty-printer.

---
 semantic-core/semantic-core.cabal     |  29 +++---
 semantic-core/src/Data/Core.hs        |  64 ++++---------
 semantic-core/src/Data/Core/Pretty.hs | 130 ++++++++++++++++++++++++++
 semantic-core/src/Data/Name.hs        |   7 ++
 4 files changed, 171 insertions(+), 59 deletions(-)
 create mode 100644 semantic-core/src/Data/Core/Pretty.hs

diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal
index a8955c373c..48c855ae66 100644
--- a/semantic-core/semantic-core.cabal
+++ b/semantic-core/semantic-core.cabal
@@ -27,25 +27,28 @@ library
                      , Control.Effect.Readline
                      , Data.Core
                      , Data.Core.Parser
+                     , Data.Core.Pretty
                      , Data.File
                      , Data.Loc
                      , Data.Name
                      , Data.Stack
   -- other-modules:
   -- other-extensions:
-  build-depends:       algebraic-graphs     ^>= 0.3
-                     , base                 >= 4.11 && < 5
-                     , containers           ^>= 0.6
-                     , directory            ^>= 1.3
-                     , filepath             ^>= 1.4
-                     , fused-effects        ^>= 0.4
-                     , haskeline            ^>= 0.7.5
-                     , parsers              ^>= 0.12.10
-                     , prettyprinter        ^>= 1.2.1
-                     , semigroupoids        ^>= 5.3
-                     , transformers         ^>= 0.5.6
-                     , trifecta             ^>= 2
-                     , unordered-containers ^>= 0.2.10
+  build-depends:       algebraic-graphs            ^>= 0.3
+                     , base                         >= 4.11 && < 5
+                     , containers                  ^>= 0.6
+                     , directory                   ^>= 1.3
+                     , filepath                    ^>= 1.4
+                     , fused-effects               ^>= 0.4
+                     , haskeline                   ^>= 0.7.5
+                     , parsers                     ^>= 0.12.10
+                     , prettyprinter               ^>= 1.2.1
+                     , prettyprinter-ansi-terminal ^>= 1.1.1
+                     , recursion-schemes           ^>= 5.1
+                     , semigroupoids               ^>= 5.3
+                     , 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
diff --git a/semantic-core/src/Data/Core.hs b/semantic-core/src/Data/Core.hs
index 952f11ed90..6cb92dcd9f 100644
--- a/semantic-core/src/Data/Core.hs
+++ b/semantic-core/src/Data/Core.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE DeriveTraversable, FlexibleContexts, LambdaCase, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies #-}
 module Data.Core
 ( Core(..)
+, CoreF(..)
 , Edge(..)
-, showCore
 , lams
 , ($$*)
 , unapply
@@ -10,18 +10,21 @@ module Data.Core
 , block
 , ann
 , annWith
+, stripAnnotations
 ) where
 
 import           Control.Applicative (Alternative (..))
+import           Data.Functor.Foldable hiding (ListF(..))
+import           Data.Functor.Foldable.TH
 import           Data.Foldable (foldl')
 import           Data.Loc
 import           Data.Name
 import           Data.Stack
-import           Data.Text.Prettyprint.Doc (Pretty (..), (<+>), vsep)
-import qualified Data.Text.Prettyprint.Doc as Pretty
-import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
 import           GHC.Stack
 
+data Edge = Lexical | Import
+  deriving (Eq, Ord, Show)
+
 data Core
   = Var Name
   | Let Name
@@ -50,52 +53,16 @@ infixr 1 :>>
 infix  3 :=
 infixl 4 :.
 
-data Edge = Lexical | Import
-  deriving (Eq, Ord, Show)
+makeBaseFunctor ''Core
 
-instance Pretty Edge where
-  pretty = pretty . show
+infixl 2 :$$
+infixr 1 :>>$
+infix  3 :=$
+infixl 4 :.$
 
 instance Semigroup Core where
   (<>) = (:>>)
 
-softsemi :: Pretty.Doc a
-softsemi = Pretty.flatAlt mempty ";"
-
-showCore :: Core -> String
-showCore = Pretty.renderString . Pretty.layoutPretty Pretty.defaultLayoutOptions . pretty
-
-instance Pretty Core where
-  pretty = \case
-    Var a    -> pretty a
-    Let a    -> "let" <+> pretty a
-    a :>>  b -> vsep [pretty a <> softsemi, pretty b]
-
-    Lam x f  -> vsep [ Pretty.nest 2 $ vsep [ "λ" <> pretty x <+> "-> {"
-                                            , pretty f
-                                            ]
-                     , "}"
-                     ]
-
-    f :$ x   -> pretty f <> "." <> pretty x
-    Unit     -> Pretty.parens mempty
-    Bool b   -> pretty b
-    If c x y -> Pretty.sep [ "if" <+> pretty c
-                           , "then" <+> pretty x
-                           , "else" <+> pretty y
-                           ]
-
-    String s -> pretty (show s)
-
-    Frame    -> Pretty.braces mempty
-
-    Load p   -> "load" <+> pretty p
-    Edge e n -> pretty e <+> pretty n
-    a :. b   -> "push" <+> Pretty.parens (pretty a) <+> Pretty.brackets (pretty b)
-    var := x -> pretty var <+> "=" <+> pretty x
-    Ann (Loc p s) c  -> pretty c <> Pretty.brackets (pretty p <> ":" <> pretty s)
-
-
 lams :: Foldable t => t Name -> Core -> Core
 lams names body = foldr Lam body names
 
@@ -124,3 +91,8 @@ ann = annWith callStack
 
 annWith :: CallStack -> Core -> Core
 annWith callStack c = maybe c (flip Ann c) (stackLoc callStack)
+
+stripAnnotations :: Core -> Core
+stripAnnotations = cata go where
+  go (AnnF _ item) = item
+  go item          = embed item
diff --git a/semantic-core/src/Data/Core/Pretty.hs b/semantic-core/src/Data/Core/Pretty.hs
new file mode 100644
index 0000000000..710a83199b
--- /dev/null
+++ b/semantic-core/src/Data/Core/Pretty.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TypeApplications #-}
+
+module Data.Core.Pretty
+  ( showCore
+  , printCore
+  , showFile
+  , printFile
+  , prettyCore
+  ) where
+
+import           Control.Effect
+import           Control.Effect.Reader
+import           Data.Core
+import           Data.File
+import           Data.Functor.Foldable
+import           Data.Name
+import           Data.Text.Prettyprint.Doc (Pretty (..), annotate, softline, (<+>))
+import qualified Data.Text.Prettyprint.Doc as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
+
+showCore :: Core -> String
+showCore = Pretty.renderString . Pretty.layoutSmart Pretty.defaultLayoutOptions . Pretty.unAnnotate . prettyCore Ascii
+
+printCore :: Core -> IO ()
+printCore p = Pretty.putDoc (prettyCore Unicode p) *> putStrLn ""
+
+showFile :: File Core -> String
+showFile = showCore . fileBody
+
+printFile :: File Core -> IO ()
+printFile = printCore . fileBody
+
+type AnsiDoc = Pretty.Doc Pretty.AnsiStyle
+
+keyword, symbol, strlit, primitive :: AnsiDoc -> AnsiDoc
+keyword = annotate (Pretty.colorDull Pretty.Cyan)
+symbol  = annotate (Pretty.color Pretty.Yellow)
+strlit  = annotate (Pretty.colorDull Pretty.Green)
+primitive = keyword . mappend "#"
+
+type Prec    = Int
+
+data Style = Unicode | Ascii
+
+lambda, arrow :: (Member (Reader Style) sig, Carrier sig m) => m AnsiDoc
+lambda = ask @Style >>= \case
+  Unicode -> pure $ symbol "λ"
+  Ascii   -> pure $ symbol "\\"
+arrow = ask @Style >>= \case
+  Unicode -> pure $ symbol "→"
+  Ascii   -> pure $ symbol "->"
+
+name :: Name -> AnsiDoc
+name = \case
+  Gen p  -> pretty p
+  Path p -> strlit (Pretty.viaShow p  )
+  User n -> encloseIf (needsQuotation n) (symbol "#{") (symbol "}") (pretty n)
+
+with :: (Member (Reader Prec) sig, Carrier sig m) => Prec -> m a -> m a
+with n = local (const n)
+
+inParens :: (Member (Reader Prec) sig, Carrier sig m) => Prec -> m AnsiDoc -> m AnsiDoc
+inParens amount go = do
+  prec <- ask
+  body <- with amount go
+  pure (encloseIf (amount >= prec) (symbol "(") (symbol ")") body)
+
+encloseIf :: Monoid m => Bool -> m -> m -> m -> m
+encloseIf True  l r x = l <> x <> r
+encloseIf False _ _ x = x
+
+prettify :: (Member (Reader Prec) sig, Member (Reader Style) sig, Carrier sig m)
+         => CoreF (m AnsiDoc)
+         -> m AnsiDoc
+prettify = \case
+  VarF a -> pure $ name a
+  LetF a -> pure $ keyword "let" <+> name a
+  a :>>$ b -> do
+    prec <- ask @Prec
+    fore <- with 12 a
+    aft  <- with 12 b
+
+    let open  = symbol (if 12 > prec then "{" <> softline else "")
+        close = symbol (if 12 > prec then softline <> "}" else "")
+        separator = ";" <> Pretty.line
+        body = fore <> separator <> aft
+
+    pure . Pretty.align $ open <> Pretty.align body <> close
+
+  LamF x f  -> inParens 11 $ do
+    body <- f
+    lam  <- lambda
+    arr  <- arrow
+    pure (lam <> name x <+> arr <+> body)
+
+  FrameF    -> pure $ primitive "frame"
+  UnitF     -> pure $ primitive "unit"
+  BoolF b   -> pure $ primitive (if b then "true" else "false")
+  StringF s -> pure . strlit $ Pretty.viaShow s
+
+  f :$$ x -> inParens 11 $ (<+>) <$> f <*> x
+
+  IfF con tru fal -> do
+    con' <- "if"   `appending` con
+    tru' <- "then" `appending` tru
+    fal' <- "else" `appending` fal
+    pure $ Pretty.sep [con', tru', fal']
+
+  LoadF p   -> "load" `appending` p
+  EdgeF Lexical n -> "lexical" `appending` n
+  EdgeF Import n -> "import" `appending` n
+  item :.$ body   -> inParens 5 $ do
+    f <- item
+    g <- body
+    pure (f <> symbol "." <> g)
+
+  lhs :=$ rhs -> inParens 4 $ do
+    f <- lhs
+    g <- rhs
+    pure (f <+> symbol "=" <+> g)
+
+  -- Annotations are not pretty-printed, as it lowers the signal/noise ratio too profoundly.
+  AnnF _ c -> c
+
+appending :: Functor f => AnsiDoc -> f AnsiDoc -> f AnsiDoc
+appending k item = (keyword k <+>) <$> item
+
+prettyCore :: Style -> Core -> AnsiDoc
+prettyCore s = run . runReader @Prec 0 . runReader s . cata prettify
diff --git a/semantic-core/src/Data/Name.hs b/semantic-core/src/Data/Name.hs
index 0fc4ee02c3..ccffcb30c9 100644
--- a/semantic-core/src/Data/Name.hs
+++ b/semantic-core/src/Data/Name.hs
@@ -5,6 +5,7 @@ module Data.Name
 , Name(..)
 , reservedNames
 , isSimpleCharacter
+, needsQuotation
 , Gensym(..)
 , (//)
 , gensym
@@ -24,6 +25,7 @@ import           Control.Monad.Fail
 import           Control.Monad.IO.Class
 import qualified Data.Char as Char
 import           Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
 import           Data.Text.Prettyprint.Doc (Pretty (..))
 import qualified Data.Text.Prettyprint.Doc as Pretty
 
@@ -58,6 +60,11 @@ reservedNames :: HashSet User
 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
+
 -- | A ‘simple’ character is, loosely defined, a character that is compatible
 -- with identifiers in most ASCII-oriented programming languages. This is defined
 -- as the alphanumeric set plus @$@ and @_@.

From 132c30a47507b193b7192afc20d4e2fb9d4ef52b Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 10:55:37 -0400
Subject: [PATCH 3/8] Add EBNF grammar.

---
 docs/core-grammar.md | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)
 create mode 100644 docs/core-grammar.md

diff --git a/docs/core-grammar.md b/docs/core-grammar.md
new file mode 100644
index 0000000000..a961fd0264
--- /dev/null
+++ b/docs/core-grammar.md
@@ -0,0 +1,30 @@
+# Semantic Core grammar
+
+This is an EBNF grammar for the (experimental) core IR language.
+
+```
+	expr ::= expr '.' expr
+	       | expr ' '+ expr
+	       | '{' expr (';' expr)* ';'? '}'
+	       | 'if' expr 'then' expr 'else' expr
+	       | ('lexical' | 'import' | 'load') expr
+	       | lit
+	       | 'let'? lvalue '=' expr
+	       | '(' expr ')'
+
+	lvalue ::= ident
+	         | parens expr
+
+	lit ::= '#true'
+	      | '#false'
+	      | 'unit'
+	      | 'frame'
+	      | lambda
+	      | ident
+
+	lambda ::= ('λ' | '\') ident ('->' | '→') expr
+
+	ident ::= [A-z_] ([A-z0-9_])*
+	        | '#{' [^{}]+ '}'
+	        | '"' [^"]+ '"'
+	```

From 11a5217f45079af2ce5834a82690e76660ff779d Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 11:26:42 -0400
Subject: [PATCH 4/8] Enable tests.

---
 semantic-core/semantic-core.cabal  |  14 ++++
 semantic-core/src/Analysis/Eval.hs |   2 +-
 semantic-core/test/Generators.hs   |  56 +++++++++++++
 semantic-core/test/Spec.hs         | 127 +++++++++++++++++++++++++++++
 4 files changed, 198 insertions(+), 1 deletion(-)
 create mode 100644 semantic-core/test/Generators.hs
 create mode 100644 semantic-core/test/Spec.hs

diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal
index 48c855ae66..b608ad41f6 100644
--- a/semantic-core/semantic-core.cabal
+++ b/semantic-core/semantic-core.cabal
@@ -64,3 +64,17 @@ test-suite doctest
                      , semantic-core
   hs-source-dirs:      test
   default-language:    Haskell2010
+
+test-suite spec
+  type:                exitcode-stdio-1.0
+  main-is:             Spec.hs
+  other-modules:       Generators
+  build-depends:       base
+                     , semantic-core
+                     , hedgehog >= 0.6 && <1
+                     , tasty >= 1.2 && <2
+                     , tasty-hedgehog >= 0.2 && <1
+                     , tasty-hunit >= 0.10 && <1
+                     , trifecta
+  hs-source-dirs:      test
+  default-language:    Haskell2010
diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs
index 7940112967..4e296e9a32 100644
--- a/semantic-core/src/Analysis/Eval.hs
+++ b/semantic-core/src/Analysis/Eval.hs
@@ -119,7 +119,7 @@ prog6 =
       ]
     ]
   , File (Loc "main" (locSpan (fromJust here))) $ block
-    [ Load (String "dep")
+    [ Load (Var (Path "dep"))
     , Let (User "thing") := Var (Path "dep") :. Var (User "var")
     ]
   ]
diff --git a/semantic-core/test/Generators.hs b/semantic-core/test/Generators.hs
new file mode 100644
index 0000000000..72c6e79447
--- /dev/null
+++ b/semantic-core/test/Generators.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Generators
+  ( literal
+  , name
+  , variable
+  , boolean
+  , lambda
+  , apply
+  , ifthenelse
+  ) where
+
+import Prelude hiding (span)
+
+import Hedgehog hiding (Var)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+import Data.Core
+import Data.Name
+
+-- The 'prune' call here ensures that we don't spend all our time just generating
+-- fresh names for variables, since the length of variable names is not an
+-- 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
+
+boolean :: MonadGen m => m Core
+boolean = Bool <$> Gen.bool
+
+variable :: MonadGen m => m Core
+variable = Var <$> name
+
+ifthenelse :: MonadGen m => m Core -> m Core
+ifthenelse bod = Gen.subterm3 boolean bod bod If
+
+apply :: MonadGen m => m Core -> m Core
+apply gen = go where
+  go = Gen.recursive
+    Gen.choice
+    [ Gen.subterm2 gen gen (:$)]
+    [ Gen.subterm2 go go (:$)  -- balanced
+    , Gen.subtermM go (\x -> Lam <$> name <*> pure x)
+    ]
+
+lambda :: MonadGen m => m Core -> m Core
+lambda bod = do
+  arg <- name
+  Gen.subterm bod (Lam arg)
+
+atoms :: MonadGen m => [m Core]
+atoms = [boolean, variable, pure Unit, pure Frame]
+
+literal :: MonadGen m => m Core
+literal = Gen.recursive Gen.choice atoms [lambda literal]
diff --git a/semantic-core/test/Spec.hs b/semantic-core/test/Spec.hs
new file mode 100644
index 0000000000..edc49efb0e
--- /dev/null
+++ b/semantic-core/test/Spec.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE OverloadedStrings, TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Main (main) where
+
+import           Data.String
+import qualified Text.Trifecta as Trifecta
+
+import           Hedgehog hiding (Var)
+import           Test.Tasty
+import           Test.Tasty.Hedgehog
+import           Test.Tasty.HUnit
+
+import           Data.File
+import qualified Generators as Gen
+import qualified Analysis.Eval as Eval
+import           Data.Core
+import           Data.Core.Pretty
+import           Data.Core.Parser as Parse
+import           Data.Name
+
+-- * Helpers
+
+true, false :: Core
+true  = Bool True
+false = Bool False
+
+instance IsString Name where fromString = User
+
+parseEither :: Trifecta.Parser a -> String -> Either String a
+parseEither p = Trifecta.foldResult (Left . show . Trifecta._errDoc) Right . Trifecta.parseString (p <* Trifecta.eof) mempty
+
+-- * Parser roundtripping properties. Note that parsing and prettyprinting is generally
+-- not a roundtrip, because the parser inserts 'Ann' nodes itself.
+
+prop_roundtrips :: Gen Core -> Property
+prop_roundtrips gen = property $ do
+  input <- forAll gen
+  tripping input showCore (parseEither (Parse.core <* Trifecta.eof))
+
+parserProps :: TestTree
+parserProps = testGroup "Parsing: roundtripping"
+  [ testProperty "literals" $ prop_roundtrips Gen.literal
+  , testProperty "if/then/else" . prop_roundtrips . Gen.ifthenelse $ Gen.variable
+  , testProperty "lambda" . prop_roundtrips $ Gen.lambda Gen.literal
+  , testProperty "function application" . prop_roundtrips $ Gen.apply Gen.variable
+  ]
+
+-- * Parser specs
+
+parsesInto :: String -> Core -> Assertion
+parsesInto str res = case parseEither Parse.core str of
+  Right x -> x @?= res
+  Left m  -> assertFailure m
+
+assert_booleans_parse :: Assertion
+assert_booleans_parse = do
+  parseEither Parse.core "#true"  @?= Right true
+  parseEither Parse.core "#false" @?= Right false
+
+a, f, g, h :: Core
+(a, f, g, h) = (Var "a", Var "f", Var "g", Var "h")
+
+assert_ifthen_parse :: Assertion
+assert_ifthen_parse = "if #true then #true else #false" `parsesInto` (If true true false)
+
+assert_application_parse :: Assertion
+assert_application_parse ="f g" `parsesInto` (f :$ g)
+
+assert_application_left_associative :: Assertion
+assert_application_left_associative = "f g h" `parsesInto` (f :$ g :$ h)
+
+assert_push_left_associative :: Assertion
+assert_push_left_associative = "f.g.h" `parsesInto` (f :. g :. h)
+
+assert_ascii_lambda_parse :: Assertion
+assert_ascii_lambda_parse = "\\a -> a" `parsesInto` Lam "a" a
+
+assert_unicode_lambda_parse :: Assertion
+assert_unicode_lambda_parse = "λa → a" `parsesInto` Lam "a" a
+
+assert_quoted_name_parse :: Assertion
+assert_quoted_name_parse = "#{(NilClass)}" `parsesInto` Var (User "(NilClass)")
+
+assert_let_dot_precedence :: Assertion
+assert_let_dot_precedence = "let a = f.g.h" `parsesInto` (Let "a" := (f :. g :. h))
+
+assert_let_in_push_precedence :: Assertion
+assert_let_in_push_precedence = "f.let g = h" `parsesInto` (f :. (Let "g" := h))
+
+parserSpecs :: TestTree
+parserSpecs = testGroup "Parsing: simple specs"
+  [ testCase "true/false" assert_booleans_parse
+  , testCase "if/then/else" assert_ifthen_parse
+  , testCase "function application" assert_application_parse
+  , testCase "application is left-associative" assert_application_left_associative
+  , testCase "dotted push is left-associative" assert_push_left_associative
+  , testCase "lambda with ASCII syntax" assert_ascii_lambda_parse
+  , testCase "lambda with unicode syntax" assert_unicode_lambda_parse
+  , testCase "quoted names" assert_quoted_name_parse
+  , testCase "let + dot precedence" assert_let_dot_precedence
+  , testCase "let in push" assert_let_in_push_precedence
+  ]
+
+assert_roundtrips :: File Core -> Assertion
+assert_roundtrips (File _ core) = parseEither Parse.core (showCore core) @?= Right (stripAnnotations core)
+
+parserExamples :: TestTree
+parserExamples = testGroup "Parsing: Eval.hs examples"
+  [ testCase "prog1" (assert_roundtrips Eval.prog1)
+  , testCase "prog2" (assert_roundtrips Eval.prog2)
+  , testCase "prog3" (assert_roundtrips Eval.prog3)
+  , testCase "prog4" (assert_roundtrips Eval.prog4)
+  , testCase "prog6.1" (assert_roundtrips (head Eval.prog6))
+  , testCase "prog6.2" (assert_roundtrips (last Eval.prog6))
+  , testCase "ruby" (assert_roundtrips Eval.ruby)
+  ]
+
+tests :: TestTree
+tests = testGroup "semantic-core"
+  [ parserSpecs
+  , parserExamples
+  , parserProps
+  ]
+
+main :: IO ()
+main = defaultMain tests

From e9b0c4548f0e0a329a0cfae9f83e0fa758efbc80 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 11:32:45 -0400
Subject: [PATCH 5/8] Remove unused language extensions.

---
 semantic-core/src/Data/Core/Parser.hs | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/semantic-core/src/Data/Core/Parser.hs b/semantic-core/src/Data/Core/Parser.hs
index a00342766d..fcce1b899e 100644
--- a/semantic-core/src/Data/Core/Parser.hs
+++ b/semantic-core/src/Data/Core/Parser.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE ExplicitForAll, FlexibleInstances, LambdaCase, MultiParamTypeClasses, OverloadedLists,
-             ScopedTypeVariables #-}
-
 module Data.Core.Parser
   ( module Text.Trifecta
   , core

From 01a4bd2ed4861b54b2b34486d722c96dadd2c79e Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 11:34:49 -0400
Subject: [PATCH 6/8] Label compound and assignment parsers and use infix
 chainl1.

---
 semantic-core/src/Data/Core/Parser.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/semantic-core/src/Data/Core/Parser.hs b/semantic-core/src/Data/Core/Parser.hs
index fcce1b899e..4e8df75706 100644
--- a/semantic-core/src/Data/Core/Parser.hs
+++ b/semantic-core/src/Data/Core/Parser.hs
@@ -47,7 +47,7 @@ core :: (TokenParsing m, Monad m) => m Core
 core = expr
 
 expr :: (TokenParsing m, Monad m) => m Core
-expr = chainl1 atom go where
+expr = atom `chainl1` go where
   go = choice [ (:.) <$ dot
               , (:$) <$ notFollowedBy dot
               ]
@@ -64,7 +64,7 @@ atom = choice
   ]
 
 comp :: (TokenParsing m, Monad m) => m Core
-comp = braces (sconcat <$> sepEndByNonEmpty expr semi)
+comp = braces (sconcat <$> sepEndByNonEmpty expr semi) <?> "compound statement"
 
 ifthenelse :: (TokenParsing m, Monad m) => m Core
 ifthenelse = If
@@ -74,7 +74,7 @@ ifthenelse = If
   <?> "if-then-else statement"
 
 assign :: (TokenParsing m, Monad m) => m Core
-assign = (:=) <$> try (lvalue <* symbolic '=') <*> core
+assign = (:=) <$> try (lvalue <* symbolic '=') <*> core <?> "assignment"
 
 edge :: (TokenParsing m, Monad m) => m Core
 edge = kw <*> expr where kw = choice [ Edge Lexical <$ reserved "lexical"

From f0c880c700a5bc451c97e55e18cd4405bf95409e Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 14:19:12 -0400
Subject: [PATCH 7/8] Fix tabs that crept into this file :angry:

---
 docs/core-grammar.md | 42 +++++++++++++++++++++---------------------
 1 file changed, 21 insertions(+), 21 deletions(-)

diff --git a/docs/core-grammar.md b/docs/core-grammar.md
index a961fd0264..a353af7bf2 100644
--- a/docs/core-grammar.md
+++ b/docs/core-grammar.md
@@ -3,28 +3,28 @@
 This is an EBNF grammar for the (experimental) core IR language.
 
 ```
-	expr ::= expr '.' expr
-	       | expr ' '+ expr
-	       | '{' expr (';' expr)* ';'? '}'
-	       | 'if' expr 'then' expr 'else' expr
-	       | ('lexical' | 'import' | 'load') expr
-	       | lit
-	       | 'let'? lvalue '=' expr
-	       | '(' expr ')'
+expr ::= expr '.' expr
+       | expr ' '+ expr
+       | '{' expr (';' expr)* ';'? '}'
+       | 'if' expr 'then' expr 'else' expr
+       | ('lexical' | 'import' | 'load') expr
+       | lit
+       | 'let'? lvalue '=' expr
+       | '(' expr ')'
 
-	lvalue ::= ident
-	         | parens expr
+lvalue ::= ident
+         | parens expr
 
-	lit ::= '#true'
-	      | '#false'
-	      | 'unit'
-	      | 'frame'
-	      | lambda
-	      | ident
+lit ::= '#true'
+      | '#false'
+      | 'unit'
+      | 'frame'
+      | lambda
+      | ident
 
-	lambda ::= ('λ' | '\') ident ('->' | '→') expr
+lambda ::= ('λ' | '\') ident ('->' | '→') expr
 
-	ident ::= [A-z_] ([A-z0-9_])*
-	        | '#{' [^{}]+ '}'
-	        | '"' [^"]+ '"'
-	```
+ident ::= [A-z_] ([A-z0-9_])*
+        | '#{' [^{}]+ '}'
+        | '"' [^"]+ '"'
+```

From b135c62444f8372b1ffa4b615cb591ce9a03f5d8 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Tue, 4 Jun 2019 14:19:35 -0400
Subject: [PATCH 8/8] Address @robrix's suggestions.

---
 semantic-core/src/Data/Core/Pretty.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/semantic-core/src/Data/Core/Pretty.hs b/semantic-core/src/Data/Core/Pretty.hs
index 710a83199b..0229769079 100644
--- a/semantic-core/src/Data/Core/Pretty.hs
+++ b/semantic-core/src/Data/Core/Pretty.hs
@@ -39,7 +39,7 @@ symbol  = annotate (Pretty.color Pretty.Yellow)
 strlit  = annotate (Pretty.colorDull Pretty.Green)
 primitive = keyword . mappend "#"
 
-type Prec    = Int
+type Prec = Int
 
 data Style = Unicode | Ascii
 
@@ -54,7 +54,7 @@ arrow = ask @Style >>= \case
 name :: Name -> AnsiDoc
 name = \case
   Gen p  -> pretty p
-  Path p -> strlit (Pretty.viaShow p  )
+  Path p -> strlit (Pretty.viaShow p)
   User n -> encloseIf (needsQuotation n) (symbol "#{") (symbol "}") (pretty n)
 
 with :: (Member (Reader Prec) sig, Carrier sig m) => Prec -> m a -> m a
@@ -81,12 +81,12 @@ prettify = \case
     fore <- with 12 a
     aft  <- with 12 b
 
-    let open  = symbol (if 12 > prec then "{" <> softline else "")
-        close = symbol (if 12 > prec then softline <> "}" else "")
+    let open  = symbol ("{" <> softline)
+        close = symbol (softline <> "}")
         separator = ";" <> Pretty.line
         body = fore <> separator <> aft
 
-    pure . Pretty.align $ open <> Pretty.align body <> close
+    pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
 
   LamF x f  -> inParens 11 $ do
     body <- f