Merge remote-tracking branch 'origin/master' into build-semantic-core-in-travis

.gitignore

@@ -3,6 +3,8 @@
 .docsets
 .stack-work
 .stack-work-profiling
+stack.yaml
+stack.yaml.lock
 profiles
 /tags
 

README.md

@@ -108,7 +108,7 @@ cabal new-test
 cabal new-run semantic -- --help
 ```
 
-`semantic` requires GHC 8.6.4. We recommend using [`ghcup`][ghcup] to sandbox GHC versions. Our version bounds are based on [Stackage][stackage] LTS versions. The current LTS version is 13.13; `stack` build should also work if you prefer.
+`semantic` requires GHC 8.6.4. We recommend using [`ghcup`][ghcup] to sandbox GHC versions. Our version bounds are based on [Stackage][stackage] LTS versions. The current LTS version is 13.13; `stack` build should also work if you prefer, there is an unofficial [`stack.yaml`](https://gist.github.com/jkachmar/f200caee83280f1f25e9cfa2dd2b16bb).
 
 [nix]: https://www.haskell.org/cabal/users-guide/nix-local-build-overview.html
 [stackage]: https://stackage.org

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_])*
+        | '#{' [^{}]+ '}'
+        | '"' [^"]+ '"'
+```

semantic-core/semantic-core.cabal

@@ -26,22 +26,29 @@ library
                      , Analysis.Typecheck
                      , 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
-                     , 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
+                     , 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
@@ -57,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

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")
     ]
   ]

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

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

@@ -0,0 +1,115 @@
+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 = atom `chainl1` 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) <?> "compound statement"
+
+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 <?> "assignment"
+
+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"
+

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 ("{" <> softline)
+        close = symbol (softline <> "}")
+        separator = ";" <> Pretty.line
+        body = fore <> separator <> aft
+
+    pure . Pretty.align $ encloseIf (12 > prec) open close (Pretty.align body)
+
+  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

semantic-core/src/Data/Name.hs

@@ -1,8 +1,11 @@
-{-# 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
+, needsQuotation
 , Gensym(..)
 , (//)
 , gensym
@@ -20,6 +23,9 @@ 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 qualified Data.HashSet as HashSet
 import           Data.Text.Prettyprint.Doc (Pretty (..))
 import qualified Data.Text.Prettyprint.Doc as Pretty
 
@@ -50,6 +56,25 @@ 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"]
+
+-- | 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 @_@.
+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)

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]

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

src/Semantic/CLI.hs

@@ -166,7 +166,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
 
 shaReader :: ReadM Git.OID
 shaReader = eitherReader parseSha
-  where parseSha arg = if length arg == 40
+  where parseSha arg = if length arg == 40 || arg == "HEAD"
           then Right (Git.OID (T.pack arg))
           else Left (arg <> " is not a valid sha1")