Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 192 lines (173 sloc) 4.972 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU GPL, see LICENSE

-- We'd like to parse openscad code, with some improvements, for backwards compatability.


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables #-}

module Graphics.Implicit.ExtOpenScad.Util where

import Prelude hiding (lookup)
import Graphics.Implicit.Definitions
import Graphics.Implicit.ExtOpenScad.Definitions
import Graphics.Implicit.ExtOpenScad.Expressions
import Graphics.Implicit.ExtOpenScad.Util.ArgParser
import Data.Map (Map, lookup, insert)
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.List
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Data.Maybe (isJust,isNothing)
import Control.Monad (forM_)


type Any = OpenscadObj

caseOType = flip ($)

infixr 2 <||>

(<||>) :: forall desiredType out. (OTypeMirror desiredType)
=> (desiredType -> out)
-> (OpenscadObj -> out)
-> (OpenscadObj -> out)

(<||>) f g = \input ->
let
coerceAttempt = fromOObj input :: Maybe desiredType
in
if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req
then f $ (\(Just a) -> a) coerceAttempt
else g input

-- white space, including tabs and comments
genSpace = many $
( try $
space
) <|> ( try $
char '\t'
) <|> (try $ do
string "//"
many ( noneOf "\n")
string "\n"
return ' '
) <|> (try $ do
string "/*"
manyTill anyChar (try $ string "*/")
return ' '
)

moduleArgsUnit ::
GenParser Char st ([VariableLookup -> OpenscadObj], [(String, VariableLookup -> OpenscadObj)])
moduleArgsUnit = do
char '(';
genSpace
args <- sepBy (
(try $ do -- eg. a = 12
symb <- variableSymb;
genSpace
char '=';
genSpace
expr <- expression 0;
return $ Right (symb, expr);
) <|> (try $ do -- eg. a(x,y) = 12
symb <- variableSymb;
genSpace
char '('
many space
argVars <- sepBy variableSymb (many space >> char ',' >> many space)
char ')'
many space
char '=';
genSpace
expr <- expression 0;
let
makeFunc baseExpr (argVar:xs) varlookup' = OFunc $
\argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup')
makeFunc baseExpr [] varlookup' = baseExpr varlookup'
funcExpr = makeFunc expr argVars
return $ Right (symb, funcExpr);
) <|> (do { -- eg. 12
expr <- expression 0;
return $ Left expr;
})
) (many space >> char ',' >> many space);
genSpace
char ')';
let
isRight (Right a) = True
isRight _ = False
named = map (\(Right a) -> a) $ filter isRight $ args
unnamed = map (\(Left a) -> a) $ filter (not . isRight) $ args
in return (unnamed, named)

moduleArgsUnitDecl ::
GenParser Char st (VariableLookup -> ArgParser (VariableLookup -> VariableLookup))
moduleArgsUnitDecl = do
char '(';
genSpace
args <- sepBy (
(try $ do
symb <- variableSymb;
genSpace
char '=';
genSpace
expr <- expression 0;
return $ \varlookup ->
ArgParser symb (Just$ expr varlookup) "" (\val -> return $ insert symb val);
) <|> (try $ do
symb <- variableSymb;
genSpace
char '('
many space
argVars <- sepBy variableSymb (many space >> char ',' >> many space)
char ')'
many space
char '=';
genSpace
expr <- expression 0;
let
makeFunc baseExpr (argVar:xs) varlookup' = OFunc $
\argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup')
makeFunc baseExpr [] varlookup' = baseExpr varlookup'
funcExpr = makeFunc expr argVars
return $ \varlookup ->
  ArgParser symb (Just$ funcExpr varlookup) "" (\val -> return $ insert symb val);
) <|> (do {
vsymb <- variableSymb;
return $ \varlookup ->
  ArgParser vsymb Nothing "" (\val -> return $ insert vsymb val);
})
) (many space >> char ',' >> many space);
genSpace
char ')';
let
merge ::
(ArgParser (VariableLookup -> VariableLookup))
-> (ArgParser (VariableLookup -> VariableLookup))
-> (ArgParser (VariableLookup -> VariableLookup))
merge a b = do
a' <- a
b' <- b
return (b'.a')
return $ \varlookup -> foldl merge (return id) $ map ($varlookup) $ args


pad parser = do
many space
a <- parser
many space
return a



patternMatcher :: GenParser Char st (OpenscadObj -> Maybe VariableLookup)
patternMatcher =
(do
char '_'
return (\obj -> Just Map.empty)
) <|> ( do
a <- literal
return $ \obj ->
if obj == (a undefined)
then Just (Map.empty)
else Nothing
) <|> ( do
symb <- variableSymb
return $ \obj -> Just $ Map.singleton symb obj
) <|> ( do
char '['
many space
components <- patternMatcher `sepBy` (many space >> char ',' >> many space)
many space
char ']'
return $ \obj -> case obj of
OList l ->
if length l == length components
then fmap Map.unions $ sequence $ zipWith ($) components l
else Nothing
_ -> Nothing
)
Something went wrong with that request. Please try again.