mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-09-17 16:08:01 +03:00
change from passing around separate line and column, into passing around a type containing line, column, and source file.
This commit is contained in:
Julia Longtin
parent
29ca418177
commit
4c335ae967
@ -294,4 +294,3 @@ data SymbolicObj3 =
|
||||
| ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2
|
||||
deriving Show
|
||||
|
||||
|
||||
|
||||
@ -13,6 +13,7 @@ import Prelude(String, Either(Left, Right), IO, ($), fmap)
|
||||
import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup)
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Util (sourcePosition)
|
||||
import Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI)
|
||||
import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)
|
||||
import Graphics.Implicit.ExtOpenScad.Util.StateC (CompState(CompState))
|
||||
@ -29,10 +30,10 @@ runOpenscad :: String -> Either ParseError (IO (VarLookup, [SymbolicObj2], [Symb
|
||||
runOpenscad source =
|
||||
let
|
||||
initial = defaultObjects
|
||||
rearrange :: forall t. (t, CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3])
|
||||
rearrange :: (t, CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3])
|
||||
rearrange (_, (CompState (varlookup, ovals, _))) = (varlookup, obj2s, obj3s) where
|
||||
(obj2s, obj3s, _ ) = divideObjs ovals
|
||||
in case parseProgram source of
|
||||
in case parseProgram "" source of
|
||||
Left e -> Left e
|
||||
Right sts -> Right
|
||||
$ fmap rearrange
|
||||
|
||||
@ -13,7 +13,7 @@ module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where
|
||||
import Prelude (String, Bool(True, False), Maybe(Just, Nothing), ($), (++), map, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), otherwise)
|
||||
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc), Symbol(Symbol))
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc), Symbol(Symbol), SourcePosition)
|
||||
import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr)
|
||||
import Graphics.Implicit.ExtOpenScad.Primitives (primitives)
|
||||
import Data.Map (fromList)
|
||||
@ -34,7 +34,8 @@ defaultObjects = VarLookup $ fromList $
|
||||
|
||||
defaultConstants :: [(Symbol, OVal)]
|
||||
defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) ))
|
||||
[((Symbol "pi"), pi)]
|
||||
[((Symbol "pi"), pi),
|
||||
((Symbol "PI"), pi)]
|
||||
|
||||
defaultFunctions :: [(Symbol, OVal)]
|
||||
defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
|
||||
|
||||
@ -11,13 +11,14 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
|
||||
OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OModule,OError, OObj2, OObj3),
|
||||
VarLookup(VarLookup),
|
||||
TestInvariant(EulerCharacteristic),
|
||||
SourcePosition(SourcePosition),
|
||||
lookupVarIn,
|
||||
collector) where
|
||||
|
||||
import Prelude(Eq, Show, Ord, String, Maybe, Bool(True, False), IO, (==), show, map, ($), (++), undefined, and, zipWith, foldl1)
|
||||
import Prelude(Eq, Show, Ord, String, Maybe, Bool(True, False), IO, FilePath, (==), show, map, ($), (++), undefined, and, zipWith, foldl1)
|
||||
|
||||
-- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ, SymbolicObj2, SymbolicObj3)
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, SymbolicObj2, SymbolicObj3)
|
||||
|
||||
import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))
|
||||
import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap, return, (>=>))
|
||||
@ -95,8 +96,8 @@ data Expr = Var Symbol
|
||||
| Expr :$ [Expr]
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- a statement, along with the line and column number it is found on.
|
||||
data StatementI = StatementI Line Column (Statement StatementI)
|
||||
-- | A statement, along with the line and column number it is found on.
|
||||
data StatementI = StatementI SourcePosition (Statement StatementI)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Statement st = Include String Bool
|
||||
@ -109,8 +110,6 @@ data Statement st = Include String Bool
|
||||
| DoNothing
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
|
||||
-- | Objects for our OpenSCAD-like language
|
||||
data OVal = OUndefined
|
||||
| OError [String]
|
||||
@ -142,6 +141,18 @@ instance Show OVal where
|
||||
show (OObj2 obj) = "<obj2: " ++ show obj ++ ">"
|
||||
show (OObj3 obj) = "<obj3: " ++ show obj ++ ">"
|
||||
|
||||
-- In order to not propagate Parsec or other modules around, create our own source position type for the AST.
|
||||
data SourcePosition = SourcePosition
|
||||
{ sourceLine :: Fastℕ
|
||||
, sourceColumn :: Fastℕ
|
||||
, sourceName :: FilePath
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
instance Show SourcePosition where
|
||||
show (SourcePosition line col []) = "line " ++ show line ++ ", column " ++ show col
|
||||
show (SourcePosition line col filePath) = "line " ++ show line ++ ", column " ++ show col ++ ", file " ++ filePath
|
||||
|
||||
-- | Apply a symbolic operator to a list of expressions, returning one big expression.
|
||||
-- Accepts a string for the operator, to simplify callers.
|
||||
collector :: String -> [Expr] -> Expr
|
||||
@ -155,4 +166,3 @@ lookupVarIn target (VarLookup vars) = lookup (Symbol target) vars
|
||||
|
||||
newtype TestInvariant = EulerCharacteristic ℕ
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@ -42,27 +42,27 @@ varUnion (VarLookup a) (VarLookup b) = VarLookup $ union a b
|
||||
-- Run statements out of the OpenScad file.
|
||||
runStatementI :: StatementI -> StateC ()
|
||||
|
||||
runStatementI (StatementI lineN columnN (pat := expr)) = do
|
||||
runStatementI (StatementI sourcePos (pat := expr)) = do
|
||||
val <- evalExpr expr
|
||||
let posMatch = matchPat pat val
|
||||
case (getErrors val, posMatch) of
|
||||
(Just err, _ ) -> errorC lineN columnN err
|
||||
(Just err, _ ) -> errorC sourcePos err
|
||||
(_, Just match) -> modifyVarLookup $ varUnion match
|
||||
(_, Nothing ) -> errorC lineN columnN "pattern match failed in assignment"
|
||||
(_, Nothing ) -> errorC sourcePos "pattern match failed in assignment"
|
||||
|
||||
runStatementI (StatementI lineN columnN (Echo exprs)) = do
|
||||
runStatementI (StatementI sourcePos (Echo exprs)) = do
|
||||
let
|
||||
show2 (OString s) = s
|
||||
show2 x = show x
|
||||
vals <- mapM evalExpr exprs
|
||||
case getErrors (OList vals) of
|
||||
Nothing -> liftIO . putStrLn $ concatMap show2 vals
|
||||
Just err -> errorC lineN columnN err
|
||||
Just err -> errorC sourcePos err
|
||||
|
||||
runStatementI (StatementI lineN columnN (For pat expr loopContent)) = do
|
||||
runStatementI (StatementI sourcePos (For pat expr loopContent)) = do
|
||||
val <- evalExpr expr
|
||||
case (getErrors val, val) of
|
||||
(Just err, _) -> errorC lineN columnN err
|
||||
(Just err, _) -> errorC sourcePos err
|
||||
(_, OList vals) -> forM_ vals $ \v ->
|
||||
case matchPat pat v of
|
||||
Just match -> do
|
||||
@ -71,21 +71,21 @@ runStatementI (StatementI lineN columnN (For pat expr loopContent)) = do
|
||||
Nothing -> return ()
|
||||
_ -> return ()
|
||||
|
||||
runStatementI (StatementI lineN columnN (If expr a b)) = do
|
||||
runStatementI (StatementI sourcePos (If expr a b)) = do
|
||||
val <- evalExpr expr
|
||||
case (getErrors val, val) of
|
||||
(Just err, _ ) -> errorC lineN columnN ("In conditional expression of if statement: " ++ err)
|
||||
(Just err, _ ) -> errorC sourcePos ("In conditional expression of if statement: " ++ err)
|
||||
(_, OBool True ) -> runSuite a
|
||||
(_, OBool False) -> runSuite b
|
||||
_ -> return ()
|
||||
|
||||
runStatementI (StatementI lineN columnN (NewModule name argTemplate suite)) = do
|
||||
runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do
|
||||
argTemplate' <- forM argTemplate $ \(name', defexpr) -> do
|
||||
defval <- mapMaybeM evalExpr defexpr
|
||||
return (name', defval)
|
||||
(CompState (VarLookup varlookup, _, path)) <- get
|
||||
-- FIXME: \_? really?
|
||||
runStatementI . StatementI lineN columnN $ (Name name :=) $ LitE $ OModule $ \_ -> do
|
||||
runStatementI . StatementI sourcePos $ (Name name :=) $ LitE $ OModule $ \_ -> do
|
||||
newNameVals <- forM argTemplate' $ \(name', maybeDef) -> do
|
||||
val <- case maybeDef of
|
||||
Just def -> argument name' `defaultTo` def
|
||||
@ -112,7 +112,7 @@ runStatementI (StatementI lineN columnN (NewModule name argTemplate suite)) = do
|
||||
suiteVals = runSuiteCapture (VarLookup varlookup') path suite
|
||||
return suiteVals
|
||||
|
||||
runStatementI (StatementI lineN columnN (ModuleCall (Symbol name) argsExpr suite)) = do
|
||||
runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) = do
|
||||
maybeMod <- lookupVar (Symbol name)
|
||||
(CompState (varlookup, _, path)) <- get
|
||||
childVals <- fmap reverse . liftIO $ runSuiteCapture varlookup path suite
|
||||
@ -125,18 +125,18 @@ runStatementI (StatementI lineN columnN (ModuleCall (Symbol name) argsExpr suite
|
||||
ioNewVals = fromMaybe (return []) (fst $ argMap argsVal argparser)
|
||||
Just foo -> do
|
||||
case getErrors foo of
|
||||
Just err -> errorC lineN columnN err
|
||||
Nothing -> errorC lineN columnN "Object called not module!"
|
||||
Just err -> errorC sourcePos err
|
||||
Nothing -> errorC sourcePos "Object called not module!"
|
||||
return []
|
||||
Nothing -> do
|
||||
errorC lineN columnN $ "Module " ++ name ++ " not in scope."
|
||||
errorC sourcePos $ "Module " ++ name ++ " not in scope."
|
||||
return []
|
||||
pushVals newVals
|
||||
|
||||
runStatementI (StatementI _ _ (Include name injectVals)) = do
|
||||
runStatementI (StatementI _ (Include name injectVals)) = do
|
||||
name' <- getRelPath name
|
||||
content <- liftIO $ readFile name'
|
||||
case parseProgram content of
|
||||
case parseProgram name' content of
|
||||
Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e
|
||||
Right sts -> withPathShiftedBy (takeDirectory name) $ do
|
||||
vals <- getVals
|
||||
@ -145,7 +145,7 @@ runStatementI (StatementI _ _ (Include name injectVals)) = do
|
||||
vals' <- getVals
|
||||
if injectVals then putVals (vals' ++ vals) else putVals vals
|
||||
|
||||
runStatementI (StatementI _ _ DoNothing) = liftIO $ putStrLn "Do Nothing?"
|
||||
runStatementI (StatementI _ DoNothing) = liftIO $ putStrLn "Do Nothing?"
|
||||
|
||||
runSuite :: [StatementI] -> StateC ()
|
||||
runSuite = mapM_ runStatementI
|
||||
|
||||
@ -23,14 +23,14 @@ import Data.Functor.Identity(Identity)
|
||||
import Data.Kind (Type)
|
||||
|
||||
-- We use parsec to parse.
|
||||
import Text.ParserCombinators.Parsec (try, sepBy, sourceLine, sourceColumn, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, ParseError, many, noneOf, Line, Column, (<|>), (<?>))
|
||||
import Text.ParserCombinators.Parsec (SourceName, try, sepBy, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, ParseError, many, noneOf, Line, Column, (<|>), (<?>))
|
||||
import Text.Parsec.Prim (ParsecT)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall, (:=)), Expr(LamE), StatementI(StatementI), Symbol(Symbol))
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall, (:=)), Expr(LamE), StatementI(StatementI), Symbol(Symbol), SourcePosition)
|
||||
|
||||
import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Pattern(Name))
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, tryMany, stringGS, (*<|>), (?:), patternMatcher, variableSymb)
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, tryMany, stringGS, (*<|>), (?:), patternMatcher, variableSymb, sourcePosition)
|
||||
|
||||
-- the top level of the expression parser.
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)
|
||||
@ -38,8 +38,8 @@ import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)
|
||||
-- Let us use the old syntax when defining Names.
|
||||
pattern Name n = GIED.Name (Symbol n)
|
||||
|
||||
parseProgram :: String -> Either ParseError [StatementI]
|
||||
parseProgram = parse program "" where -- "" is our program name.
|
||||
parseProgram :: SourceName -> String -> Either ParseError [StatementI]
|
||||
parseProgram name s = parse program name s where
|
||||
program :: ParsecT String u Identity [StatementI]
|
||||
program = do
|
||||
sts <- many1 computation
|
||||
@ -104,115 +104,102 @@ suite = (fmap return computation <|> do
|
||||
-- | commenting out a comuptation: use % or * before the statement, and it will not be run.
|
||||
throwAway :: GenParser Char st StatementI
|
||||
throwAway = do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
pos <- sourcePos
|
||||
_ <- genSpace
|
||||
_ <- oneOf "%*"
|
||||
_ <- genSpace
|
||||
_ <- computation
|
||||
return $ StatementI line column DoNothing
|
||||
return $ StatementI pos DoNothing
|
||||
|
||||
-- | An include! Basically, inject another extopenscad file here...
|
||||
include :: GenParser Char st StatementI
|
||||
include = (do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
pos <- sourcePos
|
||||
injectVals <- (string "include" >> return True )
|
||||
<|> (string "use" >> return False)
|
||||
_ <- stringGS " < "
|
||||
filename <- many (noneOf "<> ")
|
||||
_ <- stringGS " > "
|
||||
return $ StatementI line column $ Include filename injectVals
|
||||
return $ StatementI pos $ Include filename injectVals
|
||||
) <?> "include "
|
||||
|
||||
-- | An assignment (parser)
|
||||
assignment :: GenParser Char st StatementI
|
||||
assignment = ("assignment " ?:) $
|
||||
do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
lvalue <- patternMatcher
|
||||
_ <- stringGS " = "
|
||||
valExpr <- expr0
|
||||
return $ StatementI line column $ lvalue := valExpr
|
||||
assignment = ("assignment " ?:) $ do
|
||||
pos <- sourcePos
|
||||
lvalue <- patternMatcher
|
||||
_ <- stringGS " = "
|
||||
valExpr <- expr0
|
||||
return $ StatementI pos $ lvalue := valExpr
|
||||
|
||||
-- | A function declaration (parser)
|
||||
function :: GenParser Char st StatementI
|
||||
function = ("function " ?:) $
|
||||
do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
varSymb <- string "function" >> space >> genSpace >> variableSymb
|
||||
_ <- stringGS " ( "
|
||||
argVars <- sepBy patternMatcher (stringGS " , ")
|
||||
_ <- stringGS " ) = "
|
||||
valExpr <- expr0
|
||||
return $ StatementI line column $ Name varSymb := LamE argVars valExpr
|
||||
function = ("function " ?:) $ do
|
||||
pos <- sourcePos
|
||||
varSymb <- string "function" >> space >> genSpace >> variableSymb
|
||||
_ <- stringGS " ( "
|
||||
argVars <- sepBy patternMatcher (stringGS " , ")
|
||||
_ <- stringGS " ) = "
|
||||
valExpr <- expr0
|
||||
return $ StatementI pos $ Name varSymb := LamE argVars valExpr
|
||||
|
||||
-- | An echo (parser)
|
||||
echo :: GenParser Char st StatementI
|
||||
echo = do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
pos <- sourcePos
|
||||
_ <- stringGS "echo ( "
|
||||
exprs <- expr0 `sepBy` stringGS " , "
|
||||
_ <- stringGS " ) "
|
||||
return $ StatementI line column $ Echo exprs
|
||||
return $ StatementI pos $ Echo exprs
|
||||
|
||||
ifStatementI :: GenParser Char st StatementI
|
||||
ifStatementI =
|
||||
"if " ?: do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
_ <- stringGS "if ( "
|
||||
bexpr <- expr0
|
||||
_ <- stringGS " ) "
|
||||
sTrueCase <- suite
|
||||
_ <- genSpace
|
||||
sFalseCase <- (stringGS "else " >> suite ) *<|> return []
|
||||
return $ StatementI line column $ If bexpr sTrueCase sFalseCase
|
||||
ifStatementI = "if " ?: do
|
||||
pos <- sourcePos
|
||||
_ <- stringGS "if ( "
|
||||
bexpr <- expr0
|
||||
_ <- stringGS " ) "
|
||||
sTrueCase <- suite
|
||||
_ <- genSpace
|
||||
sFalseCase <- (stringGS "else " >> suite ) *<|> return []
|
||||
return $ StatementI pos $ If bexpr sTrueCase sFalseCase
|
||||
|
||||
forStatementI :: GenParser Char st StatementI
|
||||
forStatementI =
|
||||
"for " ?: do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
-- a for loop is of the form:
|
||||
-- for ( vsymb = vexpr ) loops
|
||||
-- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}
|
||||
-- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}
|
||||
_ <- stringGS "for ( "
|
||||
lvalue <- patternMatcher
|
||||
_ <- stringGS " = "
|
||||
vexpr <- expr0
|
||||
_ <- stringGS " ) "
|
||||
loopContent <- suite
|
||||
return $ StatementI line column $ For lvalue vexpr loopContent
|
||||
forStatementI = "for " ?: do
|
||||
pos <- sourcePos
|
||||
-- a for loop is of the form:
|
||||
-- for ( vsymb = vexpr ) loops
|
||||
-- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}
|
||||
-- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}
|
||||
_ <- stringGS "for ( "
|
||||
lvalue <- patternMatcher
|
||||
_ <- stringGS " = "
|
||||
vexpr <- expr0
|
||||
_ <- stringGS " ) "
|
||||
loopContent <- suite
|
||||
return $ StatementI pos $ For lvalue vexpr loopContent
|
||||
|
||||
-- | parse a call to a module.
|
||||
userModule :: GenParser Char st StatementI
|
||||
userModule = do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
pos <- sourcePos
|
||||
name <- variableSymb
|
||||
_ <- genSpace
|
||||
args <- moduleArgsUnit
|
||||
_ <- genSpace
|
||||
s <- suite *<|> (stringGS " ; " >> return [])
|
||||
return $ StatementI line column $ ModuleCall (Symbol name) args s
|
||||
return $ StatementI pos $ ModuleCall (Symbol name) args s
|
||||
|
||||
-- | declare a module.
|
||||
userModuleDeclaration :: GenParser Char st StatementI
|
||||
userModuleDeclaration = do
|
||||
line <- lineNumber
|
||||
column <- columnNumber
|
||||
pos <- sourcePos
|
||||
_ <- stringGS "module "
|
||||
newModuleName <- variableSymb
|
||||
_ <- genSpace
|
||||
args <- moduleArgsUnitDecl
|
||||
_ <- genSpace
|
||||
s <- suite
|
||||
return $ StatementI line column $ NewModule (Symbol newModuleName) args s
|
||||
return $ StatementI pos $ NewModule (Symbol newModuleName) args s
|
||||
|
||||
-- | parse the arguments passed to a module.
|
||||
moduleArgsUnit :: GenParser Char st [(Maybe Symbol, Expr)]
|
||||
@ -266,13 +253,8 @@ moduleArgsUnitDecl = do
|
||||
_ <- stringGS " ) "
|
||||
return argTemplate
|
||||
|
||||
-- | Find the line number. Used when generating errors.
|
||||
lineNumber :: forall s u (m :: Type -> Type).
|
||||
Monad m => ParsecT s u m Line
|
||||
lineNumber = fmap sourceLine getPosition
|
||||
|
||||
-- | Find the column number. Used when generating errors.
|
||||
columnNumber :: forall s u (m :: Type -> Type).
|
||||
Monad m => ParsecT s u m Column
|
||||
columnNumber = fmap sourceColumn getPosition
|
||||
|
||||
-- | Find the source position. Used when generating errors.
|
||||
sourcePos :: ParsecT s u Identity SourcePosition
|
||||
sourcePos = do
|
||||
pos <- getPosition
|
||||
return $ sourcePosition pos
|
||||
|
||||
@ -8,17 +8,21 @@
|
||||
-- FIXME: required. why?
|
||||
{-# LANGUAGE KindSignatures, FlexibleContexts #-}
|
||||
|
||||
module Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, pad, (*<|>), (?:), stringGS, padString, padChar, tryMany, variableSymb, patternMatcher) where
|
||||
module Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, pad, (*<|>), (?:), stringGS, padString, padChar, tryMany, variableSymb, patternMatcher, sourcePosition) where
|
||||
|
||||
import Prelude (String, Char, ($), (++), foldl1, map, (>>), (.), return)
|
||||
|
||||
import Text.ParserCombinators.Parsec (GenParser, many, oneOf, noneOf, (<|>), try, string, manyTill, anyChar, (<?>), char, many1, sepBy)
|
||||
import Text.ParserCombinators.Parsec (GenParser, SourcePos, many, oneOf, noneOf, (<|>), try, string, manyTill, anyChar, (<?>), char, many1, sepBy)
|
||||
|
||||
import qualified Text.ParserCombinators.Parsec as P (sourceLine, sourceColumn, sourceName)
|
||||
|
||||
import Text.Parsec.Prim (ParsecT, Stream)
|
||||
|
||||
import Data.Functor.Identity (Identity)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP), Symbol(Symbol))
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP), SourcePosition(SourcePosition), Symbol(Symbol))
|
||||
|
||||
import Graphics.Implicit.Definitions (toFastℕ)
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
@ -108,3 +112,6 @@ patternMatcher =
|
||||
_ <- char ']'
|
||||
return $ ListP components
|
||||
)
|
||||
|
||||
sourcePosition :: SourcePos -> SourcePosition
|
||||
sourcePosition pos = SourcePosition (toFastℕ $ P.sourceLine pos) (toFastℕ $ P.sourceColumn pos) (P.sourceName pos)
|
||||
|
||||
@ -13,7 +13,7 @@ module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup,
|
||||
|
||||
import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Monad, fmap, (.), ($), (++), return, putStrLn, show)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition)
|
||||
|
||||
import Data.Map (lookup)
|
||||
import Control.Monad.State (StateT, get, put, modify, liftIO)
|
||||
@ -71,8 +71,9 @@ getRelPath relPath = do
|
||||
path <- getPath
|
||||
return $ path </> relPath
|
||||
|
||||
errorC :: forall (m :: Type -> Type) a. (Show a, MonadIO m) => a -> a -> String -> m ()
|
||||
errorC lineN columnN err = liftIO $ putStrLn $ "On line " ++ show lineN ++ ", column " ++ show columnN ++ ": " ++ err
|
||||
errorC :: SourcePosition -> String -> StateC()
|
||||
errorC sourcePos err =
|
||||
liftIO $ putStrLn $ "At " ++ show sourcePos ++ ": " ++ err
|
||||
{-# INLINABLE errorC #-}
|
||||
|
||||
mapMaybeM :: forall t (m :: Type -> Type) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)
|
||||
|
||||
@ -33,7 +33,7 @@ parseExpr s = case parse expr0 "src" s of
|
||||
Right e -> e
|
||||
|
||||
parseStatements :: String -> [StatementI]
|
||||
parseStatements s = case parseProgram s of
|
||||
parseStatements s = case parseProgram "noname" s of
|
||||
Left err -> error (show err)
|
||||
Right e -> e
|
||||
|
||||
|
||||
@ -132,9 +132,9 @@ exprSpec = do
|
||||
it "handles multiple function calls" $
|
||||
"foo(1)(2)(3)" --> ((Var "foo" :$ [num 1]) :$ [num 2]) :$ [num 3]
|
||||
describe "arithmetic" $ do
|
||||
it "handles unary -" $ do
|
||||
it "handles unary -" $
|
||||
"-42" --> num (-42)
|
||||
it "handles unary +" $ do
|
||||
it "handles unary +" $
|
||||
"+42" --> num 42
|
||||
it "handles unary - with extra spaces" $
|
||||
"- 42" --> num (-42)
|
||||
|
||||
@ -14,13 +14,15 @@ import Test.Hspec (Spec, Expectation, shouldBe, shouldSatisfy, it, pendingWith,
|
||||
|
||||
import ParserSpec.Util (bool, num, minus, plus, mult, index)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol(Symbol), Expr(ListE, LamE, (:$)), Statement(NewModule, ModuleCall, If, (:=)), Pattern(ListP))
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol(Symbol), Expr(ListE, LamE, (:$)), Statement(NewModule, ModuleCall, If, (:=)), Pattern(ListP), SourcePosition(SourcePosition))
|
||||
|
||||
import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name))
|
||||
|
||||
-- Parse an ExtOpenScad program.
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
|
||||
|
||||
import Graphics.Implicit.Definitions (Fastℕ)
|
||||
|
||||
import Data.Either (Either(Right), isLeft)
|
||||
|
||||
import Text.ParserCombinators.Parsec (Line, Column)
|
||||
@ -33,19 +35,19 @@ pattern Name n = GIED.Name (Symbol n)
|
||||
infixr 1 -->
|
||||
(-->) :: String -> [StatementI] -> Expectation
|
||||
(-->) source stmts =
|
||||
parseProgram source `shouldBe` Right stmts
|
||||
parseProgram "noname" source `shouldBe` Right stmts
|
||||
|
||||
-- | an expectation that a string generates an error.
|
||||
parsesAsError :: String -> Expectation
|
||||
parsesAsError source = parseProgram source `shouldSatisfy` isLeft
|
||||
parsesAsError source = parseProgram "noname" source `shouldSatisfy` isLeft
|
||||
|
||||
-- | A single statement.
|
||||
single :: Statement StatementI -> [StatementI]
|
||||
single st = [StatementI 1 1 st]
|
||||
single st = [StatementI (SourcePosition 1 1 "noname") st]
|
||||
|
||||
-- | A function call.
|
||||
call :: String -> Column -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI
|
||||
call name position args stmts = StatementI 1 position (ModuleCall (Symbol name) args stmts)
|
||||
call :: String -> Fastℕ -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI
|
||||
call name column args stmts = StatementI (SourcePosition 1 column "noname") (ModuleCall (Symbol name) args stmts)
|
||||
|
||||
-- | Test a simple if block.
|
||||
ifSpec :: Spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user