From 29a358a76a4a4fa8385e421f43e540ea67bfaecf Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Thu, 6 Jan 2011 23:37:31 -0800 Subject: [PATCH] Changed my mind on the basic syntax; less Haskell, more C. --- Makefile | 2 +- bsrc/Data/List.bs | 55 +++++-- hsrc/Main.hs | 2 +- hsrc/Syntax/AST.hs | 29 +++- hsrc/Syntax/Parser.y | 352 +++++++++++++++++++++++++++++-------------- mk/build.mk | 2 +- 6 files changed, 301 insertions(+), 141 deletions(-) diff --git a/Makefile b/Makefile index b44da76..f0f61a1 100644 --- a/Makefile +++ b/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 diff --git a/bsrc/Data/List.bs b/bsrc/Data/List.bs index 3fe3f48..f90d697 100644 --- a/bsrc/Data/List.bs +++ b/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) +}; diff --git a/hsrc/Main.hs b/hsrc/Main.hs index dcd3a19..f26fdcf 100644 --- a/hsrc/Main.hs +++ b/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 diff --git a/hsrc/Syntax/AST.hs b/hsrc/Syntax/AST.hs index 16c9871..976412e 100644 --- a/hsrc/Syntax/AST.hs +++ b/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) diff --git a/hsrc/Syntax/Parser.y b/hsrc/Syntax/Parser.y index 67a74aa..d344738 100644 --- a/hsrc/Syntax/Parser.y +++ b/hsrc/Syntax/Parser.y @@ -17,21 +17,25 @@ import qualified Codec.Binary.UTF8.Generic as UTF8 %token -- reserved words - 'module' { Lexeme $$ (TokValIdent "module" ) } - 'export' { Lexeme $$ (TokValIdent "export" ) } - 'import' { Lexeme $$ (TokValIdent "import" ) } - 'data' { Lexeme $$ (TokValIdent "data" ) } - 'type' { Lexeme $$ (TokValIdent "type" ) } - 'newtype' { Lexeme $$ (TokValIdent "newtype" ) } - 'class' { Lexeme $$ (TokValIdent "class" ) } - 'instance' { Lexeme $$ (TokValIdent "instance") } - 'qualified' { Lexeme $$ (TokValIdent "instance") } - 'as' { Lexeme $$ (TokValIdent "instance") } + 'module' { Lexeme $$ (TokValIdent "module" ) } + 'export' { Lexeme $$ (TokValIdent "export" ) } + 'import' { Lexeme $$ (TokValIdent "import" ) } + 'datatype' { Lexeme $$ (TokValIdent "datatype") } + 'type' { Lexeme $$ (TokValIdent "type" ) } + 'newtype' { Lexeme $$ (TokValIdent "newtype" ) } + 'class' { Lexeme $$ (TokValIdent "class" ) } + 'instance' { 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 } - : TYPE_IDENT { TVar (makeQualified $1) Star } - | '(' bangtype ')' { $2 } +opt_restrict :: { Decl Position -> Decl Position } + : 'restrict' '(' type_restrictions ')' { addTypeRestrictions $3 } --- Expressions -------------------------------------------------------------- +type_restrictions :: { [Type] } + : type_restriction { [$1] } + | type_restrictions ',' type_restriction { $1 ++ [$3] } -expr :: { Expr () } - : '\\' arglist '->' expr1 { Lambda () $2 $4 } - | expr1 { $1 } +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) } -arglist :: { [QualifiedName] } - : VAL_IDENT { [makeQualified $1] } - | arglist VAL_IDENT { $1 ++ [makeQualified $2] } +decl2 :: { Decl Position } + : data_decl { $1 } + | type_decl { $1 } + | newtype_decl { $1 } + | class_decl { $1 } + | instance_decl { $1 } + | value_decl { $1 } -expr1 :: { Expr () } - : '{' exprs '}' { Block () $2 } - | expr2 { $1 } +-- Data Declarations -------------------------------------------------------- -exprs :: { [Expr ()] } - : expr ';' { [$1] } - | exprs expr ';' { $1 ++ [$2] } +data_decl :: { Decl Position } + : 'datatype' { undefined } -expr2 :: { Expr () } - : '[' list_exprs ']' { unwindList $2 } - | expr3 { $1 } +-- Type Declarations -------------------------------------------------------- -list_exprs :: { [Expr ()] } - : { [] } - | list_exprs ',' expr3 { $1 ++ [$3] } +type_decl :: { Decl Position } + : 'type' { undefined } -expr3 :: { Expr () } - : bottom_expr { $1 } +-- Newtype Declarations ----------------------------------------------------- -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 } +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 } + +-- +-- 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 diff --git a/mk/build.mk b/mk/build.mk index 60cc8b3..1dde1e9 100644 --- a/mk/build.mk +++ b/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 $@ $^