module Alga.Representation.Parser
( probeAlga
, parseAlga )
where
import Alga.Language.Element (NRatio)
import Alga.Language.SyntaxTree
import Control.Applicative
import Control.Monad (void)
import Data.Ratio ((%))
import Data.Text.Lazy (Text)
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.Text.Lazy
import qualified Alga.Representation.Base as B
import qualified Data.List.NonEmpty as NE
import qualified Data.Text.Lazy as T
import qualified Text.Megaparsec.Lexer as L
probeAlga :: Text -> Bool
probeAlga txt = not $ or
["," `T.isSuffixOf` stripped
, f ("[", "]")
, f ("{", "}")
, f ("<", ">")
, f ("(", ")") ]
where stripped = T.strip txt
f (x, y) = (&&) <$> (> 0) <*> (/= g y) $ g x
g x = T.count x stripped
parseAlga
:: String
-> Text
-> Either String [Statement]
parseAlga file txt =
case parse parser file txt of
Right x -> if null x
then Left $ '\"' : file ++ "\":\ninvalid definition syntax"
else Right x
Left x -> Left (parseErrorPretty x)
where parser = if T.pack B.defOp `T.isInfixOf` txt
then pSource
else return <$> pExposition
pSource :: Parser [Statement]
pSource = sc *> many pDefinition <* eof
pDefinition :: Parser Statement
pDefinition = Definition <$> pIdentifier <* pOperator B.defOp <*> pPrinciple
pExposition :: Parser Statement
pExposition = Exposition <$> (sc *> pPrinciple <* eof)
pIdentifier :: Parser String
pIdentifier = lexeme $ (:) <$> first <*> many other
where first = letterChar <|> char '_'
other = alphaNumChar <|> char '_' <|> char B.autoDel
pOperator :: String -> Parser String
pOperator = lexeme . string
pPrinciple :: Parser SyntaxTree
pPrinciple = sepBy (pExpression <|> pElement) (optional comma)
pElement :: Parser Sel
pElement
= try pRange
<|> pValue
<|> try pReference
<|> pSection
<|> try pMulti
<|> pCMulti
<?> "element"
pRange :: Parser Sel
pRange = Range <$> pLiteral <* pOperator B.rangeOp <*> pLiteral
pValue :: Parser Sel
pValue = Value <$> pLiteral
pLiteral :: Parser NRatio
pLiteral = rational <?> "literal value"
pReference :: Parser Sel
pReference = Reference <$> pIdentifier <* notFollowedBy (pOperator B.defOp)
pSection :: Parser Sel
pSection = Section <$> brackets pPrinciple
pMulti :: Parser Sel
pMulti = Multi <$> braces pPrinciple
pCMulti :: Parser Sel
pCMulti = CMulti . NE.fromList <$>
braces (some $ (,) <$> angles pPrinciple <*> pPrinciple)
pExpression :: Parser Sel
pExpression = makeExprParser (parens pExpression <|> pElement) optTable
optTable :: [[Operator Parser Sel]]
optTable =
[[ Prefix (pOperator B.reverseOp *> pure Reverse ) ]
, [ InfixL (pOperator B.productOp *> pure Product )
, InfixL (pOperator B.divisionOp *> pure Division)
, InfixL (pOperator B.sumOp *> pure Sum )
, InfixL (pOperator B.diffOp *> pure Diff )
, InfixL (pOperator B.loopOp *> pure Loop )
, InfixL (pOperator B.rotationOp *> pure Rotation) ]]
angles :: Parser a -> Parser a
angles = between (symbol "<") (symbol ">")
braces :: Parser a -> Parser a
braces = between (symbol "{") (symbol "}")
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
comma :: Parser ()
comma = void . hidden . symbol $ ","
rational :: Parser NRatio
rational = (% 1) . fromIntegral <$> lexeme L.integer
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")
symbol :: String -> Parser String
symbol = L.symbol sc
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
sc :: Parser ()
sc = L.space (void spaceChar) (L.skipLineComment "#") empty