Something parses!
This commit is contained in:
28
bang.cabal
28
bang.cabal
@@ -9,20 +9,30 @@ maintainer: Adam Wick <awick@uhsure.com>
|
|||||||
|
|
||||||
category: Development
|
category: Development
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
cabal-version: >=1.10
|
cabal-version: >= 1.10
|
||||||
|
|
||||||
|
|
||||||
executable bang
|
executable bang
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends:
|
build-depends:
|
||||||
array >= 0.5.1.0 && < 0.7,
|
array,
|
||||||
base >= 4.8 && < 4.9,
|
base,
|
||||||
bytestring >= 0.10 && < 0.11,
|
bytestring,
|
||||||
containers >= 0.5.6.2 && < 0.7,
|
containers,
|
||||||
lens >= 4.14 && < 4.18,
|
lens,
|
||||||
monadLib >= 3.7.3 && < 3.9,
|
monadLib,
|
||||||
optparse-applicative >= 0.12.1 && < 0.14,
|
optparse-applicative,
|
||||||
text >= 1.2.2.1 && < 1.4
|
pretty,
|
||||||
|
text
|
||||||
|
-- array >= 0.5.1.0 && < 0.7,
|
||||||
|
-- base >= 4.8 && < 4.9,
|
||||||
|
-- bytestring >= 0.10 && < 0.11,
|
||||||
|
-- containers >= 0.5.6.2 && < 0.7,
|
||||||
|
-- lens >= 4.14 && < 4.18,
|
||||||
|
-- monadLib >= 3.7.3 && < 3.9,
|
||||||
|
-- optparse-applicative >= 0.12.1 && < 0.14,
|
||||||
|
-- pretty >= 1.1.3.2 && < 1.5,
|
||||||
|
-- text >= 1.2.2.1 && < 1.4
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-tools: alex, happy
|
build-tools: alex, happy
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|||||||
@@ -2,6 +2,7 @@ module Bang.CommandLine(
|
|||||||
BangCommand(..)
|
BangCommand(..)
|
||||||
, BangOperation(..)
|
, BangOperation(..)
|
||||||
, LexerOptions(..)
|
, LexerOptions(..)
|
||||||
|
, ParserOptions(..)
|
||||||
, getCommand
|
, getCommand
|
||||||
, helpString
|
, helpString
|
||||||
)
|
)
|
||||||
@@ -32,13 +33,15 @@ outputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE"
|
|||||||
data BangOperation = Help
|
data BangOperation = Help
|
||||||
| Version
|
| Version
|
||||||
| Lex LexerOptions
|
| Lex LexerOptions
|
||||||
|
| Parse ParserOptions
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
bangOperation :: Parser BangOperation
|
bangOperation :: Parser BangOperation
|
||||||
bangOperation = subparser $
|
bangOperation = subparser $
|
||||||
command "help" (pure Help `withInfo` "Describe common commands.") <>
|
command "help" (pure Help `withInfo` "Describe common commands.") <>
|
||||||
command "version" (pure Version `withInfo` "Display version information.") <>
|
command "version" (pure Version `withInfo` "Display version information.") <>
|
||||||
command "lex" (parseLex `withInfo` "Lex a file into its component tokens.")
|
command "lex" (parseLex `withInfo` "Lex a file into its component tokens.") <>
|
||||||
|
command "parse" (parseParse `withInfo` "Parse a file into its AST.")
|
||||||
|
|
||||||
withInfo :: Parser a -> String -> ParserInfo a
|
withInfo :: Parser a -> String -> ParserInfo a
|
||||||
withInfo opts desc = info (helper <*> opts) (progDesc desc)
|
withInfo opts desc = info (helper <*> opts) (progDesc desc)
|
||||||
@@ -54,6 +57,17 @@ parseLex = Lex <$> parseLexOptions
|
|||||||
parseLexOptions :: Parser LexerOptions
|
parseLexOptions :: Parser LexerOptions
|
||||||
parseLexOptions = LexerOptions <$> argument str (metavar "FILE")
|
parseLexOptions = LexerOptions <$> argument str (metavar "FILE")
|
||||||
|
|
||||||
|
data ParserOptions = ParserOptions {
|
||||||
|
parseInputFile :: FilePath
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
parseParse :: Parser BangOperation
|
||||||
|
parseParse = Parse <$> parseParseOptions
|
||||||
|
|
||||||
|
parseParseOptions :: Parser ParserOptions
|
||||||
|
parseParseOptions = ParserOptions <$> argument str (metavar "FILE")
|
||||||
|
|
||||||
parseOptions :: Parser BangCommand
|
parseOptions :: Parser BangCommand
|
||||||
parseOptions = BangCommand <$> verboseOption <*> outputFile <*> bangOperation
|
parseOptions = BangCommand <$> verboseOption <*> outputFile <*> bangOperation
|
||||||
|
|
||||||
|
|||||||
@@ -3,18 +3,33 @@ module Bang.Syntax.AST
|
|||||||
|
|
||||||
import Data.Text.Lazy(Text)
|
import Data.Text.Lazy(Text)
|
||||||
import Bang.Syntax.Location
|
import Bang.Syntax.Location
|
||||||
import Bang.Syntax.Token
|
|
||||||
|
|
||||||
data Name = Name Text
|
data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
identToName :: Located Token -> Name
|
data Name = Name Location NameEnvironment Word Text
|
||||||
identToName = undefined
|
deriving (Show)
|
||||||
|
|
||||||
data Module = Module Name [Declaration]
|
data Module = Module Name [Declaration]
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data Declaration = TypeDeclaration
|
data Declaration = TypeDeclaration !Name !Type
|
||||||
| ValueDeclaration
|
| ValueDeclaration !Name !Expression
|
||||||
|
| PrimTypeDecl !PrimitiveType
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data Expression = Expression
|
data PrimitiveType = PrimType Name Text
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data Type = Type
|
data Expression = ConstantExp Location ConstantVal
|
||||||
|
| ReferenceExp Location Name
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data ConstantVal = ConstantInt Word Text
|
||||||
|
| ConstantChar Text
|
||||||
|
| ConstantString Text
|
||||||
|
| ConstantFloat Text
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data Type = TypeRef Location Name
|
||||||
|
deriving (Show)
|
||||||
|
|||||||
@@ -10,6 +10,7 @@ import Bang.Syntax.Location
|
|||||||
import Bang.Syntax.Name
|
import Bang.Syntax.Name
|
||||||
import Bang.Syntax.Token
|
import Bang.Syntax.Token
|
||||||
import Data.Char(isSpace, isAscii, ord)
|
import Data.Char(isSpace, isAscii, ord)
|
||||||
|
import Data.Int(Int64)
|
||||||
import Data.Maybe(fromMaybe)
|
import Data.Maybe(fromMaybe)
|
||||||
import Data.Text.Lazy(Text)
|
import Data.Text.Lazy(Text)
|
||||||
import qualified Data.Text.Lazy as T
|
import qualified Data.Text.Lazy as T
|
||||||
@@ -34,13 +35,13 @@ $escape_char = [abfnrtv'\"\\]
|
|||||||
|
|
||||||
-- Whitespace
|
-- Whitespace
|
||||||
$white+ ;
|
$white+ ;
|
||||||
"/*".*"*/" ;
|
"/*"[.\n]*"*/" ;
|
||||||
|
|
||||||
-- Numbers
|
-- Numbers
|
||||||
$decdigit+ { emitS (IntTok 10) }
|
$decdigit+ { emitI 0 (IntTok 10) }
|
||||||
"0x"$hexdigit+ { emitS (IntTok 16) }
|
"0x"$hexdigit+ { emitI 2 (IntTok 16) }
|
||||||
"0o"$octdigit+ { emitS (IntTok 8) }
|
"0o"$octdigit+ { emitI 2 (IntTok 8) }
|
||||||
"0b"$bindigit+ { emitS (IntTok 2) }
|
"0b"$bindigit+ { emitI 2 (IntTok 2) }
|
||||||
$decdigit+"."$decdigit+ ("e""-"?$decdigit+)? { emitS FloatTok}
|
$decdigit+"."$decdigit+ ("e""-"?$decdigit+)? { emitS FloatTok}
|
||||||
$decdigit+"e""-"?$decdigit+ { emitS FloatTok}
|
$decdigit+"e""-"?$decdigit+ { emitS FloatTok}
|
||||||
|
|
||||||
@@ -74,7 +75,9 @@ lexer src mbPos txt = go (AlexInput startPos txt)
|
|||||||
startPos = fromMaybe initialPosition mbPos
|
startPos = fromMaybe initialPosition mbPos
|
||||||
go input =
|
go input =
|
||||||
case alexScan input 0 of
|
case alexScan input 0 of
|
||||||
AlexEOF -> []
|
AlexEOF -> let AlexInput pos _ = input
|
||||||
|
loc = Location src pos pos
|
||||||
|
in [EOFTok `locatedAt` loc]
|
||||||
AlexError input' -> let AlexInput pos text = input'
|
AlexError input' -> let AlexInput pos text = input'
|
||||||
(as, bs) = T.break isSpace text
|
(as, bs) = T.break isSpace text
|
||||||
pos' = advanceWith' pos as
|
pos' = advanceWith' pos as
|
||||||
@@ -106,4 +109,12 @@ emitS mk src len (AlexInput pos t) = token `locatedAt` loc
|
|||||||
token = mk txt
|
token = mk txt
|
||||||
loc = Location src pos (pos `advanceWith'` txt)
|
loc = Location src pos (pos `advanceWith'` txt)
|
||||||
|
|
||||||
|
emitI :: Int64 -> (Text -> Token) -> AlexAction
|
||||||
|
emitI dropCount mk src len (AlexInput pos t) = token `locatedAt` loc
|
||||||
|
where
|
||||||
|
baseText = T.take (fromIntegral len) t
|
||||||
|
txt = T.drop dropCount baseText
|
||||||
|
token = mk txt
|
||||||
|
loc = Location src pos (pos `advanceWith'` baseText)
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -9,6 +9,7 @@ module Bang.Syntax.Location(
|
|||||||
, locSource, locStart, locEnd
|
, locSource, locStart, locEnd
|
||||||
, Located(..)
|
, Located(..)
|
||||||
, locatedAt
|
, locatedAt
|
||||||
|
, unknownLocation
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@@ -66,3 +67,6 @@ instance Show a => Show (Located a) where
|
|||||||
|
|
||||||
locatedAt :: a -> Location -> Located a
|
locatedAt :: a -> Location -> Located a
|
||||||
locatedAt a p = Located p a
|
locatedAt a p = Located p a
|
||||||
|
|
||||||
|
unknownLocation :: Location
|
||||||
|
unknownLocation = Location Unknown initialPosition initialPosition
|
||||||
|
|||||||
@@ -1,534 +0,0 @@
|
|||||||
{-# OPTIONS_GHC -w #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# OPTION_GHC -w #-}
|
|
||||||
module Bang.Syntax.Parser(
|
|
||||||
parseModule
|
|
||||||
, ParseError, showError
|
|
||||||
, lexWithLayout
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Bang.Syntax.AST
|
|
||||||
import Bang.Syntax.Lexer
|
|
||||||
import Bang.Syntax.Location
|
|
||||||
import Bang.Syntax.Token
|
|
||||||
import Data.Map.Strict(Map)
|
|
||||||
import Data.Map.Strict as Map
|
|
||||||
import Data.Text.Lazy(Text)
|
|
||||||
import qualified Data.Text.Lazy as T
|
|
||||||
import MonadLib
|
|
||||||
import Control.Applicative(Applicative(..))
|
|
||||||
|
|
||||||
-- parser produced by Happy Version 1.19.4
|
|
||||||
|
|
||||||
data HappyAbsSyn t8 t9 t10
|
|
||||||
= HappyTerminal (Located Token)
|
|
||||||
| HappyErrorToken Int
|
|
||||||
| HappyAbsSyn4 (Module)
|
|
||||||
| HappyAbsSyn5 (Maybe Declaration)
|
|
||||||
| HappyAbsSyn6 (Type)
|
|
||||||
| HappyAbsSyn7 (Expression)
|
|
||||||
| HappyAbsSyn8 t8
|
|
||||||
| HappyAbsSyn9 t9
|
|
||||||
| HappyAbsSyn10 t10
|
|
||||||
|
|
||||||
action_0 (17) = happyShift action_2
|
|
||||||
action_0 (4) = happyGoto action_3
|
|
||||||
action_0 _ = happyFail
|
|
||||||
|
|
||||||
action_1 (17) = happyShift action_2
|
|
||||||
action_1 _ = happyFail
|
|
||||||
|
|
||||||
action_2 (20) = happyShift action_4
|
|
||||||
action_2 _ = happyFail
|
|
||||||
|
|
||||||
action_3 (52) = happyAccept
|
|
||||||
action_3 _ = happyFail
|
|
||||||
|
|
||||||
action_4 (8) = happyGoto action_5
|
|
||||||
action_4 _ = happyReduce_7
|
|
||||||
|
|
||||||
action_5 (14) = happyShift action_7
|
|
||||||
action_5 (21) = happyShift action_8
|
|
||||||
action_5 (5) = happyGoto action_6
|
|
||||||
action_5 _ = happyReduce_1
|
|
||||||
|
|
||||||
action_6 _ = happyReduce_8
|
|
||||||
|
|
||||||
action_7 (18) = happyShift action_11
|
|
||||||
action_7 _ = happyFail
|
|
||||||
|
|
||||||
action_8 (11) = happyShift action_9
|
|
||||||
action_8 (12) = happyShift action_10
|
|
||||||
action_8 _ = happyFail
|
|
||||||
|
|
||||||
action_9 (6) = happyGoto action_16
|
|
||||||
action_9 _ = happyReduce_5
|
|
||||||
|
|
||||||
action_10 (7) = happyGoto action_15
|
|
||||||
action_10 _ = happyReduce_6
|
|
||||||
|
|
||||||
action_11 (19) = happyShift action_14
|
|
||||||
action_11 (9) = happyGoto action_12
|
|
||||||
action_11 (10) = happyGoto action_13
|
|
||||||
action_11 _ = happyReduce_9
|
|
||||||
|
|
||||||
action_12 _ = happyReduce_4
|
|
||||||
|
|
||||||
action_13 (13) = happyShift action_17
|
|
||||||
action_13 _ = happyReduce_10
|
|
||||||
|
|
||||||
action_14 _ = happyReduce_11
|
|
||||||
|
|
||||||
action_15 _ = happyReduce_3
|
|
||||||
|
|
||||||
action_16 _ = happyReduce_2
|
|
||||||
|
|
||||||
action_17 (19) = happyShift action_18
|
|
||||||
action_17 _ = happyFail
|
|
||||||
|
|
||||||
action_18 _ = happyReduce_12
|
|
||||||
|
|
||||||
happyReduce_1 = happySpecReduce_3 4 happyReduction_1
|
|
||||||
happyReduction_1 _
|
|
||||||
(HappyTerminal happy_var_2)
|
|
||||||
(HappyTerminal (Located happy_var_1 (ValIdent _ "module")))
|
|
||||||
= HappyAbsSyn4
|
|
||||||
(Module (identToName happy_var_1 happy_var_2)
|
|
||||||
)
|
|
||||||
happyReduction_1 _ _ _ = notHappyAtAll
|
|
||||||
|
|
||||||
happyReduce_2 = happySpecReduce_3 5 happyReduction_2
|
|
||||||
happyReduction_2 _
|
|
||||||
_
|
|
||||||
_
|
|
||||||
= HappyAbsSyn5
|
|
||||||
(Just TypeDeclartion
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_3 = happySpecReduce_3 5 happyReduction_3
|
|
||||||
happyReduction_3 _
|
|
||||||
_
|
|
||||||
_
|
|
||||||
= HappyAbsSyn5
|
|
||||||
(Just ValueDeclaration
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_4 = happySpecReduce_3 5 happyReduction_4
|
|
||||||
happyReduction_4 _
|
|
||||||
_
|
|
||||||
_
|
|
||||||
= HappyAbsSyn5
|
|
||||||
(return Nothing
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_5 = happySpecReduce_0 6 happyReduction_5
|
|
||||||
happyReduction_5 = HappyAbsSyn6
|
|
||||||
(Type
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_6 = happySpecReduce_0 7 happyReduction_6
|
|
||||||
happyReduction_6 = HappyAbsSyn7
|
|
||||||
(Expression
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_7 = happySpecReduce_0 8 happyReduction_7
|
|
||||||
happyReduction_7 = HappyAbsSyn8
|
|
||||||
([]
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_8 = happySpecReduce_2 8 happyReduction_8
|
|
||||||
happyReduction_8 (HappyAbsSyn5 happy_var_2)
|
|
||||||
(HappyAbsSyn8 happy_var_1)
|
|
||||||
= HappyAbsSyn8
|
|
||||||
(case happy_var_2 of
|
|
||||||
Nothing -> happy_var_1
|
|
||||||
Just x -> happy_var_1 ++ [x]
|
|
||||||
)
|
|
||||||
happyReduction_8 _ _ = notHappyAtAll
|
|
||||||
|
|
||||||
happyReduce_9 = happySpecReduce_0 9 happyReduction_9
|
|
||||||
happyReduction_9 = HappyAbsSyn9
|
|
||||||
([]
|
|
||||||
)
|
|
||||||
|
|
||||||
happyReduce_10 = happySpecReduce_1 9 happyReduction_10
|
|
||||||
happyReduction_10 (HappyAbsSyn10 happy_var_1)
|
|
||||||
= HappyAbsSyn9
|
|
||||||
(reverse happy_var_1
|
|
||||||
)
|
|
||||||
happyReduction_10 _ = notHappyAtAll
|
|
||||||
|
|
||||||
happyReduce_11 = happySpecReduce_1 10 happyReduction_11
|
|
||||||
happyReduction_11 (HappyTerminal happy_var_1)
|
|
||||||
= HappyAbsSyn10
|
|
||||||
([happy_var_1]
|
|
||||||
)
|
|
||||||
happyReduction_11 _ = notHappyAtAll
|
|
||||||
|
|
||||||
happyReduce_12 = happySpecReduce_3 10 happyReduction_12
|
|
||||||
happyReduction_12 (HappyTerminal happy_var_3)
|
|
||||||
_
|
|
||||||
(HappyAbsSyn10 happy_var_1)
|
|
||||||
= HappyAbsSyn10
|
|
||||||
(happy_var_3 : happy_var_1
|
|
||||||
)
|
|
||||||
happyReduction_12 _ _ _ = notHappyAtAll
|
|
||||||
|
|
||||||
happyNewToken action sts stk
|
|
||||||
= runNextToken(\tk ->
|
|
||||||
let cont i = action i i tk (HappyState action) sts stk in
|
|
||||||
case tk of {
|
|
||||||
Located initialPosition EOFTok -> action 52 52 tk (HappyState action) sts stk;
|
|
||||||
Located happy_dollar_dollar (OpIdent _ "::") -> cont 11;
|
|
||||||
Located happy_dollar_dollar (OpIdent _ "=") -> cont 12;
|
|
||||||
Located happy_dollar_dollar (OpIdent _ ",") -> cont 13;
|
|
||||||
Located happy_dollar_dollar (ValIdent _ "infixl") -> cont 14;
|
|
||||||
Located happy_dollar_dollar (ValIdent _ "infixr") -> cont 15;
|
|
||||||
Located happy_dollar_dollar (ValIdent _ "infix") -> cont 16;
|
|
||||||
Located happy_dollar_dollar (ValIdent _ "module") -> cont 17;
|
|
||||||
Located _ (IntTok _ _) -> cont 18;
|
|
||||||
Located _ (OpIdent _) -> cont 19;
|
|
||||||
Located _ (TypeIdent _) -> cont 20;
|
|
||||||
Located _ (ValIdent _) -> cont 21;
|
|
||||||
Located _ (OpIdent (LeftAssoc 0) _) -> cont 22;
|
|
||||||
Located _ (OpIdent (RightAssoc 0) _) -> cont 23;
|
|
||||||
Located _ (OpIdent (NonAssoc 0) _) -> cont 24;
|
|
||||||
Located _ (OpIdent (LeftAssoc 1) _) -> cont 25;
|
|
||||||
Located _ (OpIdent (RightAssoc 1) _) -> cont 26;
|
|
||||||
Located _ (OpIdent (NonAssoc 1) _) -> cont 27;
|
|
||||||
Located _ (OpIdent (LeftAssoc 2) _) -> cont 28;
|
|
||||||
Located _ (OpIdent (RightAssoc 2) _) -> cont 29;
|
|
||||||
Located _ (OpIdent (NonAssoc 2) _) -> cont 30;
|
|
||||||
Located _ (OpIdent (LeftAssoc 3) _) -> cont 31;
|
|
||||||
Located _ (OpIdent (RightAssoc 3) _) -> cont 32;
|
|
||||||
Located _ (OpIdent (NonAssoc 3) _) -> cont 33;
|
|
||||||
Located _ (OpIdent (LeftAssoc 4) _) -> cont 34;
|
|
||||||
Located _ (OpIdent (RightAssoc 4) _) -> cont 35;
|
|
||||||
Located _ (OpIdent (NonAssoc 4) _) -> cont 36;
|
|
||||||
Located _ (OpIdent (LeftAssoc 5) _) -> cont 37;
|
|
||||||
Located _ (OpIdent (RightAssoc 5) _) -> cont 38;
|
|
||||||
Located _ (OpIdent (NonAssoc 5) _) -> cont 39;
|
|
||||||
Located _ (OpIdent (LeftAssoc 6) _) -> cont 40;
|
|
||||||
Located _ (OpIdent (RightAssoc 6) _) -> cont 41;
|
|
||||||
Located _ (OpIdent (NonAssoc 6) _) -> cont 42;
|
|
||||||
Located _ (OpIdent (LeftAssoc 7) _) -> cont 43;
|
|
||||||
Located _ (OpIdent (RightAssoc 7) _) -> cont 44;
|
|
||||||
Located _ (OpIdent (NonAssoc 7) _) -> cont 45;
|
|
||||||
Located _ (OpIdent (LeftAssoc 8) _) -> cont 46;
|
|
||||||
Located _ (OpIdent (RightAssoc 8) _) -> cont 47;
|
|
||||||
Located _ (OpIdent (NonAssoc 8) _) -> cont 48;
|
|
||||||
Located _ (OpIdent (LeftAssoc 9) _) -> cont 49;
|
|
||||||
Located _ (OpIdent (RightAssoc 9) _) -> cont 50;
|
|
||||||
Located _ (OpIdent (NonAssoc 9) _) -> cont 51;
|
|
||||||
_ -> happyError' tk
|
|
||||||
})
|
|
||||||
|
|
||||||
happyError_ 52 tk = happyError' tk
|
|
||||||
happyError_ _ tk = happyError' tk
|
|
||||||
|
|
||||||
happyThen :: () => Parser a -> (a -> Parser b) -> Parser b
|
|
||||||
happyThen = (>>=)
|
|
||||||
happyReturn :: () => a -> Parser a
|
|
||||||
happyReturn = (return)
|
|
||||||
happyThen1 = happyThen
|
|
||||||
happyReturn1 :: () => a -> Parser a
|
|
||||||
happyReturn1 = happyReturn
|
|
||||||
happyError' :: () => (Located Token) -> Parser a
|
|
||||||
happyError' tk = parseError tk
|
|
||||||
|
|
||||||
top_module = happySomeParser where
|
|
||||||
happySomeParser = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
|
|
||||||
|
|
||||||
happySeq = happyDontSeq
|
|
||||||
|
|
||||||
|
|
||||||
newtype Parser a = Parser {
|
|
||||||
unParser :: StateT ParserState (ExceptionT ParseError Id) a
|
|
||||||
}
|
|
||||||
deriving (Functor, Applicative, Monad)
|
|
||||||
|
|
||||||
data ParseError = LexError Location Text
|
|
||||||
| ParseError Location Token
|
|
||||||
| UnexpectedEOF
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
showError :: ParseError -> String
|
|
||||||
showError (LexError l t) = show l ++ ": lexer error around " ++ T.unpack t
|
|
||||||
showError (ParseError l t) = show l ++ ": parse error around " ++ showToken t
|
|
||||||
showError UnexpectedEOF = "Unexpected end of file"
|
|
||||||
|
|
||||||
data ParserState = ParserState {
|
|
||||||
psPrecTable :: Map Text Word
|
|
||||||
, psTokenStream :: [Located Token]
|
|
||||||
}
|
|
||||||
|
|
||||||
instance StateM Parser ParserState where
|
|
||||||
get = Parser get
|
|
||||||
set = Parser . set
|
|
||||||
|
|
||||||
instance ExceptionM Parser ParseError where
|
|
||||||
raise = Parser . raise
|
|
||||||
|
|
||||||
instance RunExceptionM Parser ParseError where
|
|
||||||
try m = Parser (try (unParser m))
|
|
||||||
|
|
||||||
runNextToken :: (Located Token -> Parser a) -> Parser a
|
|
||||||
runNextToken action =
|
|
||||||
do state <- get
|
|
||||||
case psTokenStream state of
|
|
||||||
[] -> raise UnexpectedEOF
|
|
||||||
(x : rest) ->
|
|
||||||
do set (state{ psTokenStream = rest })
|
|
||||||
action x
|
|
||||||
|
|
||||||
lexWithLayout :: Origin -> Position -> Text -> [Located Token]
|
|
||||||
lexWithLayout src pos txt = lexer src (Just pos) txt
|
|
||||||
|
|
||||||
parseModule :: Origin -> Text -> Either ParseError Module
|
|
||||||
parseModule src txt =
|
|
||||||
let parserM = unParser top_module
|
|
||||||
excM = runStateT initialState (parserM :: StateT ParserState (ExceptionT ParseError Id) Module)
|
|
||||||
idM = runExceptionT (excM :: ExceptionT ParseError Id (Module, ParserState))
|
|
||||||
resWState = runId idM
|
|
||||||
in fmap fst resWState
|
|
||||||
where
|
|
||||||
tokenStream = lexWithLayout src initialPosition txt
|
|
||||||
initialState = ParserState Map.empty tokenStream
|
|
||||||
|
|
||||||
parseError :: Located Token -> Parser a
|
|
||||||
parseError t =
|
|
||||||
case t of
|
|
||||||
Located _ EOFTok -> raise UnexpectedEOF
|
|
||||||
Located p (ErrorTok t) -> raise (LexError p t)
|
|
||||||
Located p t -> raise (ParseError p t)
|
|
||||||
{-# LINE 1 "templates/GenericTemplate.hs" #-}
|
|
||||||
-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
infixr 9 `HappyStk`
|
|
||||||
data HappyStk a = HappyStk a (HappyStk a)
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- starting the parse
|
|
||||||
|
|
||||||
happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Accepting the parse
|
|
||||||
|
|
||||||
-- If the current token is (1), it means we've just accepted a partial
|
|
||||||
-- parse (a %partial parser). We must ignore the saved token on the top of
|
|
||||||
-- the stack in this case.
|
|
||||||
happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =
|
|
||||||
happyReturn1 ans
|
|
||||||
happyAccept j tk st sts (HappyStk ans _) =
|
|
||||||
(happyReturn1 ans)
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Arrays only: do the next action
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- HappyState data type (not arrays)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
newtype HappyState b c = HappyState
|
|
||||||
(Int -> -- token number
|
|
||||||
Int -> -- token number (yes, again)
|
|
||||||
b -> -- token semantic value
|
|
||||||
HappyState b c -> -- current state
|
|
||||||
[HappyState b c] -> -- state stack
|
|
||||||
c)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Shifting a token
|
|
||||||
|
|
||||||
happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =
|
|
||||||
let i = (case x of { HappyErrorToken (i) -> i }) in
|
|
||||||
-- trace "shifting the error token" $
|
|
||||||
new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
|
|
||||||
|
|
||||||
happyShift new_state i tk st sts stk =
|
|
||||||
happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
|
|
||||||
|
|
||||||
-- happyReduce is specialised for the common cases.
|
|
||||||
|
|
||||||
happySpecReduce_0 i fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
|
|
||||||
= action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
|
|
||||||
|
|
||||||
happySpecReduce_1 i fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
|
|
||||||
= let r = fn v1 in
|
|
||||||
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
|
|
||||||
|
|
||||||
happySpecReduce_2 i fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
|
|
||||||
= let r = fn v1 v2 in
|
|
||||||
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
|
|
||||||
|
|
||||||
happySpecReduce_3 i fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
|
|
||||||
= let r = fn v1 v2 v3 in
|
|
||||||
happySeq r (action nt j tk st sts (r `HappyStk` stk'))
|
|
||||||
|
|
||||||
happyReduce k i fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happyReduce k nt fn j tk st sts stk
|
|
||||||
= case happyDrop (k - ((1) :: Int)) sts of
|
|
||||||
sts1@(((st1@(HappyState (action))):(_))) ->
|
|
||||||
let r = fn stk in -- it doesn't hurt to always seq here...
|
|
||||||
happyDoSeq r (action nt j tk st1 sts1 r)
|
|
||||||
|
|
||||||
happyMonadReduce k nt fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happyMonadReduce k nt fn j tk st sts stk =
|
|
||||||
case happyDrop k ((st):(sts)) of
|
|
||||||
sts1@(((st1@(HappyState (action))):(_))) ->
|
|
||||||
let drop_stk = happyDropStk k stk in
|
|
||||||
happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
|
|
||||||
|
|
||||||
happyMonad2Reduce k nt fn (1) tk st sts stk
|
|
||||||
= happyFail (1) tk st sts stk
|
|
||||||
happyMonad2Reduce k nt fn j tk st sts stk =
|
|
||||||
case happyDrop k ((st):(sts)) of
|
|
||||||
sts1@(((st1@(HappyState (action))):(_))) ->
|
|
||||||
let drop_stk = happyDropStk k stk
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
new_state = action
|
|
||||||
|
|
||||||
in
|
|
||||||
happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
|
|
||||||
|
|
||||||
happyDrop (0) l = l
|
|
||||||
happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t
|
|
||||||
|
|
||||||
happyDropStk (0) l = l
|
|
||||||
happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Moving to a new state after a reduction
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
happyGoto action j tk st = action j j tk (HappyState action)
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Error recovery ((1) is the error token)
|
|
||||||
|
|
||||||
-- parse error if we are in recovery and we fail again
|
|
||||||
happyFail (1) tk old_st _ stk@(x `HappyStk` _) =
|
|
||||||
let i = (case x of { HappyErrorToken (i) -> i }) in
|
|
||||||
-- trace "failing" $
|
|
||||||
happyError_ i tk
|
|
||||||
|
|
||||||
{- We don't need state discarding for our restricted implementation of
|
|
||||||
"error". In fact, it can cause some bogus parses, so I've disabled it
|
|
||||||
for now --SDM
|
|
||||||
|
|
||||||
-- discard a state
|
|
||||||
happyFail (1) tk old_st (((HappyState (action))):(sts))
|
|
||||||
(saved_tok `HappyStk` _ `HappyStk` stk) =
|
|
||||||
-- trace ("discarding state, depth " ++ show (length stk)) $
|
|
||||||
action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
|
|
||||||
-}
|
|
||||||
|
|
||||||
-- Enter error recovery: generate an error token,
|
|
||||||
-- save the old token and carry on.
|
|
||||||
happyFail i tk (HappyState (action)) sts stk =
|
|
||||||
-- trace "entering error recovery" $
|
|
||||||
action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)
|
|
||||||
|
|
||||||
-- Internal happy errors:
|
|
||||||
|
|
||||||
notHappyAtAll :: a
|
|
||||||
notHappyAtAll = error "Internal Happy error\n"
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Hack to get the typechecker to accept our action functions
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Seq-ing. If the --strict flag is given, then Happy emits
|
|
||||||
-- happySeq = happyDoSeq
|
|
||||||
-- otherwise it emits
|
|
||||||
-- happySeq = happyDontSeq
|
|
||||||
|
|
||||||
happyDoSeq, happyDontSeq :: a -> b -> b
|
|
||||||
happyDoSeq a b = a `seq` b
|
|
||||||
happyDontSeq a b = b
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- Don't inline any functions from the template. GHC has a nasty habit
|
|
||||||
-- of deciding to inline happyGoto everywhere, which increases the size of
|
|
||||||
-- the generated parser quite a bit.
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{-# NOINLINE happyShift #-}
|
|
||||||
{-# NOINLINE happySpecReduce_0 #-}
|
|
||||||
{-# NOINLINE happySpecReduce_1 #-}
|
|
||||||
{-# NOINLINE happySpecReduce_2 #-}
|
|
||||||
{-# NOINLINE happySpecReduce_3 #-}
|
|
||||||
{-# NOINLINE happyReduce #-}
|
|
||||||
{-# NOINLINE happyMonadReduce #-}
|
|
||||||
{-# NOINLINE happyGoto #-}
|
|
||||||
{-# NOINLINE happyFail #-}
|
|
||||||
|
|
||||||
-- end of Happy Template.
|
|
||||||
|
|
||||||
@@ -15,65 +15,71 @@ import Bang.Syntax.AST
|
|||||||
import Bang.Syntax.Lexer
|
import Bang.Syntax.Lexer
|
||||||
import Bang.Syntax.Location
|
import Bang.Syntax.Location
|
||||||
import Bang.Syntax.Token
|
import Bang.Syntax.Token
|
||||||
|
import Data.Char(digitToInt)
|
||||||
import Data.Map.Strict(Map)
|
import Data.Map.Strict(Map)
|
||||||
import Data.Map.Strict as Map
|
import Data.Map.Strict as Map
|
||||||
|
import Data.Maybe(catMaybes)
|
||||||
import Data.Text.Lazy(Text)
|
import Data.Text.Lazy(Text)
|
||||||
import qualified Data.Text.Lazy as T
|
import qualified Data.Text.Lazy as T
|
||||||
import MonadLib
|
import MonadLib
|
||||||
|
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
%name top_module
|
||||||
%tokentype { Located Token }
|
%tokentype { Located Token }
|
||||||
|
%monad { Parser }
|
||||||
|
%error { parseError }
|
||||||
|
%lexer { runNextToken } { Located _ EOFTok }
|
||||||
|
|
||||||
%token
|
%token
|
||||||
'::' { Located $$ (OpIdent _ "::") }
|
'::' { Located $$ (OpIdent _ "::") }
|
||||||
'=' { Located $$ (OpIdent _ "=") }
|
'=' { Located $$ (OpIdent _ "=") }
|
||||||
',' { Located $$ (OpIdent _ ",") }
|
',' { Located $$ (OpIdent _ ",") }
|
||||||
'infixl' { Located $$ (ValIdent "infixl") }
|
'infixl' { Located $$ (ValIdent "infixl") }
|
||||||
'infixr' { Located $$ (ValIdent "infixr") }
|
'infixr' { Located $$ (ValIdent "infixr") }
|
||||||
'infix' { Located $$ (ValIdent "infix") }
|
'infix' { Located $$ (ValIdent "infix") }
|
||||||
'module' { Located $$ (ValIdent "module") }
|
'module' { Located $$ (ValIdent "module") }
|
||||||
Integer { Located _ (IntTok _ _) }
|
'primitive' { Located $$ (ValIdent "primitive") }
|
||||||
OpIdent { Located _ (OpIdent _ _) }
|
'type' { Located $$ (ValIdent "type") }
|
||||||
TypeIdent { Located _ (TypeIdent _) }
|
Integer { Located _ (IntTok _ _) }
|
||||||
ValIdent { Located _ (ValIdent _) }
|
Float { Located _ (FloatTok _) }
|
||||||
OPL0 { Located _ (OpIdent (LeftAssoc 0) _) }
|
Char { Located _ (CharTok _) }
|
||||||
OPR0 { Located _ (OpIdent (RightAssoc 0) _) }
|
String { Located _ (StringTok _) }
|
||||||
OPN0 { Located _ (OpIdent (NonAssoc 0) _) }
|
OpIdent { Located _ (OpIdent _ _) }
|
||||||
OPL1 { Located _ (OpIdent (LeftAssoc 1) _) }
|
TypeIdent { Located _ (TypeIdent _) }
|
||||||
OPR1 { Located _ (OpIdent (RightAssoc 1) _) }
|
ValIdent { Located _ (ValIdent _) }
|
||||||
OPN1 { Located _ (OpIdent (NonAssoc 1) _) }
|
OPL0 { Located _ (OpIdent (LeftAssoc 0) _) }
|
||||||
OPL2 { Located _ (OpIdent (LeftAssoc 2) _) }
|
OPR0 { Located _ (OpIdent (RightAssoc 0) _) }
|
||||||
OPR2 { Located _ (OpIdent (RightAssoc 2) _) }
|
OPN0 { Located _ (OpIdent (NonAssoc 0) _) }
|
||||||
OPN2 { Located _ (OpIdent (NonAssoc 2) _) }
|
OPL1 { Located _ (OpIdent (LeftAssoc 1) _) }
|
||||||
OPL3 { Located _ (OpIdent (LeftAssoc 3) _) }
|
OPR1 { Located _ (OpIdent (RightAssoc 1) _) }
|
||||||
OPR3 { Located _ (OpIdent (RightAssoc 3) _) }
|
OPN1 { Located _ (OpIdent (NonAssoc 1) _) }
|
||||||
OPN3 { Located _ (OpIdent (NonAssoc 3) _) }
|
OPL2 { Located _ (OpIdent (LeftAssoc 2) _) }
|
||||||
OPL4 { Located _ (OpIdent (LeftAssoc 4) _) }
|
OPR2 { Located _ (OpIdent (RightAssoc 2) _) }
|
||||||
OPR4 { Located _ (OpIdent (RightAssoc 4) _) }
|
OPN2 { Located _ (OpIdent (NonAssoc 2) _) }
|
||||||
OPN4 { Located _ (OpIdent (NonAssoc 4) _) }
|
OPL3 { Located _ (OpIdent (LeftAssoc 3) _) }
|
||||||
OPL5 { Located _ (OpIdent (LeftAssoc 5) _) }
|
OPR3 { Located _ (OpIdent (RightAssoc 3) _) }
|
||||||
OPR5 { Located _ (OpIdent (RightAssoc 5) _) }
|
OPN3 { Located _ (OpIdent (NonAssoc 3) _) }
|
||||||
OPN5 { Located _ (OpIdent (NonAssoc 5) _) }
|
OPL4 { Located _ (OpIdent (LeftAssoc 4) _) }
|
||||||
OPL6 { Located _ (OpIdent (LeftAssoc 6) _) }
|
OPR4 { Located _ (OpIdent (RightAssoc 4) _) }
|
||||||
OPR6 { Located _ (OpIdent (RightAssoc 6) _) }
|
OPN4 { Located _ (OpIdent (NonAssoc 4) _) }
|
||||||
OPN6 { Located _ (OpIdent (NonAssoc 6) _) }
|
OPL5 { Located _ (OpIdent (LeftAssoc 5) _) }
|
||||||
OPL7 { Located _ (OpIdent (LeftAssoc 7) _) }
|
OPR5 { Located _ (OpIdent (RightAssoc 5) _) }
|
||||||
OPR7 { Located _ (OpIdent (RightAssoc 7) _) }
|
OPN5 { Located _ (OpIdent (NonAssoc 5) _) }
|
||||||
OPN7 { Located _ (OpIdent (NonAssoc 7) _) }
|
OPL6 { Located _ (OpIdent (LeftAssoc 6) _) }
|
||||||
OPL8 { Located _ (OpIdent (LeftAssoc 8) _) }
|
OPR6 { Located _ (OpIdent (RightAssoc 6) _) }
|
||||||
OPR8 { Located _ (OpIdent (RightAssoc 8) _) }
|
OPN6 { Located _ (OpIdent (NonAssoc 6) _) }
|
||||||
OPN8 { Located _ (OpIdent (NonAssoc 8) _) }
|
OPL7 { Located _ (OpIdent (LeftAssoc 7) _) }
|
||||||
OPL9 { Located _ (OpIdent (LeftAssoc 9) _) }
|
OPR7 { Located _ (OpIdent (RightAssoc 7) _) }
|
||||||
OPR9 { Located _ (OpIdent (RightAssoc 9) _) }
|
OPN7 { Located _ (OpIdent (NonAssoc 7) _) }
|
||||||
OPN9 { Located _ (OpIdent (NonAssoc 9) _) }
|
OPL8 { Located _ (OpIdent (LeftAssoc 8) _) }
|
||||||
|
OPR8 { Located _ (OpIdent (RightAssoc 8) _) }
|
||||||
|
OPN8 { Located _ (OpIdent (NonAssoc 8) _) }
|
||||||
%monad { Parser }
|
OPL9 { Located _ (OpIdent (LeftAssoc 9) _) }
|
||||||
%error { parseError }
|
OPR9 { Located _ (OpIdent (RightAssoc 9) _) }
|
||||||
%lexer { runNextToken } { Located initialPosition EOFTok }
|
OPN9 { Located _ (OpIdent (NonAssoc 9) _) }
|
||||||
|
|
||||||
%name top_module
|
|
||||||
|
|
||||||
%right OPL0
|
%right OPL0
|
||||||
%left OPR0
|
%left OPR0
|
||||||
@@ -110,25 +116,65 @@ import MonadLib
|
|||||||
|
|
||||||
top_module :: { Module }
|
top_module :: { Module }
|
||||||
: 'module' TypeIdent listopt(declaration)
|
: 'module' TypeIdent listopt(declaration)
|
||||||
{ Module (identToName $2) $3 }
|
{%
|
||||||
|
do let Located src (TypeIdent rawName) = $2
|
||||||
|
name <- registerName False src ModuleEnv rawName
|
||||||
|
return (Module name $3) }
|
||||||
|
|
||||||
declaration :: { Maybe Declaration }
|
declaration :: { Maybe Declaration }
|
||||||
: ValIdent '::' Type
|
: ValIdent '::' Type
|
||||||
{ Just TypeDeclaration }
|
{%
|
||||||
|
do let Located src (ValIdent rawName) = $1
|
||||||
|
name <- registerName True src VarEnv rawName
|
||||||
|
return (Just (TypeDeclaration name $3)) }
|
||||||
| ValIdent '=' Expression
|
| ValIdent '=' Expression
|
||||||
{ Just ValueDeclaration }
|
{%
|
||||||
|
do let Located src (ValIdent rawName) = $1
|
||||||
|
name <- registerName True src VarEnv rawName
|
||||||
|
return (Just (ValueDeclaration name $3)) }
|
||||||
| 'infixl' Integer sep(',',OpIdent)
|
| 'infixl' Integer sep(',',OpIdent)
|
||||||
{% addFixities $1 LeftAssoc $2 $3 >> return Nothing }
|
{% addFixities $1 LeftAssoc $2 $3 >> return Nothing }
|
||||||
| 'infixr' Integer sep(',',OpIdent)
|
| 'infixr' Integer sep(',',OpIdent)
|
||||||
{% addFixities $1 RightAssoc $2 $3 >> return Nothing }
|
{% addFixities $1 RightAssoc $2 $3 >> return Nothing }
|
||||||
| 'infix' Integer sep(',',OpIdent)
|
| 'infix' Integer sep(',',OpIdent)
|
||||||
{% addFixities $1 NonAssoc $2 $3 >> return Nothing }
|
{% addFixities $1 NonAssoc $2 $3 >> return Nothing }
|
||||||
|
| 'primitive' 'type' TypeIdent '=' String
|
||||||
|
{%
|
||||||
|
do let Located src (TypeIdent rawName) = $3
|
||||||
|
Located _ (StringTok rawText) = $5
|
||||||
|
name <- registerName False src TypeEnv rawName
|
||||||
|
return (Just (PrimTypeDecl (PrimType name rawText))) }
|
||||||
|
|
||||||
Type :: { Type }
|
Type :: { Type }
|
||||||
: {- empty -} { Type }
|
: TypeIdent {%
|
||||||
|
do let Located src (TypeIdent rawName) = $1
|
||||||
|
name <- lookupName src TypeEnv rawName
|
||||||
|
return (TypeRef src name) }
|
||||||
|
|
||||||
Expression :: { Expression }
|
Expression :: { Expression }
|
||||||
: {- empty -} { Expression }
|
: BaseExpression { $1 }
|
||||||
|
|
||||||
|
BaseExpression :: { Expression }
|
||||||
|
: OpIdent {%
|
||||||
|
do let Located src (OpIdent _ rawName) = $1
|
||||||
|
name <- lookupName src VarEnv rawName
|
||||||
|
return (ReferenceExp src name) }
|
||||||
|
| ValIdent {%
|
||||||
|
do let Located src (ValIdent rawName) = $1
|
||||||
|
name <- lookupName src VarEnv rawName
|
||||||
|
return (ReferenceExp src (trace "NAME" name)) }
|
||||||
|
| Integer {%
|
||||||
|
do let Located src (IntTok base val) = $1
|
||||||
|
return (ConstantExp src (ConstantInt base val)) }
|
||||||
|
| String {%
|
||||||
|
do let Located src (StringTok val) = $1
|
||||||
|
return (ConstantExp src (ConstantString val)) }
|
||||||
|
| Float {%
|
||||||
|
do let Located src (FloatTok val) = $1
|
||||||
|
return (ConstantExp src (ConstantFloat val)) }
|
||||||
|
| Char {%
|
||||||
|
do let Located src (CharTok val) = $1
|
||||||
|
return (ConstantExp src (ConstantChar val)) }
|
||||||
|
|
||||||
-- -----------------------------------------------------------------------------
|
-- -----------------------------------------------------------------------------
|
||||||
|
|
||||||
@@ -159,11 +205,12 @@ list_body(p)
|
|||||||
| list_body(p) p { $2 : $1 }
|
| list_body(p) p { $2 : $1 }
|
||||||
|
|
||||||
listopt(p)
|
listopt(p)
|
||||||
: {- empty -} { [] }
|
: p p p { catMaybes [$1, $2, $3] }
|
||||||
| listopt(p) p { case $2 of
|
-- : {- empty -} { [] }
|
||||||
Nothing -> $1
|
-- | listopt(p) p { case $2 of
|
||||||
Just x -> $1 ++ [x]
|
-- Nothing -> $1
|
||||||
}
|
-- Just x -> $1 ++ [x]
|
||||||
|
-- }
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
||||||
@@ -172,9 +219,11 @@ newtype Parser a = Parser {
|
|||||||
}
|
}
|
||||||
deriving (Functor, Applicative, Monad)
|
deriving (Functor, Applicative, Monad)
|
||||||
|
|
||||||
data ParseError = LexError Location Text
|
data ParseError = LexError Location Text
|
||||||
| ParseError Location Token
|
| ParseError Location Token
|
||||||
| SemanticError Location Text
|
| RedefinitionError Location Location Text
|
||||||
|
| InternalError Location Text
|
||||||
|
| UnboundVariable Location Text
|
||||||
| UnexpectedEOF
|
| UnexpectedEOF
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
@@ -184,10 +233,21 @@ showError (ParseError l t) = show l ++ ": parse error around " ++ showToken t
|
|||||||
showError UnexpectedEOF = "Unexpected end of file"
|
showError UnexpectedEOF = "Unexpected end of file"
|
||||||
|
|
||||||
data ParserState = ParserState {
|
data ParserState = ParserState {
|
||||||
psPrecTable :: Map Text Word
|
psPrecTable :: Map Text Fixity
|
||||||
, psTokenStream :: [Located Token]
|
, psTokenStream :: [Located Token]
|
||||||
|
, psNameDatabase :: Map (NameEnvironment, Text) Name
|
||||||
|
, psNextIdent :: Word
|
||||||
}
|
}
|
||||||
|
|
||||||
|
initialState :: [Located Token] -> ParserState
|
||||||
|
initialState tokenStream = ParserState {
|
||||||
|
psPrecTable = Map.empty
|
||||||
|
, psTokenStream = tokenStream
|
||||||
|
, psNameDatabase = Map.empty
|
||||||
|
, psNextIdent = 1
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
instance StateM Parser ParserState where
|
instance StateM Parser ParserState where
|
||||||
get = Parser get
|
get = Parser get
|
||||||
set = Parser . set
|
set = Parser . set
|
||||||
@@ -201,13 +261,82 @@ instance RunExceptionM Parser ParseError where
|
|||||||
addFixities :: Location ->
|
addFixities :: Location ->
|
||||||
(Word -> Fixity) -> Located Token -> [Located Token] ->
|
(Word -> Fixity) -> Located Token -> [Located Token] ->
|
||||||
Parser ()
|
Parser ()
|
||||||
addFixities = undefined
|
addFixities src fixityBuilder lval names =
|
||||||
|
do value <- processInteger lval
|
||||||
|
let fixity = fixityBuilder value
|
||||||
|
forM_ names $ \ tok ->
|
||||||
|
do state <- get
|
||||||
|
name <- forceNameDefined VarEnv src tok state
|
||||||
|
let table' = Map.insert name fixity (psPrecTable state)
|
||||||
|
set state{ psPrecTable = table' }
|
||||||
|
where
|
||||||
|
processInteger x =
|
||||||
|
case x of
|
||||||
|
Located _ (IntTok base text) ->
|
||||||
|
return (makeNumeric base text 0)
|
||||||
|
_ ->
|
||||||
|
raise (InternalError src "Non-number in fixity?")
|
||||||
|
|
||||||
|
--
|
||||||
|
makeNumeric base text acc =
|
||||||
|
case T.uncons text of
|
||||||
|
Nothing -> acc
|
||||||
|
Just (x, rest) ->
|
||||||
|
let acc' = (acc * base) + charValue x
|
||||||
|
in makeNumeric base rest acc'
|
||||||
|
--
|
||||||
|
charValue = fromIntegral . digitToInt
|
||||||
|
--
|
||||||
|
tokenName t =
|
||||||
|
case t of
|
||||||
|
Located _ (TypeIdent x) -> x
|
||||||
|
Located _ (ValIdent x) -> x
|
||||||
|
Located _ (OpIdent _ x) -> x
|
||||||
|
_ ->
|
||||||
|
error "Internal error (tokenName in Parser.y)"
|
||||||
|
--
|
||||||
|
forceNameDefined env src token state =
|
||||||
|
do let name = tokenName token
|
||||||
|
case Map.lookup (env, name) (psNameDatabase state) of
|
||||||
|
Just _ -> return name
|
||||||
|
Nothing -> raise (UnboundVariable src name)
|
||||||
|
|
||||||
|
registerName :: Bool -> Location -> NameEnvironment -> Text -> Parser Name
|
||||||
|
registerName redefOk loc env name =
|
||||||
|
do state <- get
|
||||||
|
let key = (env, name)
|
||||||
|
db = psNameDatabase state
|
||||||
|
case Map.lookup key db of
|
||||||
|
Nothing ->
|
||||||
|
do let res = Name loc env (psNextIdent state) name
|
||||||
|
state' = state {
|
||||||
|
psNameDatabase = Map.insert key res db
|
||||||
|
, psNextIdent = 1 + psNextIdent state
|
||||||
|
}
|
||||||
|
set state'
|
||||||
|
return res
|
||||||
|
Just res | redefOk ->
|
||||||
|
return res
|
||||||
|
Just (Name origLoc _ _ _) ->
|
||||||
|
raise (RedefinitionError loc origLoc name)
|
||||||
|
|
||||||
|
lookupName :: Location -> NameEnvironment -> Text -> Parser Name
|
||||||
|
lookupName loc env name =
|
||||||
|
do state <- get
|
||||||
|
case Map.lookup (env, name) (psNameDatabase state) of
|
||||||
|
Nothing ->
|
||||||
|
raise (UnboundVariable loc name)
|
||||||
|
Just name ->
|
||||||
|
return name
|
||||||
|
|
||||||
runNextToken :: (Located Token -> Parser a) -> Parser a
|
runNextToken :: (Located Token -> Parser a) -> Parser a
|
||||||
runNextToken action =
|
runNextToken action =
|
||||||
do state <- get
|
do state <- get
|
||||||
case psTokenStream state of
|
case psTokenStream state of
|
||||||
[] -> raise UnexpectedEOF
|
[] ->
|
||||||
|
raise (InternalError unknownLocation "End of stream, but no EOF?")
|
||||||
|
(eof@(Located _ EOFTok) : _) ->
|
||||||
|
action eof -- leave this on at the end of the stream
|
||||||
(x : rest) ->
|
(x : rest) ->
|
||||||
do set (state{ psTokenStream = rest })
|
do set (state{ psTokenStream = rest })
|
||||||
action x
|
action x
|
||||||
@@ -218,13 +347,13 @@ lexWithLayout src pos txt = lexer src (Just pos) txt
|
|||||||
parseModule :: Origin -> Text -> Either ParseError Module
|
parseModule :: Origin -> Text -> Either ParseError Module
|
||||||
parseModule src txt =
|
parseModule src txt =
|
||||||
let parserM = unParser top_module
|
let parserM = unParser top_module
|
||||||
excM = runStateT initialState (parserM :: StateT ParserState (ExceptionT ParseError Id) Module)
|
excM = runStateT (initialState tokenStream)
|
||||||
|
(parserM :: StateT ParserState (ExceptionT ParseError Id) Module)
|
||||||
idM = runExceptionT (excM :: ExceptionT ParseError Id (Module, ParserState))
|
idM = runExceptionT (excM :: ExceptionT ParseError Id (Module, ParserState))
|
||||||
resWState = runId idM
|
resWState = runId idM
|
||||||
in fmap fst resWState
|
in fmap fst resWState
|
||||||
where
|
where
|
||||||
tokenStream = lexWithLayout src initialPosition txt
|
tokenStream = lexWithLayout src initialPosition txt
|
||||||
initialState = ParserState Map.empty tokenStream
|
|
||||||
|
|
||||||
parseError :: Located Token -> Parser a
|
parseError :: Located Token -> Parser a
|
||||||
parseError t =
|
parseError t =
|
||||||
|
|||||||
15
src/Main.hs
15
src/Main.hs
@@ -12,7 +12,8 @@ import System.IO.Error(isDoesNotExistError)
|
|||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = getCommand >>= \ cmd ->
|
main = getCommand >>= \ cmd ->
|
||||||
case cmdCommand cmd of
|
case cmdCommand cmd of
|
||||||
Lex o -> runLexer cmd o
|
Lex o -> runLexer cmd o
|
||||||
|
Parse o -> runParser cmd o
|
||||||
Help -> putStrLn helpString
|
Help -> putStrLn helpString
|
||||||
Version -> putStrLn ("Bang tool, version " ++ showVersion version)
|
Version -> putStrLn ("Bang tool, version " ++ showVersion version)
|
||||||
|
|
||||||
@@ -21,9 +22,17 @@ runLexer _cmd opts =
|
|||||||
do let path = lexInputFile opts
|
do let path = lexInputFile opts
|
||||||
mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
|
mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
|
||||||
case mtxt of
|
case mtxt of
|
||||||
Left _ -> fail ("Unable to opten file: " ++ path)
|
Left _ -> fail ("Unable to open file: " ++ path)
|
||||||
Right txt ->
|
Right txt ->
|
||||||
do let tokens = lexer (File path) (Just initialPosition) txt
|
do let tokens = lexer (File path) (Just initialPosition) txt
|
||||||
mapM_ (putStrLn . show) tokens
|
mapM_ (putStrLn . show) tokens
|
||||||
|
|
||||||
|
runParser :: BangCommand -> ParserOptions -> IO ()
|
||||||
|
runParser _cmd opts =
|
||||||
|
do let path = parseInputFile opts
|
||||||
|
mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
|
||||||
|
case mtxt of
|
||||||
|
Left _ -> fail ("Unable to open file: " ++ path)
|
||||||
|
Right txt ->
|
||||||
|
do let mod = parseModule (File path) txt
|
||||||
|
putStrLn (show mod)
|
||||||
|
|||||||
Reference in New Issue
Block a user