packages feed

GLM 0.3.0.0 → 0.5.0.0

raw patch · 15 files changed

+582/−468 lines, 15 filesdep +aesonnew-component:exe:glm2json

Dependencies added: aeson

Files

GLM.cabal view
@@ -1,5 +1,5 @@ name:                GLM-version:             0.3.0.0+version:             0.5.0.0 synopsis:            Simple Gridlab-D GLM parser and utilities. description:         Simple Gridlab-D GLM parser and utilities. category:            Language@@ -10,6 +10,7 @@ maintainer:          maydwell@gmail.com build-type:          Simple cabal-version:       >=1.10+extra-source-files:  README.md  source-repository head   type:     git@@ -18,20 +19,26 @@ Library   default-language:    Haskell2010   Hs-source-dirs:      src-  Exposed-modules:     Dot, Nesting, Parser2, Tokenizer+  Exposed-modules:     GLM.Dot, GLM.Nesting, GLM.Parser, GLM.Tokenizer   build-depends:       base <= 5, parsec, interpolate, bytestring, pureMD5, transformers, lens, mtl,                        test-framework, test-framework-quickcheck2, QuickCheck, test-framework-th  executable glm2props   default-language:    Haskell2010-  main-is:             Main.hs+  main-is:             PropMain.hs   build-depends:       base <= 5, parsec, lens, test-framework, test-framework-th, test-framework-quickcheck2, pureMD5, interpolate, bytestring, mtl, GLM   hs-source-dirs:      src  executable glm2dot   default-language:    Haskell2010-  main-is:             Dot.hs+  main-is:             DotMain.hs   build-depends:       base <= 5, parsec, lens, test-framework, test-framework-th, test-framework-quickcheck2, pureMD5, interpolate, bytestring, mtl, GLM+  hs-source-dirs:      src++executable glm2json+  default-language:    Haskell2010+  main-is:             JSONMain.hs+  build-depends:       base <= 5, parsec, lens, test-framework, test-framework-th, test-framework-quickcheck2, pureMD5, interpolate, bytestring, mtl, GLM, aeson   hs-source-dirs:      src  Test-Suite test-glm
+ README.md view
@@ -0,0 +1,93 @@+# GLM++A small [GridLab-D](http://gridlab-d.sourceforge.net) markup parser.++Currently incomplete, but does work for simple files.++Includes the executables:++* glm2props - List properties found in file+* glm2dot   - Output a Dot file for use with GraphViz+* glm2json  - Convert GLM format to JSON format++Library functions are also exposesd under:++* GLM.Dot+* GLM.Nesting+* GLM.Parser2+* GLM.Tokenizer+* GLM.JSON++## Library++The main library interface can be found in GLM.Parser.++## glm2dot++Usage:++		Usage: glm2dot [-h|--help] [-e|--edges] [-f|--flatten] [FILE]*++		--flatten    creates new linked nodes for nested nodes+		--edge       only renders nodes that are connected to others+++Also accepts GLM format on STDIN.+++## glm2json++## glmprops+++Downloads:++* <http://sordina.binaries.s3.amazonaws.com/GLM-0.5.0.0-MacOSX-10.9.5-13F1077.zip>+* <http://sordina.binaries.s3.amazonaws.com/GLM-0.4.0.0-MacOSX-10.9.5-13F1077.zip>+* <http://sordina.binaries.s3.amazonaws.com/glm2props-0.3.0.0-MacOSX-10.9.5-13F1077.zip>+* <http://sordina.binaries.s3.amazonaws.com/glm2dot-0.3.0.0-MacOSX-10.9.5-13F1077.zip>+* <http://sordina.binaries.s3.amazonaws.com/glm2props-0.1.0.0-MacOSX-10.9.5-13F1077.zip>+* <http://sordina.binaries.s3.amazonaws.com/glm2dot-0.1.0.0-MacOSX-10.9.5-13F1077.zip>+++Example:++		bash-3.2$ head IEEE_4_node.glm+		// Exercise 4.1.1++		clock {+			timestamp '2000-01-01 0:00:00';+			timezone EST+5EDT;+		}++		module powerflow {+			solver_method NR;+		}++		bash-3.2$ glm2dot IEEE_4_node.glm++		digraph {+			// Missed entry ["clock"] - noname+			// Missed entry ["module","powerflow"] - powerflow+			"460bc4159" [label="overhead_line_conductor100"];+			"f98a57e6e" [label="overhead_line_conductor101"];+			"3ae695a1a" [label="line_spacing200"];+			"125c9f13f" [label="line_configuration300"];+			"6666bc20c" [label="transformer_configuration400"];+			"164546f60" [label="node1"];+			"89b8519c3" [label="overhead_line"];+			"164546f60" -> "78882aaeb"; // node1 -> node2+			"78882aaeb" [label="node2"];+			"72f1da2f1" [label="transformer23"];+			"78882aaeb" -> "1315e07dc"; // node2 -> node3+			"1315e07dc" [label="node3"];+			"ff93d9775" [label="overhead_line:34"];+			"1315e07dc" -> "6bf7ab42e"; // node3 -> load4+			"6bf7ab42e" [label="load4"];+		}++Graphical output:++		glm2dot -e IEEE_37node.glm | dot -Tpng -o blah.png && open blah.png++![Rendered GLM](http://i.imgur.com/OgqAYTl.png)
− src/Dot.hs 
@@ -1,100 +0,0 @@--{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ViewPatterns #-}--module Dot where--import Parser2-import qualified Nesting as N--import Data.Maybe-import System.Environment-import System.Exit-import System.IO-import Data.Digest.Pure.MD5-import Data.List-import Data.String.Interpolate-import qualified Data.ByteString.Lazy.Char8 as BS--data Options = Options { edges   :: Bool-                       , flatten :: Bool } deriving (Eq, Show)--def :: Options-def = Options { edges   = False-              , flatten = False }--str5 :: String -> String-str5 = take 9 . show . md5 . BS.pack--main :: IO ()-main = getArgs >>= start def--start :: Options -> [String] -> IO ()-start _ ["-h"     ]         = help-start _ ["--help" ]         = help-start o ("-e"       : args) = start (o {edges   = True}) args-start o ("--edges"  : args) = start (o {edges   = True}) args-start o ("-f"       : args) = start (o {flatten = True}) args-start o ("--flatten": args) = start (o {flatten = True}) args-start o args                = go args >>= mapM_ (outputResult o)--outputResult :: Options -> ParseResult -> IO ()-outputResult _    (Left  issue)   = putStrLn "Got an error:" >> spew issue >> exitFailure-outputResult opts (Right results) = putStrLn [i|digraph {#{unl $ concatMap graph (filter crit ung)}}|]-  where-  unl s = "\n" ++ unlines (map ("\t" ++) s)-  ung   = if (flatten opts) then N.flatten results else results-  rt    = concatMap refs ung-  crit  = criteria (edges opts) rt--spew :: Show a => a -> IO ()-spew = hPutStrLn stderr . show--criteria :: Bool -> [String] -> Entry -> Bool-criteria False _ _ = True-criteria True  l e = isJust $ find (== name e) l--refs :: Entry -> [String]-refs e@(Entry _ p) = fromMaybe [] $ do-  f <- lookup "from" c-  t <- lookup "to"   c-  return [name e, f, t]-  where-  c = catProps p--help :: IO ()-help = putStrLn "Usage: glm2dot [-h|--help] [-e|--edges] [-f|--flatten] [FILE]*"--go :: [String] -> IO [ParseResult]-go xs@(_:_) = mapM processFile xs-go []       = (return . glmParser "<STDIN>") `fmap` getContents--processFile :: String -> IO ParseResult-processFile f = glmParser f `fmap` readFile f--chash :: Entry -> String-chash = (++ "ef") . take 4 . str5 . (!! 1) . unSelector--graph :: Entry -> [String]-graph e@(Entry ("object":_:_) _) = fromMaybe [ [i|"#{nhash e}" [label="#{name e}", fillcolor="##{chash e}", style=filled];|] ] (edge e)-graph e@(Entry s _) = [ [i|// Missed entry #{s} - #{name e}|] ]--edge :: Entry -> Maybe [String]-edge e@(Entry _ p) = do-  f <- lookup "from" c-  t <- lookup "to"   c-  return [[i|"#{str5 f}" -> "#{str5 t}" [label="#{name e}"]; // #{f} -> #{t}|]]-  where-  c = catProps p--nhash :: Entry -> String-nhash = str5 . name--name :: Entry -> String-name (Entry (_:s:_) p) = maybe s noquote (lookup "name" c) where c = catProps p-name _ = "noname"---- TODO: Shouldn't need this now...----noquote :: String -> String-noquote = filter (/= '\'')
+ src/DotMain.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified GLM.Dot as D++main :: IO ()+main = D.main
+ src/GLM/Dot.hs view
@@ -0,0 +1,100 @@++{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module GLM.Dot where++import GLM.Parser+import qualified GLM.Nesting as N++import Data.Maybe+import System.Environment+import System.Exit+import System.IO+import Data.Digest.Pure.MD5+import Data.List+import Data.String.Interpolate+import qualified Data.ByteString.Lazy.Char8 as BS++data Options = Options { edges   :: Bool+                       , flatten :: Bool } deriving (Eq, Show)++def :: Options+def = Options { edges   = False+              , flatten = False }++str5 :: String -> String+str5 = take 9 . show . md5 . BS.pack++main :: IO ()+main = getArgs >>= start def++start :: Options -> [String] -> IO ()+start _ ["-h"     ]         = help+start _ ["--help" ]         = help+start o ("-e"       : args) = start (o {edges   = True}) args+start o ("--edges"  : args) = start (o {edges   = True}) args+start o ("-f"       : args) = start (o {flatten = True}) args+start o ("--flatten": args) = start (o {flatten = True}) args+start o args                = go args >>= mapM_ (outputResult o)++outputResult :: Options -> ParseResult -> IO ()+outputResult _    (Left  issue)   = putStrLn "Got an error:" >> spew issue >> exitFailure+outputResult opts (Right results) = putStrLn [i|digraph {#{unl $ concatMap graph (filter crit ung)}}|]+  where+  unl s = "\n" ++ unlines (map ("\t" ++) s)+  ung   = if (flatten opts) then N.flatten results else results+  rt    = concatMap refs ung+  crit  = criteria (edges opts) rt++spew :: Show a => a -> IO ()+spew = hPutStrLn stderr . show++criteria :: Bool -> [String] -> Entry -> Bool+criteria False _ _ = True+criteria True  l e = isJust $ find (== name e) l++refs :: Entry -> [String]+refs e@(Entry _ p) = fromMaybe [] $ do+  f <- lookup "from" c+  t <- lookup "to"   c+  return [name e, f, t]+  where+  c = catProps p++help :: IO ()+help = putStrLn "Usage: glm2dot [-h|--help] [-e|--edges] [-f|--flatten] [FILE]*"++go :: [String] -> IO [ParseResult]+go xs@(_:_) = mapM processFile xs+go []       = (return . glmParser "<STDIN>") `fmap` getContents++processFile :: String -> IO ParseResult+processFile f = glmParser f `fmap` readFile f++chash :: Entry -> String+chash = (++ "ef") . take 4 . str5 . (!! 1) . unSelector++graph :: Entry -> [String]+graph e@(Entry ("object":_:_) _) = fromMaybe [ [i|"#{nhash e}" [label="#{name e}", fillcolor="##{chash e}", style=filled];|] ] (edge e)+graph e@(Entry s _) = [ [i|// Missed entry #{s} - #{name e}|] ]++edge :: Entry -> Maybe [String]+edge e@(Entry _ p) = do+  f <- lookup "from" c+  t <- lookup "to"   c+  return [[i|"#{str5 f}" -> "#{str5 t}" [label="#{name e}"]; // #{f} -> #{t}|]]+  where+  c = catProps p++nhash :: Entry -> String+nhash = str5 . name++name :: Entry -> String+name (Entry (_:s:_) p) = maybe s noquote (lookup "name" c) where c = catProps p+name _ = "noname"++-- TODO: Shouldn't need this now...+--+noquote :: String -> String+noquote = filter (/= '\'')
+ src/GLM/Nesting.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module GLM.Nesting where++import GLM.Parser++import Data.Maybe+import Control.Lens+import Control.Monad.State++import Test.Framework+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++-- Tests++tests :: Test+tests = $(testGroupGenerator)++-- Properties++prop_flatten :: Bool+prop_flatten = (== 3) $ length $ flatten [Entry ["l1"] [Prop ("name", "n1"), Nested (Entry ["l2"] [])]]++-- Main Nesting Function++flatten :: [Entry] -> [Entry]+flatten entries = evalState (flatPack entries) 0++-- Nesting Helper Functions++catNested :: Entry -> [Entry]+catNested = toListOf (contents . each . _Nested)++addParent :: String -> Entry -> Entry+addParent p = over contents (++ [Prop ("parent",p)])++addName :: String -> Entry -> Entry+addName n = over contents (++ [Prop ("name",n)])++phantomLink :: String -> String -> Entry+phantomLink f t = Entry ["object","link"] [Prop ("name", "nl_"), Prop ("from", f), Prop ("to", t)]++flatPack :: [Entry] -> State Int [Entry]+flatPack es = do+  r <- mapM unNest es+  return $ (map stripNested es) ++ concat r++-- TODO: This could be better...+stripNested :: Entry -> Entry+stripNested e = set contents (map Prop (e ^.. contents . each . _Prop)) e++unNest :: Entry -> State Int [Entry]+unNest e = do+  r <- mapM (fabulate e) (catNested e)+  flatPack $ concat r++fabulate :: Entry -> Entry -> State Int [Entry]+fabulate p c = do+  modify succ+  s <- get+  let cname = getType c ++ show s ++ "_"+  return [c & addName cname & addParent pname, phantomLink pname cname]+  where+  pname = getName p++getName :: Entry -> String+getName = fromMaybe "unnamed" . lookup "name" . toListOf (contents . each . _Prop)++getType :: Entry -> String+getType (Entry (_:t:_) _) = t+getType _                 = "unknown"
+ src/GLM/Parser.hs view
@@ -0,0 +1,129 @@++{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module GLM.Parser where++import qualified GLM.Tokenizer as T++import qualified Text.Parsec as P+import Text.Parsec ((<|>))+import Control.Lens+import Data.Either++import Test.Framework+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++import Control.Applicative hiding (many, (<|>))++-- Data Types and Instances++data EntryItem = Prop   (String, String)+               | Nested Entry deriving (Show, Eq)++data Entry = Entry { _selector :: [String   ]+                   , _contents :: [EntryItem] } deriving (Show, Eq)++makePrisms ''EntryItem+makeLenses ''Entry++-- TODO: Temporary++type ParseResult = Either P.ParseError [Entry]++unSelector :: Entry -> [String]+unSelector = _selector+unContents :: Entry -> [EntryItem]+unContents = _contents++catProps :: Each s s EntryItem EntryItem => s -> [(String, String)]+catProps = toListOf (each . _Prop)++-- Tests++tests :: Test+tests = $(testGroupGenerator)++-- Positive Testing Properties++prop_topLevel_1, prop_topLevel_2, prop_topLevel_3, prop_topLevel_4, prop_topLevel_5, prop_topLevel_6, prop_topLevel_7 :: Bool+prop_topLevel_1 = isLen 1 $ glmParser "TEST" "x { y zzz; }"+prop_topLevel_2 = isLen 2 $ glmParser "TEST" "q { r s; }; t u {v w x;}"+prop_topLevel_3 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s; }; t u {v w x;}"+prop_topLevel_4 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s \"a super string!\"; }; t u {v w x;}"+prop_topLevel_5 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s \"a super string!\"; }; t u {v w x;}\n"+prop_topLevel_6 = isLen 2 $ glmParser "TEST" "a { b c; }\n// comment\nc d { e f g; }"+prop_topLevel_7 = isLen 3 $ glmParser "TEST" "a { b c; }\nmodule tape;\nc d { e f g; }"++-- Imported from old parser++prop_glmParser_1, prop_glmParser_2, prop_glmParser_3, prop_glmParser_4 :: Bool+prop_glmParser_1 = isRight $ glmParser "TEST" "object foo {\n\thello world;\n}"+prop_glmParser_2 = isRight $ glmParser "TEST" "object foo {\n\thello world;\n}\n"+prop_glmParser_3 = isLen 2 $ glmParser "TEST" "object foo {\n\ta b;\n};\nobject bar {\n\tc d;\n};\n"+prop_glmParser_4 = isRight $ glmParser "TEST" "object foo { a b; object x { y z; }; }; object bar { c d; };"++-- Negative Testing Properties++prop_topLevel_neg_1 :: Bool+prop_topLevel_neg_1 = isLeft  $ glmParser "TEST" "a { b c;sdf''' \n\n/ }} }\n// comment\nc d { e f g; }"++-- Testing Helpers++isLen :: Int -> Either t [a] -> Bool+isLen n (Right l) = length l == n+isLen _ _ = False++-- String Parser combining Tokenization and GLM Parsing++glmParser :: FilePath -> String -> Either P.ParseError [Entry]+glmParser f s = do+  x <- P.parse T.parseTokens (f ++ " (TOKENS)") s+  y <- P.parse topLevel      (f ++ " (GLM)"   ) (stripComments x)+  return y++stripComments :: [(T.Token, b)] -> [(T.Token, b)]+stripComments = filter (not . (T.?> _1 . T._TComment))++-- Assume that comments have been stripped out of the stream++topLevel :: T.T [ Entry ]+topLevel = P.sepEndBy entry (P.optional T.pTSemi)++entry :: T.T Entry+entry = do+  sel <- P.many1 T.pTString+  braced sel <|> modl sel++modl :: [T.Token] -> T.T Entry+modl p = return $ Entry (selWords p) []++selWords :: Each s s T.Token T.Token => s -> [String]+selWords p = (p ^.. each . T._TString)++entryItems :: T.T [EntryItem]+entryItems = P.sepEndBy item T.pTSemi++item :: T.T EntryItem+item = do+  p <- prop+  P.try (nested p) <|> return (Prop (p ^. _head . T._TString, unwords $ p ^.. _tail . each . T._TString))++prop :: T.T [ T.Token ]+prop = P.many1 T.pTString++nested :: [T.Token] -> T.T EntryItem+nested p = Nested <$> braced p++braced :: [T.Token] -> T.T Entry+braced p = do+  T.pTLBrace+  c <- entryItems+  T.pTRBrace+  return $ Entry (selWords p) c
+ src/GLM/Tokenizer.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GLM.Tokenizer where++import qualified Text.Parsec as P+import Text.Parsec ((<|>))+import Data.String+import Data.Either+import Data.Maybe+import Data.Monoid+import Control.Lens+import Control.Applicative hiding (many, (<|>))++import Test.Framework+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++-- Data Types and Instances++type P a = P.Parsec String     () a+type T a = P.Parsec [TokenPos] () a++type TokenPos = (Token, P.SourcePos)++data Token = TString  String+           | TComment String+           | LBrace+           | RBrace+           | Semi+           deriving (Eq, Show)++makePrisms ''Token++instance s ~ String => IsString (P s) where fromString = P.string+instance t ~ Token  => IsString (T t) where fromString = pTParse -- Should just "Do the right thing"++(?>) :: s -> Getting (First a) s a -> Bool+d ?> p = isJust $ d ^? p++parseTokens :: P [TokenPos]+parseTokens = P.sepEndBy parseTokenPos (P.many P.space)++parseTokenPos :: P TokenPos+parseTokenPos = do+  pos <- P.getPosition+  tok <- pToken+  return (tok, pos)++pToken :: P Token+pToken = pComment <|> pLBrace <|> pRBrace <|> pSemi <|> pString <|> pWord++-- Tests++tests :: Test+tests = $(testGroupGenerator)++-- Props++prop_tokens_1, prop_tokens_2, prop_tokens_3, prop_tokens_4, prop_tokens_5 :: Bool+prop_tokens_1 = isRight $ P.parse parseTokens "TEST" "\"he\\\"as\\ndf\\\"llo\";;;"+prop_tokens_2 = isRight $ P.parse parseTokens "TEST" "\"he\\\"as\\ndf\\\"llo\";  ;;\n//wtf  alksdjhfs \n;;"+prop_tokens_3 = Right LBrace == P.parse pToken "TEST" "{"+prop_tokens_4 = Right RBrace == P.parse pToken "TEST" "}"+prop_tokens_5 = Right RBrace == P.parse pToken "TEST" "}"++-- TokenPos Combinators++pTStringE, pTCommentE, pTParse :: String -> T Token+pTParse    s = tSatisfy ((== P.parse pToken "inline" s) . Right . fst)+pTStringE  s = tSatisfy ((== TString  s) . fst)+pTCommentE s = tSatisfy ((== TComment s) . fst)++pTLBrace, pTRBrace, pTSemi, pTComment, pTString, pTAny :: T Token+pTAny     = tSatisfy (const True)+pTString  = tSatisfy (?> _1 . _TString )+pTComment = tSatisfy (?> _1 . _TComment)+pTLBrace  = tSatisfy (?> _1 . _LBrace  )+pTRBrace  = tSatisfy (?> _1 . _RBrace  )+pTSemi    = tSatisfy (?> _1 . _Semi    )++-- Token Parsers++pString, pWord, pLBrace, pRBrace, pSemi, pComment :: P Token+pString  = fmap TString parseString+pWord    = fmap TString parseWord+pLBrace  = "{" *> return LBrace+pRBrace  = "}" *> return RBrace+pSemi    = ";" *> return Semi+pComment = do+  start <- "#" <|> "//"+  body  <- P.many $ P.noneOf "\r\n"+  P.optional P.endOfLine+  return $ TComment $ start ++ body++-- Word Parser++parseWord :: P String+parseWord = P.many1 (P.noneOf " ;\n\t\r{}\"\\#")++-- String Parser++escape :: P String+escape = do+    d <- P.char '\\'+    c <- P.oneOf "\\\"0nrvtbf" -- all the characters which can be escaped+    return [d, c]++nonEscape :: P Char+nonEscape = P.noneOf "\\\"\0\n\r\v\t\b\f"++character :: P String+character = fmap return nonEscape <|> escape++parseString :: P String+parseString = fmap concat ( P.char '"' *> P.many character <* P.char '"' )++-- Primitives for token stream++advance :: P.SourcePos -> t -> [TokenPos] -> P.SourcePos+advance _ _ ((_, pos) : _) = pos+advance pos _ [] = pos++tSatisfy :: (TokenPos -> Bool) -> T Token+tSatisfy f = P.tokenPrim show advance (\c -> if f c then Just (fst c) else Nothing)
+ src/JSONMain.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified GLM.JSON as J++main :: IO ()+main = J.main
− src/Main.hs 
@@ -1,29 +0,0 @@-module Main where--import System.Environment-import Parser2--main :: IO ()-main = getArgs >>= start--start :: [String] -> IO ()-start ["-h"]     = help-start ["--help"] = help-start args       = go args >>= mapM_ outputResult--outputResult :: ParseResult -> IO ()-outputResult (Left  issue)   = print "Got an error:" >> print issue-outputResult (Right results) = mapM_ print results--help :: IO ()-help = putStrLn "Usage: glm [FILE]*"--go :: [String] -> IO [ParseResult]-go xs@(_:_) = mapM processFile xs-go []       = fmap return $ getContents >>= processContents "<STDIN>"--processFile :: String -> IO ParseResult-processFile f = readFile f >>= processContents f--processContents :: String -> String -> IO ParseResult-processContents f c = return $ glmParser f c
− src/Nesting.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module Nesting where--import Parser2-import Data.Maybe-import Control.Lens-import Control.Monad.State--import Test.Framework-import Test.Framework.TH-import Test.Framework.Providers.QuickCheck2---- Tests--tests :: Test-tests = $(testGroupGenerator)---- Properties--prop_flatten :: Bool-prop_flatten = (== 3) $ length $ flatten [Entry ["l1"] [Prop ("name", "n1"), Nested (Entry ["l2"] [])]]---- Main Nesting Function--flatten :: [Entry] -> [Entry]-flatten entries = evalState (flatPack entries) 0---- Nesting Helper Functions--catNested :: Entry -> [Entry]-catNested = toListOf (contents . each . _Nested)--addParent :: String -> Entry -> Entry-addParent p = over contents (++ [Prop ("parent",p)])--addName :: String -> Entry -> Entry-addName n = over contents (++ [Prop ("name",n)])--phantomLink :: String -> String -> Entry-phantomLink f t = Entry ["object","link"] [Prop ("name", "nl_"), Prop ("from", f), Prop ("to", t)]--flatPack :: [Entry] -> State Int [Entry]-flatPack es = do-  r <- mapM unNest es-  return $ (map stripNested es) ++ concat r---- TODO: This could be better...-stripNested :: Entry -> Entry-stripNested e = set contents (map Prop (e ^.. contents . each . _Prop)) e--unNest :: Entry -> State Int [Entry]-unNest e = do-  r <- mapM (fabulate e) (catNested e)-  flatPack $ concat r--fabulate :: Entry -> Entry -> State Int [Entry]-fabulate p c = do-  modify succ-  s <- get-  let cname = getType c ++ show s ++ "_"-  return [c & addName cname & addParent pname, phantomLink pname cname]-  where-  pname = getName p--getName :: Entry -> String-getName = fromMaybe "unnamed" . lookup "name" . toListOf (contents . each . _Prop)--getType :: Entry -> String-getType (Entry (_:t:_) _) = t-getType _                 = "unknown"
− src/Parser2.hs 
@@ -1,128 +0,0 @@--{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoMonomorphismRestriction #-}--module Parser2 where--import qualified Tokenizer as T-import qualified Text.Parsec as P-import Text.Parsec ((<|>))-import Control.Lens-import Data.Either--import Test.Framework-import Test.Framework.TH-import Test.Framework.Providers.QuickCheck2--import Control.Applicative hiding (many, (<|>))---- Data Types and Instances--data EntryItem = Prop   (String, String)-               | Nested Entry deriving (Show, Eq)--data Entry = Entry { _selector :: [String   ]-                   , _contents :: [EntryItem] } deriving (Show, Eq)--makePrisms ''EntryItem-makeLenses ''Entry---- TODO: Temporary--type ParseResult = Either P.ParseError [Entry]--unSelector :: Entry -> [String]-unSelector = _selector-unContents :: Entry -> [EntryItem]-unContents = _contents--catProps :: Each s s EntryItem EntryItem => s -> [(String, String)]-catProps = toListOf (each . _Prop)---- Tests--tests :: Test-tests = $(testGroupGenerator)---- Positive Testing Properties--prop_topLevel_1, prop_topLevel_2, prop_topLevel_3, prop_topLevel_4, prop_topLevel_5, prop_topLevel_6, prop_topLevel_7 :: Bool-prop_topLevel_1 = isLen 1 $ glmParser "TEST" "x { y zzz; }"-prop_topLevel_2 = isLen 2 $ glmParser "TEST" "q { r s; }; t u {v w x;}"-prop_topLevel_3 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s; }; t u {v w x;}"-prop_topLevel_4 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s \"a super string!\"; }; t u {v w x;}"-prop_topLevel_5 = isLen 2 $ glmParser "TEST" "q { a {b c}; r s \"a super string!\"; }; t u {v w x;}\n"-prop_topLevel_6 = isLen 2 $ glmParser "TEST" "a { b c; }\n// comment\nc d { e f g; }"-prop_topLevel_7 = isLen 3 $ glmParser "TEST" "a { b c; }\nmodule tape;\nc d { e f g; }"---- Imported from old parser--prop_glmParser_1, prop_glmParser_2, prop_glmParser_3, prop_glmParser_4 :: Bool-prop_glmParser_1 = isRight $ glmParser "TEST" "object foo {\n\thello world;\n}"-prop_glmParser_2 = isRight $ glmParser "TEST" "object foo {\n\thello world;\n}\n"-prop_glmParser_3 = isLen 2 $ glmParser "TEST" "object foo {\n\ta b;\n};\nobject bar {\n\tc d;\n};\n"-prop_glmParser_4 = isRight $ glmParser "TEST" "object foo { a b; object x { y z; }; }; object bar { c d; };"---- Negative Testing Properties--prop_topLevel_neg_1 :: Bool-prop_topLevel_neg_1 = isLeft  $ glmParser "TEST" "a { b c;sdf''' \n\n/ }} }\n// comment\nc d { e f g; }"---- Testing Helpers--isLen :: Int -> Either t [a] -> Bool-isLen n (Right l) = length l == n-isLen _ _ = False---- String Parser combining Tokenization and GLM Parsing--glmParser :: FilePath -> String -> Either P.ParseError [Entry]-glmParser f s = do-  x <- P.parse T.parseTokens (f ++ " (TOKENS)") s-  y <- P.parse topLevel      (f ++ " (GLM)"   ) (stripComments x)-  return y--stripComments :: [(T.Token, b)] -> [(T.Token, b)]-stripComments = filter (not . (T.?> _1 . T._TComment))---- Assume that comments have been stripped out of the stream--topLevel :: T.T [ Entry ]-topLevel = P.sepEndBy entry (P.optional T.pTSemi)--entry :: T.T Entry-entry = do-  sel <- P.many1 T.pTString-  braced sel <|> modl sel--modl :: [T.Token] -> T.T Entry-modl p = return $ Entry (selWords p) []--selWords :: Each s s T.Token T.Token => s -> [String]-selWords p = (p ^.. each . T._TString)--entryItems :: T.T [EntryItem]-entryItems = P.sepEndBy item T.pTSemi--item :: T.T EntryItem-item = do-  p <- prop-  P.try (nested p) <|> return (Prop (p ^. _head . T._TString, unwords $ p ^.. _tail . each . T._TString))--prop :: T.T [ T.Token ]-prop = P.many1 T.pTString--nested :: [T.Token] -> T.T EntryItem-nested p = Nested <$> braced p--braced :: [T.Token] -> T.T Entry-braced p = do-  T.pTLBrace-  c <- entryItems-  T.pTRBrace-  return $ Entry (selWords p) c
+ src/PropMain.hs view
@@ -0,0 +1,29 @@+module Main where++import System.Environment+import GLM.Parser++main :: IO ()+main = getArgs >>= start++start :: [String] -> IO ()+start ["-h"]     = help+start ["--help"] = help+start args       = go args >>= mapM_ outputResult++outputResult :: ParseResult -> IO ()+outputResult (Left  issue)   = print "Got an error:" >> print issue+outputResult (Right results) = mapM_ print results++help :: IO ()+help = putStrLn "Usage: glm [FILE]*"++go :: [String] -> IO [ParseResult]+go xs@(_:_) = mapM processFile xs+go []       = fmap return $ getContents >>= processContents "<STDIN>"++processFile :: String -> IO ParseResult+processFile f = readFile f >>= processContents f++processContents :: String -> String -> IO ParseResult+processContents f c = return $ glmParser f c
− src/Tokenizer.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Tokenizer where--import qualified Text.Parsec as P-import Text.Parsec ((<|>))-import Data.String-import Data.Either-import Data.Maybe-import Data.Monoid-import Control.Lens-import Control.Applicative hiding (many, (<|>))--import Test.Framework-import Test.Framework.TH-import Test.Framework.Providers.QuickCheck2---- Data Types and Instances--type P a = P.Parsec String     () a-type T a = P.Parsec [TokenPos] () a--type TokenPos = (Token, P.SourcePos)--data Token = TString  String-           | TComment String-           | LBrace-           | RBrace-           | Semi-           deriving (Eq, Show)--makePrisms ''Token--instance s ~ String => IsString (P s) where fromString = P.string-instance t ~ Token  => IsString (T t) where fromString = pTParse -- Should just "Do the right thing"--(?>) :: s -> Getting (First a) s a -> Bool-d ?> p = isJust $ d ^? p--parseTokens :: P [TokenPos]-parseTokens = P.sepEndBy parseTokenPos (P.many P.space)--parseTokenPos :: P TokenPos-parseTokenPos = do-  pos <- P.getPosition-  tok <- pToken-  return (tok, pos)--pToken :: P Token-pToken = pComment <|> pLBrace <|> pRBrace <|> pSemi <|> pString <|> pWord---- Tests--tests :: Test-tests = $(testGroupGenerator)---- Props--prop_tokens_1, prop_tokens_2, prop_tokens_3, prop_tokens_4, prop_tokens_5 :: Bool-prop_tokens_1 = isRight $ P.parse parseTokens "TEST" "\"he\\\"as\\ndf\\\"llo\";;;"-prop_tokens_2 = isRight $ P.parse parseTokens "TEST" "\"he\\\"as\\ndf\\\"llo\";  ;;\n//wtf  alksdjhfs \n;;"-prop_tokens_3 = Right LBrace == P.parse pToken "TEST" "{"-prop_tokens_4 = Right RBrace == P.parse pToken "TEST" "}"-prop_tokens_5 = Right RBrace == P.parse pToken "TEST" "}"---- TokenPos Combinators--pTStringE, pTCommentE, pTParse :: String -> T Token-pTParse    s = tSatisfy ((== P.parse pToken "inline" s) . Right . fst)-pTStringE  s = tSatisfy ((== TString  s) . fst)-pTCommentE s = tSatisfy ((== TComment s) . fst)--pTLBrace, pTRBrace, pTSemi, pTComment, pTString, pTAny :: T Token-pTAny     = tSatisfy (const True)-pTString  = tSatisfy (?> _1 . _TString )-pTComment = tSatisfy (?> _1 . _TComment)-pTLBrace  = tSatisfy (?> _1 . _LBrace  )-pTRBrace  = tSatisfy (?> _1 . _RBrace  )-pTSemi    = tSatisfy (?> _1 . _Semi    )---- Token Parsers--pString, pWord, pLBrace, pRBrace, pSemi, pComment :: P Token-pString  = fmap TString parseString-pWord    = fmap TString parseWord-pLBrace  = "{" *> return LBrace-pRBrace  = "}" *> return RBrace-pSemi    = ";" *> return Semi-pComment = do-  start <- "#" <|> "//"-  body  <- P.many $ P.noneOf "\r\n"-  P.optional P.endOfLine-  return $ TComment $ start ++ body---- Word Parser--parseWord :: P String-parseWord = P.many1 (P.noneOf " ;\n\t\r{}\"\\#")---- String Parser--escape :: P String-escape = do-    d <- P.char '\\'-    c <- P.oneOf "\\\"0nrvtbf" -- all the characters which can be escaped-    return [d, c]--nonEscape :: P Char-nonEscape = P.noneOf "\\\"\0\n\r\v\t\b\f"--character :: P String-character = fmap return nonEscape <|> escape--parseString :: P String-parseString = fmap concat ( P.char '"' *> P.many character <* P.char '"' )---- Primitives for token stream--advance :: P.SourcePos -> t -> [TokenPos] -> P.SourcePos-advance _ _ ((_, pos) : _) = pos-advance pos _ [] = pos--tSatisfy :: (TokenPos -> Bool) -> T Token-tSatisfy f = P.tokenPrim show advance (\c -> if f c then Just (fst c) else Nothing)
test/TestMain.hs view
@@ -4,9 +4,9 @@  import Test.Framework -import qualified Parser2   as P-import qualified Tokenizer as T-import qualified Nesting   as N+import qualified GLM.Parser    as P+import qualified GLM.Tokenizer as T+import qualified GLM.Nesting   as N  main :: IO () main = defaultMain