Explicit environments

emacs/shonkier.el

@@ -4,7 +4,7 @@
 
 ;; define several class of keywords
 (setq shonkier-keywords  '("import" "as"))
-(setq shonkier-operators '("->" "@" ";"))
+(setq shonkier-operators '("->" "@" ";" ":="))
 (setq shonkier-warnings  '("TODO" "FIXME"))
 
 ;; create the regex string for each class of keywords

examples/explicit.shonkier

@@ -0,0 +1,13 @@
+foo(x) -> ['foo x]
+catch('abort,):
+catch(v, _) -> v
+catch({'abort() -> k}, f) -> f()
+
+main() -> [ foo := 5; foo
+            x := foo(7); x
+            ['foo x] := foo(7); x
+            catch(['goo x] := foo(7); x, {'phew})
+            catch('0 ; 'boo, {'phew})
+            catch('1 ; 'phew, {'boo})
+          ]
+

src/Data/Bwd.hs

@@ -3,21 +3,21 @@ module Data.Bwd where
 import Data.Semigroup (Semigroup, (<>)) -- needed for ghc versions <= 8.2.2
 
 data Bwd a
-  = Nil
+  = B0
   | Bwd a :< a
   deriving (Show, Functor, Foldable, Traversable)
 
 (<>>) :: Bwd a -> [a] -> [a]
-Nil       <>> as = as
+B0        <>> as = as
 (az :< a) <>> as = az <>> (a : as)
 
 (<><) :: Bwd a -> [a] -> Bwd a
 az <>< []       = az
 az <>< (a : as) = (az :< a) <>< as
 
 instance Monoid (Bwd a) where
-  mempty = Nil
-  mappend xz Nil       = xz
+  mempty = B0
+  mappend xz B0        = xz
   mappend xz (yz :< y) = mappend xz yz :< y
 
 instance Semigroup (Bwd a) where (<>) = mappend

src/Shonkier/Import.hs

@@ -148,8 +148,8 @@ simplifyTerm :: Functor f => String -> f ScopedVariable -> f ScopedVariable
 simplifyTerm lcp = fmap simp
   where
     simp :: ScopedVariable -> ScopedVariable
-    simp (GlobalVar fp x) = GlobalVar (stripPrefixButDot lcp fp) x
-    simp y                = y
+    simp (GlobalVar b fp :.: x) = GlobalVar b (stripPrefixButDot lcp fp) :.: x
+    simp y                      = y
 
 stripPrefixButDot :: String -> String -> String
 stripPrefixButDot prf "." = "."

src/Shonkier/Parser.hs

@@ -4,6 +4,7 @@ module Shonkier.Parser where
 
 import Control.Applicative
 import Control.Arrow (first)
+import Control.Monad
 
 import Data.Attoparsec.Text hiding (skipSpace)
 import qualified Data.Attoparsec.Text as Atto
@@ -35,7 +36,7 @@ import_ = do
 
 program :: Parser RawProgram
 program = id <$ skipSpace
-            <*> many ((,) <$> identifier <*> (Left <$> decl <|> Right <$>defn) <* skipSpace)
+            <*> many ((,) <$> identifier <*> (Left <$> decl <|> Right <$> defn) <* skipSpace)
              <* endOfInput
 
 data Comment = Line | Nested deriving (Eq, Show)
@@ -121,11 +122,38 @@ punc c = () <$ skipSpace <* char c <* skipSpace
 sep :: Parser () -> Parser x -> Parser [x]
 sep s p = (:) <$> p <*> many (id <$ s <*> p) <|> pure []
 
+data Forbidden
+  = NoProb
+  | NoSemi
+  deriving (Show, Ord, Eq, Enum, Bounded)
+
 term :: Parser RawTerm
-term = weeTerm >>= moreTerm
+term = termBut NoProb
+
+termBut :: Forbidden -> Parser RawTerm
+termBut z = weeTerm >>= moreTerm z
+
+weeTerm :: Parser RawTerm
+weeTerm = choice
+  [ Match <$> pvalue <* skipSpace <* char ':' <* char '=' <* skipSpace <*> termBut NoSemi
+  , Atom <$> atom
+  , Lit <$> literal
+  , (\ (k, t, es) -> String k t es) <$> spliceOf term
+  , Var <$> variable
+  , uncurry (flip $ foldr Cell) <$> listOf term Nil
+  , Fun [] <$ char '{' <* skipSpace <*> sep skipSpace clause <* skipSpace <* char '}'
+  , id <$ char '(' <* skipSpace <*> term <* skipSpace <* char ')'
+  ]
+
+moreTerm :: Forbidden -> RawTerm -> Parser RawTerm
+moreTerm z t = choice
+  [ App t <$> tupleOf term >>= moreTerm z
+  , Semi t <$ guard (z < NoSemi) <* punc ';' <*> termBut z
+  , pure t
+  ]
 
 atom :: Parser String
-atom = id <$ char '\'' <*> some (satisfy isAlphaNum)
+atom = id <$ char '\'' <*> identifier
 
 identifier :: Parser String
 identifier = (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum)
@@ -134,7 +162,7 @@ arrow :: Parser ()
 arrow = () <$ char '-' <* char '>'
 
 literal :: Parser Literal
-literal = numlit
+literal = boolit <|> numlit
 
 spliceOf :: Parser a -> Parser (Keyword, [(Text, a)], Text)
 spliceOf p = do
@@ -173,6 +201,9 @@ spliceOf p = do
          pure (txt', [])
        | otherwise -> choice []
 
+boolit :: Parser Literal
+boolit = Boolean <$ char '\'' <*> (False <$ char '0' <|> True <$ char '1')
+
 data NumExtension
   = Dot   String
   | Slash String
@@ -208,23 +239,6 @@ variable = do
     Nothing  -> (Nothing, start)
     Just end -> (Just start, end)
 
-weeTerm :: Parser RawTerm
-weeTerm = choice
-  [ Atom <$> atom
-  , Lit <$> literal
-  , (\ (k, t, es) -> String k t es) <$> spliceOf term
-  , Var <$> variable
-  , uncurry (flip $ foldr Cell) <$> listOf term (Atom "")
-  , Fun [] <$ char '{' <* skipSpace <*> sep skipSpace clause <* skipSpace <* char '}'
-  ]
-
-moreTerm :: RawTerm -> Parser RawTerm
-moreTerm t = choice
-  [ App t <$> tupleOf term >>= moreTerm
-  , Semi t <$ punc ';' <*> term
-  , pure t
-  ]
-
 clause :: Parser RawClause
 clause = (,) <$> sep skipSpace pcomputation <* skipSpace <* arrow <* skipSpace
              <*> term
@@ -253,7 +267,7 @@ pvalue = choice
   , PAtom <$> atom
   , pvar
   , PWild <$ char '_'
-  , uncurry (flip $ foldr PCell) <$> listOf pvalue (PAtom "")
+  , uncurry (flip $ foldr PCell) <$> listOf pvalue PNil
   ]
 
 getMeA :: Parser a -> Text -> a

src/Shonkier/Pretty.hs

@@ -24,6 +24,7 @@ data Annotation
   | AnnFunction
   | AnnKeyword
   | AnnNumeric
+  | AnnBoolean  -- wasn't she married to Henry VIII?
   | AnnOperator
   | AnnPrimitive
   | AnnSplice
@@ -67,7 +68,6 @@ ppRational p = T.pack $
 
 ppAtom :: String -> Doc
 ppAtom str = annotate AnnAtom $ case str of
-  [] -> "[]"
   a  -> squote <> pretty a
 
 arrow :: Doc
@@ -76,6 +76,9 @@ arrow = annotate AnnOperator "->"
 arobase :: Doc
 arobase = annotate AnnOperator "@"
 
+assignment :: Doc
+assignment = annotate AnnOperator ":="
+
 semi :: Doc
 semi = annotate AnnOperator P.semi
 
@@ -155,17 +158,20 @@ mkKeyword k ts = pretty $ case maximum (maximum ((-2):occ) : qso) of
 instance Pretty Literal where
   pretty = \case
     Num r        -> annotate AnnNumeric $ pretty r
+    Boolean b
+      | b         -> annotate AnnBoolean "'1"
+      | otherwise -> annotate AnnBoolean "'0"
 
 instance Pretty RawVariable where
   pretty (mns, v) = pretty (fmap (++ ".") mns) <> ppGlobalVar v
 
 instance Pretty ScopedVariable where
-  pretty = \case
-    LocalVar x           -> pretty x
-    GlobalVar _ x        -> ppGlobalVar x
-    AmbiguousVar _ x     -> annotate AnnError $ pretty x
-    OutOfScope x         -> annotate AnnError $ pretty x
-    InvalidNamespace _ x -> annotate AnnError $ pretty x
+  pretty (sco :.: x) = case sco of
+    LocalVar           -> pretty x
+    GlobalVar b _      -> if b then ppGlobalVar x else pretty x
+    AmbiguousVar _     -> annotate AnnError $ pretty x
+    OutOfScope         -> annotate AnnError $ pretty x
+    InvalidNamespace _ -> annotate AnnError $ pretty x
 
 instance Pretty v => Pretty (Term' String v) where
   pretty t = case listView t of
@@ -174,10 +180,12 @@ instance Pretty v => Pretty (Term' String v) where
       Lit l         -> pretty l
       String k ps t -> ppSplice k ps t
       Var v         -> pretty v
+      Nil           -> error "The IMPOSSIBLE happened! listView refused to eat a nil."
       Cell a b      -> error "The IMPOSSIBLE happened! listView refused to eat a cell."
       App f ts      -> ppApp (pretty f) ts
       Semi l r      -> pretty l <> semi <+> pretty r
       Fun hs cls    -> ppFun hs cls
+      Match p t     -> parens $ pretty p <+> assignment <+> pretty t
     it -> ppList it
 
 instance Pretty v => Pretty (Clause' String v) where
@@ -194,6 +202,7 @@ instance Pretty PValue where
       PBind v        -> pretty v
       PAs v p        -> pretty v <> arobase <> pretty p
       PWild          -> "_"
+      PNil           -> error "The IMPOSSIBLE happened! listView refused to eat a nil."
       PCell a b      -> error "The IMPOSSIBLE happened! listView refused to eat a cell."
     it -> ppList it
 
@@ -210,6 +219,7 @@ instance Pretty Value where
       VLit l           -> pretty l
       VString k t      -> ppStringLit k t
       VPrim f _        -> pretty f
+      VNil             -> error "The IMPOSSIBLE happened! listView refused to eat a nil."
       VCell a b        -> error "The IMPOSSIBLE happened! listView refused to eat a cell."
       VFun _ _ hs cls  -> ppFun hs cls
       VThunk c         -> braces $ pretty c

src/Shonkier/Pretty/Render/Pandoc.hs

@@ -29,6 +29,7 @@ renderAnn ann = "shonkier-" <> case ann of
   AnnFunction  -> "function"
   AnnKeyword   -> "keyword"
   AnnNumeric   -> "numeric"
+  AnnBoolean   -> "boolean"
   AnnOperator  -> "operator"
   AnnPrimitive -> "primitive"
   AnnSplice    -> "splice"

src/Shonkier/Scope.hs

@@ -74,27 +74,28 @@ instance ScopeCheck RawProgram Program where
 
 instance ScopeCheck RawVariable ScopedVariable where
   scopeCheck local (mns, v) = case mns of
-    Nothing | Set.member v local -> pure $ LocalVar v
+    Nothing | Set.member v local -> pure $ LocalVar :.: v
     Just nm -> get >>= \ st -> case namespaces st Map.!? nm of
-      Nothing  -> pure $ InvalidNamespace nm v
-      Just fps -> checkGlobal fps v
-    _ -> get >>= \ st -> checkGlobal (imports st) v
+      Nothing  -> pure $ InvalidNamespace nm :.: v
+      Just fps -> checkGlobal True fps v
+    _ -> get >>= \ st -> checkGlobal False (imports st) v
 
     where
 
-    checkGlobal :: Set FilePath -> Variable -> ScopeM ScopedVariable
-    checkGlobal scp v = do
+    checkGlobal :: Bool -> Set FilePath -> Variable -> ScopeM ScopedVariable
+    checkGlobal b scp v = do
       candidates <- gets (\ st -> globalScope st Map.!? v)
       pure $ case Set.toList . Set.intersection scp <$> candidates of
-        Just [fp]      -> GlobalVar fp v
-        Just fps@(_:_) -> AmbiguousVar fps v
-        _              -> OutOfScope v
+        Just [fp]      -> GlobalVar b fp :.: v
+        Just fps@(_:_) -> AmbiguousVar fps :.: v
+        _              -> OutOfScope :.: v
 
 instance ScopeCheck RawTerm Term where
   scopeCheck local = \case
     Atom a -> pure (Atom a)
     Lit l  -> pure (Lit l)
     Var v  -> Var <$> scopeCheck local v
+    Nil    -> pure Nil
     Cell a b  -> Cell <$> scopeCheck local a <*> scopeCheck local b
     App f ts  -> App <$> scopeCheck local f <*> mapM (scopeCheck local) ts
     Semi l r  -> Semi <$> scopeCheck local l <*> scopeCheck local r
@@ -103,6 +104,7 @@ instance ScopeCheck RawTerm Term where
       String k
         <$> traverse (traverse (scopeCheck local)) sts
         <*> pure u
+    Match p t -> Match p <$> scopeCheck local t  -- for now
 
 instance ScopeCheck RawClause Clause where
   scopeCheck local (ps, t) = do
@@ -121,6 +123,7 @@ instance ScopeCheck PValue LocalScope where
   scopeCheck local = \case
     PAtom{}   -> pure Set.empty
     PLit{}    -> pure Set.empty
+    PNil      -> pure Set.empty
     PBind x   -> pure (Set.singleton x)
     PWild{}   -> pure Set.empty
     PAs x p   -> Set.insert x <$> scopeCheck local p