diff --git a/.gitignore b/.gitignore index 1ba0c46..a83453a 100644 --- a/.gitignore +++ b/.gitignore @@ -11,4 +11,8 @@ /*.hs # except for this one -!/Setup.hs \ No newline at end of file +!/Setup.hs + +# alex/happy artefacts +src/*.o +src/*.hi \ No newline at end of file diff --git a/src/Frontend/Autogen/Lexer.x b/src/Frontend/Autogen/Lexer.x index 2f47527..e255a0d 100644 --- a/src/Frontend/Autogen/Lexer.x +++ b/src/Frontend/Autogen/Lexer.x @@ -25,7 +25,7 @@ tokens :- { just $ pushStartCode newline } <0,module_header,import_> - $alpha [$alpha $digit \_ \']* { variableOrKeyword } + $alpha [$alpha $digit \_ \' \.]* { variableOrKeyword } <0> \= { always TokEqual } <0> \: \: { always TokDoubleColon } @@ -169,16 +169,16 @@ data LayoutState deriving (Show) data AlexUserState = - AlexUserState { layoutColumns :: [LayoutState] - , startCodes :: [Int] - , leastColumn :: Int + AlexUserState { layoutColumns :: ![LayoutState] + , startCodes :: ![Int] + , leastColumn :: !Int , pendingLayoutKw :: Maybe (Int -> LayoutState) - , pendingTokens :: [Token] - , pendingLambdaCase :: Bool - , haveModuleHeader :: Bool + , pendingTokens :: ![Token] + , pendingLambdaCase :: !Bool + , haveModuleHeader :: !Bool - , stringBuffer :: T.Text + , stringBuffer :: !T.Text } alexInitUserState = AlexUserState [] [] 0 Nothing [] False False T.empty @@ -293,26 +293,41 @@ closeBrace (AlexPn _ line col, _, _, _) _ = do pure (Token TokCBrace line col) variableOrKeyword :: AlexAction Token -variableOrKeyword (AlexPn _ l c, _, s, _) size = do +variableOrKeyword (AlexPn _ l c, _, s, _) size = finishVarKw l c $ T.decodeUtf8 (Lbs.toStrict (Lbs.take size s)) + +finishVarKw :: Int -> Int -> T.Text -> Alex Token +finishVarKw l c text + | T.null text = undefined + | Data.Char.isUpper (T.head text), T.singleton '.' `T.isInfixOf` text = pure $ + let + txet = T.reverse text + (suffix', prefix') = T.span (/= '.') txet + + prefix = T.reverse (T.tail prefix') + suffix = T.reverse suffix' + in if Data.Char.isUpper (T.head suffix) + then Token (TokQual ConId prefix suffix) l c + else Token (TokQual VarId prefix suffix) l c + | Data.Char.isUpper (T.head text) = pure $ Token (TokUnqual ConId text) l c + +finishVarKw l c text = do sc <- alexGetStartCode state <- getUserState clearPendingLC - let - text = T.decodeUtf8 (Lbs.toStrict (Lbs.take size s)) - col = layoutCol (head (layoutColumns state)) + let col = layoutCol (head (layoutColumns state)) case T.unpack text of "as" | sc == import_, c > col -> pure (Token TokAs l c) - | sc == import_ -> offsideKeyword (TokVar text) l c - | otherwise -> pure (Token (TokVar text) l c) + | sc == import_ -> offsideKeyword (TokUnqual VarId text) l c + | otherwise -> pure (Token (TokUnqual VarId text) l c) "qualified" | sc == import_, c > col -> pure (Token TokQualified l c) - | sc == import_ -> offsideKeyword (TokVar text) l c - | otherwise -> pure (Token (TokVar text) l c) + | sc == import_ -> offsideKeyword (TokUnqual VarId text) l c + | otherwise -> pure (Token (TokUnqual VarId text) l c) "let" -> laidOut' (Just LetLayout) TokLet l c "in" -> do @@ -348,9 +363,7 @@ variableOrKeyword (AlexPn _ l c, _, s, _) size = do pushStartCode module_header pure (Token TokModule l c) - (x:_) - | Data.Char.isUpper x -> pure (Token (TokCon text) l c) - | otherwise -> pure (Token (TokVar text) l c) + (x:_) -> pure (Token (TokUnqual VarId text) l c) [] -> error "empty keyword/identifier" diff --git a/src/Frontend/Autogen/Parser.y b/src/Frontend/Autogen/Parser.y index cc44323..2840f3d 100644 --- a/src/Frontend/Autogen/Parser.y +++ b/src/Frontend/Autogen/Parser.y @@ -3,7 +3,6 @@ module Frontend.Autogen.Parser where import qualified Data.Text as T -import Data.Text (Text) import Frontend.Lexer.Tokens import Frontend.Parser.Posn @@ -29,8 +28,11 @@ import Debug.Trace %error { parseError } %token - VAR { Token (TokVar _) _ _ } - CON { Token (TokCon _) _ _ } + VAR { Token (TokUnqual VarId _) _ _ } + CON { Token (TokUnqual ConId _) _ _ } + + QVAR { Token (TokQual VarId _ _) _ _ } + QCON { Token (TokQual ConId _ _) _ _ } STRING { Token (TokString _) _ _ } 'eof' { Token TokEof _ _ } @@ -89,8 +91,8 @@ FuncExp :: { Exp } | Aexp { $1 } Aexp :: { Exp } - : qvar { span $1 $1 $ Ref (getVar $1) } - | qcon { span $1 $1 $ Con (getVar $1) } + : qvar { span $1 $1 $ Ref $1 } + | qcon { span $1 $1 $ Con $1 } | '(' CommaList(Exp) ')' { span $1 $3 $ makeTuple $2 } | STRING { span $1 $1 $ Literal (LitString (getString $1)) } @@ -103,10 +105,9 @@ Btype :: { Type } | Atype { $1 } Atype :: { Type } - : qvar { span $1 $1 $ Tyvar (getVar $1) } - | qcon { span $1 $1 $ Tycon (getVar $1) } + : qvar { span $1 $1 $ Tyvar $1 } + | qcon { span $1 $1 $ Tycon $1 } | '(' CommaList(Type) ')' { span $1 $3 $ makeTupleType $2 } - Pat :: { Pat } : Lpat { $1 } @@ -120,9 +121,9 @@ Apat :: { Pat } | '(' CommaList(Pat) ')' { span $1 $3 $ makeTuplePattern $2 } Decl :: { Decl } - : VAR '::' Type { TySig (getVar $1) $3 } - | VAR Apat List(Apat) Rhs { FunDecl (getVar $1) ($2:$3) $4 } - | Pat Rhs { PatDecl $1 $2 } + : CommaList1(VAR) '::' Type { TySig (getVar `fmap` $1) $3 } + | VAR Apat List(Apat) Rhs { FunDecl (getVar $1) ($2:$3) $4 } + | Pat Rhs { PatDecl $1 $2 } Rhs :: { Rhs } : '=' Exp { BareRhs $2 [] } @@ -139,16 +140,16 @@ LOLContents(p, End) Module :: { Module } : 'module' CON ImportExportList 'where' LaidOutList(ModItem) - { Module { moduleName = getVar $2 + { Module { moduleName = toModId (getVar $2) , moduleExports = $3 , moduleItems = thd $5 } } -ImportExportList :: { Maybe [NamespacedItem Text] } +ImportExportList :: { Maybe [NamespacedItem ParsedVar] } : {-empty-} { Nothing } | '(' CommaList(NSItem) ')' { Just $2 } -NSItem :: { NamespacedItem Text } +NSItem :: { NamespacedItem ParsedVar } : VAR { IEVar (getVar $1) } | CON { IECon (getVar $1) } | 'module' CON { IEModule (getVar $2) } @@ -157,18 +158,18 @@ ModItem :: { Item } : Decl { ModDecl $1 } | Import { ModImport $1 } -Import - : 'import' qcon ImportExportList - { Import (getVar $2) $3 False Nothing } +Import :: { ModuleImport ParsedVar } + : 'import' modid ImportExportList + { Import $2 $3 False Nothing } - | 'import' qcon ImportExportList 'as' CON - { Import (getVar $2) $3 False (Just (getVar $5)) } + | 'import' modid ImportExportList 'as' CON + { Import $2 $3 False (Just (getVar $5)) } - | 'import' 'qualified' qcon ImportExportList - { Import (getVar $3) $4 True Nothing } + | 'import' 'qualified' modid ImportExportList + { Import $3 $4 True Nothing } - | 'import' 'qualified' qcon ImportExportList 'as' CON - { Import (getVar $3) $4 True (Just (getVar $6)) } + | 'import' 'qualified' modid ImportExportList 'as' CON + { Import $3 $4 True (Just (getVar $6)) } Opt(p) : { () } @@ -179,8 +180,14 @@ Semis | ';' { () } -- TODO: qualified names -qvar : VAR { $1 } -qcon : CON { $1 } +qvar :: { ParsedVar } +qvar : VAR { getVar $1 } + | QVAR { getVar $1 } + +qcon : CON { getVar $1 } + | QCON { getVar $1 } + +modid : qcon { toModId $1 } List(p) : {-empty-} { [] } @@ -191,19 +198,23 @@ CommaList(p) | p { [$1] } | p ',' CommaList(p) { $1:$3 } +CommaList1(p) + : p { [$1] } + | p ',' CommaList(p) { $1:$3 } + Block(p) : START p END { (startPosn $1, endPosn $3, $2) } | '{' p '}' { (startPosn $1, endPosn $3, $2) } { -type Exp = FeExpr Text -type Pat = FePat Text -type Decl = FeDecl Text -type Type = FeType Text -type Rhs = FeRhs Text -type Module = FeModule Text -type Item = ModuleItem Text +type Exp = FeExpr ParsedVar +type Pat = FePat ParsedVar +type Decl = FeDecl ParsedVar +type Type = FeType ParsedVar +type Rhs = FeRhs ParsedVar +type Module = FeModule ParsedVar +type Item = ModuleItem ParsedVar lexer cont = alexMonadScan >>= cont @@ -211,8 +222,9 @@ parseError x = alexError (show x) makeLams xs b = foldr Lam b xs -getVar (Token (TokVar s) _ _) = s -getVar (Token (TokCon s) _ _) = s +getVar :: Token -> ParsedVar +getVar tok@(Token (TokQual _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok } +getVar tok@(Token (TokUnqual _ s) _ _) = UnqualVar { varId = s, varBegin = startPosn tok, varEnd = endPosn tok } getVar _ = error "getVar non-var" getString (Token (TokString s) _ _) = s diff --git a/src/Frontend/Lexer/Tokens.hi b/src/Frontend/Lexer/Tokens.hi deleted file mode 100644 index 2db5bba..0000000 Binary files a/src/Frontend/Lexer/Tokens.hi and /dev/null differ diff --git a/src/Frontend/Lexer/Tokens.hs b/src/Frontend/Lexer/Tokens.hs index 97e8844..a554a9c 100644 --- a/src/Frontend/Lexer/Tokens.hs +++ b/src/Frontend/Lexer/Tokens.hs @@ -3,9 +3,12 @@ module Frontend.Lexer.Tokens where import qualified Data.Text as T import Data.Text (Text) +data IdClass = ConId | VarId + deriving (Eq, Show, Ord) + data TokenClass - = TokVar Text - | TokCon Text + = TokUnqual IdClass Text + | TokQual IdClass Text Text | TokString Text | TokEof @@ -48,8 +51,8 @@ data TokenClass deriving (Eq, Show, Ord) tokSize :: TokenClass -> Int -tokSize (TokVar x) = T.length x -tokSize (TokCon x) = T.length x +tokSize (TokUnqual _ x) = T.length x +tokSize (TokQual _ x y) = T.length x + T.length y + 1 tokSize TokEof = 0 tokSize TokLambda = 1 tokSize TokOParen = 1 diff --git a/src/Frontend/Lexer/Tokens.o b/src/Frontend/Lexer/Tokens.o deleted file mode 100644 index b738599..0000000 Binary files a/src/Frontend/Lexer/Tokens.o and /dev/null differ diff --git a/src/Frontend/Parser/Posn.hi b/src/Frontend/Parser/Posn.hi deleted file mode 100644 index 9ed0dc8..0000000 Binary files a/src/Frontend/Parser/Posn.hi and /dev/null differ diff --git a/src/Frontend/Parser/Posn.o b/src/Frontend/Parser/Posn.o deleted file mode 100644 index 51c50f7..0000000 Binary files a/src/Frontend/Parser/Posn.o and /dev/null differ diff --git a/src/Frontend/Syntax.hi b/src/Frontend/Syntax.hi deleted file mode 100644 index 47bb172..0000000 Binary files a/src/Frontend/Syntax.hi and /dev/null differ diff --git a/src/Frontend/Syntax.hs b/src/Frontend/Syntax.hs index 969038a..8d97411 100644 --- a/src/Frontend/Syntax.hs +++ b/src/Frontend/Syntax.hs @@ -2,6 +2,7 @@ module Frontend.Syntax where import Frontend.Parser.Posn import qualified Data.Text as T +import Data.Text (Text) data FeExpr var = Ref var @@ -71,9 +72,9 @@ instance HasPosn (FeType var) where span sp ep x = SPType x (startPosn sp) (endPosn ep) data FeDecl var - = PatDecl (FePat var) (FeRhs var) + = PatDecl (FePat var) (FeRhs var) | FunDecl var [FePat var] (FeRhs var) - | TySig var (FeType var) + | TySig [var] (FeType var) deriving (Eq, Show, Ord) data FeRhs var @@ -109,4 +110,34 @@ data NamespacedItem var data ModuleItem var = ModDecl (FeDecl var) | ModImport (ModuleImport var) - deriving (Eq, Show, Ord) \ No newline at end of file + deriving (Eq, Show, Ord) + +data ParsedVar + = UnqualVar + { varId :: Text + , varBegin :: Posn + , varEnd :: Posn + } + | QualVar + { varId :: Text + , varPrefix :: Text + , varBegin :: Posn + , varEnd :: Posn + } + | ModId + { varId :: Text + , varBegin :: Posn + , varEnd :: Posn + } + deriving (Eq, Show, Ord) + +toModId :: ParsedVar -> ParsedVar +toModId x@ModId{} = x +toModId (UnqualVar x y z) = ModId x y z +toModId (QualVar id pref b e) = ModId (pref <> T.singleton '.' <> id) b e + +instance HasPosn ParsedVar where + startPosn = varBegin + endPosn = varEnd + + span sp ep s = s { varBegin = startPosn sp, varEnd = endPosn ep } \ No newline at end of file diff --git a/src/Frontend/Syntax.o b/src/Frontend/Syntax.o deleted file mode 100644 index 9c53603..0000000 Binary files a/src/Frontend/Syntax.o and /dev/null differ diff --git a/src/Main.hi b/src/Main.hi deleted file mode 100644 index 51f1c32..0000000 Binary files a/src/Main.hi and /dev/null differ diff --git a/src/Main.hs b/src/Main.hs index 31348eb..08056b0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -27,7 +27,7 @@ testParse s = Main.lex print parseMod (Lbs.fromStrict (T.encodeUtf8 (T.pack s))) testLex :: String -> IO () testLex s = Main.lex (const (pure ())) (scan []) (Lbs.fromStrict (T.encodeUtf8 (T.pack s))) - + lex :: (a -> IO ()) -> Alex a -> Lbs.ByteString -> IO () lex show cont arg = do let x = runAlex arg cont diff --git a/src/Main.o b/src/Main.o deleted file mode 100644 index c5cf209..0000000 Binary files a/src/Main.o and /dev/null differ