Changed my mind on the basic syntax; less Haskell, more C.

Makefile

@@ -4,7 +4,7 @@ ALEX         ?= alex
 ALEX_FLAGS   ?=
 HAPPY        ?= happy
 HAPPY_FLAGS  ?=
-SED          ?= sed
+SED          ?= sed -E
 FIND         ?= find
 RM           ?= rm
 PACKAGES      = monadLib bytestring utf8-string

bsrc/Data/List.bs

@@ -1,24 +1,47 @@
 module Data.List
 
-data List a = Null | (:) a (List a)
+export datatype List a =
+   NULL()
+ | (:)(a,List a);
 
-(++) :: [a] -> [a] -> [a]
-a ++ []      = a
-[] ++ b      = b
-(af:ar) ++ b = af:(ar ++ b)
+export (++)(a :: [a], b :: [a]) :: [a]
+{
+  case a of
+    []       -> b
+    (af:ar)  -> case b of
+                  [] -> a
+                  _  -> af:(ar ++ b)
+};
 
-null :: [a] -> Bool
-null [] = True
-null _  = False
+export null(ls :: [a]) :: Bool
+{
+  case ls of
+    [] -> True
+    _  -> False
+};
 
-length :: [a] -> Word
-length [] = 0
-length (a:rest) = 1 + length rest
+export length(ls :: [a]) :: Int
+{
+  case ls of
+    []     -> 0
+    _:rest -> length rest
+};
 
-reverse :: [a] -> [a]
-reverse xs = helper xs []
- where
-  helper [] acc = acc
-  helper (a:rest) acc = helper rest (a:acc)
+export reverse(ls :: [a]) :: [a]
+{
+  helper(xs,acc) = {
+    case xs of
+      []       -> acc
+      (a:rest) -> helper rest (a:acc)
+  }
 
+  helper ls [];
+};
 
+export restrict(Eq a) find(f :: a -> Bool, ls :: [a]) :: Maybe a
+{
+  case ls of
+    []             -> False
+    (a:_)    | f a -> a
+    (_:rest)       -> find(f, rest)
+};

hsrc/Main.hs

@@ -39,7 +39,7 @@ pullTokens = do
         then return [res]
         else return (res :) `ap` pullTokens
 
-loadModule :: FilePath -> IO (Module ())
+loadModule :: FilePath -> IO (Module Position)
 loadModule path = do
   mtxt <- tryJust (guard . isDoesNotExistError) $ S.readFile path
   case mtxt of

hsrc/Syntax/AST.hs

@@ -26,14 +26,25 @@ data ImportName = ImportNamed QualifiedName
  deriving (Show)
 
 data Show a => Decl a =
-    DeclData [Type] QualifiedName [QualifiedName] [DataClause]
-  | DeclType
-  | DeclNewtype
-  | DeclClass
-  | DeclInstance
-  | DeclValue Type QualifiedName (Expr a)
+    DeclData a [Type] QualifiedName [QualifiedName] [DataClause]
+  | DeclType a [Type]
+  | DeclNewtype a [Type]
+  | DeclClass a [Type] 
+  | DeclInstance a [Type]
+  | DeclValue a [Type] Type QualifiedName [Stmt a]
+  | DeclExport a (Decl a)
  deriving (Show)
 
+addTypeRestrictions :: Show a => [Type] -> Decl a -> Decl a
+addTypeRestrictions rs (DeclData     s _ a b c) = DeclData s rs a b c
+addTypeRestrictions rs (DeclType     s _)       = DeclType s rs
+addTypeRestrictions rs (DeclNewtype  s _)       = DeclNewtype s rs
+addTypeRestrictions rs (DeclClass    s _)       = DeclClass s rs
+addTypeRestrictions rs (DeclInstance s _)       = DeclInstance s rs
+addTypeRestrictions rs (DeclValue    s _ a b c) = DeclValue s rs a b c
+addTypeRestrictions rs (DeclExport   s d)     =
+  DeclExport s (addTypeRestrictions rs d)
+
 data DataClause = DataClause QualifiedName [Type]
  deriving (Show)
 
@@ -46,6 +57,12 @@ data Show a => Expr a =
   | Lambda a [QualifiedName] (Expr a)
  deriving (Show)
 
+data Show a => Stmt a =
+    SExpr a (Expr a)
+  | SBind a QualifiedName (Stmt a)
+  | SCase a
+ deriving (Show)
+
 data Kind = Star | KFun Kind Kind
  deriving (Eq,Show)
 

hsrc/Syntax/Parser.y

@@ -20,18 +20,22 @@ import qualified Codec.Binary.UTF8.Generic as UTF8
   'module'    { Lexeme $$ (TokValIdent "module"  )  }
   'export'    { Lexeme $$ (TokValIdent "export"  )  }
   'import'    { Lexeme $$ (TokValIdent "import"  )  }
-  'data'      { Lexeme $$ (TokValIdent "data"    ) }
+  'datatype'  { Lexeme $$ (TokValIdent "datatype")  }
   'type'      { Lexeme $$ (TokValIdent "type"    )  }
   'newtype'   { Lexeme $$ (TokValIdent "newtype" )  }
   'class'     { Lexeme $$ (TokValIdent "class"   )  }
   'instance'  { Lexeme $$ (TokValIdent "instance")  }
-  'qualified' { Lexeme $$ (TokValIdent "instance") }
-  'as'        { Lexeme $$ (TokValIdent "instance") }
+  'qualified' { Lexeme $$ (TokValIdent "qualified") }
+  'as'        { Lexeme $$ (TokValIdent "as")        }
+  'case'      { Lexeme $$ (TokValIdent "case")      }
+  'of'        { Lexeme $$ (TokValIdent "of")        }
+  'restrict'  { Lexeme $$ (TokValIdent "restrict")  }
 
 -- symbols
   '='        { Lexeme $$ (TokOpIdent  "=")        }
   '->'       { Lexeme $$ (TokOpIdent  "->")       }
   '=>'       { Lexeme $$ (TokOpIdent  "=>")       }
+  '::'       { Lexeme $$ (TokOpIdent  "::")       }
   '\\'       { Lexeme $$ (TokOpIdent  "\\")       }
   '('        { Lexeme $$ LParen  }
   ')'        { Lexeme $$ RParen  }
@@ -62,73 +66,20 @@ import qualified Codec.Binary.UTF8.Generic as UTF8
 
 %%
 
-top_module :: { Module () } : 'module' TYPE_IDENT module_decls {
+top_module :: { Module Position } : 'module' TYPE_IDENT module_decls {
     let (imports,items) = $3
     in Module (makeQualified $2) imports items
   }
 
-module_decls :: { ([Import], [Decl ()]) }
+module_decls :: { ([Import], [Decl Position]) }
   : module_decls module_decl { $1 `pappend` $2 }
   | module_decl              { $1              }
 
-module_decl :: { ([Import], [Decl ()]) }
-  : data_decl     { ([],   [$1]) }
-  | type_decl     { ([],   [$1]) }
-  | newtype_decl  { ([],   [$1]) }
-  | class_decl    { ([],   [$1]) }
-  | instance_decl { ([],   [$1]) }
-  | value_decl    { ([],   [$1]) }
-  | import_decl   { ([$1], []  ) } 
+module_decl :: { ([Import], [Decl Position]) }
+  : import_decl ';' { ([$1], [])   }
+  | decl        ';' { ([],   [$1]) }
 
--- Data Declarations --------------------------------------------------------
-
-data_decl :: { Decl () }
-  : 'data' mqualifiers TYPE_IDENT data_args dataclauses
-  { DeclData $2 (makeQualified $3) $4 $5 }
-
-mqualifiers :: { [Type] }
-  :                          { [] }
-  | '(' tqualifiers ')' '=>' { $2 }
-
-tqualifiers :: { [Type] }
-  : tqualifier                 { [$1] }
-  | tqualifiers ',' tqualifier { $1 ++ [$3] }
-
-tqualifier :: { Type }
-  : TYPE_IDENT VAL_IDENT
-    { TAp (TCon (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
-  | tqualifier VAL_IDENT
-    { TAp $1 (TVar (makeQualified $2) Star) }
-
-data_args :: { [QualifiedName] }
-  :                            { [] }
-  | data_args VAL_IDENT        { $1 ++ [makeQualified $2] }
-
-dataclauses :: { [DataClause] }
-  : '=' dataclause             { [$2] }
-  | dataclauses '|' dataclause { $1 ++ [$3] }
-
-dataclause :: { DataClause }
-  : TYPE_IDENT                 { DataClause (makeQualified $1) [] }
-  | dataclause bangtype        { let DataClause name items = $1
-                                 in DataClause name (items ++ [$2]) }
-
--- Type alias Declarations --------------------------------------------------
-
-type_decl :: { Decl () }
-  : 'type'        { DeclType }
-
-newtype_decl :: { Decl () }
-  : 'newtype'     { DeclNewtype }
-
-class_decl :: { Decl () }
-  : 'class'       { DeclClass }
-
-instance_decl :: { Decl () }
-  : 'instance'    { DeclInstance }
-
-value_decl :: { Decl () }
-  : VAL_IDENT '=' expr { DeclValue undefined (makeQualified $1) $3 }
+-- Import Declarations ------------------------------------------------------
 
 import_decl :: { Import }
   : 'import' mqualified TYPE_IDENT mimport_list mas
@@ -159,60 +110,235 @@ either_ident :: { QualifiedName }
   : TYPE_IDENT          { makeQualified $1 }
   | VAL_IDENT           { makeQualified $1 }
 
--- Types --------------------------------------------------------------------
+-- Actual Declarations ------------------------------------------------------
 
-bangtype :: { Type }
-  : bangtype1            { $1 }
+-- A declaration starts with an optional export flag and an optional type
+-- restriction flag, and then has the declaration. We apply the restrictions /
+-- exports post-hoc because we're lazy.
+decl :: { Decl Position }
+  : optional_decl_flags decl2 { $1 $2 }
 
-bangtype1 :: { Type }
-  : bangtype1 VAL_IDENT  { TAp $1 (TVar (makeQualified $2) Star) }
-  | bangtype2            { $1 }
+optional_decl_flags :: { Decl Position -> Decl Position }
+  :                           { id }
+  | opt_export                { $1 }
+  | opt_restrict              { $1 }
+  | opt_export opt_restrict   { $1 . $2 }
+  | opt_restrict opt_export   { $1 . $2 }
 
-bangtype2 :: { Type }
-  : bangtype2 '->' bangtype3
-    { TAp (TAp (TCon (QualifiedName [] "->") Star) $1) $3 }
-  | bangtype3            { $1 }
+opt_export :: { Decl Position -> Decl Position }
+  : 'export'                  { DeclExport $1 }
 
-bangtype3 :: { Type }
+opt_restrict :: { Decl Position -> Decl Position }
+  : 'restrict' '(' type_restrictions ')' { addTypeRestrictions $3 }
+
+type_restrictions :: { [Type] }
+  : type_restriction                       { [$1] }
+  | type_restrictions ',' type_restriction { $1 ++ [$3] }
+
+type_restriction :: { Type }
+  : TYPE_IDENT VAL_IDENT
+    { TAp (TVar (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
+  | type_restriction VAL_IDENT
+    { TAp $1 (TVar (makeQualified $2) Star) }
+
+decl2 :: { Decl Position }
+  : data_decl     { $1 }
+  | type_decl     { $1 }
+  | newtype_decl  { $1 }
+  | class_decl    { $1 }
+  | instance_decl { $1 }
+  | value_decl    { $1 }
+
+-- Data Declarations --------------------------------------------------------
+
+data_decl :: { Decl Position }
+  : 'datatype'    { undefined }
+
+-- Type Declarations --------------------------------------------------------
+
+type_decl :: { Decl Position }
+  : 'type'        { undefined }
+
+-- Newtype Declarations -----------------------------------------------------
+
+newtype_decl :: { Decl Position }
+  : 'newtype'     { undefined }
+
+-- Class Declarations -------------------------------------------------------
+
+class_decl :: { Decl Position }
+  : 'class'       { undefined }
+
+-- Instance Declarations ----------------------------------------------------
+
+instance_decl :: { Decl Position }
+  : 'instance'    { undefined }
+
+-- Value Declaration --------------------------------------------------------
+
+value_decl :: { Decl Position }
+  : value_ident optional_args optional_type { undefined }
+
+optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
+  : '(' optional_args2 ')'   { Just $2 }
+  |                          { Nothing }
+
+optional_args2 :: { [(QualifiedName, Maybe Type)] }
+  : optional_arg                     { [$1] }
+  | optional_args2 ',' optional_arg  { $1 ++ [$3] }
+
+optional_arg :: { (QualifiedName, Maybe Type) }
+  : value_ident optional_type        { ($1, $2) }
+
+optional_type :: { Maybe Type }
+  :                      { Nothing }
+  | '::' bang_type       { Just $2 }
+
+value_ident :: { QualifiedName }
+  : VAL_IDENT            { makeQualified $1 }
+  | '(' OP_IDENT ')'     { makeQualified $2 }
+
+-- Types in Bang ------------------------------------------------------------
+
+bang_type :: { Type }
   : TYPE_IDENT           { TVar (makeQualified $1) Star }
-  | '(' bangtype ')'       { $2 }
 
--- Expressions --------------------------------------------------------------
-
-expr :: { Expr () }
-  : '\\' arglist '->' expr1 { Lambda () $2 $4 }
-  | expr1                   { $1 }
-
-arglist :: { [QualifiedName] }
-  : VAL_IDENT           { [makeQualified $1] }
-  | arglist VAL_IDENT   { $1 ++ [makeQualified $2] }
-
-expr1 :: { Expr () }
-  : '{' exprs '}'       { Block () $2 }
-  | expr2               { $1 }
-
-exprs :: { [Expr ()] }
-  : expr ';'            { [$1] }
-  | exprs expr ';'      { $1 ++ [$2] }
-
-expr2 :: { Expr () }
-  : '[' list_exprs ']'  { unwindList $2 }
-  | expr3               { $1 }
-
-list_exprs :: { [Expr ()] }
-  :                      { [] }
-  | list_exprs ',' expr3 { $1 ++ [$3] }
-
-expr3 :: { Expr () }
-  : bottom_expr         { $1 }
-
-bottom_expr :: { Expr () }
-  : INTVAL              { let (b,v) = $1 in Const () (ConstInteger b v) }
-  | FLOATVAL            { Const () (ConstFloat $1) }
-  | CHARVAL             { Const () (ConstChar $1) }
-  | STRVAL              { Const () (ConstString  $1) }
-  | VAL_IDENT           { VarRef () (makeQualified $1) }
-  | '(' expr ')'        { $2 }
+-- 
+-- data_decl :: { Decl Position }
+--   : 'datatype' mqualifiers TYPE_IDENT data_args dataclauses
+--   { DeclData $2 (makeQualified $3) $4 $5 }
+-- 
+-- mqualifiers :: { [Type] }
+--   :                          { [] }
+--   | '(' tqualifiers ')' '=>' { $2 }
+-- 
+-- tqualifiers :: { [Type] }
+--   : tqualifier                 { [$1] }
+--   | tqualifiers ',' tqualifier { $1 ++ [$3] }
+-- 
+-- tqualifier :: { Type }
+--   : TYPE_IDENT VAL_IDENT
+--     { TAp (TCon (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
+--   | tqualifier VAL_IDENT
+--     { TAp $1 (TVar (makeQualified $2) Star) }
+-- 
+-- data_args :: { [QualifiedName] }
+--   :                            { [] }
+--   | data_args VAL_IDENT        { $1 ++ [makeQualified $2] }
+-- 
+-- dataclauses :: { [DataClause] }
+--   : '=' dataclause             { [$2] }
+--   | dataclauses '|' dataclause { $1 ++ [$3] }
+-- 
+-- dataclause :: { DataClause }
+--   : constructor_id             { DataClause $1 [] }
+--   | dataclause bangtype3       { let DataClause name items = $1
+--                                  in DataClause name (items ++ [$2]) }
+-- 
+-- constructor_id :: { QualifiedName }
+--   : TYPE_IDENT                 { makeQualified $1 }
+--   | '(' OP_IDENT ')'           { makeQualified $2 }
+-- 
+-- -- Type alias Declarations --------------------------------------------------
+-- 
+-- type_decl :: { Decl Position }
+--   : 'type'        { DeclType }
+-- 
+-- -- Newtype Declarations -----------------------------------------------------
+-- 
+-- newtype_decl :: { Decl Position }
+--   : 'newtype'     { DeclNewtype }
+-- 
+-- -- Type class Declarations --------------------------------------------------
+-- 
+-- class_decl :: { Decl Position }
+--   : 'class'       { DeclClass }
+-- 
+-- -- Instance Declarations ----------------------------------------------------
+-- 
+-- instance_decl :: { Decl Position }
+--   : 'instance'    { DeclInstance }
+-- 
+-- -- Data value Declarations --------------------------------------------------
+-- 
+-- value_decl :: { Decl Position }
+--   : value_name '=' expr { DeclValue Nothing $1 (Just $3) }
+-- 
+-- value_name :: { QualifiedName }
+--   : VAL_IDENT    { makeQualified $1 }
+--   | '(' OP_IDENT ')' { makeQualified $2 }
+-- 
+-- -- Data value type Declarations ---------------------------------------------
+-- 
+-- vtype_decl :: {Decl Position }
+--  : value_name '::' bangtype { DeclValue (Just $3) $1 Nothing }
+-- 
+-- -- Types --------------------------------------------------------------------
+-- 
+-- bangtype :: { Type }
+--   : bangtype1            { $1 }
+-- 
+-- bangtype1 :: { Type }
+--   : bangtype1 VAL_IDENT  { TAp $1 (TVar (makeQualified $2) Star) }
+--   | bangtype2            { $1 }
+-- 
+-- bangtype2 :: { Type }
+--   : bangtype2 '->' bangtype3
+--     { TAp (TAp (TCon (QualifiedName [] "->") Star) $1) $3 }
+--   | bangtype3            { $1 }
+-- 
+-- bangtype3 :: { Type }
+--   : '[' bangtype3 ']'
+--     { TAp (TVar (QualifiedName ["Data","List"] "List") Star) $2 }
+--   | bangtype4              { $1 }
+-- 
+-- bangtype4 :: { Type }
+--   : TYPE_IDENT             { TVar (makeQualified $1) Star }
+--   | '(' bangtype ')'       { $2 }
+-- 
+-- -- Statements ---------------------------------------------------------------
+-- 
+-- statement :: { Statement }
+--   : expr ';'               { }
+--   | 'case' expr 'of'       { }
+-- 
+-- -- Expressions --------------------------------------------------------------
+-- 
+-- expr :: { Expr Position }
+--   : '\\' arglist '->' expr1 { Lambda Position $2 $4 }
+--   | expr1                   { $1 }
+-- 
+-- arglist :: { [QualifiedName] }
+--   : VAL_IDENT           { [makeQualified $1] }
+--   | arglist VAL_IDENT   { $1 ++ [makeQualified $2] }
+-- 
+-- expr1 :: { Expr Position }
+--   : '{' exprs '}'       { Block Position $2 }
+--   | expr2               { $1 }
+-- 
+-- exprs :: { [Expr Position] }
+--   : expr ';'            { [$1] }
+--   | exprs expr ';'      { $1 ++ [$2] }
+-- 
+-- expr2 :: { Expr Position }
+--   : '[' list_exprs ']'  { unwindList $2 }
+--   | expr3               { $1 }
+-- 
+-- list_exprs :: { [Expr Position] }
+--   :                      { [] }
+--   | list_exprs ',' expr3 { $1 ++ [$3] }
+-- 
+-- expr3 :: { Expr Position }
+--   : bottom_expr         { $1 }
+-- 
+-- bottom_expr :: { Expr Position }
+--   : INTVAL              { let (b,v) = $1 in Const () (ConstInteger b v) }
+--   | FLOATVAL            { Const Position (ConstFloat $1) }
+--   | CHARVAL             { Const Position (ConstChar $1) }
+--   | STRVAL              { Const Position (ConstString  $1) }
+--   | VAL_IDENT           { VarRef Position (makeQualified $1) }
+--   | '[' ']'             { VarRef () (QualifiedName ["Data","List"] "Null") }
+--   | '(' expr ')'        { $2 }
 
 {
 lexer :: (Lexeme -> Parser a) -> Parser a
@@ -224,12 +350,6 @@ happyError  = raiseP "Parse Error"
 pappend :: ([a],[b]) -> ([a],[b]) -> ([a],[b])
 pappend (a,b) (c,d) = (a++c,b++d)
 
-unwindList :: [Expr ()] -> Expr ()
-unwindList [] = Const () ConstEmpty
-unwindList (a:rest) = 
-  App () (App () (VarRef () (QualifiedName ["Data","List"] ":")) a)
-    (unwindList rest)
-
 makeQualified :: String -> QualifiedName
 makeQualified str = QualifiedName prefixes name
  where

mk/build.mk

@@ -22,7 +22,7 @@ cmd_ghc_d_hs         = $(GHC) $(GHC_FLAGS) -M -dep-makefile $@ $<
 quiet_cmd_ghc_d_hs   = DEPEND  $(notdir $@)
 %.d : %.hs
 	$(call cmd,ghc_d_hs)
-	@$(SED) -i "s!: hsrc!: $(TOPDIR)/hsrc!g" $@
+	@$(SED) -i "" "s|: hsrc|: $(TOPDIR)/hsrc|g" $@
 
 # ghc-ld
 cmd_ghc_ld           = $(GHC) -o $@ $^