mirror of
https://github.com/grin-compiler/grin.git
synced 2024-09-11 15:37:54 +03:00
Parser: store and update only accept node and vars.
This commit is contained in:
Andor Penzes
parent
edccfe9aea
commit
81322fe8cb
@ -1,10 +1,10 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TupleSections, LambdaCase #-}
|
||||
|
||||
module ParseGrin (parseGrin, parseDef, parseExpr) where
|
||||
|
||||
import Data.Void
|
||||
import Control.Applicative (empty)
|
||||
import Control.Monad (void)
|
||||
import Control.Monad (void, mzero)
|
||||
import Text.Megaparsec
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
import Text.Megaparsec.Char as C
|
||||
@ -75,11 +75,17 @@ ifThenElse i = do
|
||||
]
|
||||
|
||||
simpleExp i = SReturn <$ kw "pure" <*> value <|>
|
||||
SStore <$ kw "store" <*> value <|>
|
||||
SStore <$ kw "store" <*> satisfyM nodeOrVar value <|>
|
||||
SFetchI <$ kw "fetch" <*> var <*> optional (between (char '[') (char ']') $ fromIntegral <$> integer) <|>
|
||||
SUpdate <$ kw "update" <*> var <*> value <|>
|
||||
SUpdate <$ kw "update" <*> var <*> satisfyM nodeOrVar value <|>
|
||||
SBlock <$ kw "do" <*> (L.indentGuard sc GT i >>= expr) <|>
|
||||
SApp <$> primNameOrDefName <*> some simpleValue
|
||||
where
|
||||
nodeOrVar = \case
|
||||
ConstTagNode _ _ -> True
|
||||
VarTagNode _ _ -> True
|
||||
Var _ -> True
|
||||
_ -> False
|
||||
|
||||
primNameOrDefName = ('_':) <$ char '_' <*> var <|> var
|
||||
|
||||
@ -107,6 +113,14 @@ literal = (try $ LFloat . realToFrac <$> signedFloat) <|>
|
||||
LInt64 . fromIntegral <$> signedInteger <|>
|
||||
LBool <$> (True <$ kw "#True" <|> False <$ kw "#False")
|
||||
|
||||
satisfyM :: (a -> Bool) -> Parser a -> Parser a
|
||||
satisfyM pred parser = do
|
||||
x <- parser
|
||||
if pred x
|
||||
then pure x
|
||||
else mzero
|
||||
|
||||
|
||||
grinModule :: Parser Exp
|
||||
grinModule = Program <$> some def <* sc <* eof
|
||||
|
||||
|
||||
@ -22,7 +22,7 @@ spec = do
|
||||
(newVar "y'" int64_t) <>
|
||||
(newVar "x'" int64_t)
|
||||
let before = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -36,7 +36,7 @@ spec = do
|
||||
let teAfter = extend teBefore $
|
||||
newVar "v'" int64_t
|
||||
let after = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
v' <- do
|
||||
case v of
|
||||
@ -57,7 +57,7 @@ spec = do
|
||||
(newVar "y'" int64_t) <>
|
||||
(newVar "x'" int64_t)
|
||||
let before = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -68,7 +68,7 @@ spec = do
|
||||
pure m0
|
||||
|]
|
||||
let after = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -89,7 +89,7 @@ spec = do
|
||||
(newVar "y1'" int64_t) <>
|
||||
(newVar "x1'" int64_t)
|
||||
let before = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -110,7 +110,7 @@ spec = do
|
||||
newVar "v'" int64_t <>
|
||||
newVar "v1'" int64_t
|
||||
let after = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
v' <- do
|
||||
case v of
|
||||
@ -142,7 +142,7 @@ spec = do
|
||||
newVar "z1'" float_t <>
|
||||
newVar "x1'" int64_t
|
||||
let before = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -162,7 +162,7 @@ spec = do
|
||||
let teAfter = extend teBefore $
|
||||
newVar "v'" int64_t
|
||||
let after = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
v' <- do
|
||||
case v of
|
||||
@ -192,7 +192,7 @@ spec = do
|
||||
newVar "z1'" int64_t <>
|
||||
newVar "x1'" int64_t
|
||||
let before = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
@ -212,7 +212,7 @@ spec = do
|
||||
let teAfter = extend teBefore $
|
||||
newVar "v1'" int64_t
|
||||
let after = [expr|
|
||||
m0 <- store 3
|
||||
m0 <- store (CNone)
|
||||
u <- do
|
||||
case v of
|
||||
(Ffoo a) -> y' <- foo a
|
||||
|
||||
@ -15,24 +15,6 @@ import Assertions
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "constant folding" $ do
|
||||
it "inside bind" $ do
|
||||
let before =
|
||||
[expr|
|
||||
x <- store a
|
||||
y <- store b
|
||||
u <- pure 5
|
||||
store u
|
||||
pure u
|
||||
|]
|
||||
let after =
|
||||
[expr|
|
||||
x <- store a
|
||||
y <- store b
|
||||
store 5
|
||||
pure 5
|
||||
|]
|
||||
constantFolding before `sameAs` after
|
||||
|
||||
it "last bind" $ do
|
||||
let before =
|
||||
[expr|
|
||||
@ -52,13 +34,13 @@ spec = do
|
||||
it "unused variable" $ do
|
||||
let before =
|
||||
[expr|
|
||||
x <- store 3
|
||||
x <- store (CNone)
|
||||
u <- pure 4
|
||||
pure 5
|
||||
|]
|
||||
let after =
|
||||
[expr|
|
||||
x <- store 3
|
||||
x <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
constantFolding before `sameAs` after
|
||||
|
||||
@ -33,7 +33,7 @@ spec = do
|
||||
it "Example from Figure 4.11" $ do
|
||||
let before =
|
||||
[expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
case (t a1 a2) of
|
||||
CNil -> pure 3
|
||||
(CCons x xs) -> store x
|
||||
@ -42,7 +42,7 @@ spec = do
|
||||
|]
|
||||
let after =
|
||||
[expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
case t of
|
||||
CNil -> pure 3
|
||||
CCons -> store a1
|
||||
|
||||
@ -18,26 +18,26 @@ spec = do
|
||||
|
||||
it "Example from Figure 4.17" $ do
|
||||
let before = [expr|
|
||||
l1 <- store 0
|
||||
l1 <- store (CNone)
|
||||
p <- store (CCons a b)
|
||||
u' <- foo 1 3
|
||||
q <- store (CInt u')
|
||||
x <- pure (CCons q p)
|
||||
l2 <- store 1
|
||||
l2 <- store (CNone)
|
||||
pure 2
|
||||
|]
|
||||
let after = [expr|
|
||||
l1 <- store 0
|
||||
l1 <- store (CNone)
|
||||
t1 <- pure CCons
|
||||
p <- store (t1 a b)
|
||||
x' <- store 1
|
||||
y' <- store 3
|
||||
x' <- pure 1
|
||||
y' <- pure 3
|
||||
u' <- foo x' y'
|
||||
t2 <- pure CInt
|
||||
q <- store (t2 u')
|
||||
t3 <- pure CCons
|
||||
x <- pure (t3 q p)
|
||||
l2 <- store 1
|
||||
l2 <- store (CNone)
|
||||
pure 2
|
||||
|]
|
||||
registerIntroduction 0 before `sameAs` after
|
||||
|
||||
@ -15,31 +15,31 @@ spec :: Spec
|
||||
spec = do
|
||||
it "Example from Figure 4.16" $ do
|
||||
let before = [expr|
|
||||
l0 <- store 0
|
||||
l0 <- store (CNone)
|
||||
p <- store (CCons 1 2)
|
||||
t <- fetch p[0]
|
||||
a1 <- fetch p[1]
|
||||
a2 <- fetch p[2]
|
||||
l1 <- store 1
|
||||
l1 <- store (CNone)
|
||||
case t of
|
||||
CNil -> l3 <- store 2
|
||||
CNil -> l3 <- store (CNone)
|
||||
unit 2
|
||||
CCons -> l4 <- store 3
|
||||
CCons -> l4 <- store (CNone)
|
||||
l5 <- store a1
|
||||
l6 <- store a2
|
||||
pure 3
|
||||
|]
|
||||
let after = [expr|
|
||||
l0 <- store 0
|
||||
l0 <- store (CNone)
|
||||
p <- store (CCons 1 2)
|
||||
t <- fetch p[0]
|
||||
l1 <- store 1
|
||||
l1 <- store (CNone)
|
||||
case t of
|
||||
CNil -> l3 <- store 2
|
||||
CNil -> l3 <- store (CNone)
|
||||
pure 2
|
||||
CCons -> a1a1 <- fetch p[1]
|
||||
a2a1 <- fetch p[2]
|
||||
l4 <- store 3
|
||||
l4 <- store (CNone)
|
||||
l5 <- store a1a1
|
||||
l6 <- store a2a1
|
||||
pure 3
|
||||
|
||||
@ -17,33 +17,33 @@ spec :: Spec
|
||||
spec = do
|
||||
it "Example from Figure 4.13" $ do
|
||||
let before = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
(t a1 a2 a3) <- fetch p
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
let after = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
t <- fetch p[0]
|
||||
a1 <- fetch p[1]
|
||||
a2 <- fetch p[2]
|
||||
a3 <- fetch p[3]
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
splitFetch before `sameAs` after
|
||||
|
||||
it "Example from Figure 4.14" $ do
|
||||
let before = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
(CInt x) <- fetch p
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
let after = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
x <- fetch p[1]
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
splitFetch before `sameAs` after
|
||||
@ -51,17 +51,17 @@ spec = do
|
||||
it "Example from Figure 4.15" $ do
|
||||
-- TODO Include hpt-result with t \elem { CPair }
|
||||
let before = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
(t a1 a2) <- fetch p
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
let after = [expr|
|
||||
l1 <- store 3
|
||||
l1 <- store (CNone)
|
||||
t <- pure CPair
|
||||
a1 <- fetch p[1]
|
||||
a2 <- fetch p[2]
|
||||
l2 <- store 4
|
||||
l2 <- store (CNone)
|
||||
pure 5
|
||||
|]
|
||||
splitFetch before `sameAs` after
|
||||
|
||||
@ -35,13 +35,13 @@ spec = do
|
||||
mempty
|
||||
|
||||
let before = [expr|
|
||||
l0 <- store 0
|
||||
l0 <- store (CNone)
|
||||
v <- pure (Cq p1 p2)
|
||||
l1 <- store v
|
||||
pure 1
|
||||
|]
|
||||
let after = [expr|
|
||||
l0 <- store 0
|
||||
l0 <- store (CNone)
|
||||
(v0 v1 v2) <- pure (Cq p1 p2)
|
||||
l1 <- store (v0 v1 v2)
|
||||
pure 1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user