Skip to content

Instantly share code, notes, and snippets.

@jda0

jda0/proc.hs

Created January 22, 2019 12:31
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jda0/16f302039dfa49ce214ee8d960195ca3 to your computer and use it in GitHub Desktop.
Save jda0/16f302039dfa49ce214ee8d960195ca3 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
proc.hs
module Proc where
import Prelude hiding (Num, and, lookup, map)
import Control.Applicative hiding (empty)
import Control.Arrow (second)
import Control.Monad
import Data.Functor.Identity (Identity)
import Data.Map.Lazy
import Data.Maybe
import Text.Megaparsec hiding (State, parse)
import qualified Text.Megaparsec.Lexer as L
import Text.Megaparsec.String
-- # Revisions
{-
- V1.2.1 01 May 2017
- Added State call fallback to prevent errors when using undeclared
variables known to a previous State. Further improvements -
especially reducing the memory footprint of the semantic functions -
could be made by replacing `Store` with `State` entirely except in
`Block`s. [:323]
- `Block`-private `Scope`s are now empty to reduce memory footprint,
as only the keys are needed to make a comparison. Further memory
footprint reductions could be made by changing the structure of
private `Store`s to ([Var], [Pname]) [:369, :377]
- Changed the scoping of `proc`s to be performed after all `var`s
and `proc`s have been declared to allow recursion and look-
forward. [:378 - :372]
- Mixed-scope state applicator now falls back on the current state if
the child scope cannot be found due to recursion (`Store` is only
set in the top-most declaration) [:368, :414]
- Removed some unused symbols
- TODO: Replace usage of `map` with `fmap` in next version [:398]
- TODO: Improve documentation
-}
--
-- # Grammar
{-
The grammar for Proc is as follows:
I ::= I Ib | Ia
Ia ::= a | b | ... | z | _
Ib ::= Ia | 0 | 1 | ... | 9
V ::= I
P ::= I
A ::= Aa + A | Aa - A | Aa
Aa ::= Ab * Aa | Ab
Ab ::= N | V | ( A )
B ::= Ba & B | Ba
Ba ::= Neg Ba | Bb
Bb ::= TRUE | FALSE | ( B ) | A <= A | A = A
Dv ::= var V := A ; Dv | E
Dp ::= proc P := Sa ; Dp | E
Sb ::= if B then S else S | while B do S | begin Dv Dp S end
Ss ::= skip | call P | x := A | ( S )
Sa ::= Sb | Ss
Sc ::= Sa ; S
S ::= Sb | Sc | Sa
-}
--
-- # Parser
-- ## Typedefs
type Num = Integer
type Var = String
type Pname = String
type DecV = [(Var, Aexp)]
type DecP = [(Pname, Stm)]
data Aexp = N Num | V Var | Mult Aexp Aexp | Add Aexp Aexp
| Sub Aexp Aexp
deriving (Show)
data Bexp = TRUE | FALSE | Neg Bexp | And Bexp Bexp
| Le Aexp Aexp | Eq Aexp Aexp
deriving (Show)
data Stm = Skip | Ass Var Aexp | Comp Stm Stm
| If Bexp Stm Stm | While Bexp Stm
| Block DecV DecP Stm | Call Pname
deriving (Show)
-- ## Lexer setup
spaceConsumer :: ParsecT Dec String Identity ()
spaceConsumer = L.space sp lc bc where
sp = void spaceChar
lc = L.skipLineComment "//"
bc = L.skipBlockComment "/*" "*/"
lexeme :: ParsecT Dec String Identity a
-> ParsecT Dec String Identity a
lexeme = L.lexeme spaceConsumer
symbol :: String -> ParsecT Dec String Identity String
symbol' :: String -> ParsecT Dec String Identity String
symbol = L.symbol spaceConsumer
symbol' = L.symbol' spaceConsumer
-- ## Lexeme Parsers
-- ### Parentheses
parens :: ParsecT Dec String Identity a
-> ParsecT Dec String Identity a
parens x = lexeme (between (symbol "(") (symbol ")") x)
<?> "parens"
-- ### Integers
num :: Parser Num
num = lexeme L.integer <?> "num"
-- ### Identity Names
-- Form of this function body inspired by
-- https://hackage.haskell.org/package/dotenv-0.3.0.3/src/src/Configuration/Dotenv/Parse.hs
ident :: ParsecT Dec String
Data.Functor.Identity.Identity String
ident = liftM2 (:) (letterChar <|> char '_')
(many $ try
(letterChar <|> char '_' <|> digitChar))
<?> "ident"
var :: Parser Var
var = lexeme ident <?> "var"
pname :: Parser Pname
pname = lexeme ident <?> "pname"
-- ## Declaration Block Parsers
-- ### Variable Declaration Blocks
decv :: Parser DecV
decv = many (try decv') <?> "decv" where
decv' = (,) <$> var' <*> a' <* symbol ";" <?> "decvi"
var' = symbol' "var" *> var <* symbol' ":="
<?> "decvv"
a' = aexp <?> "decva"
-- ### Procedure Declaration Blocks
decp :: Parser DecP
decp = many (try decp') <?> "decp" where
decp' = (,) <$> var' <*> s' <* symbol ";" <?> "decpi"
var' = symbol' "proc" *> pname <* symbol' "is"
<?> "decpv"
s' = stm' <?> "decps"
-- ## Expression Parsers
-- ### Arithmetic Expressions
aexp :: Parser Aexp
aexp = aexp0 <?> "aexp" where
-- Lowest precedence
aexp0 = try (Add <$> aexp1 <* symbol "+" <*> aexp0)
<|> try (Sub <$> aexp1 <* symbol "-" <*> aexp0)
<|> aexp1
aexp1 = try (Mult <$> aexp2 <* symbol "*" <*> aexp1)
<|> aexp2
-- Highest precedence & symbols
aexp2 = (N <$> num)
<|> (V <$> var)
<|> parens aexp
-- ### Boolean Expressions
bexp :: Parser Bexp
bexp = bexp0 <?> "bexp" where
-- Lowest precedence
bexp0 = try (And <$> bexp1 <* symbol "&" <*> bexp0)
<|> bexp1
bexp1 = try (Neg <$ symbol "!" <*> bexp1)
<|> bexp2
-- Highest precedence & symbols
bexp2 = (TRUE <$ symbol' "true")
<|> (FALSE <$ symbol' "false")
<|> parens bexp
<|> try (Le <$> aexp <* symbol "<=" <*> aexp)
<|> try (Eq <$> aexp <* symbol "=" <*> aexp)
-- ## Statement Parsers
-- ### Block Statements
stmb :: Parser Stm
stmb = (If <$ symbol' "if" <*> bexp
<* symbol' "then" <*> stm
<* symbol' "else" <*> stm
<?> "if")
<|> (While <$ symbol' "while" <*> bexp
<* symbol' "do" <*> stm
<?> "while")
<|> (Block <$ symbol' "begin" <*> decv
<*> decp <*> stm
<* symbol' "end"
<?> "block")
-- ### Inline Statements
stma :: Parser Stm
stma = (Skip <$ symbol' "skip"
<?> "skip")
<|> (Call <$ symbol' "call" <*> pname
<?> "call")
<|> (try (Ass <$> var <* symbol ":=" <*> aexp)
<?> "ass")
<|> parens stm <?> "parens'"
-- ### Single Statements
stm' :: Parser Stm
stm' = stmb <|> stma
-- ### Composite Statements
comp :: Parser Stm
comp = try (Comp <$> stm' <* symbol ";"
<*> stm)
<?> "comp"
-- ### General Statements
stm :: Parser Stm
stm = stmb <|> comp <|> stma
-- ### Outermost Statement Parser
prog :: Parser Stm
prog = spaceConsumer *> stm
-- ## Parser Applicators
parse :: String -> Stm
parse = fromJust . parseMaybe prog
parseDebug :: String -> IO ()
parseDebug x = case runParser prog "" x of
Left err -> putStr (parseErrorPretty err)
Right f -> print f
--
-- # Semantic Functions
-- ## Typedefs
{-# ANN module "HLint: ignore Use camelCase" #-}
type T = Bool
type Z = Integer
type State = Var -> Z
data Scope = Scope (Map Pname (Stm, Maybe Scope))
(Map Var (Maybe Z)) State
-- ## Expression Evaluation
-- ### Arithmetic Expressions
aexpEval :: Aexp -> Scope -> Maybe Z
aexpEval = aee where
aee (N a) _ = Just a
aee (V a ) s = svLookup s a
aee (Mult a b) s = f' (*) a b s
aee (Add a b) s = f' (+) a b s
aee (Sub a b) s = f' (-) a b s
f' g a b s = pure g <*> aee a s <*> aee b s
-- ### Boolean Expressions
bexpEval :: Bexp -> Scope -> T
bexpEval = bee where
bee TRUE _ = True
bee FALSE _ = False
bee (And a b) s = bee a s && bee b s
bee (Neg a ) s = not $ bee a s
bee (Le a b) s = justAee a s <= justAee b s
bee (Eq a b) s = justAee a s == justAee b s
justAee a = fromJust . aexpEval a
-- ## Scope Manipulation
-- ### Scope Lookup
svLookup :: Scope -> Var -> Maybe Z
spLookup :: Scope -> Pname -> (Stm, Maybe Scope)
svLookup (Scope _ vs s) v = fromMaybe (Just $ s v) $ lookup v vs
spLookup (Scope ps _ _) = (!) ps
-- ### Insert Procedures
-- ### Insert Variables
-- ## Generic State Applicator
s_generic :: (Stm -> Scope -> Scope)
-> Stm -> State -> State
s_generic a f s v = fromJust $ svLookup (g' a f s v) v where
g' :: (Stm -> Scope -> Scope)
-> Stm -> State -> Var -> Scope
g' a' f' s' v' = a' f' (Scope empty
(singleton v' . Just . s' $ v') s')
-- ## Default Scope Applicator
siDefault :: (Stm -> Scope -> Scope) -> Stm -> Scope ->
Scope
siDefault _ Skip _ = Scope empty empty $ const 0
siDefault _ (Ass v a)
(Scope ps vs s) = Scope ps
(insert v (aexpEval a (Scope ps vs s)) vs) s
siDefault i (Comp a b) s = i b (i a s)
siDefault i (If c f g) s = i (if bexpEval c s then f else g) s
siDefault i (While c f) s = if bexpEval c s
then i (While c f) (i f s)
else s
siDefault i (Block v p f)
s@(Scope ps vs sc) =
let addPs :: DecP -> (Scope, Scope) -> (Scope, Scope)
addPs [] ss = ss
addPs ((q, qf) : qs)
(Scope po vo so,
Scope pp vp sp) = addPs qs
(Scope (insert q (qf, Nothing) po) vo so,
Scope (insert q (Skip, Nothing) pp) vp sp)
addVs :: DecV -> (Scope, Scope) -> (Scope, Scope)
addVs [] ss = ss
addVs ((u, ua) : us)
(so@(Scope po vo to),
Scope pp vp tp) = addVs us (Scope po
(insert u (aexpEval ua so) vo) to,
Scope pp
(insert u Nothing vp) tp)
rescopePs :: (Scope, Scope) -> (Scope, Scope)
rescopePs
(so@(Scope po vo to),
sp) = (Scope (setScope so po) vo to, sp)
setScope ss = map (second (Just . fromMaybe ss))
sa :: (Scope, Scope)
sa = rescopePs .
addPs p $ addVs v
(s, Scope empty empty $ const 0)
(Scope pps pvs _) = snd sa
(Scope fp fv _) = i f $ fst sa
in Scope (difference fp pps `union` ps)
(difference fv pvs `union` vs) sc
siDefault _ _ _ = undefined
-- ## Dynamic-scope State Applicator
s_dynamic :: Stm -> State -> State
s_dynamic = s_generic d' where
d' :: Stm -> Scope -> Scope
d' (Call p) s = let (p', _) = spLookup s p
in d' p' s
d' f s = siDefault d' f s
-- ## Mixed-scope State Applicator
s_mixed :: Stm -> State -> State
s_mixed = s_generic m' where
m' :: Stm -> Scope -> Scope
m' (Call p)
s@(Scope _ vs sc) = let (p', s') = spLookup s p
(Scope ps' _ _) = fromMaybe s s'
in m' p' (Scope ps' vs sc)
m' f s = siDefault m' f s
-- ## Static-scope State Applicator
s_static :: Stm -> State -> State
s_static = s_generic s' where
s' (Call _) s = s
s' f s = siDefault s' f s
--
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment