Commit d24e2352 authored by matthew-eads's avatar matthew-eads
Browse files

multi-exps

parent d6d4b7ab
#Readme for Grammar Generator Prototype Version 2
#Readme for Grammar Generator Prototype
This is a much more simplified version of the original
grammar-generator prototype (which is in the mk1 branch).
......@@ -8,8 +8,8 @@ Build using `stack build` which should install all the dependencies
and use ghc to compile the source files in the src directory.
###Run:
The executable produced is `gg-mk2`, which takes a filename
as input. Running `stack exec gg-mk2 file.ast` will run the
The executable produced is `gg-proto`, which takes a filename
as input. Running `stack exec gg-proto file.ast` will run the
grammar generator with the AST specified in the given file.
The file needs to be a valid Haskell file describing the
AST of your program, `src/Imp.ast` is given as an example.
......
.stack-work/install/x86_64-linux/lts-5.4/7.10.3/bin/gg-mk2
\ No newline at end of file
name: gg-mk2
name: gg-proto
version: 0.1.0.0
synopsis: Second Version of the grammar-generator prototype for Siriusly
synopsis: Grammar-generator prototype for Siriusly
description: Please see README.md
homepage: https://github.cs.tufts.edu/siriusly/gg-proto
author: Matthew Eads
......@@ -8,7 +8,7 @@ build-type: Simple
extra-source-files: AST.hs
cabal-version: >=1.10
executable gg-mk2
executable gg-proto
hs-source-dirs: src
main-is: AST.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
......
{-
- Main module for grammar generator prototype
- Converts a Haskell AST data structure specified
- in a given file to a yacc-like grammar to produce
- the language described by the AST
- by Matthew Eads, March 2016
-}
module Main where
import System.IO
import System.Environment
......@@ -6,30 +14,43 @@ import Language.Haskell.TH.Syntax
import Debug.Trace
type Grammar = String
-- name , Constructor name,
-- ex: Exp , [(SET , [
-- name , [constructions]
-- ex: Exp ,
data DecT = DecT String [RHS] deriving Show
-- Constructor name, [
data RHS = RHS String [String] deriving Show
isDataD :: Dec -> Bool
isDataD (DataD _ _ _ _ _) = True
isDataD _ = False
-- Converts a Haskell Declaration to our DecT type
-- (mostly just strips unessecary data and converts Names to Strings)
dataDToDecT :: Dec -> DecT
dataDToDecT (DataD cxt name tvb constructors derives) =
DecT (showName name) (map conToRHS constructors)
dataDToDecT _ = error "dataDtoDecT applied to non-data dec"
-- Converts Haskell Con type (right hand sides in a data declaration)
conToRHS :: Con -> RHS
conToRHS (NormalC n stypes) = RHS (showName n) (map stypeToString stypes)
conToRHS _ = error "conToRHS on not-NormalC not supported"
-- Tuples and other types not supported
stypeToString :: StrictType -> String
stypeToString (_, (ConT n)) = showName n
stypeToString (_, (AppT ListT t)) = (stypeToString (IsStrict, t)) ++ "*"
stypeToString (_, t) = error ("stypeToString of " ++ (show t) ++ " not yet supported")
showDecT :: DecT -> String
showDecT (DecT n rhs) = n ++ " [" ++ (foldr (\s a -> if a == "" then s else s ++ ", " ++ a) "" (map showRHS rhs)) ++ "] "
showRHS :: RHS -> String
showRHS (RHS n types) = n ++ " [" ++ (foldr (\s a -> if a == "" then s else s ++ ", " ++ a) "" types) ++ "] "
-- Indicates if the given RHS construction is unique in the entire
-- data declaration. data A = X E | Y E E: X,Y are unique, not so
-- in data A = X E | Y E
isUnique :: [RHS] -> RHS -> Bool
isUnique rules (RHS n types) =
foldr (\(RHS name ts) acc -> acc && (name == n ||ts /= types)) True rules
......@@ -37,39 +58,71 @@ isUnique rules (RHS n types) =
myappend :: String -> String -> String
myappend s1 s2 = s1 ++ " " ++ s2
-- produces a string of form {$1 $2 ... $n}
makeNums :: Int -> Int -> String
makeNums i 0 = "}"
makeNums _ 0 = "}"
makeNums i n = " $"++(show (i-n+1))++(makeNums i (n-1))
-- produces the construction -> {EXP $1 $2} from the given RHS rule
rrhs :: RHS -> String
rrhs (RHS s ts) = "\t{" ++ s ++ (makeNums (length ts) (length ts))
isMulti :: String -> Bool
isMulti "*" = True
isMulti [] = False
isMulti (s:r) = isMulti r
fixMultis :: String -> String
fixMultis s = if isMulti s then "Multi" ++ (strip s)
else s
rhsToRule :: [RHS] -> RHS -> String
rhsToRule rules = \(RHS s ts) ->
let ts' = (map fixMultis ts) in
(if (isUnique rules (RHS s ts))
then foldr myappend "" ts'
else "\"" ++ s ++ "\" " ++ (foldr myappend "" ts')) ++ rrhs (RHS s ts')
strip :: String -> String
strip ('*':[]) = []
strip (s:r) = s:(strip r)
strip [] = []
getMultiRules :: RHS -> String -> String
getMultiRules (RHS n ts) acc =
let multis = filter (\s -> (last s) == '*') ts
multiRule s = let name = "Multi" ++ (strip s)
in name ++ ": " ++ (strip s) ++ " " ++ name ++
"\t{$1:$2}\n" ++ (makeTab name) ++ "|\t{[]}"
in (foldr (\s x -> "\n" ++ s ++ "\n" ++ x) "" (map multiRule multis)) ++ acc
makeTab :: String -> String
makeTab s = let helper 0 a = a
helper n a = helper (n-1) (" " ++ a)
in helper (length s) ""
-- converts the given DecT declaration to a grammar rule which
-- will in turn produce the given declaration.
decTToRule :: DecT -> String
decTToRule (DecT n rhs) =
let rhsToRule = \(RHS s ts) -> (if (isUnique rhs (RHS s ts))
then foldr myappend "" ts
else "\"" ++ s ++ "\" " ++ (foldr myappend "" ts))++ rrhs (RHS s ts)
rhsStrings = map rhsToRule rhs
tab = let makeTab 0 a = a
makeTab n a = makeTab (n - 1) (" " ++ a)
in makeTab (length n) ""
let multiRules = foldr getMultiRules "" rhs
rhsStrings = map (rhsToRule rhs) rhs
tab = makeTab n
in n ++ ": " ++ (head rhsStrings) ++ "\n" ++
(foldr (\r acc -> tab ++ "| " ++ r ++ "\n" ++ acc) "" (tail rhsStrings))
(foldr (\r acc -> tab ++ "| " ++ r ++ "\n" ++ acc) "" (tail rhsStrings)) ++ multiRules
-- Creates the grammar rules from the declarations
makeRules :: [DecT] -> String
makeRules decs = foldr (\dec acc -> (decTToRule dec) ++ "\n" ++ acc) "" decs
stypeToString :: StrictType -> String
stypeToString (_, (ConT n)) = showName n
stypeToString (_, (AppT ListT t)) = (stypeToString (IsStrict, t)) ++ "*"
stypeToString (_, t) = error ("stypeToString of " ++ (show t) ++ " not yet supported")
parseAstDecs :: String -> Grammar
parseAstDecs s = let decs = case parseDecs s of
(Right ds) -> ds
(Left err) -> (trace err undefined)
dataDs = filter isDataD decs
dataNames = foldr (\s a -> if a == "" then s else s ++ "\n" ++ a) "" (map showDecT (map dataDToDecT dataDs))
rules = makeRules (map dataDToDecT dataDs)
in rules
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment