mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 13:00:08 +00:00
initial commit
This commit is contained in:
2
.gitignore
vendored
2
.gitignore
vendored
@@ -21,3 +21,5 @@ cabal.project.local
|
||||
cabal.project.local~
|
||||
.HTF/
|
||||
.ghc.environment.*
|
||||
.idea/
|
||||
/test/
|
||||
|
||||
3
ChangeLog.md
Normal file
3
ChangeLog.md
Normal file
@@ -0,0 +1,3 @@
|
||||
# Changelog for RosettaParser
|
||||
|
||||
## Unreleased changes
|
||||
30
LICENSE
Normal file
30
LICENSE
Normal file
@@ -0,0 +1,30 @@
|
||||
Copyright Author name here (c) 2021
|
||||
|
||||
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.
|
||||
88
RosettaParser.cabal
Normal file
88
RosettaParser.cabal
Normal file
@@ -0,0 +1,88 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: RosettaParser
|
||||
version: 0.1.0.0
|
||||
description: Please see the README on GitHub at <https://github.com/githubuser/RosettaParser#readme>
|
||||
homepage: https://github.com/githubuser/RosettaParser#readme
|
||||
bug-reports: https://github.com/githubuser/RosettaParser/issues
|
||||
author: Author name here
|
||||
maintainer: example@example.com
|
||||
copyright: 2021 Author name here
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
ChangeLog.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/githubuser/RosettaParser
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Model.Enum
|
||||
Model.Function
|
||||
Model.Type
|
||||
Parser.AnotherExpression
|
||||
Parser.Enum
|
||||
Parser.Expr
|
||||
Parser.Expression
|
||||
Parser.Function
|
||||
Parser.General
|
||||
Parser.Type
|
||||
PrettyPrinter.Enum
|
||||
PrettyPrinter.Function
|
||||
PrettyPrinter.General
|
||||
PrettyPrinter.Type
|
||||
other-modules:
|
||||
Paths_RosettaParser
|
||||
hs-source-dirs:
|
||||
src
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, prettyprinter
|
||||
, text
|
||||
, time
|
||||
default-language: Haskell2010
|
||||
|
||||
executable RosettaParser-exe
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_RosettaParser
|
||||
hs-source-dirs:
|
||||
app
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
RosettaParser
|
||||
, base >=4.7 && <5
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, prettyprinter
|
||||
, text
|
||||
, time
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite RosettaParser-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Paths_RosettaParser
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
RosettaParser
|
||||
, base >=4.7 && <5
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, prettyprinter
|
||||
, text
|
||||
, time
|
||||
default-language: Haskell2010
|
||||
37
RosettaParser.iml
Normal file
37
RosettaParser.iml
Normal file
@@ -0,0 +1,37 @@
|
||||
<?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$/app" isTestSource="false" />
|
||||
<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.14.3.0" level="project" />
|
||||
<orderEntry type="library" name="megaparsec-9.0.1" level="project" />
|
||||
<orderEntry type="library" name="text-1.2.4.1" level="project" />
|
||||
<orderEntry type="library" name="ghc-prim-0.6.1" level="project" />
|
||||
<orderEntry type="library" name="integer-gmp-1.0.3.0" level="project" />
|
||||
<orderEntry type="library" name="bytestring-0.10.12.0" level="project" />
|
||||
<orderEntry type="library" name="case-insensitive-1.2.1.0" level="project" />
|
||||
<orderEntry type="library" name="containers-0.6.5.1" level="project" />
|
||||
<orderEntry type="library" name="deepseq-1.4.4.0" level="project" />
|
||||
<orderEntry type="library" name="mtl-2.2.2" level="project" />
|
||||
<orderEntry type="library" name="parser-combinators-1.2.1" level="project" />
|
||||
<orderEntry type="library" name="scientific-0.3.7.0" level="project" />
|
||||
<orderEntry type="library" name="transformers-0.5.6.2" level="project" />
|
||||
<orderEntry type="library" name="array-0.5.4.0" level="project" />
|
||||
<orderEntry type="library" name="binary-0.8.8.0" level="project" />
|
||||
<orderEntry type="library" name="template-haskell-2.16.0.0" level="project" />
|
||||
<orderEntry type="library" name="hashable-1.3.0.0" level="project" />
|
||||
<orderEntry type="library" name="integer-logarithms-1.0.3.1" level="project" />
|
||||
<orderEntry type="library" name="primitive-0.7.2.0" level="project" />
|
||||
<orderEntry type="library" name="ghc-boot-th-8.10.7" level="project" />
|
||||
<orderEntry type="library" name="pretty-1.1.3.6" level="project" />
|
||||
<orderEntry type="library" name="time-1.9.3" level="project" />
|
||||
<orderEntry type="library" name="prettyprinter-1.7.0" level="project" />
|
||||
</component>
|
||||
</module>
|
||||
54
app/Main.hs
Normal file
54
app/Main.hs
Normal file
@@ -0,0 +1,54 @@
|
||||
module Main where
|
||||
|
||||
import Parser.Enum
|
||||
import Parser.Type
|
||||
import Parser.Function
|
||||
import Data.Text
|
||||
import Text.Megaparsec
|
||||
import PrettyPrinter.Enum
|
||||
import PrettyPrinter.Type
|
||||
import PrettyPrinter.Function
|
||||
import Parser.Expression
|
||||
import Model.Function
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
rosettaString <- readFile "app/testFile.rosetta"
|
||||
putStrLn "rosetta String: "
|
||||
putStrLn rosettaString
|
||||
putStrLn "\nFinal enum: \n"
|
||||
case parse enumParser "" (pack rosettaString) of
|
||||
Left errorBundle -> print (errorBundlePretty errorBundle)
|
||||
Right enum -> putStrLn $ printEnum enum
|
||||
|
||||
testEnum :: IO()
|
||||
testEnum = do
|
||||
rosettaString <- readFile "src/TestFiles/testEnum.rosetta"
|
||||
case parse enumParser "" (pack rosettaString) of
|
||||
Left errorBundle -> print (errorBundlePretty errorBundle)
|
||||
Right enum ->
|
||||
do
|
||||
putStrLn $ printEnum enum
|
||||
writeFile "src/TestFiles/typeEnum.hs" (printEnum enum)
|
||||
|
||||
testType :: IO()
|
||||
testType = do
|
||||
rosettaString <- readFile "src/TestFiles/testType.rosetta"
|
||||
case parse typeParser "" (pack rosettaString) of
|
||||
Left errorBundle -> print (errorBundlePretty errorBundle)
|
||||
Right typ ->
|
||||
do
|
||||
putStrLn $ printType typ
|
||||
print typ
|
||||
writeFile "src/TestFiles/typeTest.hs" (printType typ)
|
||||
|
||||
testFunc :: IO()
|
||||
testFunc = do
|
||||
rosettaString <- readFile "src/TestFiles/testFunction.rosetta"
|
||||
case parse functionParser "" (pack rosettaString) of
|
||||
Left errorBundle -> print (errorBundlePretty errorBundle)
|
||||
Right fun ->
|
||||
do
|
||||
print $ printFunctionSignature fun
|
||||
print (assignments fun)
|
||||
writeFile "src/TestFiles/functionTest.hs" (show $ printFunctionSignature fun)
|
||||
53
package.yaml
Normal file
53
package.yaml
Normal file
@@ -0,0 +1,53 @@
|
||||
name: RosettaParser
|
||||
version: 0.1.0.0
|
||||
github: "githubuser/RosettaParser"
|
||||
license: BSD3
|
||||
author: "Author name here"
|
||||
maintainer: "example@example.com"
|
||||
copyright: "2021 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/RosettaParser#readme>
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- megaparsec
|
||||
- time
|
||||
- prettyprinter
|
||||
- parser-combinators
|
||||
- text
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
executables:
|
||||
RosettaParser-exe:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- RosettaParser
|
||||
|
||||
tests:
|
||||
RosettaParser-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- RosettaParser
|
||||
13
src/Model/Enum.hs
Normal file
13
src/Model/Enum.hs
Normal file
@@ -0,0 +1,13 @@
|
||||
module Model.Enum where
|
||||
|
||||
data EnumType = MakeEnum {
|
||||
enumName :: String,
|
||||
enumDescription :: Maybe String,
|
||||
enumValues :: [EnumValue]
|
||||
} deriving (Show)
|
||||
|
||||
data EnumValue = MakeEnumValue {
|
||||
enumValueName :: String,
|
||||
enumValueDescription :: Maybe String,
|
||||
enumValueDisplayName :: Maybe String
|
||||
} deriving (Show)
|
||||
60
src/Model/Function.hs
Normal file
60
src/Model/Function.hs
Normal file
@@ -0,0 +1,60 @@
|
||||
module Model.Function where
|
||||
|
||||
import Model.Type (TypeAttribute)
|
||||
|
||||
data Function =
|
||||
MakeFunction {
|
||||
functionName :: String,
|
||||
functionDescription :: Maybe String,
|
||||
inputParameters :: [TypeAttribute],
|
||||
outputParameter :: TypeAttribute,
|
||||
assignments :: [(Expression, Expression)]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Condition =
|
||||
MakeCondition {
|
||||
conditionDescription :: Maybe String,
|
||||
conditionStatement :: Expression
|
||||
-- conditionStatement :: String
|
||||
}
|
||||
| MakePostCondition {
|
||||
conditionDescription :: Maybe String,
|
||||
conditionStatement :: Expression
|
||||
-- conditionStatement :: String
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Expression = --String deriving (Show)
|
||||
Variable String
|
||||
| Literal String
|
||||
| ExpressionList [Expression]
|
||||
| InnerType Expression Expression
|
||||
|
||||
| Or Expression Expression
|
||||
| And Expression Expression
|
||||
| Not Expression
|
||||
|
||||
| Exists Expression
|
||||
| IsAbsent Expression
|
||||
| Contains Expression Expression
|
||||
| Disjoint Expression Expression
|
||||
| Count Expression
|
||||
| OnlyExists Expression
|
||||
| OnlyElement Expression
|
||||
|
||||
| Equals Expression Expression
|
||||
| Different Expression Expression
|
||||
| GreaterStrict Expression Expression
|
||||
| SmallerStrict Expression Expression
|
||||
| GreaterOrEqual Expression Expression
|
||||
| SmallerOrEqual Expression Expression
|
||||
|
||||
| Sum Expression Expression
|
||||
| Subtract Expression Expression
|
||||
| Product Expression Expression
|
||||
| Division Expression Expression
|
||||
|
||||
| IfSimple Expression Expression
|
||||
| IfElse Expression Expression Expression
|
||||
deriving (Show)
|
||||
35
src/Model/Type.hs
Normal file
35
src/Model/Type.hs
Normal file
@@ -0,0 +1,35 @@
|
||||
module Model.Type where
|
||||
|
||||
import Data.Time.LocalTime()
|
||||
import Model.Enum
|
||||
|
||||
data BasicType = String
|
||||
| Integer
|
||||
| Double
|
||||
| Boolean
|
||||
| TimeOfDay
|
||||
deriving (Show)
|
||||
|
||||
data Type =
|
||||
TypeFromBasicType BasicType
|
||||
| TypeFromEnum EnumType
|
||||
| MakeType {
|
||||
typeName :: String,
|
||||
typeDescription :: Maybe String,
|
||||
typeAttributes :: [TypeAttribute]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data TypeAttribute = MakeTypeAttribute {
|
||||
attributeName :: String,
|
||||
attributeType :: String,
|
||||
cardinality :: Cardinality,
|
||||
attributeDescription :: Maybe String
|
||||
} deriving (Show)
|
||||
|
||||
data Cardinality =
|
||||
ZeroOrOne
|
||||
| ExactlyOne
|
||||
| OneOrMore -- One or more
|
||||
| ZeroOrMore -- Zero or more
|
||||
deriving (Show)
|
||||
251
src/Parser/AnotherExpression.hs
Normal file
251
src/Parser/AnotherExpression.hs
Normal file
@@ -0,0 +1,251 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.AnotherExpression where
|
||||
|
||||
import Parser.General
|
||||
import qualified Data.Text as Text
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
|
||||
data Expression = Variable String
|
||||
| Int String
|
||||
| Real String
|
||||
| Boolean String
|
||||
| Empty
|
||||
| Parens Expression
|
||||
| List [Expression]
|
||||
| Function String [Expression]
|
||||
| PrefixExp String Expression
|
||||
| PostfixExp String Expression
|
||||
| InfixExp String Expression Expression
|
||||
| IfSimple Expression Expression
|
||||
| IfElse Expression Expression Expression
|
||||
deriving (Show)
|
||||
|
||||
|
||||
expressionParser :: Parser Expression
|
||||
expressionParser =
|
||||
choice [ ifParser,
|
||||
try functionParser,
|
||||
eqParser]
|
||||
|
||||
--------------------------------------------
|
||||
-- Command Structures ----------------------
|
||||
--------------------------------------------
|
||||
|
||||
functionParser :: Parser Expression
|
||||
functionParser =
|
||||
do
|
||||
f <- pascalNameParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char '('
|
||||
ats <- many $ try (expressionParser >>= \ats -> spaceConsumer >> char ',' >> spaceConsumer >> return ats)
|
||||
lat <- optional expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char ')'
|
||||
_ <- spaceConsumer
|
||||
case lat of
|
||||
Nothing -> return $ Function f []
|
||||
Just at -> return $ Function f (ats ++ [at])
|
||||
|
||||
ifParser :: Parser Expression
|
||||
ifParser =
|
||||
do
|
||||
_ <- string "if"
|
||||
_ <- spaceConsumer
|
||||
condition <- between (char '(') (char ')') expressionParser <|> expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- string "then"
|
||||
_ <- spaceConsumer
|
||||
expr <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
els <- observing $ string "else"
|
||||
_ <- spaceConsumer
|
||||
case els of
|
||||
Left _ -> return (IfSimple condition expr)
|
||||
Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2)
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = between (char '(') (char ')')
|
||||
|
||||
--------------------------------------------
|
||||
-- Terminals -------------------------------
|
||||
--------------------------------------------
|
||||
|
||||
listParser :: Parser Expression
|
||||
listParser =
|
||||
do
|
||||
_ <- char '['
|
||||
_ <- spaceConsumer
|
||||
expressions <- many $ try (expressionParser >>= \ex -> spaceConsumer >> char ',' >> spaceConsumer >> return ex)
|
||||
_ <- spaceConsumer
|
||||
lastExpr <- try expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char ']'
|
||||
_ <- spaceConsumer
|
||||
return $ List (expressions ++ [lastExpr])
|
||||
|
||||
variableParser :: Parser Expression
|
||||
variableParser =
|
||||
do
|
||||
var <- camelNameParser
|
||||
_ <- spaceConsumer
|
||||
inner <- many innerVariableParser
|
||||
return $ Variable (var ++ concatMap ("->" ++) inner)
|
||||
|
||||
innerVariableParser :: Parser String
|
||||
innerVariableParser =
|
||||
do
|
||||
_ <- string "->"
|
||||
_ <- spaceConsumer
|
||||
var <- camelNameParser
|
||||
_ <- spaceConsumer
|
||||
return var
|
||||
|
||||
integerParser :: Parser Expression
|
||||
integerParser =
|
||||
do
|
||||
nr <- some digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ Int $ show nr
|
||||
|
||||
decimalParser :: Parser Expression
|
||||
decimalParser =
|
||||
do
|
||||
nr <- some digitChar
|
||||
_ <- char '.'
|
||||
real <- many digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ Real $ show nr ++ "." ++ real
|
||||
|
||||
booleanParser :: Parser Expression
|
||||
booleanParser =
|
||||
do
|
||||
bol <- string "True" <|> string "False"
|
||||
_ <- spaceConsumer
|
||||
return $ Boolean $ Text.unpack bol
|
||||
|
||||
emptyParser :: Parser Expression
|
||||
emptyParser =
|
||||
do
|
||||
_ <- string "empty"
|
||||
_ <- spaceConsumer
|
||||
return Empty
|
||||
|
||||
terminalParser :: Parser Expression
|
||||
terminalParser =
|
||||
do
|
||||
choice
|
||||
[ prefixParser,
|
||||
parens expressionParser >>= \e -> return (Parens e),
|
||||
listParser,
|
||||
try booleanParser,
|
||||
try emptyParser,
|
||||
try decimalParser,
|
||||
try variableParser,
|
||||
integerParser
|
||||
]
|
||||
|
||||
--------------------------------------------
|
||||
-- Expressions -----------------------------
|
||||
--------------------------------------------
|
||||
|
||||
prefixParser :: Parser Expression
|
||||
prefixParser =
|
||||
do
|
||||
op <- choice $ fmap (try . string . Text.pack) prefixOperators
|
||||
_ <- spaceConsumer
|
||||
ex <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return $ PrefixExp (Text.unpack op) ex
|
||||
|
||||
eqParser :: Parser Expression
|
||||
eqParser =
|
||||
do
|
||||
s <- sumParser
|
||||
_ <- spaceConsumer
|
||||
op <- observing (string "<=" <|> string "=" <|> string "<" <|> string ">" <|> string ">=")
|
||||
_ <- spaceConsumer
|
||||
case op of
|
||||
Left _ -> return s
|
||||
Right o -> eqParser >>= \ex -> return $ InfixExp (Text.unpack o) s ex
|
||||
|
||||
sumParser :: Parser Expression
|
||||
sumParser =
|
||||
do
|
||||
f <- factorParser
|
||||
_ <- spaceConsumer
|
||||
op <- observing (char '+' <|> char '-')
|
||||
_ <- spaceConsumer
|
||||
case op of
|
||||
Left _ -> return f
|
||||
Right o -> sumParser >>= \ex -> return $ reverseExpression $ InfixExp [o] f ex
|
||||
|
||||
factorParser :: Parser Expression
|
||||
factorParser =
|
||||
do
|
||||
p <- powerParser
|
||||
_ <- spaceConsumer
|
||||
op <- observing (char '*' <|> char '/')
|
||||
_ <- spaceConsumer
|
||||
case op of
|
||||
Left _ -> return p
|
||||
Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex
|
||||
|
||||
powerParser :: Parser Expression
|
||||
powerParser =
|
||||
do
|
||||
p <- postfixParser
|
||||
_ <- spaceConsumer
|
||||
op <- observing $ char '^'
|
||||
_ <- spaceConsumer
|
||||
case op of
|
||||
Left _ -> return p
|
||||
Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex
|
||||
|
||||
postfixParser :: Parser Expression
|
||||
postfixParser =
|
||||
do
|
||||
t <- terminalParser
|
||||
_ <- spaceConsumer
|
||||
op <- observing (string "exists" <|> string "is absent" <|> string "count" <|> string "only-element")
|
||||
_ <- spaceConsumer
|
||||
case op of
|
||||
Left _ -> return t
|
||||
Right o -> return $ PostfixExp (Text.unpack o) t
|
||||
|
||||
--------------------------------------------
|
||||
-- Auxiliary ------------------------------
|
||||
--------------------------------------------
|
||||
|
||||
reverseExpression :: Expression -> Expression
|
||||
reverseExpression (InfixExp op t1 (InfixExp op2 t2 e))
|
||||
| precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 t2)) e
|
||||
| otherwise = InfixExp op t1 (InfixExp op2 t2 e)
|
||||
reverseExpression e = e
|
||||
|
||||
precedence :: String -> Int
|
||||
precedence "or" = 1
|
||||
precedence "and" = 1
|
||||
precedence "+" = 2
|
||||
precedence "-" = 2
|
||||
precedence "*" = 3
|
||||
precedence "/" = 3
|
||||
precedence "^" = 4
|
||||
precedence _ = 100
|
||||
|
||||
prefixOperators :: [String]
|
||||
prefixOperators = ["-", "not"]
|
||||
|
||||
testArith3 = parseTest expressionParser "1 + (2 - 3)"
|
||||
testArith4 = parseTest expressionParser "a * b - c * d - e * f = g * h - i * j - k * l"
|
||||
testArith5 = parseTest expressionParser "a + b - c * d ^ e"
|
||||
testArith6 = parseTest expressionParser "1 - 2 - 3 - 4 - 5 - 6"
|
||||
testList = parseTest expressionParser "[1, 2, 3]"
|
||||
testList2 = parseTest expressionParser "[1, 2 + 3, e]"
|
||||
testFun = parseTest functionParser "Function()"
|
||||
testFun2 = parseTest functionParser "Function(e)"
|
||||
testFun3 = parseTest functionParser "Function(3, 3+2,e)"
|
||||
testIf = parseTest expressionParser "if (Function(2 + 3, e)) then a + b - c * d ^ e -> x else not a exists"
|
||||
testEverything = parseTest expressionParser "if [1, Function(3)] then 1 - 2 - 3 * a -> b ^ c"
|
||||
testFail = parseTest expressionParser "if[1,as]thenxandoelseaora"
|
||||
72
src/Parser/Enum.hs
Executable file
72
src/Parser/Enum.hs
Executable file
@@ -0,0 +1,72 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.Enum where
|
||||
|
||||
import Parser.General
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec
|
||||
import Model.Enum
|
||||
|
||||
--parseTest enumParser "enum periodEnum: <\"description\"> D displayName \"day\" <\"Day\">"
|
||||
enumParser :: Parser EnumType
|
||||
enumParser =
|
||||
do
|
||||
eName <- enumNameParser
|
||||
eDescription <- descriptionParser
|
||||
values <- many enumValueParser
|
||||
_ <- spaceConsumer
|
||||
return (MakeEnum eName (Just eDescription) values)
|
||||
|
||||
--parseTest enumValueParser "D displayName \"day\" <\"Day\">"
|
||||
enumValueParser :: Parser EnumValue
|
||||
enumValueParser =
|
||||
do
|
||||
vName <- enumValueNameParser
|
||||
dName <- enumValueDisplayNameParser
|
||||
vDescription <- descriptionParser
|
||||
return (MakeEnumValue vName (Just vDescription) (Just dName))
|
||||
|
||||
enumValueNameParser :: Parser String
|
||||
enumValueNameParser =
|
||||
do
|
||||
name <- nameParser
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
enumValueDisplayNameParser :: Parser String
|
||||
enumValueDisplayNameParser =
|
||||
do
|
||||
_ <- string "displayName \""
|
||||
name <- anySingle `manyTill` char '"'
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
enumNameParser :: Parser String
|
||||
enumNameParser =
|
||||
do
|
||||
_ <- string "enum"
|
||||
_ <- spaceConsumer
|
||||
name <- nameParser
|
||||
_ <- char ':'
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
periodEnum :: EnumType
|
||||
periodEnum = MakeEnum
|
||||
"PeriodEnum"
|
||||
(Just "The enumerated values to specifie the period, e.g. day, week.")
|
||||
[MakeEnumValue
|
||||
"D"
|
||||
(Just "Day")
|
||||
Nothing,
|
||||
|
||||
MakeEnumValue
|
||||
"W"
|
||||
(Just "Week")
|
||||
Nothing,
|
||||
|
||||
MakeEnumValue
|
||||
"Y"
|
||||
(Just "Year")
|
||||
Nothing
|
||||
]
|
||||
3
src/Parser/Expr.hs
Normal file
3
src/Parser/Expr.hs
Normal file
@@ -0,0 +1,3 @@
|
||||
module Parser.Expr where
|
||||
|
||||
import Parser.General
|
||||
165
src/Parser/Expression.hs
Normal file
165
src/Parser/Expression.hs
Normal file
@@ -0,0 +1,165 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.Expression where
|
||||
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Model.Function
|
||||
import Parser.General
|
||||
import Data.Text
|
||||
|
||||
variableParser :: Parser Expression
|
||||
variableParser =
|
||||
do
|
||||
var <- camelNameParser
|
||||
_ <- spaceConsumer
|
||||
return $ Variable var
|
||||
|
||||
integerParser :: Parser Expression
|
||||
integerParser =
|
||||
do
|
||||
nr <- some digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ Literal $ show nr
|
||||
|
||||
decimalParser :: Parser Expression
|
||||
decimalParser =
|
||||
do
|
||||
nr <- some digitChar
|
||||
_ <- char '.'
|
||||
real <- many digitChar
|
||||
_ <- spaceConsumer
|
||||
return $ Literal $ show nr ++ "." ++ real
|
||||
|
||||
booleanParser :: Parser Expression
|
||||
booleanParser =
|
||||
do
|
||||
bol <- string (pack "True") <|> string (pack "False")
|
||||
_ <- spaceConsumer
|
||||
return $ Literal $ unpack bol
|
||||
|
||||
listParser :: Parser Expression
|
||||
listParser =
|
||||
do
|
||||
_ <- char '['
|
||||
_ <- spaceConsumer
|
||||
expressions <- many $ try expressionList
|
||||
_ <- spaceConsumer
|
||||
lastExpr <- try expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char ']'
|
||||
_ <- spaceConsumer
|
||||
return $ ExpressionList (expressions ++ [lastExpr])
|
||||
where
|
||||
expressionList =
|
||||
do
|
||||
expr <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char ','
|
||||
_ <- spaceConsumer
|
||||
return expr
|
||||
|
||||
emptyParser :: Parser Expression
|
||||
emptyParser =
|
||||
do
|
||||
_ <- string "empty"
|
||||
_ <- spaceConsumer
|
||||
return $ Literal "empty"
|
||||
|
||||
literalParser :: Parser Expression
|
||||
literalParser =
|
||||
do
|
||||
choice
|
||||
[ booleanParser,
|
||||
try emptyParser,
|
||||
try decimalParser,
|
||||
try variableParser,
|
||||
integerParser
|
||||
]
|
||||
|
||||
parensParser :: Parser Expression
|
||||
parensParser =
|
||||
do
|
||||
_ <- char '('
|
||||
expr <- expressionParser
|
||||
_ <- char ')'
|
||||
return expr
|
||||
|
||||
ifElseParser :: Parser Expression
|
||||
ifElseParser =
|
||||
do
|
||||
(IfSimple cond expr) <- simpleIfParser
|
||||
_ <- string "else"
|
||||
_ <- spaceConsumer
|
||||
expr2 <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return $ IfElse cond expr expr2
|
||||
|
||||
simpleIfParser :: Parser Expression
|
||||
simpleIfParser =
|
||||
do
|
||||
_ <- string "if"
|
||||
_ <- spaceConsumer
|
||||
condition <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- string "then"
|
||||
_ <- spaceConsumer
|
||||
expr <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return $ IfSimple condition expr
|
||||
|
||||
andParser :: Parser Expression
|
||||
andParser =
|
||||
do
|
||||
(ex1, ex2) <- try $ binaryParser "and"
|
||||
return $ And ex1 ex2
|
||||
|
||||
orParser :: Parser Expression
|
||||
orParser =
|
||||
do
|
||||
(ex1, ex2) <- try $ binaryParser "or"
|
||||
return $ Or ex1 ex2
|
||||
|
||||
subParser :: Parser Expression
|
||||
subParser =
|
||||
do
|
||||
(ex1, ex2) <- try $ binaryParser "-"
|
||||
return $ Subtract ex1 ex2
|
||||
|
||||
notParser :: Parser Expression
|
||||
notParser =
|
||||
do
|
||||
_ <- string "not"
|
||||
_ <- spaceConsumer
|
||||
ex <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return $ Not ex
|
||||
|
||||
binaryParser :: String -> Parser (Expression, Expression)
|
||||
binaryParser op =
|
||||
do
|
||||
ex1 <- literalParser
|
||||
_ <- spaceConsumer
|
||||
_ <- string $ pack op
|
||||
_ <- spaceConsumer
|
||||
ex2 <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return (ex1, ex2)
|
||||
|
||||
expressionParser :: Parser Expression
|
||||
expressionParser = choice
|
||||
[parensParser,
|
||||
notParser,
|
||||
andParser,
|
||||
orParser,
|
||||
subParser,
|
||||
ifElseParser,
|
||||
simpleIfParser,
|
||||
literalParser,
|
||||
variableParser
|
||||
]
|
||||
|
||||
testIfElse = parseTest expressionParser "if asd then 123 else 4"
|
||||
testAnd = parseTest expressionParser "23 and 34 and 24 and a"
|
||||
testOr = parseTest expressionParser "23 or 34 or 24 or a"
|
||||
testMin = parseTest expressionParser "(a - b) - c"
|
||||
185
src/Parser/Function backup.hs
Normal file
185
src/Parser/Function backup.hs
Normal file
@@ -0,0 +1,185 @@
|
||||
module Parser.Function where
|
||||
|
||||
import Model.Function
|
||||
import Model.Type (TypeAttribute)
|
||||
import Parser.Type (typeAttributeParser)
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec
|
||||
import Parser.General
|
||||
import Data.Text
|
||||
|
||||
functionParser :: Parser Function
|
||||
functionParser =
|
||||
do
|
||||
_ <- string $ pack "func"
|
||||
_ <- spaceConsumer
|
||||
fName <- pascalNameParser
|
||||
_ <- char ':'
|
||||
_ <- spaceConsumer
|
||||
fDescription <- descriptionParser
|
||||
fInput <- inputAttributesParser
|
||||
fOutput <- outputAttributeParser
|
||||
fConditions <- many (try postConditionParser <|> try conditionParser)
|
||||
_ <- spaceConsumer
|
||||
return (MakeFunction fName (Just fDescription) fInput fOutput fConditions)
|
||||
|
||||
inputAttributesParser :: Parser [TypeAttribute]
|
||||
inputAttributesParser =
|
||||
do
|
||||
_ <- string $ pack "inputs:"
|
||||
_ <- spaceConsumer
|
||||
inputs <- many $ try typeAttributeParser
|
||||
_ <- spaceConsumer
|
||||
return inputs
|
||||
|
||||
outputAttributeParser :: Parser TypeAttribute
|
||||
outputAttributeParser =
|
||||
do
|
||||
_ <- string $ pack "output:"
|
||||
_ <- spaceConsumer
|
||||
outputs <- typeAttributeParser
|
||||
_ <- spaceConsumer
|
||||
return outputs
|
||||
|
||||
--parseTest conditionParser pack "condition: <\"Optional choice between directly passing a time or a timeType, which has to be resolved into a time based on the determination method.\"> if valuationTime exists then timeType is absent else if timeType exists then valuationTime is absent else False"
|
||||
|
||||
conditionParser :: Parser Condition
|
||||
conditionParser =
|
||||
do
|
||||
_ <- string $ pack "condition:"
|
||||
_ <- spaceConsumer
|
||||
description <- descriptionParser
|
||||
(Expression statementString) <- lookAhead expressionParser
|
||||
_ <- string $ pack statementString
|
||||
rest <- getInput
|
||||
_ <- setInput $ pack statementString
|
||||
statement <- statementParser
|
||||
_ <- setInput rest
|
||||
_ <- spaceConsumer
|
||||
return $ MakeCondition (Just description) statement
|
||||
--parseTest postConditionParser (pack "post-condition: <\"The date and time must be properly resolved as attributes on the output.\"> observation -> date = ResolveAdjustableDate(valuationDate) and if valuationTime exists then observation -> time = TimeZoneFromBusinessCenterTime(valuationTime) else observation -> time = ResolveTimeZoneFromTimeType(timeType, determinationMethod)")
|
||||
|
||||
postConditionParser :: Parser Condition
|
||||
postConditionParser =
|
||||
do
|
||||
_ <- string $ pack "post-condition:"
|
||||
_ <- spaceConsumer
|
||||
description <- descriptionParser
|
||||
(Expression statementString) <- lookAhead expressionParser
|
||||
_ <- string $ pack statementString
|
||||
rest <- getInput
|
||||
_ <- setInput $ pack statementString
|
||||
statement <- statementParser
|
||||
_ <- setInput rest
|
||||
_ <- spaceConsumer
|
||||
return $ MakePostCondition (Just description) statement
|
||||
|
||||
statementParser :: Parser Expression
|
||||
statementParser =
|
||||
do
|
||||
statement <-
|
||||
try ifElseParser <|>
|
||||
try ifParser <|>
|
||||
|
||||
try (binaryOpParser " and ") <|>
|
||||
try (binaryOpParser " contains ") <|>
|
||||
try (binaryOpParser " or ") <|>
|
||||
try (binaryOpParser " = ") <|>
|
||||
try (binaryOpParser " <> ") <|>
|
||||
try (binaryOpParser " < ") <|>
|
||||
try (binaryOpParser " <= ") <|>
|
||||
try (binaryOpParser " >") <|>
|
||||
try (binaryOpParser " >= ") <|>
|
||||
|
||||
try (unaryOpParser " count") <|>
|
||||
try (unaryOpParser " exists") <|>
|
||||
try (unaryOpParser " is absent") <|>
|
||||
|
||||
expressionParser
|
||||
_ <- spaceConsumer
|
||||
return statement
|
||||
|
||||
--binaryOpParser :: String -> Parser Expression
|
||||
--binaryOpParser op =
|
||||
-- do
|
||||
-- argument1String <- untilParser op
|
||||
-- rest <- getInput
|
||||
-- _ <- setInput $ pack argument1String
|
||||
-- argument1 <- statementParser
|
||||
-- _ <- setInput rest
|
||||
-- _ <- spaceConsumer
|
||||
-- argument2 <- statementParser
|
||||
-- _ <- spaceConsumer
|
||||
-- return $ BinaryOp (unpack $ strip $ pack op) argument1 argument2
|
||||
--
|
||||
--unaryOpParser :: String -> Parser Expression
|
||||
--unaryOpParser op =
|
||||
-- do
|
||||
-- statementString <- untilParser op
|
||||
-- rest <- getInput
|
||||
-- _ <- setInput $ pack statementString
|
||||
-- statement <- statementParser
|
||||
-- _ <- setInput rest
|
||||
-- _ <- spaceConsumer
|
||||
-- return $ UnaryOp (unpack $ strip $ pack op) statement
|
||||
--
|
||||
--ifParser :: Parser Expression
|
||||
--ifParser =
|
||||
-- do
|
||||
-- _ <- string $ pack "if"
|
||||
-- _ <- spaceConsumer
|
||||
-- cond <- statementParser
|
||||
-- _ <- spaceConsumer
|
||||
-- _ <- string $ pack "then"
|
||||
-- expr <- statementParser
|
||||
-- _ <- spaceConsumer
|
||||
-- return $ IfSimple cond expr
|
||||
|
||||
--ifParser :: Parser Expression
|
||||
--ifParser =
|
||||
-- do
|
||||
-- _ <- string $ pack "if"
|
||||
-- _ <- spaceConsumer
|
||||
-- conditionString <- untilParser "then"
|
||||
-- rest <- getInput
|
||||
-- _ <- setInput $ pack conditionString
|
||||
-- condition <- statementParser
|
||||
-- _ <- setInput rest
|
||||
-- _ <- spaceConsumer
|
||||
-- stmt <- statementParser
|
||||
-- return $ If condition stmt
|
||||
|
||||
--ifElseParser :: Parser Expression
|
||||
--ifElseParser =
|
||||
-- do
|
||||
-- _ <- string $ pack "if"
|
||||
-- _ <- spaceConsumer
|
||||
-- conditionString <- untilParser "then"
|
||||
-- rest <- getInput
|
||||
-- _ <- setInput $ pack conditionString
|
||||
-- condition <- statementParser
|
||||
-- _ <- setInput rest
|
||||
-- _ <- spaceConsumer
|
||||
-- thenString <- untilParser "else"
|
||||
-- rest1 <- getInput
|
||||
-- _ <- setInput $ pack thenString
|
||||
-- thenExpression <- statementParser
|
||||
-- _ <- setInput rest1
|
||||
-- _ <- spaceConsumer
|
||||
-- elseExpression <- statementParser
|
||||
-- return $ IfElse condition thenExpression elseExpression
|
||||
|
||||
--parseTest expressionParser (pack "alalala condition:")
|
||||
|
||||
expressionParser :: Parser Expression
|
||||
expressionParser =
|
||||
do
|
||||
statement <-
|
||||
untilParser "post-condition:" <|>
|
||||
untilParser "condition:" <|>
|
||||
untilParser "func" <|>
|
||||
untilParser "enum" <|>
|
||||
untilParser "type" <|>
|
||||
try (anySingle `manyTill` eof)
|
||||
_ <- spaceConsumer
|
||||
return $ Expression $ unpack (strip $ pack statement)
|
||||
70
src/Parser/Function.hs
Normal file
70
src/Parser/Function.hs
Normal file
@@ -0,0 +1,70 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.Function where
|
||||
|
||||
import Parser.Expression
|
||||
import Parser.Type
|
||||
import Model.Function
|
||||
import Model.Type
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Parser.General
|
||||
|
||||
functionParser :: Parser Function
|
||||
functionParser =
|
||||
do
|
||||
_ <- string "func"
|
||||
_ <- spaceConsumer
|
||||
fName <- pascalNameParser
|
||||
_ <- char ':'
|
||||
_ <- spaceConsumer
|
||||
fDescription <- descriptionParser
|
||||
fInput <- inputAttributesParser
|
||||
fOutput <- outputAttributeParser
|
||||
fAssignments <- many assignmentParser
|
||||
_ <- spaceConsumer
|
||||
return (MakeFunction fName (Just fDescription) fInput fOutput fAssignments)
|
||||
|
||||
assignmentParser :: Parser (Expression, Expression)
|
||||
assignmentParser =
|
||||
do
|
||||
_ <- string "assign-output"
|
||||
_ <- spaceConsumer
|
||||
name <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
_ <- char ':'
|
||||
_ <- spaceConsumer
|
||||
expr <- expressionParser
|
||||
_ <- spaceConsumer
|
||||
return (name, expr)
|
||||
|
||||
inputAttributesParser :: Parser [TypeAttribute]
|
||||
inputAttributesParser =
|
||||
do
|
||||
_ <- string "inputs:"
|
||||
_ <- spaceConsumer
|
||||
inputs <- many $ try attributeParser
|
||||
_ <- spaceConsumer
|
||||
return inputs
|
||||
|
||||
outputAttributeParser :: Parser TypeAttribute
|
||||
outputAttributeParser =
|
||||
do
|
||||
_ <- string "output:"
|
||||
_ <- spaceConsumer
|
||||
outputs <- attributeParser
|
||||
_ <- spaceConsumer
|
||||
return outputs
|
||||
|
||||
attributeParser :: Parser TypeAttribute
|
||||
attributeParser =
|
||||
do
|
||||
nam <- camelNameParser
|
||||
_ <- spaceConsumer
|
||||
typ <- pascalNameParser <|> camelNameParser
|
||||
_ <- spaceConsumer
|
||||
crd <- cardinalityParser
|
||||
_ <- spaceConsumer
|
||||
desc <- optional descriptionParser
|
||||
return $ MakeTypeAttribute nam typ crd desc
|
||||
|
||||
53
src/Parser/General.hs
Executable file
53
src/Parser/General.hs
Executable file
@@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.General where
|
||||
|
||||
import Text.Megaparsec
|
||||
import Data.Void
|
||||
import Text.Megaparsec.Char
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
import Data.Text
|
||||
|
||||
type Parser = Parsec Void Text
|
||||
|
||||
spaceConsumer :: Parser ()
|
||||
spaceConsumer = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/")
|
||||
|
||||
symbol :: Text -> Parser Text
|
||||
symbol = L.symbol spaceConsumer
|
||||
|
||||
descriptionParser :: Parser String
|
||||
descriptionParser =
|
||||
do
|
||||
_ <- string "<\""
|
||||
description <- anySingle `manyTill` string "\">"
|
||||
_ <- spaceConsumer
|
||||
return description
|
||||
|
||||
|
||||
pascalNameParser :: Parser String
|
||||
pascalNameParser =
|
||||
do
|
||||
first <- upperChar
|
||||
rest <- many (letterChar <|> digitChar <|> char '_')
|
||||
_ <- spaceConsumer
|
||||
return (first : rest)
|
||||
|
||||
camelNameParser :: Parser String
|
||||
camelNameParser =
|
||||
do
|
||||
first <- lowerChar
|
||||
rest <- many (letterChar <|> digitChar <|> char '_')
|
||||
_ <- spaceConsumer
|
||||
return (first : rest)
|
||||
|
||||
nameParser :: Parser String
|
||||
nameParser =
|
||||
do
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many (letterChar <|> digitChar <|> char '_')
|
||||
_ <- spaceConsumer
|
||||
return (first:rest)
|
||||
|
||||
untilParser :: String -> Parser String
|
||||
untilParser x = try (anySingle `manyTill` string (pack x))
|
||||
110
src/Parser/Type.hs
Normal file
110
src/Parser/Type.hs
Normal file
@@ -0,0 +1,110 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser.Type where
|
||||
|
||||
import Model.Type
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec
|
||||
import Parser.General
|
||||
|
||||
--parseTest typeParser "type Period: <\"description\"> periodMultiplier int (1..1) <\"A time period multiplier\"> period periodEnum (1..1) <\"A time period \">"
|
||||
typeParser :: Parser Type
|
||||
typeParser =
|
||||
do
|
||||
tName <- typeNameParser
|
||||
tDescription <- descriptionParser
|
||||
tAttributes <- many $ try typeAttributeParserWDesc <|> try typeAttributeParser
|
||||
_ <- spaceConsumer
|
||||
return (MakeType tName (Just tDescription) tAttributes)
|
||||
|
||||
typeAttributeParserWDesc :: Parser TypeAttribute
|
||||
typeAttributeParserWDesc =
|
||||
do
|
||||
(MakeTypeAttribute aName aType card Nothing) <- typeAttributeParser
|
||||
descriptionParser >>= \aDescription -> return (MakeTypeAttribute aName aType card (Just aDescription))
|
||||
|
||||
typeAttributeParser :: Parser TypeAttribute
|
||||
typeAttributeParser =
|
||||
do
|
||||
aName <- attributeNameParser
|
||||
aType <- nameParser
|
||||
_ <- spaceConsumer
|
||||
card <- cardinalityParser
|
||||
_ <- spaceConsumer
|
||||
return (MakeTypeAttribute aName aType card Nothing)
|
||||
|
||||
cardinalityParser :: Parser Cardinality
|
||||
cardinalityParser =
|
||||
do
|
||||
card <- parseExactlyOne <|> parseOneOrMore <|> parseZeroOrMore <|> parseZeroOrOne
|
||||
_ <- spaceConsumer
|
||||
return card
|
||||
|
||||
parseOneOrMore :: Parser Cardinality
|
||||
parseOneOrMore =
|
||||
do
|
||||
_ <- string "(1..*)"
|
||||
return OneOrMore
|
||||
|
||||
|
||||
parseExactlyOne :: Parser Cardinality
|
||||
parseExactlyOne =
|
||||
do
|
||||
_ <- string "(1..1)"
|
||||
return ExactlyOne
|
||||
|
||||
|
||||
parseZeroOrMore :: Parser Cardinality
|
||||
parseZeroOrMore =
|
||||
do
|
||||
_ <- string "(0..*)"
|
||||
return ZeroOrMore
|
||||
|
||||
|
||||
parseZeroOrOne :: Parser Cardinality
|
||||
parseZeroOrOne =
|
||||
do
|
||||
_ <- string "(0..1)"
|
||||
return ZeroOrOne
|
||||
|
||||
attributeNameParser :: Parser String
|
||||
attributeNameParser =
|
||||
do
|
||||
name <- camelNameParser
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
enumValueDisplayNameParser :: Parser String
|
||||
enumValueDisplayNameParser =
|
||||
do
|
||||
_ <- string "displayName \""
|
||||
name <- anySingle `manyTill` char '"'
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
typeNameParser :: Parser String
|
||||
typeNameParser =
|
||||
do
|
||||
_ <- string "type"
|
||||
_ <- spaceConsumer
|
||||
name <- pascalNameParser
|
||||
_ <- char ':'
|
||||
_ <- spaceConsumer
|
||||
return name
|
||||
|
||||
periodType :: Type
|
||||
periodType = MakeType
|
||||
"Period"
|
||||
(Just "A class to define recurring periods or time offsets")
|
||||
[MakeTypeAttribute
|
||||
"periodMultiplier"
|
||||
"Integer"
|
||||
ExactlyOne
|
||||
(Just "A time period multiplier"),
|
||||
|
||||
MakeTypeAttribute
|
||||
"period"
|
||||
"periodEnum"
|
||||
ExactlyOne
|
||||
(Just "A time period")
|
||||
]
|
||||
39
src/PrettyPrinter/Enum.hs
Normal file
39
src/PrettyPrinter/Enum.hs
Normal file
@@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PrettyPrinter.Enum where
|
||||
|
||||
import Model.Enum
|
||||
import PrettyPrinter.General
|
||||
import Prettyprinter
|
||||
|
||||
printEnum :: EnumType -> String
|
||||
printEnum (MakeEnum name description values) =
|
||||
show $ printDescription description
|
||||
(vcat ["data" <+> pretty name <+> "=",
|
||||
indent 4 (printEnumValues values),
|
||||
"",
|
||||
printDisplayNames name values])
|
||||
|
||||
printEnumValues :: [EnumValue] -> Doc a
|
||||
printEnumValues [] = ""
|
||||
printEnumValues (x:xs) = vcat (printFirstEnumValue x: map printEnumValue xs)
|
||||
|
||||
printFirstEnumValue :: EnumValue -> Doc a
|
||||
printFirstEnumValue (MakeEnumValue name description _) =
|
||||
printDescription description (pretty name)
|
||||
|
||||
printEnumValue :: EnumValue -> Doc a
|
||||
printEnumValue (MakeEnumValue name description _) =
|
||||
printDescription description ("|" <+> pretty name)
|
||||
|
||||
printDisplayNames :: String -> [EnumValue] -> Doc a
|
||||
printDisplayNames name values =
|
||||
nest 4 $ vcat ("instance Show" <+> pretty name <+> "where": map printDisplayName values)
|
||||
|
||||
printDisplayName :: EnumValue -> Doc a
|
||||
printDisplayName (MakeEnumValue name _ (Just display)) =
|
||||
"show" <+> pretty name <+> "= \"" <> pretty display <> "\""
|
||||
printDisplayName (MakeEnumValue name _ Nothing) =
|
||||
"show" <+> pretty name <+> "= \"" <> pretty name <> "\""
|
||||
|
||||
|
||||
17
src/PrettyPrinter/Function.hs
Normal file
17
src/PrettyPrinter/Function.hs
Normal file
@@ -0,0 +1,17 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PrettyPrinter.Function where
|
||||
|
||||
import Prettyprinter
|
||||
import Model.Function
|
||||
import PrettyPrinter.General
|
||||
import PrettyPrinter.Type
|
||||
|
||||
-- show printStatementTree
|
||||
|
||||
printFunctionSignature :: Function -> Doc a
|
||||
printFunctionSignature (MakeFunction name description inputs output _) =
|
||||
printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output])))
|
||||
|
||||
prettyPrintType :: [Doc x] -> Doc x
|
||||
prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
|
||||
10
src/PrettyPrinter/General.hs
Normal file
10
src/PrettyPrinter/General.hs
Normal file
@@ -0,0 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PrettyPrinter.General where
|
||||
|
||||
import Prettyprinter
|
||||
|
||||
printDescription :: Maybe String -> Doc a -> Doc a
|
||||
printDescription (Just description) doc =
|
||||
vcat [enclose "{-" "-}" (pretty description), doc]
|
||||
printDescription Nothing doc = doc
|
||||
29
src/PrettyPrinter/Type.hs
Normal file
29
src/PrettyPrinter/Type.hs
Normal file
@@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module PrettyPrinter.Type where
|
||||
|
||||
import Prettyprinter
|
||||
import PrettyPrinter.General
|
||||
import Model.Type
|
||||
import Model.Enum
|
||||
|
||||
printType :: Type -> String
|
||||
printType (MakeType name description attributes) =
|
||||
show $ printDescription description (vcat [nest 4 $ vcat("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""])
|
||||
printType x = show x
|
||||
|
||||
printTypeName :: Type -> String
|
||||
printTypeName (MakeType name _ _) = name
|
||||
printTypeName (TypeFromBasicType name) = show name
|
||||
printTypeName (TypeFromEnum (MakeEnum name _ _)) = name
|
||||
|
||||
printAttribute :: TypeAttribute -> Doc a
|
||||
printAttribute (MakeTypeAttribute name typ crd description) =
|
||||
printDescription description
|
||||
(pretty name <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description))
|
||||
|
||||
printCardinality :: TypeAttribute -> Doc a
|
||||
printCardinality (MakeTypeAttribute _ typ ExactlyOne _) = pretty typ
|
||||
printCardinality (MakeTypeAttribute _ typ OneOrMore _) = "[" <> pretty typ <> "]"
|
||||
printCardinality (MakeTypeAttribute _ typ ZeroOrMore _) = "[" <> pretty typ <> "]"
|
||||
printCardinality (MakeTypeAttribute _ typ ZeroOrOne _) = "Maybe" <+> pretty typ
|
||||
7
src/TestFiles/functionTest.hs
Normal file
7
src/TestFiles/functionTest.hs
Normal file
@@ -0,0 +1,7 @@
|
||||
{-Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class.-}
|
||||
EquityPriceObservation :: Equity
|
||||
-> AdjustableOrRelativeDate
|
||||
-> Maybe BusinessCenterTime
|
||||
-> Maybe TimeTypeEnum
|
||||
-> [DeterminationMethodEnum]
|
||||
-> ObservationPrimitive
|
||||
4
src/TestFiles/testEnum.rosetta
Executable file
4
src/TestFiles/testEnum.rosetta
Executable file
@@ -0,0 +1,4 @@
|
||||
enum PeriodEnum: <"description">
|
||||
D displayName "day" <"Day">
|
||||
M displayName "month" <"Month">
|
||||
Y displayName "year" <"Year">
|
||||
12
src/TestFiles/testFunction.rosetta
Normal file
12
src/TestFiles/testFunction.rosetta
Normal file
@@ -0,0 +1,12 @@
|
||||
func EquityPriceObservation: <"Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class.">
|
||||
inputs:
|
||||
equity Equity (1..1)
|
||||
valuationDate AdjustableOrRelativeDate (1..1)
|
||||
valuationTime BusinessCenterTime (0..1)
|
||||
timeType TimeTypeEnum (0..1)
|
||||
determinationMethod DeterminationMethodEnum (1..*)
|
||||
output:
|
||||
observation ObservationPrimitive (1..1)
|
||||
|
||||
assign-output
|
||||
observation: if asd exists then var2
|
||||
13
src/TestFiles/testType.rosetta
Normal file
13
src/TestFiles/testType.rosetta
Normal file
@@ -0,0 +1,13 @@
|
||||
type Period: <"description">
|
||||
periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
|
||||
period periodEnum (1..1) <"A time period, e.g. a day, week, month or year of the stream. If the periodMultiplier values is 0 (zero) then period must contain the value D (day).">
|
||||
testMany testType (0..*) <"Test many">
|
||||
testSome testSomeType (1..*) <"Test some">
|
||||
testMaybeOne testZeroOneType (0..1) <"Test zero or one">
|
||||
|
||||
type Period: <"description">
|
||||
periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
|
||||
period periodEnum (1..1) <"A time period, e.g. a day, week, month or year of the stream. If the periodMultiplier values is 0 (zero) then period must contain the value D (day).">
|
||||
testMany testType (0..*) <"Test many">
|
||||
testSome testSomeType (1..*) <"Test some">
|
||||
testMaybeOne testZeroOneType (0..1) <"Test zero or one">
|
||||
13
src/TestFiles/typeEnum.hs
Normal file
13
src/TestFiles/typeEnum.hs
Normal file
@@ -0,0 +1,13 @@
|
||||
{-description-}
|
||||
data PeriodEnum =
|
||||
{-Day-}
|
||||
D
|
||||
{-Month-}
|
||||
| M
|
||||
{-Year-}
|
||||
| Y
|
||||
|
||||
instance Show PeriodEnum where
|
||||
show D = "day"
|
||||
show M = "month"
|
||||
show Y = "year"
|
||||
13
src/TestFiles/typeTest.hs
Normal file
13
src/TestFiles/typeTest.hs
Normal file
@@ -0,0 +1,13 @@
|
||||
{-description-}
|
||||
data Period = MakePeriod {
|
||||
{-A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.-}
|
||||
periodMultiplier :: int
|
||||
{-A time period, e.g. a day, week, month or year of the stream. If the periodMultiplier values is 0 (zero) then period must contain the value D (day).-}
|
||||
period :: periodEnum
|
||||
{-Test many-}
|
||||
testMany :: [testType]
|
||||
{-Test some-}
|
||||
testSome :: [testSomeType]
|
||||
{-Test zero or one-}
|
||||
testMaybeOne :: Maybe testZeroOneType
|
||||
}
|
||||
67
stack.yaml
Normal file
67
stack.yaml
Normal file
@@ -0,0 +1,67 @@
|
||||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||
# These entries can reference officially published versions as well as
|
||||
# forks / in-progress versions pinned to a git hash. For example:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.7"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
13
stack.yaml.lock
Normal file
13
stack.yaml.lock
Normal file
@@ -0,0 +1,13 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 587546
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml
|
||||
sha256: 88b4f81e162ba3adc230a9fcccc4d19ac116377656bab56c7382ca88598b257a
|
||||
original:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/10.yaml
|
||||
Reference in New Issue
Block a user