started alex/happy parser for core language

smucclaw · Feb 9, 2021 · faf5d62 · faf5d62
1 parent 52b615f
commit faf5d62
Show file tree

Hide file tree

Showing 10 changed files with 339 additions and 81 deletions.
diff --git a/src/Exec.hs b/src/Exec.hs
@@ -3,7 +3,7 @@
 module Exec where
 
 import Data.List
-import AbsSyntax
+import Syntax
 import Typing
 
 lift_uarith_op :: UArithOp -> Val -> Val

diff --git a/src/Lexer.x b/src/Lexer.x
@@ -0,0 +1,84 @@
+{
+{-# OPTIONS_GHC -XFlexibleContexts #-}
+
+module Lexer (
+  Token(..),
+  scanTokens
+) where
+
+import Control.Monad.Except
+
+}
+
+%wrapper "basic"
+
+$digit = 0-9
+$alpha = [a-zA-Z]
+$eol   = [\n]
+
+tokens :-
+
+  -- Whitespace insensitive
+  $eol                          ;
+  $white+                       ;
+
+  -- Comments
+  "#".*                         ;
+
+  -- Syntax
+  let                           { \s -> TokenLet }
+  True                          { \s -> TokenTrue }
+  False                         { \s -> TokenFalse }
+  Bool                          { \s -> TokenBool }
+  in                            { \s -> TokenIn }
+  Int                           { \s -> TokenInt }
+  $digit+                       { \s -> TokenNum (read s) }
+  "->"                          { \s -> TokenArrow }
+  \\                            { \s -> TokenLambda }
+  \=                            { \s -> TokenEq }
+  \<                            { \s -> TokenLt }
+  [\+]                          { \s -> TokenAdd }
+  [\-]                          { \s -> TokenSub }
+  [\*]                          { \s -> TokenMul }
+  \:                            { \s -> TokenColon }
+  \(                            { \s -> TokenLParen }
+  \)                            { \s -> TokenRParen }
+  $alpha [$alpha $digit \_ \']* { \s -> TokenSym s }
+
+{
+
+data Token 
+  = TokenLet
+  | TokenTrue
+  | TokenFalse
+  | TokenBool
+  | TokenIn
+  | TokenInt
+  | TokenLambda
+  | TokenNum Int
+  | TokenSym String
+  | TokenArrow
+  | TokenEq
+  | TokenLt
+  | TokenAdd
+  | TokenSub
+  | TokenMul
+  | TokenColon
+  | TokenLParen
+  | TokenRParen
+  | TokenEOF
+  deriving (Eq,Show)
+
+scanTokens :: String -> Except String [Token]
+scanTokens str = go ('\n',[],str) where 
+  go inp@(_,_bs,str) =
+    case alexScan inp 0 of
+     AlexEOF -> return []
+     AlexError _ -> throwError "Invalid lexeme."
+     AlexSkip  inp' len     -> go inp'
+     AlexToken inp' len act -> do
+      res <- go inp'
+      let rest = act (take len str)
+      return (rest : res)
+
+}
diff --git a/src/Main.hs b/src/Main.hs
@@ -1,5 +1,22 @@
 module Main where
 
+import Parser (parseProgram)
+import System.Environment
+
+process :: String -> IO ()
+process input = do
+  let ast = parseProgram input
+  case ast of
+    Right ast -> putStrLn (show ast)
+    Left err -> do
+      putStrLn "Parser Error:"
+      print err
+
 main :: IO ()
 main = do
-  putStrLn "hello world"
+  args <- getArgs
+  case args of
+    []      -> putStrLn "Usage: core-language <input file>"
+    [fname] -> do
+      contents <- readFile fname
+      process contents
diff --git a/src/Parser.y b/src/Parser.y
@@ -0,0 +1,91 @@
+{
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Parser (
+  parseExpr,
+  parseTokens,
+) where
+
+import Lexer
+import Syntax
+
+import Control.Monad.Except
+
+}
+
+-- Entry point
+%name expr Expr
+
+-- Lexer structure 
+%tokentype { Token }
+
+-- Parser monad
+%monad { Except String } { (>>=) } { return }
+%error { parseError }
+
+-- Token Names
+%token
+--    let   { TokenLet }
+    true  { TokenTrue }
+    false { TokenFalse }
+    Bool  {TokenBool}
+--    in    { TokenIn }
+    Int   {TokenInt}
+    NUM   { TokenNum $$ }
+    VAR   { TokenSym $$ }
+    '\\'  { TokenLambda }
+    '->'  { TokenArrow }
+--    '='   { TokenEq }
+    '<'   { TokenLt }
+    '+'   { TokenAdd }
+    '-'   { TokenSub }
+    '*'   { TokenMul }
+    ':'   { TokenColon }
+    '('   { TokenLParen }
+    ')'   { TokenRParen }
+
+-- Operators
+%left '<'
+%left '+' '-'
+%left '*'
+%right '->'
+%%
+
+Tp   : Bool                       { BoolT }
+     | Int                        { IntT }
+     | Tp '->' Tp                 { FunT $1 $3 }
+     | '(' Tp ')'                 { $2 }
+
+Expr : '\\' VAR ':' Tp '->' Expr   { FunE () $2 $4 $6 }
+     | Form                        { $1 }
+
+Form : Form '<' Form               { BinOpE () (BCompar BClt) $1 $3 }
+     | Form '+' Form               { BinOpE () (BArith BAadd) $1 $3 }
+     | Form '-' Form               { BinOpE () (BArith BAsub) $1 $3 }
+     | Form '*' Form               { BinOpE () (BArith BAmul) $1 $3 }
+     | Fact                        { $1 }
+
+Fact : Fact Atom                   { AppE () $1 $2 }
+     | Atom                        { $1 }
+
+Atom : '(' Expr ')'                { $2 }
+     | NUM                         { ValE () (IntV $1) }
+     | VAR                         { VarE () $1 0 }
+     | true                        { ValE () (BoolV True) }
+     | false                       { ValE () (BoolV False) }
+
+{
+
+parseError :: [Token] -> Except String a
+parseError (l:ls) = throwError (show l)
+parseError [] = throwError "Unexpected end of Input"
+
+parseExpr :: String -> Either String (Exp ())
+parseExpr input = runExcept $ do
+  tokenStream <- scanTokens input
+  expr tokenStream
+
+parseTokens :: String -> Either String [Token]
+parseTokens = runExcept . scanTokens
+
+}
diff --git a/src/RuleToTa.hs b/src/RuleToTa.hs
@@ -3,7 +3,7 @@
 module RuleToTa where
 import Data.List
 import AbsL
-import AbsSyntax
+import Syntax
 import TaToUppaal
 -- import ExampleInput
 
@@ -202,22 +202,22 @@ internalFieldTpToTp "Int" = IntT
 internalFieldTpToTp nm = ClassT (ClsNm nm)
 
 internalFieldToFieldDecl :: (String, String) -> FieldDecl
-internalFieldToFieldDecl (fnm, ftp) = FldDecl (FldNm fnm) (internalFieldTpToTp ftp)
+internalFieldToFieldDecl (fnm, ftp) = FieldDecl (FldNm fnm) (internalFieldTpToTp ftp)
 
 sdrToClassDecl :: SimpleDefRule -> ClassDecl (Maybe ClassName)
-sdrToClassDecl (DefRule cn scn flds) = ClsDecl (ClsNm cn) (ClsDef (Just (ClsNm scn)) (map internalFieldToFieldDecl flds))
+sdrToClassDecl (DefRule cn scn flds) = ClassDecl (ClsNm cn) (ClassDef (Just (ClsNm scn)) (map internalFieldToFieldDecl flds))
 
 ----------------------------------------------------------------------
 -- Translation Event Rules (internal representation) to Timed Automata
 ----------------------------------------------------------------------
 
-serToTransition :: SimpleEventRule -> [Transition]
+serToTransition :: SimpleEventRule -> [Transition Tp]
 serToTransition (EvRule2State rn gv pt act (Hence hcs)) =
   let start_loc = Lc gv
       end_loc = Lc (head hcs)
       clcstr = []    -- temporarily
       clreset = []   -- temporarily
-  in [Trans start_loc clcstr act clreset end_loc]
+  in [Trans start_loc (TransCond clcstr (ValE BoolT (BoolV True))) (TransAction act clreset Skip) end_loc]
 serToTransition (EvRule3State rn gv upon pt act (Hence hcs)) =
   let start_loc = Lc gv
       interm_loc = Lc rn
@@ -226,8 +226,8 @@ serToTransition (EvRule3State rn gv upon pt act (Hence hcs)) =
       clreset1 = []   -- temporarily
       clcstr2 = []    -- temporarily
       clreset2 = []   -- temporarily
-  in [Trans start_loc clcstr1 upon clreset1 interm_loc,
-      Trans interm_loc clcstr2 act clreset2 end_loc]
+  in [Trans start_loc (TransCond clcstr1 (ValE BoolT (BoolV True))) (TransAction upon clreset1 Skip) interm_loc,
+      Trans interm_loc (TransCond clcstr2 (ValE BoolT (BoolV True))) (TransAction act clreset2 Skip) end_loc]
 
 {-
  [
@@ -245,22 +245,22 @@ quotientByResult f (x:xs) =
       (pos, neg) = partition (\e -> ec == (f e)) xs 
   in (ec, (x:pos)) : quotientByResult f neg
 
-transitionsToTA :: (PartyName, [Transition]) -> TA t
+transitionsToTA :: (PartyName, [Transition Tp]) -> TA Tp
 transitionsToTA ((PtNm pn), trans) =
-  let locs = nub (concatMap (\(Trans l1 _ _ _ l2) -> [l1, l2]) trans)
-      chans = nub (concatMap (\(Trans _ _ act _ _) -> action_name act) trans)
+  let locs = nub (concatMap (\(Trans l1 _ _ l2) -> [l1, l2]) trans)
+      chans = nub (concatMap (\(Trans _ _ tract _) -> transition_action_name tract) trans)
       clcks = []   -- TODO
       init_loc = [Lc "Start"]   -- TODO
       invs = []    -- TODO
       lbls = []   -- TODO
   in TmdAut pn locs chans clcks trans init_loc invs lbls
 
 -- TODO: exact type parameter of TASys to be determined
-sersToTASys :: [SimpleEventRule] -> TASys t
+sersToTASys :: [SimpleEventRule] -> TASys Tp [a]
 sersToTASys sers =
   let ruleQuot = quotientByResult serPartyName sers
       transQuot = map (\(p, rls) -> (p, concatMap serToTransition rls)) ruleQuot
-  in TmdAutSys (map transitionsToTA transQuot)
+  in TmdAutSys (map transitionsToTA transQuot) []
 
 ----------------------------------------------------------------------
 
@@ -319,7 +319,7 @@ rewriteTree (Toplevel tops) = Toplevel $ do
 
 -- generate Uppaal code from L4 file
 -- for example:
--- genUppaal "../l4/deon_bike_meng_detail.l4" "/home/strecker/Systems/Uppaal/Examples/deon_bike_gen.xta"
+-- genUppaal "../../l4/deon_bike_meng_detail.l4" "/home/strecker/Systems/Uppaal/Examples/deon_bike_gen.xta"
 genUppaal :: String -> String -> IO ()
 genUppaal f_in f_out = runFile 2 pTops f_in f_out