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

Merge branch 'master' of github.cs.tufts.edu:Siriusly/gg-proto

Merge
parents 11f01fa4 98fd85fb
......@@ -24,41 +24,45 @@ data DecT = DecT String [RHS] deriving Show
-- Constructor name, [
data RHS = RHS String [String] deriving Show
list0 :: Name
list0 = mkName "List0"
list1 :: Name
list1 = mkName "List1"
isDataD :: Dec -> Bool
isDataD (DataD _ _ _ _ _) = True
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, String)
dataDToDecT (DataD cxt name tvb constructors derives) =
dataDToDecT (DataD _ {- cxt -} name _ {- tvb -} constructors _ {- derives -}) =
let rhss = (map conToRHS constructors)
in (DecT (showName name) (map (\(x,y) -> x) rhss), (foldr (\(x,y) acc -> "\n" ++ y ++ acc) "" rhss))
in (DecT (showName name) (map (\(x,_) -> x) rhss),
(foldr (\(_,y) acc -> "\n" ++ y ++ acc) "" rhss))
dataDToDecT _ = error "dataDtoDecT applied to non-data dec"
-- Converts Haskell Con type (right hand sides in a data declaration)
conToRHS :: Con -> (RHS, String)
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 (NormalC n stypes) =
let sts = (map stypeToString stypes)
in (RHS (showName n) (map (\(x,_) -> x) sts),
(foldr (\(_,y) acc -> "\n" ++ y ++ acc) "\n" sts))
conToRHS _ = error "conToRHS on not-NormalC not supported"
-- flattenType :: Type -> String
flattenTuple :: Type -> Type -> [Type]
flattenTuple (TupleT n) t = [t]
flattenTuple (TupleT _) t = [t]
flattenTuple (AppT t1 t2) t3 = (flattenTuple t1 t2) ++ [t3]
flattenTuple _ _ = error "flattenTuple must be called on TupleT or AppT"
-- 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 ++ "\n\n" ++ makeMultiRules (AppT (ConT list0) t) s))
stypeToString (_, (AppT ListT t)) =
let (s, rs) = (stypeToString (IsStrict, t))
in (s ++ "*", (rs ++ "\n\n" ++ makeMultiRules (AppT (ConT list0) t) s))
stypeToString (_, (AppT (ConT n) t)) =
if n == list0 || n == list1 then
let (s, rs) = (stypeToString (IsStrict, t))
......@@ -71,19 +75,27 @@ stypeToString (_, (AppT (ConT n) t)) =
(makeTab ("maybe" ++ s)) ++ "| \t{Nothing}"))
else ("", "")
stypeToString (_, (AppT t1 t2)) = let ts = flattenTuple t1 t2
ts' = map (stypeToString . (\x -> (IsStrict, x))) ts
(s, rs) = ((foldr (\(x, y) a -> (fixMultis x) ++ "\\" ++ a) "" ts'),
(foldr (\(x, y) a -> y ++ a) "" ts'))
rs' = rs ++ "\n" ++ (makeTupleRules s)
in ((filter ((/=) '\\') s), rs')
stypeToString (_, (AppT t1 t2)) =
let ts = flattenTuple t1 t2
ts' = map (stypeToString . (\x -> (IsStrict, x))) ts
(s, rs) = ((foldr (\(x, _) a -> (fixMultis x) ++ "\\" ++ a) "" ts'),
(foldr (\(_, y) a -> y ++ a) "" ts'))
rs' = rs ++ "\n" ++ (makeTupleRules s)
in ((filter ((/=) '\\') s), rs')
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)) ++ "] "
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) ++ "] "
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
......@@ -98,7 +110,7 @@ myappend s1 s2 = s1 ++ " " ++ s2
-- produces a string of form {$1 $2 ... $n}
makeNums :: Int -> Int -> String -> String
makeNums _ 0 _ = ""
makeNums i 1 sep = "$" ++ (show i)
makeNums i 1 _ = "$" ++ (show i)
makeNums i n sep = "$" ++ (show (i-n+1)) ++ sep ++ (makeNums i (n-1) sep)
-- produces the construction -> {EXP $1 $2} from the given RHS rule
......@@ -109,17 +121,17 @@ isMulti :: String -> Bool
isMulti "*" = True
isMulti "+" = True
isMulti [] = False
isMulti (s:r) = isMulti r
isMulti (_:r) = isMulti r
isMulti0 :: String -> Bool
isMulti0 "*" = True
isMulti0 [] = False
isMulti0 (s:r) = isMulti0 r
isMulti0 (_:r) = isMulti0 r
isMulti1 :: String -> Bool
isMulti1 "+" = True
isMulti1 [] = False
isMulti1 (s:r) = isMulti1 r
isMulti1 (_:r) = isMulti1 r
fixMultis :: String -> String
fixMultis s = (if isMulti1 s then "Multi1"
......@@ -141,12 +153,12 @@ strip (s:r) = s:(strip r)
strip [] = []
makeMultiRules :: Type -> String -> String
makeMultiRules (AppT (ConT listt) t) s =
makeMultiRules (AppT (ConT listt) _) s =
let i = if listt == list0 then 0 else 1
name = "Multi" ++ (show i) ++ (strip s)
in name ++ ": " ++ (strip s) ++ " " ++ name ++
"\t{$1:$2}\n" ++ (makeTab name) ++
(if i == 0 then "|\t{[]}" else ("| " ++ (strip s) ++ "\t{[$1]}"))
(if i == (0::Integer) then "|\t{[]}" else ("| " ++ (strip s) ++ "\t{[$1]}"))
makeMultiRules _ _ = undefined
makeTupleRules :: String -> String
......@@ -164,7 +176,7 @@ makeTab s = let helper 0 a = a
-- will in turn produce the given declaration.
decTToRule :: DecT -> String
decTToRule (DecT n rhs) =
let multiRules = "" --foldr getMultiRules "" rhs
let -- multiRules = "" --foldr getMultiRules "" rhs
rhsStrings = map (rhsToRule rhs) rhs
tab = makeTab n
in n ++ ": " ++ (head rhsStrings) ++ "\n" ++
......@@ -183,27 +195,28 @@ cleanNLs :: String -> String
cleanNLs s = cleanNLs' (dropWhile ((==) '\n') s)
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)
cleanMulti s =
let regex = mkRegex "(^[^:]*:)"
getNames = \str -> case matchRegexAll regex str of
Nothing -> []
Just (_, match, rest, _) -> match:(getNames rest)
names = getNames s
duplicates = repeated names
dups' = map (\x -> (x, False)) duplicates
removeDups dups str rembef =
case matchRegexAll regex str of
Nothing -> str
Just (bef, match, rest, _) ->
case find (\(x,_) -> 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 (_, True) ->
(if rembef then "" else bef) ++
(removeDups dups rest True)
in (removeDups dups' s False)
parseAstDecs :: String -> Grammar
parseAstDecs s = let decs = case parseDecs s of
......@@ -211,8 +224,8 @@ parseAstDecs s = let decs = case parseDecs s of
(Left err) -> (trace err undefined)
dataDs = filter isDataD decs
decTs = (map dataDToDecT dataDs)
rules = makeRules (map (\(x,y) -> x) decTs)
in cleanNLs (cleanMulti (foldr (\(x, y) acc -> y ++ acc) "" decTs)) ++ rules
rules = makeRules (map (\(x,_) -> x) decTs)
in cleanNLs (cleanMulti (foldr (\(_, y) acc -> y ++ acc) "" decTs)) ++ rules
-- in (foldr (\(x, y) acc -> y ++ acc) "" decTs) ++ rules
main :: IO ()
main = do {
......
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