Add first version of project

.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+flp-project.cabal
+*~
+.idea/

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for flp-project
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2020
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -1,2 +1 @@
-# plg-2-nka
-FLP 1.project
+# flp-project

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

flp-project.iml

@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<module type="HASKELL_MODULE" version="4">
+  <component name="NewModuleRootManager" inherit-compiler-output="true">
+    <exclude-output />
+    <content url="file://$MODULE_DIR$">
+      <sourceFolder url="file://$MODULE_DIR$/src" isTestSource="false" />
+      <sourceFolder url="file://$MODULE_DIR$/test" isTestSource="true" />
+      <excludeFolder url="file://$MODULE_DIR$/.stack-work" />
+    </content>
+    <orderEntry type="inheritedJdk" />
+    <orderEntry type="sourceFolder" forTests="false" />
+    <orderEntry type="library" name="base-4.13.0.0" level="project" />
+    <orderEntry type="library" name="ghc-prim-0.5.3" level="project" />
+    <orderEntry type="library" name="integer-gmp-1.0.2.0" level="project" />
+  </component>
+</module>

out/production/flp-project/ErrorControl.hs

@@ -0,0 +1,57 @@
+module ErrorControl where
+
+import Data.List
+import System.Exit
+import System.IO
+
+errMsgGrammar :: String
+errMsgGrammar = "Wrong format of input grammar: \n "
+
+varErrMsgRange :: String
+varErrMsgRange = "Variables must be character in the range [A-Z]: "
+
+varErrMsgOccur :: String
+varErrMsgOccur = "Variables should no be entered twice in the input list: "
+
+termErrMsgRange :: String
+termErrMsgRange = "Terminals must be character in the range [a-z]: "
+
+termErrMsgOccur :: String
+termErrMsgOccur = "Terminals should not be entered twice in the input list: "
+
+productionsWrongFormat :: String
+productionsWrongFormat = "Productions have not required format: \n"
+
+exitWithErrMsg :: ExitCode -> String -> IO a
+exitWithErrMsg errCode errMsg = hPutStrLn stderr errMsg >> exitWith errCode
+
+printWarning :: String -> IO ()
+printWarning = hPutStrLn stderr
+
+productionErrMsg :: [(Int, Int)] -> [(Int, String)] -> Int -> String
+productionErrMsg errIndices errTuples errCode
+  | errCode == 0 =
+    baseErrMsg ++
+    "   Missing or badly located arrows in productions no.: " ++
+    show (map (\(x, y) -> show (x + 4) ++ ". line: " ++ show (y + 1) ++ ". column") errIndices)
+  | errCode == 1 =
+    baseErrMsg ++
+    "   Left side of productions must be character in the range [A-Z]: " ++
+    show (map (\(x, y) -> show (x + 4) ++ ". line: " ++ y) errTuples)
+  | errCode == 2 =
+    baseErrMsg ++
+    "   Invalid format of right side in productions no.: " ++
+    show (map (\(x, y) -> show (x + 4) ++ ". line: " ++ y) errTuples)
+  | otherwise = baseErrMsg
+  where
+    baseErrMsg = errMsgGrammar ++ productionsWrongFormat
+
+symbolErrMsg isRange multipleSymbols wrongSymbols symbolGroup =
+  errMsgGrammar ++
+  if symbolGroup 'A'
+    then if isRange
+           then varErrMsgRange ++ show wrongSymbols
+           else varErrMsgOccur ++ show (map (\(x, y) -> x ++ ": " ++ show y) multipleSymbols)
+    else if isRange
+           then termErrMsgRange ++ show wrongSymbols
+           else termErrMsgOccur ++ show (map (\(x, y) -> x ++ ": " ++ show y) multipleSymbols)

out/production/flp-project/Helpers.hs

@@ -0,0 +1,44 @@
+module Helpers where
+
+import Data.Char
+import Data.Function
+import Data.List
+import Data.Maybe
+
+strip :: String -> String
+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+containsInvalidSymbol :: (Char -> Bool) -> [String] -> Bool
+containsInvalidSymbol group symbols = not (all (all group) symbols)
+
+isNotGrammarSymbol :: [String] -> Bool
+isNotGrammarSymbol = any ((> 1) . length)
+
+splitBy :: (Eq a) => a -> [a] -> [[a]]
+splitBy ch = filter (notElem ch) . groupBy ((==) `on` (== ch))
+
+findString :: (Eq a) => [a] -> [a] -> Int
+findString search str = fromMaybe (-1) $ findIndex (isPrefixOf search) (tails str)
+
+getInvalidLeftSides :: (Eq (t Char), Foldable t) => [t Char] -> [(Int, t Char)]
+getInvalidLeftSides vars = zip (findIndices (`elem` invalidLeftSides) vars) invalidLeftSides
+  where
+    invalidLeftSides = vars \\ filter (all isAsciiUpper) vars
+
+getInvalidArrows :: [String] -> [(Int, Int)]
+getInvalidArrows productions =
+  zip (getInvalidIndices productions) (filter (/= 1) (map (findString "->") productions))
+
+getInvalidIndices productions =
+  [0 .. genericLength productions - 1] \\ elemIndices 1 (map (findString "->") productions)
+
+getValidatedRightSides symbols =
+  zipWith (||) (map (all isAsciiAlpha) symbols) (map (== "#") symbols)
+  where
+    isAsciiAlpha ch = (||) (isAsciiUpper ch) (isAsciiLower ch)
+
+containsInvalidSymbols :: [String] -> Bool
+containsInvalidSymbols symbols = not $ all (== True) $ getValidatedRightSides symbols
+
+getInvalidRightSides symbols =
+  map (\idx -> (idx, (!!) symbols idx)) (elemIndices False (getValidatedRightSides symbols))

