Commit 0a2ede14 authored by matthew-eads's avatar matthew-eads
Browse files

better multis

parent d24e2352
...@@ -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)
......
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
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
...@@ -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
......
...@@ -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
getMultiRules :: RHS -> String -> String makeMultiRules (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;
......
-----------------------------------------------------------------------------
-- |
-- 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)
...@@ -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: []
......
(set x (if 0 (begin 1 2 3) (set y 3)))
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