Finish being able to parse the first example file.

hsrc/Main.hs

@@ -28,14 +28,15 @@ main = do
             Right ress -> do
               mapM_ putStrLn ress
               putStrLn "Successful lex."
+    _ -> fail "Unacceptable arguments."
 
 pullTokens :: Parser [String]
 pullTokens = do
   tok <- scan
   case tok of
-    Lexeme pos tok -> do
+    Lexeme pos tok' -> do
-      let res = show pos ++ " " ++ show tok
+      let res = show pos ++ " " ++ show tok'
-      if tok == TokEOF
+      if tok' == TokEOF
         then return [res]
         else return (res :) `ap` pullTokens
 

hsrc/Syntax/AST.hs

@@ -38,7 +38,7 @@ data Show a => Decl a =
   | DeclNewtype a [Type]
   | DeclClass a [Type] 
   | DeclInstance a [Type]
-  | DeclValue a [Type] Type (Expr a)
+  | DeclValue a [Type] Type QualifiedName (Expr a)
   | DeclExport a (Decl a)
  deriving (Show)
 
@@ -48,7 +48,7 @@ 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)   = DeclValue s rs a b
+addTypeRestrictions rs (DeclValue    s _ n a b)   = DeclValue s rs n a b
 addTypeRestrictions rs (DeclExport   s d)         =
   DeclExport s (addTypeRestrictions rs d)
 
@@ -62,6 +62,7 @@ data Show a => Expr a =
   | App a (Expr a) [Expr a]
   | Block a [Stmt a]
   | Lambda a [QualifiedName] (Expr a)
+  | Let a Type QualifiedName (Expr a) (Expr a)
  deriving (Show)
 
 getSpecial :: Show a => Expr a -> a
@@ -71,11 +72,13 @@ getSpecial (Cond a _ _ _) = a
 getSpecial (App a _ _)     = a
 getSpecial (Block a _)     = a
 getSpecial (Lambda a _ _)  = a
+getSpecial (Let a _ _ _ _) = a
 
 data Show a => Stmt a =
     SExpr a (Expr a)
   | SBind a QualifiedName (Stmt a)
-  | SCase a (Expr a) [(Pattern,Maybe (Expr a),Expr a)]
+  | SLet  a Type QualifiedName (Expr a)
+  | SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)]
  deriving (Show)
 
 data Pattern =

hsrc/Syntax/Lexer.x

@@ -21,7 +21,7 @@ $bindigit = [01]
 $typestart   = [A-Z\_]
 $valstart    = [a-z\_]
 $identrest   = [a-zA-Z0-9\_\.]
-$opident     = [\~\!\@\#\$\%\^\&\*\+\-\=\.\:\<\>\?\_]
+$opident     = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_]
 $escape_char = [abfnrtv'\"\\]
 
 :-
@@ -42,6 +42,7 @@ $escape_char = [abfnrtv'\"\\]
   $typestart $identrest*                           { emitS TokTypeIdent }
   $valstart $identrest*                            { emitS TokValIdent  }
   $opident+                                        { emitS TokOpIdent   }
+  ":"+                                             { emitS TokOpIdent   }
 
 -- Characters and Strings
   ['].[']                                          { emitS TokChar }

hsrc/Syntax/Parser.y

@@ -27,6 +27,8 @@ import qualified Codec.Binary.UTF8.Generic as UTF8
   'instance'  { Lexeme $$ (TokValIdent "instance")  }
   'qualified' { Lexeme $$ (TokValIdent "qualified") }
   'as'        { Lexeme $$ (TokValIdent "as")        }
+  'let'       { Lexeme $$ (TokValIdent "let")       }
+  'in'        { Lexeme $$ (TokValIdent "in")        }
   'case'      { Lexeme $$ (TokValIdent "case")      }
   'of'        { Lexeme $$ (TokValIdent "of")        }
   'restrict'  { Lexeme $$ (TokValIdent "restrict")  }
@@ -206,7 +208,7 @@ instance_decl :: { Decl Position }
 
 value_decl :: { Decl Position }
   : value_ident optional_args optional_type value_body
-    {% postProcessDeclVal $1 $2 $3 $4 }
+    {% postProcessDeclVal DeclValue $1 $2 $3 $4 }
 
 
 optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
@@ -268,23 +270,25 @@ statements :: { [Stmt Position] }
 
 statement :: { Stmt Position }
   : assignment_statement ';' { $1 }
-  | case_statement ';'       { $1 }
+  | case_statement           { $1 }
   | expression ';'           { SExpr $2 $1 }
 
 assignment_statement :: { Stmt Position }
   : value_ident '=' expression -- FIXME: Too restrictive!
     { SBind $2 $1 (SExpr $2 $3) }
+  | 'let' value_ident optional_args optional_type value_body
+    {% postProcessDeclVal (\ s _ t n e -> SLet s t n e) $2 $3 $4 $5 }
 
 case_statement :: { Stmt Position }
-  : 'case' expression 'of' case_items
+  : 'case' expression '{' case_items '}'
     { SCase $1 $2 $4 }
 
-case_items :: { [(Pattern,Maybe (Expr Position),(Expr Position))] }
+case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] }
   : case_item            { [$1] }
   | case_items case_item { $1 ++ [$2] }
 
-case_item :: { (Pattern, Maybe (Expr Position), (Expr Position)) }
+case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) }
-  : pattern mguard '->' expression { ($1, $2, $4) }
+  : pattern mguard '->' statement { ($1, $2, $4) }
 
 mguard :: { Maybe (Expr Position) }
   :                 { Nothing }
@@ -338,11 +342,18 @@ primary_expression :: { Expr Position }
                             in Const src (ConstChar val) }
   | STRVAL                { let (Lexeme src (TokString val)) = $1
                             in Const src (ConstString val) }
+  | TYPE_IDENT            { let l@(Lexeme src (TokTypeIdent name)) = $1
+                            in VarRef src (makeQualified l) }
   | VAL_IDENT             { let l@(Lexeme src (TokValIdent name)) = $1
                             in VarRef src (makeQualified l) }
 
+let_expression :: {Expr Position}
+  : 'let' value_ident optional_args optional_type value_body 'in' let_expression
+    {% postProcessDeclVal (\ s _ t n b -> Let s t n b $7) $2 $3 $4 $5 }
+  | primary_expression { $1 }
+
 conditional_expression :: { Expr Position }
-  : primary_expression { $1 }
+  : let_expression { $1 }
 
 infix_expression :: { Expr Position }
   : infix_expression infix_operator conditional_expression
@@ -403,15 +414,17 @@ makeQualified' str = QualifiedName prefixes name
     let (pre,rest) = span (/= '.') val
     in if rest == ""
          then ([], pre)
-         else let (pres, name) = loop rest
+         else let (pres, name) = loop (tail rest)
               in (pre:pres, name)
 
-postProcessDeclVal :: QualifiedName ->
+postProcessDeclVal :: 
+  (Position -> [Type] -> Type -> QualifiedName -> Expr Position -> a) ->
+  QualifiedName ->
   Maybe [(QualifiedName, Maybe Type)] ->
   Maybe Type ->
   (Position, Expr Position) ->
-                      Parser (Decl Position)
+  Parser a
-postProcessDeclVal name margs mrettype (src, body) = do
+postProcessDeclVal builder name margs mrettype (src, body) = do
   final_type <- case mrettype of
                    Nothing -> do
                      name <- gensym
@@ -420,11 +433,19 @@ postProcessDeclVal name margs mrettype (src, body) = do
                      return x
   case margs of
     Nothing ->
-      return (DeclValue src [] final_type body)
+      return (builder src [] final_type name body)
     Just [] ->
       fail "Need to figure out empty arg items."
-    Just args ->
+    Just args -> do
-      fail "Need to figure out non-empty arg items."
+      let anames  = map fst args
-
+      atypes <- forM (map snd args) $ \ x ->
+                  case x of
+                    Nothing -> do
+                      name <- gensym
+                      return (TVar name Star)
+                    Just x ->
+                      return x
+      let ftype = foldr TAp final_type atypes
+      return (builder src [] ftype name (Lambda src anames body))
 }