out/production/flp-project/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import ParseArgs
+import ParseInput
+
+main = do
+  (args, files) <- parseArgs
+  putStrLn $ "Flags: " ++ show args
+  putStrLn $ "Files: " ++ show files
+  input <- parseInput $ head files
+  putStrLn "END OF PROGRAM "

out/production/flp-project/ParseArgs.hs

@@ -0,0 +1,43 @@
+module ParseArgs where
+
+import ErrorControl
+import Helpers
+
+import Data.List
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+
+data Options
+  = Help -- --help
+  | PLG -- -i
+  | NKA -- -1
+  | TLG -- -2
+  deriving (Eq, Ord, Enum, Show, Bounded)
+
+options =
+  [ Option ['i'] [] (NoArg PLG) "TODO DESCRIPTION"
+  , Option ['1'] [] (NoArg TLG) "TODO DESCRIPTION"
+  , Option ['2'] [] (NoArg NKA) "TODO DESCRIPTION"
+  , Option [] ["help"] (NoArg Help) "Print this help message"
+  ]
+
+parseArgs = getArgs >>= parse
+
+parse argv =
+  case getOpt Permute options argv of
+    (args, fs, []) -> do
+      let files =
+            if null fs
+              then ["-"]
+              else fs
+      if Help `elem` args
+        then exitWithErrMsg ExitSuccess printUsage
+        else return (nub args, files)
+    (_, _, errs) -> do
+      hPutStrLn stderr (concat errs ++ printUsage)
+      exitWith $ ExitFailure 1
+  where
+    printUsage = usageInfo header options
+    header = "Usage: plg-2-nka options [input]"

out/production/flp-project/ParseInput.hs

@@ -0,0 +1,67 @@
+module ParseInput where
+
+import ErrorControl
+import Helpers
+import ParseArgs
+
+import Control.Monad
+import Data.Char
+import Data.List
+import System.Exit
+
+data Grammar =
+  Grammar -- G = (V, T, S, P)
+    { variables :: [String] -- V
+    , terminals :: [String] -- T
+    , startSymbol :: Char -- S
+    , productions :: [(Char, String)] -- P
+    }
+  deriving (Show)
+
+parseInput file = do
+  grammar <-
+    if file == "-"
+      then getContents
+      else readFile file
+  variables <- validSymbols isAsciiUpper $ map strip $ splitBy ',' $ head $ lines grammar
+  terminals <- validSymbols isAsciiLower $ map strip $ splitBy ',' $ (!! 1) $ lines grammar
+  startSymbol <- validSymbols isAsciiUpper [strip ((!! 2) $ lines grammar)]
+  productions <- validProductions $ drop 3 $ lines grammar
+  putStrLn $ "Variables: " ++ show variables
+  putStrLn $ "Terminals: " ++ show terminals
+  putStrLn $ "startSymbol: " ++ head startSymbol
+  putStrLn $ "productions: " ++ show productions
+
+validSymbols symbolGroup symbols = do
+  when
+    (symbolTuples /= [])
+    (printWarning $ symbolErrMsg False symbolTuples wrongSymbols symbolGroup)
+  when
+    (containsInvalidSymbol symbolGroup symbols || isNotGrammarSymbol symbols)
+    (exitWithErrMsg (ExitFailure 1) $ symbolErrMsg True symbolTuples wrongSymbols symbolGroup)
+  return $ nub symbols
+  where
+    symbolTuples = filter ((> 1) . snd) . map (\l@(x:xs) -> (x, length l)) . group . sort $ symbols
+    wrongSymbols =
+      (symbols \\ filter (all symbolGroup) symbols) `union` filter ((> 1) . length) symbols
+
+validProductions productions = do
+  when (getInvalidIndices productions /= []) $
+    exitWithErrMsg
+      (ExitFailure 1)
+      (productionErrMsg (getInvalidArrows productions) (getInvalidLeftSides leftSide) 0)
+  when
+    (containsInvalidSymbol isAsciiUpper leftSide) -- || isNotGrammarSymbol rightSide
+    (exitWithErrMsg
+       (ExitFailure 1)
+       (productionErrMsg (getInvalidArrows productions) (getInvalidLeftSides leftSide) 1))
+  when
+    (containsInvalidSymbols rightSide)
+    (exitWithErrMsg
+       (ExitFailure 1)
+       (productionErrMsg (getInvalidArrows productions) (getInvalidRightSides rightSide) 2))
+  return parsedProductions
+  where
+    parsedProductions = map (splitAt 1 . delete '-' . delete '>') productions
+    leftSide = map fst parsedProductions
+    rightSide = map snd parsedProductions

out/test/flp-project/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"

package.yaml

@@ -0,0 +1,48 @@
+name:                flp-project
+version:             0.1.0.0
+github:              "githubuser/flp-project"
+license:             BSD3
+author:              "Author name here"
+maintainer:          "example@example.com"
+copyright:           "2020 Author name here"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/githubuser/flp-project#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+
+executables:
+  flp-project-exe:
+    main:                Main.hs
+    source-dirs:         src
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - flp-project
+
+tests:
+  flp-project-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - flp-project