Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Jeanne-Marie Musca
gg-proto
Commits
0a2ede14
Commit
0a2ede14
authored
Mar 10, 2016
by
matthew-eads
Browse files
better multis
parent
d24e2352
Changes
8
Hide whitespace changes
Inline
Side-by-side
src/
Imp.ast
→
Imp.ast
View file @
0a2ede14
...
@@ -9,7 +9,7 @@ data AST = Expression Exp
...
@@ -9,7 +9,7 @@ data AST = Expression Exp
data Exp = SET ID Exp
data Exp = SET ID Exp
| IF SimpleExp Exp Exp
| IF SimpleExp Exp Exp
| WHILE SimpleExp Exp
| WHILE SimpleExp Exp
| BEGIN
[Exp]
| BEGIN
(List1 Exp)
data BinOp = Plus SimpleExp SimpleExp
data BinOp = Plus SimpleExp SimpleExp
| Mult SimpleExp SimpleExp
| Mult SimpleExp SimpleExp
...
@@ -20,7 +20,7 @@ data BinOp = Plus SimpleExp SimpleExp
...
@@ -20,7 +20,7 @@ data BinOp = Plus SimpleExp SimpleExp
data SimpleExp =
data SimpleExp =
Lit Int
Lit Int
| Var ID
| Var ID
| Apply ID
[SimpleExp]
| Apply ID
(List0 Exp)
| BinOp BinOp
| BinOp BinOp
| AGet SimpleExp SimpleExp --(arr[i])
| AGet SimpleExp SimpleExp --(arr[i])
| ASet SimpleExp SimpleExp SimpleExp --(set arr[i] j)
| ASet SimpleExp SimpleExp SimpleExp --(set arr[i] j)
...
...
Tiger.ast
0 → 100644
View file @
0a2ede14
module TigAST where
type Pos = Int
type Line = Int
data Symbol = SYM String Pos Line
data Tyex = TYID Symbol
| ARRAY Symbol
| RECORD [(Symbol, Symbol)]
data Value = INT Int
| STRING String
data Lvalue = VAR Symbol
| DOT Lvalue Symbol
| SUBSCRIPT Lvalue Exp
data Exp = LVAL Lvalue
| NIL
| LITERAL Value
| SEQ [Exp]
| NEG Exp
| CALL Symbol [Exp]
| BINOP Exp Oper Exp
| MAKEARR Symbol Exp Exp
| MAKEREC Symbol [(Symbol, Exp)]
| ASSIGN Lvalue Exp
| IF Exp Exp (Maybe Exp)
| WHILE Exp Exp
| FOR Symbol Exp Exp Exp
| LET [Decl] [Exp]
| BREAK
data Decl = TYDECL Symbol Tyex
| VARDECL Symbol (Maybe Symbol) Exp
| FUNDECL Symbol (Maybe [(Symbol, Symbol)]) (Maybe Symbol) Exp
data Oper = PLUS | MINUS | TIMES | DIV | EQ | NEQ | LT | LE | GT | GE | AND | OR
bad.ast
0 → 100644
View file @
0a2ede14
data Stmt = IF Conditional Stmt Stmt -- if c e1 e2 (returns unit type)
| Set String Int -- x = y
| Exp
data Conditional = Equal Exp Exp -- x = y
| TernaryIf Conditional Exp Exp -- if c e1 e2 (returns e1 or e2)
data Exp = Var String
| Lit Int
gg-proto.cabal
View file @
0a2ede14
...
@@ -5,15 +5,15 @@ description: Please see README.md
...
@@ -5,15 +5,15 @@ description: Please see README.md
homepage: https://github.cs.tufts.edu/siriusly/gg-proto
homepage: https://github.cs.tufts.edu/siriusly/gg-proto
author: Matthew Eads
author: Matthew Eads
build-type: Simple
build-type: Simple
extra-source-files: AST.hs
extra-source-files: AST.hs
Unique.hs
cabal-version: >=1.10
cabal-version: >=1.10
executable gg-proto
executable gg-proto
hs-source-dirs: src
hs-source-dirs: src
main-is: AST.hs
main-is: AST.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N
-Wall
build-depends: base, array, haskell-src-meta, haskell-src-exts,
build-depends: base, array, haskell-src-meta, haskell-src-exts,
haskell-src, template-haskell
haskell-src, template-haskell
, regex-compat, containers, Unique
default-language: Haskell2010
default-language: Haskell2010
source-repository head
source-repository head
...
...
src/AST.hs
View file @
0a2ede14
...
@@ -12,6 +12,9 @@ import System.Environment
...
@@ -12,6 +12,9 @@ import System.Environment
import
Language.Haskell.Meta.Parse
import
Language.Haskell.Meta.Parse
import
Language.Haskell.TH.Syntax
import
Language.Haskell.TH.Syntax
import
Debug.Trace
import
Debug.Trace
import
Text.Regex
import
Data.List.Unique
import
Data.List
type
Grammar
=
String
type
Grammar
=
String
-- name , [constructions]
-- name , [constructions]
...
@@ -20,26 +23,49 @@ data DecT = DecT String [RHS] deriving Show
...
@@ -20,26 +23,49 @@ data DecT = DecT String [RHS] deriving Show
-- Constructor name, [
-- Constructor name, [
data
RHS
=
RHS
String
[
String
]
deriving
Show
data
RHS
=
RHS
String
[
String
]
deriving
Show
list0
=
mkName
"List0"
list1
=
mkName
"List1"
isDataD
::
Dec
->
Bool
isDataD
::
Dec
->
Bool
isDataD
(
DataD
_
_
_
_
_
)
=
True
isDataD
(
DataD
_
_
_
_
_
)
=
True
isDataD
_
=
False
isDataD
_
=
False
-- Converts a Haskell Declaration to our DecT type
-- Converts a Haskell Declaration to our DecT type
-- (mostly just strips unessecary data and converts Names to Strings)
-- (mostly just strips unessecary data and converts Names to Strings)
dataDToDecT
::
Dec
->
DecT
dataDToDecT
::
Dec
->
(
DecT
,
String
)
dataDToDecT
(
DataD
cxt
name
tvb
constructors
derives
)
=
dataDToDecT
(
DataD
cxt
name
tvb
constructors
derives
)
=
DecT
(
showName
name
)
(
map
conToRHS
constructors
)
let
rhss
=
(
map
conToRHS
constructors
)
in
(
DecT
(
showName
name
)
(
map
(
\
(
x
,
y
)
->
x
)
rhss
),
(
foldr
(
\
(
x
,
y
)
acc
->
"
\n
"
++
y
++
acc
)
""
rhss
))
dataDToDecT
_
=
error
"dataDtoDecT applied to non-data dec"
dataDToDecT
_
=
error
"dataDtoDecT applied to non-data dec"
-- Converts Haskell Con type (right hand sides in a data declaration)
-- Converts Haskell Con type (right hand sides in a data declaration)
conToRHS
::
Con
->
RHS
conToRHS
::
Con
->
(
RHS
,
String
)
conToRHS
(
NormalC
n
stypes
)
=
RHS
(
showName
n
)
(
map
stypeToString
stypes
)
conToRHS
(
NormalC
n
stypes
)
=
let
sts
=
(
map
stypeToString
stypes
)
in
(
RHS
(
showName
n
)
(
map
(
\
(
x
,
y
)
->
x
)
sts
),
(
foldr
(
\
(
x
,
y
)
acc
->
"
\n
"
++
y
++
acc
)
"
\n
"
sts
))
conToRHS
_
=
error
"conToRHS on not-NormalC not supported"
conToRHS
_
=
error
"conToRHS on not-NormalC not supported"
-- Tuples and other types not supported
-- flattenType :: Type -> String
stypeToString
::
StrictType
->
String
stypeToString
(
_
,
(
ConT
n
))
=
showName
n
-- tupleToString :: Type -> Type -> String
stypeToString
(
_
,
(
AppT
ListT
t
))
=
(
stypeToString
(
IsStrict
,
t
))
++
"*"
-- tupleToString t (ConT n) = flattenType t ++ showName n
-- Converts a type to string, returns pair of the type in string form
-- and any new rules it needed to produce (for tuples and lists)
stypeToString
::
StrictType
->
(
String
,
String
)
stypeToString
(
_
,
(
ConT
n
))
=
(
showName
n
,
""
)
stypeToString
(
_
,
(
AppT
ListT
t
))
=
let
(
s
,
rs
)
=
(
stypeToString
(
IsStrict
,
t
))
in
(
s
++
"*"
,
(
rs
++
makeMultiRules
(
AppT
(
ConT
list0
)
t
)
s
))
stypeToString
(
_
,
(
AppT
(
ConT
n
)
t
))
=
let
(
s
,
rs
)
=
(
stypeToString
(
IsStrict
,
t
))
c
=
if
n
==
list0
then
"*"
else
"+"
in
(
s
++
c
,
(
rs
++
makeMultiRules
(
AppT
(
ConT
n
)
t
)
s
))
{-stypeToString (_, (AppT (ConT n) t)) = if n == (mkName "List0") then
(stypeToString (IsStrict, t)) ++ "*"
else if n == (mkName "List1") then
(stypeToString (IsStrict, t)) ++ "+"
else error ("type " ++ (show n) ++ " not supported")-}
-- stypeToString (_, (AppT t1 t2) = tupleToString t1 t2
stypeToString
(
_
,
t
)
=
error
(
"stypeToString of "
++
(
show
t
)
++
" not yet supported"
)
stypeToString
(
_
,
t
)
=
error
(
"stypeToString of "
++
(
show
t
)
++
" not yet supported"
)
showDecT
::
DecT
->
String
showDecT
::
DecT
->
String
...
@@ -69,12 +95,24 @@ rrhs (RHS s ts) = "\t{" ++ s ++ (makeNums (length ts) (length ts))
...
@@ -69,12 +95,24 @@ rrhs (RHS s ts) = "\t{" ++ s ++ (makeNums (length ts) (length ts))
isMulti
::
String
->
Bool
isMulti
::
String
->
Bool
isMulti
"*"
=
True
isMulti
"*"
=
True
isMulti
"+"
=
True
isMulti
[]
=
False
isMulti
[]
=
False
isMulti
(
s
:
r
)
=
isMulti
r
isMulti
(
s
:
r
)
=
isMulti
r
isMulti0
::
String
->
Bool
isMulti0
"*"
=
True
isMulti0
[]
=
False
isMulti0
(
s
:
r
)
=
isMulti0
r
isMulti1
::
String
->
Bool
isMulti1
"+"
=
True
isMulti1
[]
=
False
isMulti1
(
s
:
r
)
=
isMulti1
r
fixMultis
::
String
->
String
fixMultis
::
String
->
String
fixMultis
s
=
if
isMulti
s
then
"Multi"
++
(
strip
s
)
fixMultis
s
=
(
if
isMulti1
s
then
"Multi1"
else
s
else
if
isMulti0
s
then
"Multi0"
else
""
)
++
(
strip
s
)
rhsToRule
::
[
RHS
]
->
RHS
->
String
rhsToRule
::
[
RHS
]
->
RHS
->
String
rhsToRule
rules
=
\
(
RHS
s
ts
)
->
rhsToRule
rules
=
\
(
RHS
s
ts
)
->
...
@@ -86,17 +124,18 @@ rhsToRule rules = \(RHS s ts) ->
...
@@ -86,17 +124,18 @@ rhsToRule rules = \(RHS s ts) ->
strip
::
String
->
String
strip
::
String
->
String
strip
(
'*'
:
[]
)
=
[]
strip
(
'*'
:
[]
)
=
[]
strip
(
'+'
:
[]
)
=
[]
strip
(
s
:
r
)
=
s
:
(
strip
r
)
strip
(
s
:
r
)
=
s
:
(
strip
r
)
strip
[]
=
[]
strip
[]
=
[]
makeMultiRules
::
Type
->
String
->
String
get
MultiRules
::
RHS
->
String
->
String
make
MultiRules
(
AppT
(
ConT
listt
)
t
)
s
=
getMultiRules
(
RHS
n
ts
)
acc
=
let
i
=
if
listt
==
list0
then
0
else
1
let
multis
=
filter
(
\
s
->
(
last
s
)
==
'*'
)
ts
name
=
"Multi"
++
(
show
i
)
++
(
strip
s
)
multiRule
s
=
let
name
=
"Multi"
++
(
strip
s
)
in
name
++
": "
++
(
strip
s
)
++
" "
++
name
++
in
name
++
": "
++
(
strip
s
)
++
" "
++
name
++
"
\t
{$1:$2}
\n
"
++
(
makeTab
name
)
++
"
\t
{
$1:$2}
\n
"
++
(
makeTab
name
)
++
"
|
\t
{[]}"
(
if
i
==
0
then
"
|
\t
{
[]}"
else
(
"| "
++
(
strip
s
)
++
"
\t
{[
$1
]}"
))
in
(
foldr
(
\
s
x
->
"
\n
"
++
s
++
"
\n
"
++
x
)
""
(
map
multiRule
multis
))
++
acc
makeMultiRules
_
_
=
undefined
makeTab
::
String
->
String
makeTab
::
String
->
String
...
@@ -108,24 +147,53 @@ makeTab s = let helper 0 a = a
...
@@ -108,24 +147,53 @@ makeTab s = let helper 0 a = a
-- will in turn produce the given declaration.
-- will in turn produce the given declaration.
decTToRule
::
DecT
->
String
decTToRule
::
DecT
->
String
decTToRule
(
DecT
n
rhs
)
=
decTToRule
(
DecT
n
rhs
)
=
let
multiRules
=
foldr
getMultiRules
""
rhs
let
multiRules
=
""
--
foldr getMultiRules "" rhs
rhsStrings
=
map
(
rhsToRule
rhs
)
rhs
rhsStrings
=
map
(
rhsToRule
rhs
)
rhs
tab
=
makeTab
n
tab
=
makeTab
n
in
n
++
": "
++
(
head
rhsStrings
)
++
"
\n
"
++
in
n
++
": "
++
(
head
rhsStrings
)
++
"
\n
"
++
(
foldr
(
\
r
acc
->
tab
++
"| "
++
r
++
"
\n
"
++
acc
)
""
(
tail
rhsStrings
))
++
multiRules
(
foldr
(
\
r
acc
->
tab
++
"| "
++
r
++
"
\n
"
++
acc
)
""
(
tail
rhsStrings
))
--
++ multiRules
-- Creates the grammar rules from the declarations
-- Creates the grammar rules from the declarations
makeRules
::
[
DecT
]
->
String
makeRules
::
[
DecT
]
->
String
makeRules
decs
=
foldr
(
\
dec
acc
->
(
decTToRule
dec
)
++
"
\n
"
++
acc
)
""
decs
makeRules
decs
=
foldr
(
\
dec
acc
->
(
decTToRule
dec
)
++
"
\n
"
++
acc
)
""
decs
cleanNLs
::
String
->
String
cleanNLs
(
'
\n
'
:
'
\n
'
:
'
\n
'
:
s
)
=
cleanNLs
(
'
\n
'
:
'
\n
'
:
s
)
cleanNLs
(
x
:
s
)
=
x
:
(
cleanNLs
s
)
cleanNLs
[]
=
""
cleanMulti
::
String
->
String
cleanMulti
s
=
let
regex
=
mkRegex
"(^[^:]*:)"
getNames
=
\
s
->
case
matchRegexAll
regex
s
of
Nothing
->
[]
Just
(
_
,
match
,
rest
,
_
)
->
match
:
(
getNames
rest
)
names
=
getNames
s
dups
=
repeated
names
dups'
=
map
(
\
x
->
(
x
,
False
))
dups
removeDups
dups
s
rembef
=
case
matchRegexAll
regex
s
of
Nothing
->
s
Just
(
bef
,
match
,
rest
,
_
)
->
case
find
(
\
(
x
,
y
)
->
x
==
match
)
dups
of
Nothing
->
if
rembef
then
match
++
(
removeDups
dups
rest
False
)
else
bef
++
match
++
(
removeDups
dups
rest
False
)
Just
(
x
,
False
)
->
(
if
rembef
then
match
else
bef
++
match
)
++
(
removeDups
(
insert
(
x
,
True
)
(
delete
(
x
,
False
)
dups
))
rest
False
)
Just
(
x
,
True
)
->
(
if
rembef
then
""
else
bef
)
++
(
removeDups
dups
rest
True
)
in
(
removeDups
dups'
s
False
)
parseAstDecs
::
String
->
Grammar
parseAstDecs
::
String
->
Grammar
parseAstDecs
s
=
let
decs
=
case
parseDecs
s
of
parseAstDecs
s
=
let
decs
=
case
parseDecs
s
of
(
Right
ds
)
->
ds
(
Right
ds
)
->
ds
(
Left
err
)
->
(
trace
err
undefined
)
(
Left
err
)
->
(
trace
err
undefined
)
dataDs
=
filter
isDataD
decs
dataDs
=
filter
isDataD
decs
rules
=
makeRules
(
map
dataDToDecT
dataDs
)
decTs
=
(
map
dataDToDecT
dataDs
)
in
rules
rules
=
makeRules
(
map
(
\
(
x
,
y
)
->
x
)
decTs
)
in
cleanNLs
(
cleanMulti
(
foldr
(
\
(
x
,
y
)
acc
->
y
++
acc
)
""
decTs
))
++
rules
-- in (foldr (\(x, y) acc -> y ++ acc) "" decTs) ++ rules
main
::
IO
()
main
::
IO
()
main
=
do
{
main
=
do
{
args
<-
getArgs
;
args
<-
getArgs
;
...
...
src/Unique.hs
0 → 100644
View file @
0a2ede14
-----------------------------------------------------------------------------
-- |
-- Module : Data.List.Unique
-- Copyright : (c) Volodymyr Yaschenko
-- License : BSD3
--
-- Maintainer : ualinuxcn@gmail.com
-- Stability : Unstable
-- Portability : portable
--
-- Library provides the functions to find unique and duplicate elements in the list
module
Data.List.Unique
(
sortUniq
,
repeated
,
repeatedBy
,
unique
,
count
,
count_
,
countElem
)
where
import
Data.List
(
group
,
groupBy
,
sort
,
sortBy
)
import
Control.Applicative
(
liftA2
)
import
Data.Function
(
on
)
import
Data.List.Extra
(
nubOrd
)
import
Data.Tuple
(
swap
)
-- | 'sortUniq' sorts the list and removes the duplicates of elements. Example:
--
-- > sortUniq "foo bar" == " abfor"
sortUniq
::
Ord
a
=>
[
a
]
->
[
a
]
sortUniq
=
sort
.
nubOrd
sg
::
Ord
a
=>
[
a
]
->
[[
a
]]
sg
=
group
.
sort
filterByLength
::
Ord
a
=>
(
Int
->
Bool
)
->
[
a
]
->
[[
a
]]
filterByLength
p
=
filter
(
p
.
length
)
.
sg
-- | 'repeated' finds only the elements that are present more than once in the list. Example:
--
-- > repeated "foo bar" == "o"
repeated
::
Ord
a
=>
[
a
]
->
[
a
]
repeated
=
repeatedBy
(
>
1
)
-- | The repeatedBy function behaves just like repeated, except it uses a user-supplied equality predicate.
--
-- > repeatedBy (>2) "This is the test line" == " eist"
repeatedBy
::
Ord
a
=>
(
Int
->
Bool
)
->
[
a
]
->
[
a
]
repeatedBy
p
=
map
head
.
filterByLength
p
-- | 'unique' gets only unique elements, that do not have duplicates.
-- It sorts them. Example:
--
-- > unique "foo bar" == " abfr"
unique
::
Ord
a
=>
[
a
]
->
[
a
]
unique
=
concat
.
filterByLength
(
==
1
)
lh
::
[
a
]
->
(
a
,
Int
)
lh
=
liftA2
(,)
head
length
-- | 'count' of each element in the list, it sorts by keys (elements). Example:
--
-- > count "foo bar" == [(' ',1),('a',1),('b',1),('f',1),('o',2),('r',1)]
count
::
Ord
a
=>
[
a
]
->
[(
a
,
Int
)]
count
=
map
lh
.
sg
-- | 'count_' of each elements in the list, it sorts by their number. Example:
--
-- > count_ "foo bar" == [(' ',1),('a',1),('b',1),('f',1),('r',1),('o',2)]
count_
::
Ord
a
=>
[
a
]
->
[(
a
,
Int
)]
count_
=
sortBy
(
compare
`
on
`
snd
)
.
count
-- | 'occurrences' finds all elements of each occurrences.
-- occurrences :: Ord a => [a] -> [(1,a)]
-- occurrences =
-- | 'countElem' gets the number of occurrences of the specified element. Example:
--
-- > countElem 'o' "foo bar" == 2
countElem
::
Eq
a
=>
a
->
[
a
]
->
Int
countElem
x
=
length
.
filter
(
==
x
)
stack.yaml
View file @
0a2ede14
...
@@ -6,6 +6,9 @@ resolver: lts-5.4
...
@@ -6,6 +6,9 @@ resolver: lts-5.4
# Local packages, usually specified by relative directory name
# Local packages, usually specified by relative directory name
packages
:
packages
:
-
'
.'
-
'
.'
-
location
:
git
:
https://github.com/matthew-eads/Unique.git
commit
:
f70dc0cecd5d0d2fad6b694aa378211fcc828a44
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps
:
[]
extra-deps
:
[]
...
...
test.imp
0 → 100644
View file @
0a2ede14
(set x (if 0 (begin 1 2 3) (set y 3)))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment