diff --git a/GLM.cabal b/GLM.cabal --- a/GLM.cabal +++ b/GLM.cabal @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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: + +* +* +* +* +* +* + + +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) diff --git a/src/Dot.hs b/src/Dot.hs deleted file mode 100644 --- a/src/Dot.hs +++ /dev/null @@ -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 "") `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 (/= '\'') diff --git a/src/DotMain.hs b/src/DotMain.hs new file mode 100644 --- /dev/null +++ b/src/DotMain.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified GLM.Dot as D + +main :: IO () +main = D.main diff --git a/src/GLM/Dot.hs b/src/GLM/Dot.hs new file mode 100644 --- /dev/null +++ b/src/GLM/Dot.hs @@ -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 "") `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 (/= '\'') diff --git a/src/GLM/Nesting.hs b/src/GLM/Nesting.hs new file mode 100644 --- /dev/null +++ b/src/GLM/Nesting.hs @@ -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" diff --git a/src/GLM/Parser.hs b/src/GLM/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GLM/Parser.hs @@ -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 diff --git a/src/GLM/Tokenizer.hs b/src/GLM/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/GLM/Tokenizer.hs @@ -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) diff --git a/src/JSONMain.hs b/src/JSONMain.hs new file mode 100644 --- /dev/null +++ b/src/JSONMain.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified GLM.JSON as J + +main :: IO () +main = J.main diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 "" - -processFile :: String -> IO ParseResult -processFile f = readFile f >>= processContents f - -processContents :: String -> String -> IO ParseResult -processContents f c = return $ glmParser f c diff --git a/src/Nesting.hs b/src/Nesting.hs deleted file mode 100644 --- a/src/Nesting.hs +++ /dev/null @@ -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" diff --git a/src/Parser2.hs b/src/Parser2.hs deleted file mode 100644 --- a/src/Parser2.hs +++ /dev/null @@ -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 diff --git a/src/PropMain.hs b/src/PropMain.hs new file mode 100644 --- /dev/null +++ b/src/PropMain.hs @@ -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 "" + +processFile :: String -> IO ParseResult +processFile f = readFile f >>= processContents f + +processContents :: String -> String -> IO ParseResult +processContents f c = return $ glmParser f c diff --git a/src/Tokenizer.hs b/src/Tokenizer.hs deleted file mode 100644 --- a/src/Tokenizer.hs +++ /dev/null @@ -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) diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -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