packages feed

GLM (empty) → 0.3.0.0

raw patch · 9 files changed

+543/−0 lines, 9 filesdep +GLMdep +QuickCheckdep +basesetup-changed

Dependencies added: GLM, QuickCheck, base, bytestring, interpolate, lens, mtl, parsec, pureMD5, test-framework, test-framework-quickcheck2, test-framework-th, transformers

Files

+ GLM.cabal view
@@ -0,0 +1,42 @@+name:                GLM+version:             0.3.0.0+synopsis:            Simple Gridlab-D GLM parser and utilities.+description:         Simple Gridlab-D GLM parser and utilities.+category:            Language+homepage:            http://github.com/sordina/GLM+license:             MIT+license-file:        LICENSE+author:              Lyndon Maydwell+maintainer:          maydwell@gmail.com+build-type:          Simple+cabal-version:       >=1.10++source-repository head+  type:     git+  location: git@github.com:sordina/GLM++Library+  default-language:    Haskell2010+  Hs-source-dirs:      src+  Exposed-modules:     Dot, Nesting, Parser2, 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+  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+  build-depends:       base <= 5, parsec, lens, test-framework, test-framework-th, test-framework-quickcheck2, pureMD5, interpolate, bytestring, mtl, GLM+  hs-source-dirs:      src++Test-Suite test-glm+  default-language:    Haskell2010+  Type:                exitcode-stdio-1.0+  Hs-Source-Dirs:      src,test+  Main-is:             TestMain.hs+  build-depends:       base <= 5, parsec, lens, test-framework, test-framework-th, test-framework-quickcheck2, mtl, GLM
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) <year> <copyright holders>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Dot.hs view
@@ -0,0 +1,100 @@++{-# 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/Main.hs view
@@ -0,0 +1,29 @@+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 view
@@ -0,0 +1,75 @@+{-# 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 view
@@ -0,0 +1,128 @@++{-# 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/Tokenizer.hs view
@@ -0,0 +1,129 @@+{-# 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
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Test.Framework++import qualified Parser2   as P+import qualified Tokenizer as T+import qualified Nesting   as N++main :: IO ()+main = defaultMain+  [ testGroup "Parser"    [ P.tests ]+  , testGroup "Tokenizer" [ T.tests ]+  , testGroup "Nesting"   [ N.tests ]+  ]+