{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2016 Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

-- Allow us to use string literals for Text
{-# LANGUAGE OverloadedStrings #-}

module Graphics.Implicit.ExtOpenScad.Parser.Util ((*<|>), (?:), tryMany, patternMatcher, sourcePosition, number, variable, boolean, scadString, scadUndefined) where

import Prelude (String, Char, ($), foldl1, fmap, (.), pure, (*>), Bool(True, False), read, (**), (*), (==), (<>), (<$>), (<$))

import Text.Parsec (SourcePos, (<|>), (<?>), try, char, sepBy, noneOf, string, many, digit, many1, optional, choice, option, oneOf, between)

import Text.Parsec.String (GenParser)

import qualified Text.Parsec as P (sourceLine, sourceColumn, sourceName)

import Text.Parsec.Prim (ParsecT)

import Data.Functor.Identity (Identity)

import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP), SourcePosition(SourcePosition), Symbol(Symbol), Expr(LitE, Var), OVal(ONum, OString, OBool, OUndefined))

import Graphics.Implicit.Definitions (toFastℕ)

-- The lexer.
import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchIdentifier, matchTok, matchUndef, matchTrue, matchFalse, whiteSpace, surroundedBy, matchComma)

import Data.Functor (($>))

import Data.Text.Lazy (pack)

infixr 1 *<|>
(*<|>) :: GenParser tok u a -> ParsecT [tok] u Identity a -> ParsecT [tok] u Identity a
GenParser tok u a
a *<|> :: GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|> GenParser tok u a
b = GenParser tok u a -> GenParser tok u a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try GenParser tok u a
a GenParser tok u a -> GenParser tok u a -> GenParser tok u a
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser tok u a
b

infixr 2 ?:
(?:) :: String -> ParsecT s u m a -> ParsecT s u m a
String
l ?: :: String -> ParsecT s u m a -> ParsecT s u m a
?: ParsecT s u m a
p = ParsecT s u m a
p ParsecT s u m a -> String -> ParsecT s u m a
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
l

tryMany :: [GenParser tok u a] -> ParsecT [tok] u Identity a
tryMany :: [GenParser tok u a] -> GenParser tok u a
tryMany = (GenParser tok u a -> GenParser tok u a -> GenParser tok u a)
-> [GenParser tok u a] -> GenParser tok u a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 GenParser tok u a -> GenParser tok u a -> GenParser tok u a
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
(<|>) ([GenParser tok u a] -> GenParser tok u a)
-> ([GenParser tok u a] -> [GenParser tok u a])
-> [GenParser tok u a]
-> GenParser tok u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenParser tok u a -> GenParser tok u a)
-> [GenParser tok u a] -> [GenParser tok u a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenParser tok u a -> GenParser tok u a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try

-- | A pattern parser
patternMatcher :: GenParser Char st Pattern
patternMatcher :: GenParser Char st Pattern
patternMatcher = String
"pattern" String -> GenParser Char st Pattern -> GenParser Char st Pattern
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?:
          (Pattern
Wild Pattern
-> ParsecT String st Identity Char -> GenParser Char st Pattern
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_')
      GenParser Char st Pattern
-> GenParser Char st Pattern -> GenParser Char st Pattern
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ( Symbol -> Pattern
Name (Symbol -> Pattern) -> (String -> Symbol) -> String -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Symbol
Symbol (Text -> Symbol) -> (String -> Text) -> String -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Pattern)
-> ParsecT String st Identity String -> GenParser Char st Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String st Identity String
forall st. GenParser Char st String
matchIdentifier)
      GenParser Char st Pattern
-> GenParser Char st Pattern -> GenParser Char st Pattern
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ( [Pattern] -> Pattern
ListP ([Pattern] -> Pattern)
-> ParsecT String st Identity [Pattern]
-> GenParser Char st Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> ParsecT String st Identity [Pattern]
-> Char
-> ParsecT String st Identity [Pattern]
forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'[' (GenParser Char st Pattern
forall st. GenParser Char st Pattern
patternMatcher GenParser Char st Pattern
-> ParsecT String st Identity Text
-> ParsecT String st Identity [Pattern]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` ParsecT String st Identity Text
forall st. GenParser Char st Text
matchComma) Char
']' )

-- expression parsers

-- | Parse a number.
number :: GenParser Char st Expr
number :: GenParser Char st Expr
number = (String
"number" String -> GenParser Char st Expr -> GenParser Char st Expr
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?:) (GenParser Char st Expr -> GenParser Char st Expr)
-> GenParser Char st Expr -> GenParser Char st Expr
forall a b. (a -> b) -> a -> b
$ do
  String
h <- [ParsecT String st Identity String]
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
       [
         do
           String
a <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
           String
b <- String
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" ( (Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) )
           String -> ParsecT String st Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
b)
        ,
        (String
"0." String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
        ]
  String
d <- String
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"0"
       (
         String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"eE" ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ParsecT String st Identity String]
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
         [
           (Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
         ,
           ParsecT String st Identity Char -> ParsecT String st Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+') ParsecT String st Identity ()
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
         ]
       )
  ()
_ <- ParsecT String st Identity ()
forall st. GenParser Char st ()
whiteSpace
  Expr -> GenParser Char st Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> GenParser Char st Expr)
-> (OVal -> Expr) -> OVal -> GenParser Char st Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OVal -> Expr
LitE (OVal -> GenParser Char st Expr) -> OVal -> GenParser Char st Expr
forall a b. (a -> b) -> a -> b
$ ℝ -> OVal
ONum (ℝ -> OVal) -> ℝ -> OVal
forall a b. (a -> b) -> a -> b
$ if String
d String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0"
                         then String -> ℝ
forall a. Read a => String -> a
read String
h
                         else String -> ℝ
forall a. Read a => String -> a
read String
h ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
* (ℝ
10 ℝ -> ℝ -> ℝ
forall a. Floating a => a -> a -> a
** String -> ℝ
forall a. Read a => String -> a
read String
d)

-- | Parse a variable reference.
--   NOTE: abused by the parser for function calls.
variable :: GenParser Char st Expr
variable :: GenParser Char st Expr
variable = String
"variable" String -> GenParser Char st Expr -> GenParser Char st Expr
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?:
  Symbol -> Expr
Var (Symbol -> Expr) -> (String -> Symbol) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Symbol
Symbol (Text -> Symbol) -> (String -> Text) -> String -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Expr)
-> ParsecT String st Identity String -> GenParser Char st Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String st Identity String
forall st. GenParser Char st String
matchIdentifier

-- | Parse a true or false value.
boolean :: GenParser Char st Expr
boolean :: GenParser Char st Expr
boolean = String
"boolean" String -> GenParser Char st Expr -> GenParser Char st Expr
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?:
  OVal -> Expr
LitE (OVal -> Expr) -> (Bool -> OVal) -> Bool -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> OVal
OBool (Bool -> Expr)
-> ParsecT String st Identity Bool -> GenParser Char st Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenParser Char st ()
forall st. GenParser Char st ()
matchTrue GenParser Char st () -> Bool -> ParsecT String st Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True ParsecT String st Identity Bool
-> ParsecT String st Identity Bool
-> ParsecT String st Identity Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser Char st ()
forall st. GenParser Char st ()
matchFalse GenParser Char st () -> Bool -> ParsecT String st Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False)

-- | Parse a quoted string.
--   FIXME: no @\u@ unicode support?
scadString :: GenParser Char st Expr
scadString :: GenParser Char st Expr
scadString = String
"string" String -> GenParser Char st Expr -> GenParser Char st Expr
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?: OVal -> Expr
LitE (OVal -> Expr) -> (String -> OVal) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> OVal
OString (Text -> OVal) -> (String -> Text) -> String -> OVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Expr)
-> ParsecT String st Identity String -> GenParser Char st Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between
      (Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"')
      (Char -> ParsecT String st Identity Char
forall st. Char -> GenParser Char st Char
matchTok Char
'"')
      (ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String st Identity Char
 -> ParsecT String st Identity String)
-> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall a b. (a -> b) -> a -> b
$
        (String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\\"" ParsecT String st Identity String
-> Char -> ParsecT String st Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\"') ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
        (String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\n"  ParsecT String st Identity String
-> Char -> ParsecT String st Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\n') ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
        (String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\r"  ParsecT String st Identity String
-> Char -> ParsecT String st Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\r') ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
        (String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\t"  ParsecT String st Identity String
-> Char -> ParsecT String st Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\t') ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
        (String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\\\" ParsecT String st Identity String
-> Char -> ParsecT String st Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\\') ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
        String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"\n"
      )

scadUndefined :: GenParser Char st Expr
scadUndefined :: GenParser Char st Expr
scadUndefined = String
"undefined" String -> GenParser Char st Expr -> GenParser Char st Expr
forall s u (m :: * -> *) a.
String -> ParsecT s u m a -> ParsecT s u m a
?:
  OVal -> Expr
LitE OVal
OUndefined Expr -> ParsecT String st Identity () -> GenParser Char st Expr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT String st Identity ()
forall st. GenParser Char st ()
matchUndef

sourcePosition :: SourcePos -> SourcePosition
sourcePosition :: SourcePos -> SourcePosition
sourcePosition SourcePos
pos = Fastℕ -> Fastℕ -> String -> SourcePosition
SourcePosition (Line -> Fastℕ
forall n. FastN n => n -> Fastℕ
toFastℕ (Line -> Fastℕ) -> Line -> Fastℕ
forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
P.sourceLine SourcePos
pos) (Line -> Fastℕ
forall n. FastN n => n -> Fastℕ
toFastℕ (Line -> Fastℕ) -> Line -> Fastℕ
forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
P.sourceColumn SourcePos
pos) (SourcePos -> String
P.sourceName SourcePos
pos)