packages feed

namelist (empty) → 0.1.0

raw patch · 9 files changed

+559/−0 lines, 9 filesdep +QuickCheckdep +basedep +case-insensitivesetup-changed

Dependencies added: QuickCheck, base, case-insensitive, data-default-class, namelist, parsec, tasty, tasty-hunit, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Hirotomo Moriwaki++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
+ namelist.cabal view
@@ -0,0 +1,42 @@+name:                namelist+version:             0.1.0+synopsis:            fortran90 namelist parser/pretty printer+description:         fortran90 namelist parser/pretty printer+license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage:            https://github.com/philopon/namelist-hs+Bug-reports:         https://github.com/philopon/namelist-hs/issues+copyright:           (c) 2015 Hirotomo Moriwaki+category:            Text+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Text.Namelist+                       Text.Namelist.Types+                       Text.Namelist.Parser+                       Text.Namelist.Pretty+  build-depends:       base                      >=4.6   && <4.9+                     , case-insensitive          >=1.1   && <1.3+                     , parsec                    >=3.0   && <3.2+                     , data-default-class        >=0.0   && <0.1+  hs-source-dirs:      src+  ghc-options:         -Wall -O2+  default-language:    Haskell2010++test-suite tasty+  main-is:             tasty.hs+  other-modules:       Instances+  type:                exitcode-stdio-1.0+  build-depends:       base                      >=4.6   && <4.9+                     , tasty                     >=0.10  && <0.11+                     , tasty-hunit               >=0.9   && <0.10+                     , tasty-quickcheck          >=0.8   && <0.9+                     , case-insensitive          >=1.1   && <1.3+                     , QuickCheck+                     , namelist+  hs-source-dirs:      tests+  ghc-options:         -Wall+  default-language:    Haskell2010
+ src/Text/Namelist.hs view
@@ -0,0 +1,25 @@+module Text.Namelist+    ( module Text.Namelist.Types+    , parse+    , Pretty, pretty+    , prettyCompact+    ) where++import Text.Namelist.Types+import Text.Namelist.Parser+import Text.Namelist.Pretty+import Data.Default.Class++import qualified Text.Parsec as P++parse :: String -> Either P.ParseError [Group]+parse = P.parse namelist ""++prettyWith :: Pretty a => PrettyConfig -> a -> String+prettyWith cfg = toString . ppr cfg++prettyCompact :: Pretty a => a -> String+prettyCompact = prettyWith def { mode = Compact, pairSeparator = "=" }++pretty :: Pretty a => a -> String+pretty = prettyWith def
+ src/Text/Namelist/Parser.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}++module Text.Namelist.Parser (namelist) where++import Text.Parsec hiding (letter)+import Data.Complex(Complex((:+)))+import Data.Char (toUpper, toLower, isDigit)+import Data.CaseInsensitive (CI, mk)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<$), (<*>), (<*), (*>), pure)+#endif++import Text.Namelist.Types++isLetter :: Char -> Bool+isLetter i+    | '\97' <= i && i <= '\122' = True+    | '\65' <= i && i <=  '\90' = True+    | otherwise                 = False++letter :: Stream s m Char => ParsecT s u m Char+letter = satisfy isLetter <?> "letter"++isAlphaNumeric :: Char -> Bool+isAlphaNumeric a = isLetter a || isDigit a || a == '_'++alphanumericCharacter :: Stream s m Char => ParsecT s u m Char+alphanumericCharacter = satisfy isAlphaNumeric <?> "alphanumeric-character"++name :: Stream s m Char => ParsecT s u m (CI String)+name = do+    n <- (:) <$> letter <*> many alphanumericCharacter <?> "name"+    if length n > 31+        then fail "name too long"+        else return $ mk n++sign :: (Stream s m Char, Num a) => ParsecT s u m (a -> a)+sign = (id <$ char '+') <|> (negate <$ char '-') <?> "sign"++fDigit :: Stream s m Char => ParsecT s u m Int+fDigit = (-) <$> (fromEnum <$> digit) <*> pure 48 <?> "digit"++unsignedInteger :: Stream s m Char => ParsecT s u m Int+unsignedInteger = chainl1 fDigit (pure $ \s d -> 10 * s + d)++integerLiteral :: Stream s m Char => ParsecT s u m Int+integerLiteral = ($) <$> option id sign <*> unsignedInteger <?> "integer"++exponentialPart :: Stream s m Char => ParsecT s u m Int+exponentialPart = oneOf "eEdDqQ" *> integerLiteral++realExpLiteral :: Stream s m Char => ParsecT s u m Double+realExpLiteral = do+    s <- option id sign+    i <- fromIntegral <$> unsignedInteger+    e <- fromIntegral <$> exponentialPart+    return $ s (i * 10 ** e)++realDotLiteral :: Stream s m Char => ParsecT s u m Double+realDotLiteral = do+    sgn    <- option id sign+    mbi    <- optionMaybe unsignedInteger+    _      <- char '.'+    (f, e) <- chainl ((,) <$> (fromIntegral <$> fDigit) <*> pure 1)+        (pure $ \(s, n) (d, _) -> (10 * s + d, n + 1)) (0 :: Integer,0)+    e2     <- option 0 exponentialPart+    i <- case mbi of+        Nothing | e == 0    -> fail "either decimal and floating part are missing"+                | otherwise -> return 0+        Just i -> return i++    return $ sgn $ fromIntegral (fromIntegral i * 10 ^ e + f) / 10 ** (fromIntegral $ e - e2)++realLiteral :: Stream s m Char => ParsecT s u m Double+realLiteral = try realExpLiteral <|> realDotLiteral++tokenize :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a+tokenize p = spaces *> p <* spaces++complexLiteral :: Stream s m Char => ParsecT s u m (Complex Double)+complexLiteral = (:+)+    <$> (char '(' *> tokenize realLiteral)+    <*> (char ',' *> tokenize realLiteral <* char ')')++ciString :: Stream s m Char => String -> ParsecT s u m String+ciString []     = return []+ciString (a:as) = (:) <$> oneOf [toUpper a, toLower a] <*> ciString as++shortLogicalLiteral :: Stream s m Char => ParsecT s u m Bool+shortLogicalLiteral = choice+    [ True  <$ (char 'T' <|> char 't')+    , False <$ (char 'F' <|> char 'f')+    ] <* lookAhead (satisfy $ not . isAlphaNumeric)++longLogicalLiteral :: Stream s m Char => ParsecT s u m Bool+longLogicalLiteral = char '.' *> choice+    [ True  <$ ciString "true."+    , False <$ ciString "false."+    ]++logicalLiteral :: Stream s m Char => ParsecT s u m Bool+logicalLiteral = shortLogicalLiteral <|> longLogicalLiteral++stringLiteral :: Stream s m Char => ParsecT s u m String+stringLiteral = sl '\'' <|> sl '"'+  where+    sl   s = char s *> many (body s) <* char s+    body s = try (s <$ char s *> char s) <|> noneOf [s]++literal :: Stream s m Char => ParsecT s u m Value+literal = choice+    [ try mulValue+    , try mulNull+    , try $ Real <$> realLiteral+    , Integer    <$> integerLiteral+    , Complex    <$> complexLiteral+    , try $ Logical <$> logicalLiteral+    , String     <$> stringLiteral+    ]++mulNull :: Stream s m Char => ParsecT s u m Value+mulNull = (:* Null) <$> unsignedInteger <* char '*'++mulValue :: Stream s m Char => ParsecT s u m Value+mulValue = (:*) <$> unsignedInteger <*> (char '*' *> literal)++index :: Stream s m Char => ParsecT s u m Index+index = choice+    [ try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> s (optionMaybe i)+    , try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> pure Nothing+    , try $ Index <$> u+    ] <?> "index"+  where+    u = tokenize unsignedInteger+    i = tokenize integerLiteral+    s = (char ':' *>)++key :: Stream s m Char => ParsecT s u m Key+key = choice+    [ try $ Indexed <$> name <*> (char '(' *> sepBy1 index (char ',') <* char ')')+    , try $ Sub <$> name <*> (char '%' *> key)+    , try $ Key <$> name+    ] <?> "key"++keyVal :: Stream s m Char => ParsecT s u m Pair+keyVal = do+    k <- key+    _ <- tokenize $ char '='+    v <- tokenize (literal <|> pure Null) `sepEndBy` tokenize (char ',')+    return $ k := case reverse v of+        [a]          -> a+        [Null,a]     -> a+        Null:Null:as -> Array (reverse $ Null:as)+        Null:as      -> Array (reverse as)+        as           -> Array (reverse as)++group :: Stream s m Char => ParsecT s u m Group+group = Group <$> tokenize (char '&' *> name) <*> many keyVal <* tokenize (char '/')++namelist :: Stream s m Char => ParsecT s u m [Group]+namelist = many group
+ src/Text/Namelist/Pretty.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}++module Text.Namelist.Pretty+    ( DString, toString+    , Pretty(..)+    , PrettyConfig(..), Mode(..)+    ) where++import Data.Complex(Complex((:+)))+import Data.CaseInsensitive (CI, original)+import Data.List(intersperse)+import Data.Char(toUpper)++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid(Monoid(..))+#endif++import Data.Monoid((<>))+import Data.Default.Class(Default(def))++import Text.Namelist.Types++newtype DString = DString (String -> String)++instance Monoid DString where+    mempty = DString id+    mappend (DString a) (DString b) = DString (a . b)+    {-# INLINABLE mempty #-}+    {-# INLINABLE mappend #-}++toString :: DString -> String+toString (DString d) = d []++fromString :: String -> DString+fromString s = DString (s ++)++fromShow :: Show a => a -> DString+fromShow = fromString . show++singleton :: Char -> DString+singleton c = DString (c:)++data Mode+    = Compact+    | Large { indent :: Int }++data PrettyConfig = PrettyConfig+    { prettyLogical :: String -> String+    , pairSeparator :: String+    , mode          :: Mode+    }++cfgCompact :: PrettyConfig -> Bool+cfgCompact (PrettyConfig _ _ Compact) = True+cfgCompact _ = False++instance Default PrettyConfig where+    def = PrettyConfig (map toUpper) " = " (Large 2)+    {-# INLINABLE def #-}++class Pretty a where+    ppr :: PrettyConfig -> a -> DString++instance Pretty Index where+    ppr _ (Index i)     = fromShow i+    ppr _ (Range l h s) = opt l <> colon <> opt h <> step+      where+        opt   = maybe mempty fromShow+        colon = singleton ':'+        step  = maybe mempty (\t -> colon <> fromShow t) s+    {-# INLINABLE ppr #-}++surround :: Char -> Char -> DString -> DString+surround a b c = singleton a <> c <> singleton b++instance Pretty [Index] where+    ppr _ = surround '(' ')' . mconcat . intersperse (singleton ',') . map (ppr def)+    {-# INLINABLE ppr #-}++ci :: CI String -> DString+ci = fromString . original++instance Pretty Key where+    ppr _ (Key k)       = ci k+    ppr _ (Indexed k i) = ci k <> ppr def i+    ppr _ (Sub k s)     = ci k <> singleton '%' <> ppr def s+    {-# INLINABLE ppr #-}++instance Pretty Value where+    ppr _   (Integer i) = fromShow i+    ppr _   (Real r)    = fromShow r++    ppr cfg (Complex (r :+ i)) = singleton '(' <> fromShow r <> singleton ',' <> sp <> fromShow i <> singleton ')'+      where+        sp = if cfgCompact cfg then mempty else singleton ' '++    ppr cfg (Logical True)  = fromString . prettyLogical cfg $ if cfgCompact cfg then "T" else ".True."+    ppr cfg (Logical False) = fromString . prettyLogical cfg $ if cfgCompact cfg then "F" else ".False."++    ppr _   (String s)+        | '\'' `notElem` s = singleton '\'' <> fromString s <> singleton '\''+        | '"'  `notElem` s = singleton '"'  <> fromString s <> singleton '"'+        | otherwise = singleton '\'' <> fromString (concatMap escape s) <> singleton '\''+      where+        escape '\'' = "''"+        escape a    = [a]++    ppr cfg (Array a) = mconcat . intersperse sep $ map (ppr cfg) a+      where+        sep = if cfgCompact cfg then singleton ',' else fromString ", "++    ppr cfg (r :* v)  = fromShow r <> singleton '*' <> ppr cfg v++    ppr _   Null = mempty+    {-# INLINABLE ppr #-}++instance Pretty Pair where+    ppr cfg (k := v) = ppr cfg k <> equal <> ppr cfg v+      where+        equal = if cfgCompact cfg then singleton '=' else fromString " = "+    {-# INLINABLE ppr #-}++instance Pretty [Pair] where+    ppr cfg@PrettyConfig{ mode = Compact } =+        mconcat . intersperse (fromString ", ") . map (ppr cfg)++    ppr cfg@PrettyConfig{ mode = Large i } =+        mconcat . intersperse (fromString ",\n") . map (\p -> ind <> ppr cfg p)+      where+        ind = fromString $ replicate i ' '+    {-# INLINABLE ppr #-}++instance Pretty Group where+    ppr cfg (Group g ps) = singleton '&' <> ci g <> gsp <> ppr cfg ps <> ged+      where+        gsp = if cfgCompact cfg then singleton ' ' else singleton '\n'+        ged = if cfgCompact cfg+              then fromString " /"+              else if null ps then singleton '/' else fromString "\n/"+    {-# INLINABLE ppr #-}++instance Pretty [Group] where+    ppr cfg@PrettyConfig{ mode = Compact } =+        mconcat . intersperse (singleton ' ') . map (ppr cfg)++    ppr cfg@PrettyConfig{ mode = Large _ } =+        mconcat . intersperse (singleton '\n') . map (ppr cfg)+    {-# INLINABLE ppr #-}
+ src/Text/Namelist/Types.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Text.Namelist.Types where++import Data.Complex+import Data.CaseInsensitive (CI)+import Data.Data(Data, Typeable)++data Index+    = Index Int+    | Range (Maybe Int) (Maybe Int) (Maybe Int)+    deriving (Show, Read, Data, Typeable, Eq)++data Key+    = Key     (CI String)+    | Indexed (CI String) [Index]+    | Sub     (CI String) Key+    deriving (Show, Read, Data, Typeable, Eq)++data Value+    = Integer Int+    | Real Double+    | Complex (Complex Double)+    | Logical Bool+    | String String+    | Array [Value]+    | Int :* Value+    | Null+    deriving (Show, Read, Data, Typeable, Eq)++data Pair = Key := Value+    deriving (Show, Read, Data, Typeable, Eq)++data Group = Group (CI String) [Pair]+    deriving (Show, Read, Data, Typeable, Eq)
+ tests/Instances.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Instances where++import Control.Monad(replicateM)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative((<$>), (<*>), pure)+#endif++import Test.Tasty.QuickCheck+import Text.Namelist.Types+import Data.Complex(Complex((:+)))+import Data.CaseInsensitive(mk)+import Data.Char(toUpper)+import Numeric(showFFloat)++arbitrarySafeDouble :: Gen Double+arbitrarySafeDouble = suchThat (arbitrary :: Gen Double) $ \d ->+    let (n, _:f) = break (== '.') $ showFFloat Nothing d ""+    in d == read (n ++ f) / 10 ** fromIntegral (length f)++arbitraryIndex :: Gen Index+arbitraryIndex = do+    i <- choose (1, maxBound)+    return $ Index i++arbitraryRange :: Gen Index+arbitraryRange = do+    a <- oneof [Just <$> choose (1, maxBound - 1),          pure Nothing]+    b <- oneof [Just <$> choose (maybe 1 succ a, maxBound), pure Nothing]+    s <- oneof [Just . unSmall <$> arbitrary,               pure Nothing]+    return $ Range a b s+  where+    unSmall (Small a) = a++instance Arbitrary Index where+    arbitrary = oneof+        [ arbitraryIndex+        , arbitraryRange+        ]++arbitraryName :: Gen String+arbitraryName = sized $ \i -> do+    a  <- elements alpha+    as <- replicateM (min i 30) (elements an_)+    return $ a : as+  where+    an_   = '_': ['0' .. '9'] ++ alpha+    alpha = map toUpper lower ++ lower+    lower = ['a'..'z']++arbitraryKeyName :: Gen Key+arbitraryKeyName = oneof+    [ Key . mk <$> arbitraryName+    , Indexed  <$> (mk <$> arbitraryName) <*> listOf1 arbitrary+    ]++arbitrarySub :: Gen Key+arbitrarySub = sized $ \depth ->+    if depth < 1+    then arbitraryKeyName+    else Sub <$> (mk <$> arbitraryName) <*> arbitrary++instance Arbitrary Key where+    arbitrary = oneof+        [ arbitraryKeyName+        , arbitrarySub+        ]++newtype Scalar = Scalar { unScalar :: Value }++instance Arbitrary Scalar where+    arbitrary = Scalar <$> oneof+        [ Integer <$> arbitrary+        , Real    <$> arbitrarySafeDouble+        , Complex <$> ((:+) <$> arbitrarySafeDouble <*> arbitrarySafeDouble)+        , Logical <$> arbitrary+        , String  <$> arbitrary+        ]++instance Arbitrary Value where+    arbitrary = oneof+        [ unScalar <$> arbitrary+        , pure Null+        , sized $ \i -> do+            as <- map unScalar <$> replicateM (max 1 i) arbitrary+            a  <- unScalar <$> arbitrary+            return $ Array (reverse $ a:as)+        , sized $ \i -> (:*) <$> pure i <*> (unScalar <$> arbitrary)+        ]++instance Arbitrary Pair where+    arbitrary = (:=) <$> arbitrary <*> arbitrary++scaleDouble :: (Double -> Double) -> Gen a -> Gen a+scaleDouble f = scale (round . f . fromIntegral)++instance Arbitrary Group where+    arbitrary = Group <$> (mk <$> arbitraryName) <*> arbitrary++newtype Namelist = Namelist { getNamelist :: [Group] }++instance Show Namelist where+    show (Namelist gs) = show gs++instance Arbitrary Namelist where+    arbitrary = Namelist <$> scaleDouble sqrt arbitrary
+ tests/tasty.hs view
@@ -0,0 +1,14 @@+import Test.Tasty+import Test.Tasty.QuickCheck++import Instances(Namelist(..))++import Text.Namelist++main :: IO ()+main = defaultMain $ testGroup ""+    [ testProperty "id = parse . pretty" $ \(Namelist gs) ->+        (parse . pretty) gs === Right gs+    , testProperty "id = parse . prettyCompact" $ \(Namelist gs) ->+        (parse . prettyCompact) gs === Right gs+    ]