packages feed

grm (empty) → 0.1.0

raw patch · 9 files changed

+1414/−0 lines, 9 filesdep +Cabaldep +basedep +cmdargssetup-changed

Dependencies added: Cabal, base, cmdargs, directory, filepath, parsec, process, syb, wl-pprint

Files

+ Grm/Layout.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}++-- The grm grammar generator+-- Copyright 2011-2012, Brett Letner++module Grm.Layout (layout) where++import Grm.Lex+import Grm.Prims++layout :: [Token Point] -> [Token Point]+layout ts = loop [] ts+  where+  loop [] [] = []++  loop (_:cs) [] = stopSyms eofLoc ++ loop cs []++  loop cs (x:y:xs) | isStopSym x && isStopWord y = x : y : loop cs xs++  loop (_:cs) (x:xs) | isStopWord x =+    stopSyms (startLoc x) ++ [x] ++ loop (filter ((>=) $ col x) cs) xs++  loop (c:cs) xs0@(x:_) | col x < c = stopSyms (startLoc x) ++ loop cs xs0++  loop (c:cs) (x:xs) | col x == c && (isWord ["where"] x) = stopSyms (startLoc x) ++ cont cs x xs++  loop cs0@(c:_) (x:xs) | col x == c = termSym (startLoc x) : cont cs0 x xs++  loop cs0 (x:xs) = cont cs0 x xs++  cont cs0 x0 [] | isStartWord x0 = x0 : startSym (stopLoc x0) : loop (col x0 : cs0) []++  cont cs0 x0 (x:xs) | isStartWord x0 && not (isStartSym x) =+    x0 : startSym (startLoc x) : cont (col x : cs0) x xs++  cont cs0 x xs0 = x : loop cs0 xs0++  eofLoc = stopLoc $ last ts++isStartWord :: Token Point -> Bool+isStartWord = isWord [ "where", "do", "of", "imports", "exports", "branch" ] -- , "let"++isStopWord :: Token Point -> Bool+isStopWord = isWord [ "until" ]++isStartSym :: Token Point -> Bool+isStartSym = isWord ["{"]++isStopSym :: Token Point -> Bool+isStopSym = isWord ["}"]++isWord :: [String] -> Token Point -> Bool+isWord ss (TSymbol _ s) = s `elem` ss+isWord _ _ = False++col :: Token Point -> Int+col = locColumn . startLoc++mkSym :: String -> Loc -> Token Point+mkSym s l = TSymbol (Point l l) s++startSym :: Loc -> Token Point+startSym = mkSym "{"++stopSyms :: Loc -> [Token Point]+stopSyms loc = [ termSym loc, mkSym "}" loc ]++termSym :: Loc -> Token Point+termSym = mkSym ";"
+ Grm/Lex.hs view
@@ -0,0 +1,536 @@+{-# OPTIONS -Wall #-}++-- The grm grammar generator+-- Copyright 2011-2012, Brett Letner++module Grm.Lex+  ( Token(..)+  , Point(..)+  , lexFilePath+  , lexContents+  , ppToken+  , ppTokenList+  , happyError+  , notWSToken+  , unTWhitespace+  , unTSLComment+  , unTMLComment+  , unTString+  , unTChar+  , unTNumber+  , unTSymbol+  , unTUsym+  , unTUident+  , unTLident+  ) where++import Control.Monad+import Data.Char+-- import Numeric+import Data.List+import Grm.Prims+import Text.PrettyPrint.Leijen++happyError :: [Token Point] -> a+happyError [] = error "unexpected end of tokens"+happyError (t:_) = error $ ppErr (startLoc t) ("unexpected token: " ++ show (show (ppToken t)))++-- fixme: doesn't work for empty modules (e.g. module Foo where)++notWSToken :: Token t -> Bool+notWSToken t = case t of+  TWhitespace{} -> False+  TSLComment{} -> False+  TMLComment{} -> False+  _ -> True++data Token a+  = TWhitespace a String+  | TSLComment a String+  | TMLComment a String+  | TString a String+  | TChar a Char+  | TNumber a String+  | TSymbol a String+  | TUsym a String+  | TUident a String+  | TLident a String+  deriving (Show)++unTWhitespace :: Token t -> String+unTWhitespace (TWhitespace _ b) = b+unTWhitespace _ = error "unTWhitespace"++unTSLComment :: Token t -> String+unTSLComment (TSLComment _ b) = b+unTSLComment _ = error "unTSLComment"++unTMLComment :: Token t -> String+unTMLComment (TMLComment _ b) = b+unTMLComment _ = error "unTMLComment"++unTString :: Token t -> String+unTString (TString _ b) = b+unTString _ = error "unTString"++unTChar :: Token t -> Char+unTChar (TChar _ b) = b+unTChar _ = error "unTChar"++unTNumber :: Token t -> String+unTNumber (TNumber _ b) = b+unTNumber _ = error "unTNumber"++unTSymbol :: Token t -> String+unTSymbol (TSymbol _ b) = b+unTSymbol _ = error "unTSymbol"++unTUsym :: Token t -> String+unTUsym (TUsym _ b) = b+unTUsym _ = error "unTUsym"++unTUident :: Token t -> String+unTUident (TUident _ b) = b+unTUident _ = error "unTUident"++unTLident :: Token t -> String+unTLident (TLident _ b) = b+unTLident _ = error "unTLident"++instance Eq (Token a) where+  (==) a b = case (a,b) of+    (TWhitespace _ x, TWhitespace _ y) -> x == y+    (TSLComment _ x, TSLComment _ y) -> x == y+    (TMLComment _ x, TMLComment _ y) -> x == y+    (TString _ x, TString _ y) -> x == y+    (TChar _ x, TChar _ y) -> x == y+    (TNumber _ x, TNumber _ y) -> x == y -- numbers are compared lexically+    (TSymbol _ x, TSymbol _ y) -> x == y+    (TUsym _ x, TUsym _ y) -> x == y+    (TUident _ x, TUident _ y) -> x == y+    (TLident _ x, TLident _ y) -> x == y+    _ -> False++ppTokenList :: [Token a] -> Doc+ppTokenList = sep . map ppToken++ppToken :: Token a -> Doc+ppToken t = text $ case t of+  TWhitespace _ s -> s+  TSLComment _ s -> s+  TMLComment _ s -> s+  TString _ a -> show a+  TChar _ a -> show a+  TNumber _ s -> s+  TSymbol _ s -> s+  TUsym _ s -> s+  TUident _ s -> s+  TLident _ s -> s++instance HasMeta Token where+  meta t = case t of+    TWhitespace a _ -> a+    TSLComment a _ -> a+    TMLComment a _ -> a+    TString a _ -> a+    TChar a _ -> a+    TNumber a _ -> a+    TSymbol a _ -> a+    TUsym a _ -> a+    TUident a _ -> a+    TLident a _ -> a++  -- mapMetaM f t = case t of+  --   TWhitespace a b -> f a >>= \x -> return (TWhitespace x b)+  --   TSLComment a b -> f a >>= \x -> return (TSLComment x b)+  --   TMLComment a b -> f a >>= \x -> return (TMLComment x b)+  --   TString a b -> f a >>= \x -> return (TString x b)+  --   TChar a b -> f a >>= \x -> return (TChar x b)+  --   TNumber a b -> f a >>= \x -> return (TNumber x b)+  --   TSymbol a b -> f a >>= \x -> return (TSymbol x b)+  --   TUsym a b -> f a >>= \x -> return (TUsym x b)+  --   TUident a b -> f a >>= \x -> return (TUident x b)+  --   TLident a b -> f a >>= \x -> return (TLident x b)++lexFilePath :: [String] -> FilePath -> IO [Token Point]+lexFilePath syms fn = do+  s <- readFile fn+  lexContents syms fn s++lexContents :: [String] -> FilePath -> String -> IO [Token Point]+lexContents syms fn s = do+  let st0 = initSt syms fn $ filter ((/=) '\r') s+  let M f = lexTokens+  case f st0 of+    (Left e, st) -> error $ ppErr (stLoc st) e+    (Right ts, st) -> case stInput st of+      "" -> return ts+      e -> error $ ppErr (stLoc st) $ "lexical error:" ++ show (head e)++initSt :: [String] -> FilePath -> String -> St+initSt syms fn s = St+  { stLoc = initLoc fn+  , stInput = s+  , stSymbols = syms+  }++instance Monad M where+  (M f) >>= g = M $ \st ->+    let (ma, st1) = f st+      in case ma of+        Left e -> (Left e, st)+        Right a ->+          let M h = g a+            in h st1++  return a = M $ \st -> (Right a, st)+  fail s = M $ \st -> (Left s, st)++data M a = M (St -> (Either String a, St))++getSt :: M St+getSt = M $ \st -> (Right st, st)++lexAnyChar :: M Char+lexAnyChar = M $ \st ->+  let+    loc0 = stLoc st+    in case stInput st of+      "" -> (Left "unexpected eof", st)+      (c:cs) | c == eolChar ->+        (Right c, st{ stInput = cs+                    , stLoc = loc0{ locColumn = 0, locLine = succ (locLine loc0) }})+      (c:cs) ->+        (Right c, st{ stInput = cs+                    , stLoc = loc0{ locColumn = succ (locColumn loc0) }})++tryLex :: M a -> M (Maybe a)+tryLex (M f) = M $ \st -> case f st of+  (Left _, _) -> (Right Nothing, st)+  (Right a, st1) -> (Right $ Just a, st1)++data St = St+  { stLoc :: Loc+  , stInput :: String+  , stSymbols :: [String]+  } deriving (Show)++qualChar :: Char+qualChar = '.'++escChar :: Char+escChar = '\\'++dQuoteChar :: Char+dQuoteChar = '"'++sQuoteChar :: Char+sQuoteChar = '\''++eolChar :: Char+eolChar = '\n'++wsChar :: String+wsChar = [ ' ', eolChar ]++slCommentStart :: String+slCommentStart = "//"++mlCommentStart :: String+mlCommentStart = "/*"++mlCommentEnd :: String+mlCommentEnd = "*/"++-- slCommentStart = "--", doesn't work if you support the decrement statement, e.g. i--+-- mlCommentStart = "{-"+-- mlCommentEnd = "-}"++uidentStart :: String+uidentStart = [ 'A' .. 'Z' ]++lidentStart :: String+lidentStart = '_' : [ 'a' .. 'z' ]++identEnd :: String+identEnd = uidentStart ++ lidentStart ++ [ '0' .. '9' ]++getLoc :: M Loc+getLoc = liftM stLoc getSt++getSymbols :: M [String]+getSymbols = liftM stSymbols getSt++lexStringLit :: String -> M String+lexStringLit s = do+  s1 <- sequence $ replicate (length s) lexAnyChar+  if s1 == s+    then return s+    else fail $ "unexpected string:" ++ s++lexCharPred :: (Char -> Bool) -> M Char+lexCharPred p = do+  c <- lexAnyChar+  if p c+    then return c+    else fail $ "unexpected char:" ++ show c++many :: M a -> M [a]+many m = do+  mx <- tryLex m+  case mx of+    Just x -> do+      xs <- many m+      return $ x : xs+    Nothing -> return []++oneof :: [M a] -> M a+oneof [] = fail "token doesn't match any alternatives"+oneof (m:ms) = do+  mx <- tryLex m+  case mx of+    Just x -> return x+    Nothing -> oneof ms++lexKeyword :: M (Token Point)+lexKeyword = do+  a <- getLoc+  s <- oneof [ lexUpperWord, lexLowerWord ]+  ss <- getSymbols+  b <- getLoc+  if s `elem` ss+    then return $ TSymbol (Point a b) s+    else fail $ "not a keyword:" ++ s++lexSymbol :: M (Token Point)+lexSymbol = do+  a <- getLoc+  ss <- getSymbols+  s <- oneof [ lexUsymTok, liftM singleton $ lexCharPred (flip elem symChar) ]+  b <- getLoc+  if s `elem` ss+    then return $ TSymbol (Point a b) s+    else fail $ "not a symbol:" ++ s++usymChar :: String+usymChar = "!#$%&*+-/:<=>?@\\^|~"++symChar :: String+symChar = "(),;`{}[]."++lexUsymTok :: M String+lexUsymTok = many1 (lexCharPred $ flip elem usymChar)++lexUsym :: M (Token Point)+lexUsym = do+  a <- getLoc+  s <- lexUsymTok+  b <- getLoc+  return $ TUsym (Point a b) s++lexUident :: M (Token Point)+lexUident = do+  a <- getLoc+  s <- lexQualified+  b <- getLoc+  return $ TUident (Point a b) s++lexLident :: M (Token Point)+lexLident = do+  a <- getLoc+  s <- oneof [ lexLowerQualified, lexLowerWord ]+  b <- getLoc+  return $ TLident (Point a b) s++lexLowerQualified :: M String+lexLowerQualified = do+    s1 <- lexQualified+    s2 <- do+      _ <- lexCharPred ((==) qualChar)+      lexLowerWord+    return $ qualify [s1,s2]++lexQualified :: M String+lexQualified = do+  s0 <- lexUpperWord+  ss <- many $ do+    _ <- lexCharPred ((==) qualChar)+    s <- lexUpperWord+    return s+  return $ qualify $ s0 : ss++lexUpperWord :: M String+lexUpperWord = do+  c <- lexCharPred (flip elem uidentStart)+  cs <- many $ lexCharPred (flip elem identEnd)+  return $ c : cs++lexLowerWord :: M String+lexLowerWord = do+  c <- lexCharPred (flip elem lidentStart)+  cs <- many $ lexCharPred (flip elem identEnd)+  return $ c : cs++qualify :: [String] -> String+qualify = concat . intersperse [qualChar]++many1 :: M a -> M [a]+many1 m = do+  x <- m+  xs <- many m+  return $ x : xs++lexTokens :: M [Token Point]+lexTokens = many lexToken++lexToken :: M (Token Point)+lexToken = oneof+  [ lexWhitespace+  , lexSingleLineComment+  , lexMultiLineComment+  , lexString+  , lexChar+  , lexNumber+  , lexKeyword+  , lexLident -- must be before lexUident for qualification+  , lexUident+  , lexSymbol+  , lexUsym+  ]++lexWhitespace :: M (Token Point)+lexWhitespace = do+  a <- getLoc+  s <- many1 $ lexCharPred (flip elem wsChar)+  b <- getLoc+  return $ TWhitespace (Point a b) s++lexSingleLineComment :: M (Token Point)+lexSingleLineComment = do+  a <- getLoc+  _ <- lexStringLit slCommentStart+  cs <- many $ lexCharPred ((/=) eolChar)+  b <- getLoc+  return $ TSLComment (Point a b) $ slCommentStart ++ cs++lexMultiLineComment :: M (Token Point)+lexMultiLineComment = do+  a <- getLoc+  s <- lexMLCommentStart+  b <- getLoc+  return $ TMLComment (Point a b) s++lexMLCommentStart :: M String+lexMLCommentStart = do+  sa <- lexStringLit mlCommentStart+  sb <- lexMLCommentEnd+  return $ sa ++ sb++lexMLCommentEnd :: M String+lexMLCommentEnd = do+  ms0 <- tryLex $ lexStringLit mlCommentEnd+  case ms0 of+    Just s -> return s+    Nothing -> do+      ms <- tryLex lexMLCommentStart+      sa <- case ms of+        Just s -> return s+        Nothing -> do+          c <- lexAnyChar+          return [c]+      sb <- lexMLCommentEnd+      return $ sa ++ sb++lexChar :: M (Token Point)+lexChar = do+  a <- getLoc+  _ <- lexCharPred ((==) sQuoteChar)+  s <- oneof [ lexEscChar, liftM singleton $ lexCharPred ((/=) sQuoteChar) ]+  _ <- lexCharPred ((==) sQuoteChar)+  b <- getLoc+  return $ TChar (Point a b) $ read ([sQuoteChar] ++ s ++ [sQuoteChar])++lexString :: M (Token Point)+lexString = do+  a <- getLoc+  _ <- lexCharPred ((==) dQuoteChar)+  s <- liftM concat $ many $ oneof [ lexEscChar, liftM singleton $ lexCharPred ((/=) dQuoteChar) ]+  _ <- lexCharPred ((==) dQuoteChar)+  b <- getLoc+  return $ TString (Point a b) $ read ([dQuoteChar] ++ s ++ [dQuoteChar])++lexDot :: M String+lexDot = liftM singleton $ lexCharPred ((==) '.')++lexSeq :: [M String] -> M String+lexSeq = liftM concat . sequence++lexExponent :: M String+lexExponent = do+  a <- liftM toLower $+       oneof [ lexCharPred ((==) 'e'), lexCharPred ((==) 'E') ]+  b <- oneof [ lexCharPred ((==) '+') >> return ""+             , liftM singleton $ lexCharPred ((==) '-')+             , return ""+             ]+  c <- lexDecimal+  return $ a : b ++ c+  +lexNumber :: M (Token Point)+lexNumber = do+  a <- getLoc+  c <- oneof+       [ liftM singleton $ lexCharPred ((==) '-')+       , return ""+       ]+  s <- oneof+       [ lex0x "0x" isHexit+       , lex0x "0X" isHexit+       , lex0x "0o" isOctit+       , lex0x "0O" isOctit+       , lex0x "0b" isBinit+       , lex0x "0B" isBinit+       , lexFloat+       , lexDecimal+       ]+  b <- getLoc+  return $ TNumber (Point a b) $ c ++ s++lexFloat :: M String+lexFloat = oneof+  [ lexSeq [ lexDecimal, lexDot, lexDecimal, lexExponent ]+  , lexSeq [ lexDecimal, lexDot, lexDecimal ]+  , lexSeq [ lexDecimal, lexExponent ]+  ]++lexDecimal :: M String+lexDecimal = liftM delLeadingZeros $ many1 $ lexCharPred isDigit++lex0x :: String -> (Char -> Bool) -> M String+lex0x s f = do+  cs <- sequence [lexCharPred ((==) c) | c <- s]+  ds <- many1 $ lexCharPred f+  return $ map toLower (cs ++ delLeadingZeros ds)++delLeadingZeros :: String -> String+delLeadingZeros x = case dropWhile ((==) '0') x of+  [] -> "0"+  a -> a+  +isHexit :: Char -> Bool+isHexit c = isDigit c || toLower c `elem` ['a' .. 'f']++isOctit :: Char -> Bool+isOctit c = c `elem` ['0' .. '7']++isBinit :: Char -> Bool+isBinit c = c `elem` ['0','1']++lexEscChar :: M String+lexEscChar = do+  _ <- lexCharPred ((==) escChar)+  s <- oneof+    [ liftM (show . (read :: String -> Int)) lexDecimal+    , liftM singleton lexAnyChar+    ]+  return $ escChar : s
+ Grm/Prims.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE DeriveDataTypeable #-}
++-- The grm grammar generator+-- Copyright 2011-2012, Brett Letner++module Grm.Prims+  ( module Grm.Prims+  , module Debug.Trace+  )+where++import Control.Monad+import Data.Char+import Data.Generics hiding (empty)+import Data.List+import Data.Unique+import Debug.Trace+import System.Directory+import System.Exit (ExitCode(..))+import System.FilePath+import System.IO+import System.IO.Unsafe+import System.Process (system)+import Text.PrettyPrint.Leijen++data Terminator = Terminator | Separator deriving (Show, Eq)++data Horiz = Vert | Horiz deriving (Show, Eq)++data Empty = Empty | NonEmpty deriving (Show, Eq)++data Point = Point { beginLoc :: Loc, endLoc :: Loc }+  deriving (Show, Ord, Eq, Data, Typeable)++data Loc = Loc+  { locFilePath :: FilePath+  , locLine :: Int+  , locColumn :: Int+  } deriving (Show, Eq, Ord, Data, Typeable)++class HasMeta t where+  meta :: t a -> a+  -- mapMetaM :: Monad m => (a -> m b) -> t a -> m (t b)++ppString :: String -> Doc+ppString = text . show++ppInteger :: Integer -> Doc+ppInteger = text . show++type Number = String++ppNumber :: Number -> Doc+ppNumber = text++readNumber :: (Num a, Read a) => Number -> a+readNumber ('-':cs) = negate $ readNumber cs+readNumber cs | isBinary cs = fromIntegral $ readBinary cs+readNumber s = read s++readBinary :: String -> Integer+readBinary = foldl' (\b a -> 2*b + f a) 0 . drop 2+  where+    f '0' = 0+    f '1' = 1+    f c = error $ "readBinary:" ++ show c+    +ppChar :: Char -> Doc+ppChar c = text s+  where+  s = case show c of+    '\'':'\\':x:_ | isUpper x -> "'\\" ++ show (ord c) ++ "'" -- control chars+    str -> str++isFloat :: String -> Bool+isFloat s = '.' `elem` s || 'e' `elem` (map toLower s)++isBinary :: String -> Bool+isBinary s = 'b' `elem` map toLower s++isOctal :: String -> Bool+isOctal s = 'o' `elem` map toLower s++ppDouble :: Double -> Doc+ppDouble = text . show++ppList :: (a -> Doc) -> Terminator -> String -> Horiz -> [a] -> Doc+ppList f a s b cs = case b of+  Horiz -> hsep ds+  Vert -> empty <$> indent 2 (vsep ds) <$> empty+  where+    ds = case cs of+      [] -> []+      _ -> if a == Terminator then map g cs else map g (init cs) ++ [f $ last cs]+    g x = if null s then f x else f x <> text s++nubSort :: Ord a => [a] -> [a]+nubSort = nub . sort++ppLident :: String -> Doc+ppLident = text++ppMlcode :: String -> Doc+ppMlcode = text++ppUident :: String -> Doc+ppUident = text++ppUsym :: String -> Doc+ppUsym = text++singleton :: a -> [a]+singleton a = [a]++ppErr :: Loc -> String -> String+ppErr loc s = ppLoc loc ++ ": " ++ s++ppLoc :: Loc -> String+ppLoc loc = locFilePath loc ++ ":" ++ show (locLine loc) ++ ":" ++ show (1 + locColumn loc)++startLoc :: HasMeta m => m Point -> Loc+startLoc = beginLoc . point++stopLoc :: HasMeta m => m Point -> Loc+stopLoc = endLoc . point++noLoc :: Loc+noLoc = Loc "" 0 0++noPoint :: Point+noPoint = Point noLoc noLoc++initLoc :: FilePath -> Loc+initLoc fn = Loc fn 1 0++point :: HasMeta m => m Point -> Point+point = meta++lrPoint :: [Point] -> Point+lrPoint xs = case filter ((/=) noPoint) xs of+  [] -> noPoint+  _ -> Point (minimum $ map beginLoc xs) (maximum $ map endLoc xs)+  +lrPointList :: HasMeta m => [m Point] -> Point+lrPointList = lrPoint . map point++type Uident = String+type Lident = String+type Mlcode = String+type Usym = String++ppShow :: Pretty a => a -> String+ppShow = show . pretty++unreachable :: a+unreachable = panic "unreachable"++unused :: a+unused = panic "unused"++panic :: String -> a+panic s = error $ "internal:" ++ s++lowercase :: String -> String+lowercase "" = ""+lowercase (c:cs) = toLower c : cs++freshNm :: IO String+freshNm = liftM (show . hashUnique) newUnique++commaSep :: [String] -> String+commaSep = concat . intersperse ", "++mySystem :: String -> IO ()+mySystem s = do+  putStrLn s+  ec <- system s+  case ec of+    ExitSuccess -> return ()+    ExitFailure i -> error $ "unable to execute(" ++ show i ++ "):" ++ s++bitsToEncode :: Integer -> Integer+bitsToEncode 0 = 0+bitsToEncode i = ceiling $ logBase 2 (fromIntegral i :: Double)++uId :: a -> String -> String+{-# NOINLINE uId #-}+uId a s = seq a $ unsafePerformIO $ liftM ((++) s . show . hashUnique) newUnique++writeFileBinary :: FilePath -> String -> IO ()+writeFileBinary fn s = withBinaryFile fn WriteMode $ \h -> hPutStrLn h s++findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findFile [] _ = return Nothing+findFile (d:ds) n = do+  let fn = combine d n+  r <- doesFileExist fn+  if r then return (Just fn) else findFile ds n
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011-2012, Brett Letner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Brett Letner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,31 @@+Introducing the grm compiler construction tool.  Grm takes a grammar+specification and generates Haskell bindings.  Grm is essentially a+simplified bnfc which only generates Haskell (bnfc+http://www.cse.chalmers.se/research/group/Language-technology/BNFC/).++Given a grammar the tool produces:+  - an abstract syntax implementation+  - a Happy parser generator file+  - a pretty-printer++Grm also has some library code for lexing and misc. language+development tasks (e.g. unique identifiers).++I use grm heavily in my pec language+compiler. (git@github.com:stevezhee/pec.git and on hackage).  You can+check out pec for example grm usage.++Building+  - type 'make'+  - resolve all hackage dependencies+  - type 'make' again++You can download and install grm via cabal or access the git+repository on github (git@github.com:stevezhee/grm.git).++Any feedback on the design and/or implementation of grm would be+greatly appreciated :)++Thanks,+Brett+brettletner at gmail dot com
+ Setup.hs view
@@ -0,0 +1,5 @@+-- The grm grammar generator+-- Copyright 2011-2012, Brett Letner++import Distribution.Simple+main = defaultMain
+ THANKS view
@@ -0,0 +1,14 @@+The developement of grm would not have been possible without the following free software:+  - ghc http://haskell.org/ghc/+  - bnfc http://www.cse.chalmers.se/research/group/Language-technology/BNFC/+  - happy http://haskell.org/happy/+  - hackage modules http://hackage.haskell.org/packages/hackage.html++In addition I'd like to thank the following people...++Sigbjorn Finne, Andy Gill, Iavor Diatchki, Lee Pike, Isaac+Potoczny-Jones, Brian Adams, Travis Rhoades, Mike Letner, Brevin+Letner, and my family++Thanks guys!+
+ grm.cabal view
@@ -0,0 +1,39 @@+Name:                grm++Version:             0.1.0++Synopsis:            grm grammar converter++Description:  Grm takes a grammar specification and generates Haskell bindings.  Given a grammar the tool produces an abstract syntax implementation, a Happy parser generator file, and a pretty-printer.++License:             BSD3++License-file:        LICENSE++Author:              Brett Letner <brettletner@gmail.com>++Maintainer:          Brett Letner <brettletner@gmail.com>++Copyright:           Brett Letner 2011-2012++Category:            Development++Build-type:          Simple++Extra-source-files:  README, THANKS++Cabal-version:       >= 1.8++source-repository head+  type: git+  location: git://github.com/stevezhee/grm.git++Library+  Exposed-modules:     Grm.Prims, Grm.Layout, Grm.Lex+  Build-depends: base < 5, wl-pprint, process, syb, filepath, directory++Executable grm+  Main-is:             grm.hs+  Build-depends:       base < 5, parsec, wl-pprint, filepath, cmdargs, directory, Cabal, process, syb+  Build-tools:         happy+
+ grm.hs view
@@ -0,0 +1,491 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- The grm grammar generator+-- Copyright 2011-2012, Brett Letner++module Main where++import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Distribution.Text+import Grm.Prims+import Paths_grm+import System.Console.CmdArgs+import System.Directory+import System.FilePath.Posix+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Language+import Text.PrettyPrint.Leijen (braces,brackets,text,hsep,(<+>),empty,vcat,Doc,indent,(<>),parens,int,list)+import qualified Text.ParserCombinators.Parsec.Token as P++type P a = Parser a++data Args = Args+  { files :: [FilePath]+  , locations :: Bool+  } deriving (Show, Data, Typeable)++argsDesc :: Args+argsDesc = Args+  { files = def &= args+  , locations = def &= help "generate location information"+  } &= summary summ &= program prog+  where+  summ = prog ++ " v" ++ display version ++ ", " ++ copyright+  prog = "grm"+  copyright = "(C) Brett Letner 2011-2012"++main :: IO ()+main = do+  a <- cmdArgs argsDesc+  mapM_ (doit (locations a)) $ files a++doit :: Bool -> String -> IO ()+doit gen_locs fn = do+  eea <- parseFromFile grm fn+  case eea of+    Left e -> error $ show e+    Right xs -> do+      let bn = takeBaseName fn+      let dir = combine "Language" bn+      createDirectoryIfMissing True dir+      absGrm gen_locs dir bn xs+      parGrm gen_locs dir bn xs++absGrm :: Bool -> FilePath -> String -> [Decl] -> IO ()+absGrm gen_locs dir bn xs = writeFile (combine dir "Abs.hs") $ show d+  where+  d = vcat $+    [ text "{-# LANGUAGE DeriveDataTypeable #-}"+    , hsep [ text "module"+           , text $ "Language." ++ bn ++ ".Abs"+           , text "where"]+    , vcat [ text "import" <+> text imp | imp <- imps ]+    , lexDecls xs+    ] +++    map (dataDecl gen_locs) xs ++ +    (if gen_locs then map metaDecl xs else []) +++    map (ppDecl gen_locs) xs+  imps =+    [ "Control.DeepSeq"+    , "Data.Generics"+    , "Grm.Prims"+    , "Grm.Lex"+    , "Text.PrettyPrint.Leijen"+    ]++lexDecls :: [Decl] -> Doc+lexDecls xs = vcat+  [ hsep [text "myLexemes =", text $ show $ resDecls xs]+  , text "grmLexFilePath = lexFilePath myLexemes"+  , text "grmLexContents = lexContents myLexemes"+  ]++absName :: FilePath -> String+absName fn = takeBaseName fn++hdr :: String+hdr = unlines+  [ "{-# OPTIONS -w #-}"+  , "-- Haskell module generated by grm *** DO NOT EDIT ***"+  ]++parGrm :: Bool -> FilePath -> String -> [Decl] -> IO ()+parGrm gen_locs dir bn xs = do+  let fn1 = dir </> "Par.y"+  writeFile fn1 $ show d+  where+  d = vcat $+    [ parHdr+    ] +++    map (parDecl gen_locs [ s | List s _ _ _ _ _ <- xs ]) xs+  parHdr = vcat $ map text+    [ "{"+    , hdr+    , ""+    , "module Language." ++ bn ++ ".Par where"+    , "import Grm.Prims"+    , "import Grm.Lex"+    , "import Language." ++ bn ++ ".Abs"+    , "}"+    , "%tokentype { (Token Point) }"+    , "%name grmParse"+    , "%token"+    , unlines [ "  " ++ show sym ++ " " ++ "{ TSymbol _ " ++ show sym ++ " }"+                | sym <- resDecls xs ]+    , "  uident { TUident _ _ }"+    , "  usym { TUsym _ _ }"+    , "  lident { TLident _ _ }"+    , "  string { TString _ _ }"+    , "  char { TChar _ _ }"+    , "  number { TNumber _ _ }"+    , "%%"+    ]++capitalize :: String -> String+capitalize "" = ""+capitalize (c:cs) = toUpper c : cs++grm :: P [Decl]+grm = do+  whiteSpace+  ds <- many decl+  eof+  return ds++pGroup :: P Decl+pGroup = do+  reserved "group"+  liftM Group $ pBraces $ many1 pData++pData :: P DataD+pData = do+  reserved "data"+  n <- identifier+  xs <- many1 alt+  return $ DataD n xs++pList :: P Decl+pList = do+  reserved "list"+  liftM6 List identifier identifier pEmpty terminator stringLiteral horiz++decl :: P Decl+decl = choice [pGroup, liftM (Group . singleton) pData, pType, pList]++vcatStr :: String -> [Doc] -> Doc+vcatStr s xs = vcat $ intersperse (text s) xs++altList :: [Doc] -> Doc+altList (x0:xs) = vcat $+  [text "=" <+> x0] ++ [ text "|" <+> x | x <- xs ] +++  [text "deriving (Show,Eq,Ord,Data,Typeable)"]+altList [] = unreachable++dataDecl :: Bool -> Decl -> Doc+dataDecl gen_locs x = case x of+  Group [] -> unreachable+  Group xs@(DataD n0 _ : _) -> vcat $+    [text "data" <+> text n0 <+> locs, indent 2 $ altList $ concatMap (dataData gen_locs) xs]+    ++ types (dataDecl gen_locs) xs+  Type a b -> dataType gen_locs a $ text (capitalize b) <+> locs+  List a b _ _ _ _ -> dataType gen_locs a $ brackets $ text b <+> locs+  where+    locs = if gen_locs then text "a" else empty+    +types :: (Decl -> Doc) -> [DataD] -> [Doc]+types f (DataD b _ : xs) = [ f $ Type a b | DataD a _ <- xs ]+types _ [] = unreachable++dataType :: Bool -> String -> Doc -> Doc+dataType gen_locs a b = hsep [text "type", text a, locs, text "=", b]+  where locs = if gen_locs then text "a" else empty+        +dataData :: Bool -> DataD -> [Doc]+dataData gen_locs (DataD _ xs) =+  [ hsep $ map text $ s : locs : (catMaybes $ map (nameAltTok gen_locs) ts)+    | Alt s ts <- xs ]+  where locs = if gen_locs then "a" else ""+        +nameAltTok :: Bool -> AltTok -> Maybe String+nameAltTok gen_locs x = case x of+  StringT{} -> Nothing+  IdentT s -> Just $ if gen_locs then "(" ++ s ++ " a)" else s+  PrimT s -> Just $ capitalize s++metaDecl :: Decl -> Doc+metaDecl x = case x of+  Group [] -> unreachable+  Group xs@(DataD n0 _ : _) -> vcat $+    [ hsep [text "instance HasMeta", text n0, text "where"]+    , indent 2 $ text $ "meta x = case x of"+    , indent 4 $ vcat $ concatMap metaData xs+    ]+  Type{} -> empty+  List{} -> empty++metaData :: DataD -> [Doc]+metaData (DataD _ xs) = [ f s ts | Alt s ts <- xs ]+  where+  f s ts =+    hsep [text s, text "a", hsep $ replicate (length ys) (text "_"), text "-> a" ]+    where+    ys = filter (not . isStringT) ts++ppDecl :: Bool -> Decl -> Doc+ppDecl gen_locs x = case x of+  Group [] -> unreachable+  Group xs@(DataD n0 _ : _) -> vcat $+    [ hsep [ text "instance Pretty"+           , parens (text n0 <+> if gen_locs then text "a" else empty)+           , text "where" ]+    , indent 2 $ text "pretty = pp" <> text n0+    , text $ "pp" ++ n0 ++ " x = case x of"+    , indent 2 $ vcat $ concatMap (ppData gen_locs) xs+    ] ++ types (ppDecl gen_locs) xs+  Type a b -> hsep $ map text ["pp" ++ a, "=", "pp" ++ capitalize b]+  List a b _ d e f ->+    hsep $ map text ["pp" ++ a, "=", "ppList", "pp" ++ b, show d, show e, show f]++ppData :: Bool -> DataD -> [Doc]+ppData gen_locs (DataD _ xs) = [ f s ts | Alt s ts <- xs ]+  where+  f s ts =+    hsep [ text s+         , if gen_locs then text "_" else empty+         , hsep $ map text [ v | (Just v, _) <- ys ], text "->", ppAltToks ys ]+    where+    ys = nameToks "v" $ numberToks (not . isStringT) ts++isStringT :: AltTok -> Bool+isStringT (StringT{}) = True+isStringT _ = False++nameToks :: String -> [(Maybe Int, AltTok)] -> [(Maybe String, AltTok)]+nameToks s xs = [ (fmap (\i -> s ++ show i) mi, t) | (mi,t) <- xs ]++resDecls :: [Decl] -> [String]+resDecls xs = filter (not . null) $ sort $ nub $ concatMap resDecl xs++numberToks :: (AltTok -> Bool) -> [AltTok] -> [(Maybe Int, AltTok)]+numberToks f = loop 1+  where+  loop _ [] = []+  loop i (x:xs)+    | f x = (Just i, x) : loop (succ i) xs+    | otherwise = (Nothing, x) : loop i xs++ppAltToks :: [(Maybe String, AltTok)] -> Doc+ppAltToks [] = text "Text.PrettyPrint.Leijen.empty"+ppAltToks [x] = ppAltTok x+ppAltToks (x:y:xs) = ppAltTok x <+> rest+  where+  rest = case y of+    (_, StringT "") -> text "<>" <+> ppAltToks xs+    _ -> text "<+>" <+> ppAltToks (y:xs)++ppAltTok :: (Maybe String, AltTok) -> Doc+ppAltTok x = case x of+  (_, StringT "") -> error "unexpected empty string"+  (_, StringT s) -> hsep [text "text", text $ show s]+  (Just v, IdentT s) -> text $ "pp" ++ s ++ " " ++ v+  (mv, PrimT s) -> ppAltTok (mv, IdentT $ capitalize s)+  _ -> unreachable++pEmpty :: P Empty+pEmpty = choice+  [ reserved "empty" >> return Empty+  , reserved "nonempty" >> return NonEmpty+  ]++terminator :: P Terminator+terminator = choice+  [ reserved "separator" >> return Separator+  , reserved "terminator" >> return Terminator+  ]++horiz :: P Horiz+horiz = choice+  [ reserved "vert" >> return Vert+  , reserved "horiz" >> return Horiz+  ]++alt :: P Alt+alt = do+  reservedOp "|"+  choice [pAlt,defAlt]++pAlt :: P Alt+pAlt = do+  c <- identifier+  ts <- many altTok+  return $ Alt c ts++defAlt :: P Alt+defAlt = do+  reserved "_"+  liftM DefAlt identifier++pType :: P Decl+pType = do+  reserved "type"+  c <- identifier+  reservedOp "="+  p <- identifier+  return $ Type c p++altTok :: P AltTok+altTok = choice+  [ liftM StringT stringLiteral+  , liftM IdentT identifier+  , liftM PrimT prim+  ]++prim :: P String+prim = choice $ map res primNames++res :: String -> P String+res s = reserved s >> return s++primNames :: [String]+primNames = ["string","number","char","uident","lident","usym"]++data Decl+  = Group [DataD]+  | Type String String+  | List String String Empty Terminator String Horiz+  deriving Show++resDecl :: Decl -> [String]+resDecl x = case x of+  Group xs -> concatMap resData xs+  Type{} -> []+  List _ _ _ _ s _ -> [s]++resData :: DataD -> [String]+resData (DataD _ xs) = concatMap resAlt xs++resAlt :: Alt -> [String]+resAlt x = case x of+  Alt _ ys -> concatMap resAltTok ys+  DefAlt{} -> []++data DataD = DataD String [Alt] deriving Show++data Alt+  = Alt String [AltTok]+  | DefAlt String+  deriving Show++resAltTok :: AltTok -> [String]+resAltTok x = case x of+  StringT s -> [s]+  _ -> []++data AltTok+  = StringT String+  | IdentT String+  | PrimT String+  deriving (Show, Eq)++parData :: Bool -> [String] -> DataD -> Doc+parData gen_locs ss (DataD c xs0) = case filter f xs0 of+  [] -> unreachable+  x0:xs -> vcat+    [ text c+    , indent 2 $ vcat+        [ hsep [ text ":", parAlt gen_locs ss x0 ]+        , vcat [ text "|" <+> parAlt gen_locs ss x | x <- xs ]+        ]+    ]+  where+  f x = case x of+    Alt a _ -> last a /= '_'+    DefAlt{} -> True++parAlt :: Bool -> [String] -> Alt -> Doc+parAlt gen_locs ss x = case x of+  Alt c ts -> hsep $+    map parAltTokL ts +++    [braces $ hsep $ text c : (if gen_locs then loc else empty) : map parAltTokR ns ]+    where+    ns = nameToks "$" $ numberToks ((/=) (StringT "")) ts+    loc = case filter ((/=) (StringT "")) ts of+      [] -> text "noPoint"+      [_] -> parens (text "point $1")+      zs -> parens $ text "lrPoint" <+> list (map (pointAltTok ss) (zip zs [ 1 .. ]))+  DefAlt c -> hsep [text c, text "{ $1 }"]++pointAltTok :: [String] -> (AltTok,Int) -> Doc+pointAltTok ss (x,i) = case x of+  IdentT s | s `elem` ss -> text "lrPointList" <+> text "$" <> int i+  _ -> text "point" <+> text "$" <> int i++parAltTokR :: (Maybe String, AltTok) -> Doc+parAltTokR x = case x of+  (Just i, IdentT _) -> text i+  (Just i, PrimT s) -> parens (text ("unT" ++ capitalize s) <+> text i)+  _ -> empty++parAltTokL :: AltTok -> Doc+parAltTokL x = case x of+  StringT "" -> empty+  StringT s -> text $ show s+  IdentT s -> text s+  PrimT s -> text s++parDecl :: Bool -> [String] -> Decl -> Doc+parDecl gen_locs ss x = case x of+  Type a b -> hsep [text a, text ":", text b, braces $ text "$1"]+  Group xs -> vcat $ map (parData gen_locs ss) xs+  List prodsStr prodStr empt term sepStr _ -> vcat+    [ prods+    , indent 2 $ vcat+      [ hsep [text ":", rev_prods, braces $ text "reverse $1"]+      , case empt of+          Empty -> text "| {- empty -} { [] }"+          NonEmpty -> empty+      ]+    , rev_prods+    , indent 2 $ vcat+      [ hsep [text ":", a, braces $ brackets $ text "$1"]+      , hsep [text "|", rev_prods, b, braces $ hsep [c, text ": $1"]]+      ]+    ]+    where+    a = case term of+      Terminator | sepStr /= "" -> prod <+> sp+      _ -> prod+    b = case (sepStr, term) of+      ("", _) -> prod+      (_, Terminator) -> prod <+> sp+      (_, Separator) -> sp <+> prod+    c = case term of+      Separator | sepStr /= "" -> text "$3"+      _ -> text "$2"+    sp = text $ show sepStr+    rev_prods = text $ "REV_" ++ prodsStr+    prod = text prodStr+    prods = text prodsStr+++lexer :: P.TokenParser a+lexer = P.makeTokenParser grmStyle++reserved :: String -> P ()+reserved = P.reserved lexer++pBraces :: P a -> P a+pBraces = P.braces lexer++identifier :: P String+identifier = P.identifier lexer++reservedOp :: String -> P ()+reservedOp = P.reservedOp lexer++stringLiteral :: P String+stringLiteral = P.stringLiteral lexer++whiteSpace :: P ()+whiteSpace = P.whiteSpace lexer++grmStyle :: LanguageDef a+grmStyle = haskellStyle+  { P.identStart = upper+  }++liftM6 :: Monad m =>+  (t -> t1 -> t2 -> t3 -> t4 -> t5 -> b) ->+  m t -> m t1 -> m t2 -> m t3 -> m t4 -> m t5 -> m b+liftM6 z ma mb mc md me mf = do+  a <- ma+  b <- mb+  c <- mc+  d <- md+  e <- me+  f <- mf+  return $ z a b c d e f