Commit c158703f authored by Jurriën Stutterheim's avatar Jurriën Stutterheim

More work in progress to make GiN compile again


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@2405 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent d6473ebc
This diff is collapsed.
......@@ -39,6 +39,7 @@ Global
Paths
Path: {Project}
Path: {Project}/Workflows
Path: {Application}/lib/Directory
Path: {Application}/iTasks-SDK/Patches/Platform/OS-Independent/Data
Path: {Application}/iTasks-SDK/Patches/Platform/OS-Independent/Text
Path: {Application}/iTasks-SDK/Server
......@@ -51,6 +52,11 @@ Global
Path: {Application}/iTasks-SDK/Server/lib/Platform/OS-Posix/System
Path: {Application}/iTasks-SDK/Server/lib/CleanCompiler
Path: {Application}/iTasks-SDK/Server/lib/CleanCompiler/frontend
Path: {Application}/iTasks-SDK/Server/lib/CleanIDE/Pm
Path: {Application}/iTasks-SDK/Server/lib/CleanIDE/MacOSX
Path: {Application}/iTasks-SDK/Server/lib/CleanIDE/Util
Path: {Application}/iTasks-SDK/Server/lib/CleanIDE/BatchBuild
Path: {Application}/iTasks-SDK/Server/lib/CleanIDE/Interfaces/LinkerInterface
Path: {Application}/iTasks-SDK/Server/Gin
Path: {Application}/iTasks-SDK/Server/Framework
Path: {Application}/iTasks-SDK/Server/API
......
......@@ -278,10 +278,10 @@ printADefinitionType { ADefinition | name, formalParams, returnType }
and (map (\fp = typeIsDefined fp.GFormalParameter.type) formalParams)
= [ def ( text name
<+> text "::"
</> if (isEmpty formalParams)
<-/> if (isEmpty formalParams)
empty
( fillSep (map (\fp = printGTypeExpression True fp.GFormalParameter.type) formalParams)
</> (text "->" </> space) </> empty
<-/> (text "->" <-/> space) <-/> empty
)
<-> printGTypeExpression False returnType
)
......@@ -314,9 +314,9 @@ printAStart POWriteDynamics aMod
# task = hd aMod.AModule.definitions
= [ def (text "Start :: *World -> *World")
, def (text "Start world")
, text "# (_, world) = writeFile" </> dquotes (text (aMod.AModule.name +++ ".dyn"))
</> parens (text "serialize" </> text (task.ADefinition.name))
</> text "world"
, text "# (_, world) = writeFile" <-/> dquotes (text (aMod.AModule.name +++ ".dyn"))
<-/> parens (text "serialize" <-/> text (task.ADefinition.name))
<-/> text "world"
, text "= world"
]
printAStart _ _ = []
......@@ -334,15 +334,15 @@ printAExpression opt withParens (AppInfix i fix prec e1 e2)
# doc2 = case e2 of
(AppInfix e2i e2fix e2prec _ _) = printAExpression opt (e2prec < prec || i == e2i && fix == Infixr) e2
otherwise = printAExpression opt False e2
= doc1 <$> text i </> doc2
= doc1 <$> text i <-/> doc2
printAExpression opt withParens (Lambda pat exp)
= addParens withParens (text "\\" <-> printAPattern opt pat </> text "->" </> printAExpression opt False exp)
= addParens withParens (text "\\" <-> printAPattern opt pat <-/> text "->" <-/> printAExpression opt False exp)
printAExpression opt withParens (Let defs inexp) = addParens withParens (align (text "let" <+>
newscope (map (\(pat,exp) -> text pat </> text "=" </> align (printAExpression opt False exp)) defs) <$>
text "in" </> align (printAExpression opt False inexp)))
newscope (map (\(pat,exp) -> text pat <-/> text "=" <-/> align (printAExpression opt False exp)) defs) <$>
text "in" <-/> align (printAExpression opt False inexp)))
printAExpression opt withParens (Case exp alts)
= addParens withParens
( align (text "case" </> (printAExpression opt False exp) </> (text "of") <$>
( align (text "case" <-/> (printAExpression opt False exp) <-/> (text "of") <$>
newscope (map (\alt = printACaseAlt opt alt) alts)
)
)
......@@ -359,19 +359,19 @@ addParens withParens a = if withParens (parens a) a
printAListComprehension :: PrintOption (AListComprehension Void) -> a | Printer a
printAListComprehension opt alc = brackets
( (printAExpression opt False alc.AListComprehension.output)
</> text "\\\\"
</> printGeneratorList opt alc.AListComprehension.generators
</> hsep (map (\guard -> text "|" </> printAExpression opt False guard) alc.AListComprehension.guards))
<-/> text "\\\\"
<-/> printGeneratorList opt alc.AListComprehension.generators
<-/> hsep (map (\guard -> text "|" <-/> printAExpression opt False guard) alc.AListComprehension.guards))
printGeneratorList :: PrintOption (AGeneratorList Void) -> a | Printer a
printGeneratorList opt (NestedGeneratorList generators) = fillSep (punctuate comma (map (printGenerator opt) generators))
printGeneratorList opt (ParallelGeneratorList generators) = fillSep (punctuate (text "&") (map (printGenerator opt) generators))
printGenerator :: PrintOption (AGenerator Void) -> a | Printer a
printGenerator opt (Generator sel exp) = printAPattern opt sel </> text "<-" </> printAExpression opt False exp
printGenerator opt (Generator sel exp) = printAPattern opt sel <-/> text "<-" <-/> printAExpression opt False exp
printACaseAlt :: PrintOption (ACaseAlt Void) -> a | Printer a
printACaseAlt opt (CaseAlt pat exp) = def (printAPattern opt pat </> text "=" </> align (printAExpression opt False exp))
printACaseAlt opt (CaseAlt pat exp) = def (printAPattern opt pat <-/> text "=" <-/> align (printAExpression opt False exp))
printAPattern :: PrintOption APattern -> a | Printer a
printAPattern opt p = text p
......@@ -380,4 +380,4 @@ printAIdentifier :: PrintOption AIdentifier -> a | Printer a
printAIdentifier opt i = text i
printComment :: PrintOption String -> a | Printer a
printComment opt s = text "/*" </> text s </> text "*/"
printComment opt s = text "/*" <-/> text s <-/> text "*/"
definition module GinCompiler
from iTasks import class iTask
from iTasks import class iTask, :: IWorld
import GinSyntax
import GinParser
......
......@@ -4,7 +4,7 @@ import GinSyntax
import GinTypes
from syntax import ::Type
//import Error
from Error import :: MaybeErrorString, :: MaybeError
importDCL :: !String !String *World -> (MaybeErrorString GModule, *World)
......
......@@ -2,13 +2,15 @@ implementation module GinDCLImport
import StdEnv
import File
import FilePath
import Error
import Text
import ParserCombinators
from File import deleteFile
from FilePath import dropDirectory, dropExtension, :: FilePath
from Error import Error, Ok
from OSError import :: MaybeOSError, :: OSError, :: OSErrorMessage, :: OSErrorCode
import Maybe
import CleanDocParser
import GinSyntax
from general import ::Optional(..)
......
......@@ -13,7 +13,7 @@ where
align :: a -> a
(<->) infixr 6 :: a a -> a
(<+>) infixr 6 :: a a -> a
(</>) infixr 5 :: a a -> a
(<-/>) infixr 5 :: a a -> a
(<$>) infixr 5 :: a a -> a
(<$?>) infixr 5 :: a a -> a
empty :: a
......
......@@ -2,7 +2,7 @@ implementation module GinPrinter
import StdList
import StdString
import StdOverloaded, StdInt
import StdOverloaded, StdInt, StdMisc
import Map
......@@ -24,7 +24,7 @@ where
align a = 'PPrint'.align a
(<->) a b = a 'PPrint'. <-> b
(<+>) a b = a 'PPrint'. <+> b
(</>) a b = a 'PPrint'. </> b
(<-/>) a b = a 'PPrint'. </> b
(<$>) a b = a 'PPrint'. <$> b
(<$?>) a b = a 'PPrint'. <$> b
empty = 'PPrint'.empty
......@@ -72,7 +72,7 @@ where
align a = a
(<->) a b = Cat a b
(<+>) a b = Cat a (Cat space b)
(</>) a b = a <+> b
(<-/>) a b = a <+> b
(<$>) a b = Cat a (Line b)
(<$?>) a b = a <+> b
empty = Empty
......@@ -90,7 +90,7 @@ where
punctuate p [d] = [d]
punctuate p [d:ds] = [(d <-> p) : punctuate p ds]
hsep docs = fold (<->) docs
fillSep docs = fold (</>) docs
fillSep docs = fold (<-/>) docs
position p = Position p
enclose :: !String !PDoc !String -> PDoc
......
......@@ -2,19 +2,28 @@ implementation module GinStorage
import StdFile
from StdFunc import o, seqList, ::St
import StdMisc
import StdMisc, StdClass, StdList, StdOrdList, StdChar, StdString
from File import qualified fileExists, readFile
import FilePath
import Directory
import Text
from FilePath import addExtension, dropExtension, takeExtension, :: FilePath, </>
import qualified FilePath
from Text import class Text (..), instance Text String
from Directory import readDirectory
//import Directory
//import Text
from JSON import fromJSON, instance fromString JSONNode
import OSError
import Void
import iTasks
from iTasks import class iTask, enterChoice, >>*, >>|, >>=, :: Task, :: ChoiceOption (..), :: EnterOption (..), :: ViewOption (..), :: ActionOption (..), exportJSONFile
from iTasks import class descr (..), instance descr String, class OptionContainer (..), instance OptionContainer [], return, enterInformation, viewInformation, :: Stability (..), exportTextFile, accWorld, accWorldOSError
from iTasks import ActionNo, Always, ActionYes, :: TaskStep (..), :: Action (..), :: Hotkey (..), :: Key (..), :: ActionName (..), :: TaskValue (..), :: ChoiceType (..)
from iTasks import :: Tree, :: MultiChoiceType, :: UIControlSequence, class Functor, instance Functor []
import GinConfig
import GinSyntax
import GinParser
import GinPrinter
import GinFlowLibrary
import GinDCLImport
......@@ -119,9 +128,10 @@ newModuleName config
>>= \name -> moduleExists config name
>>= \exists -> if exists
( viewInformation ("Module " +++ name +++ " already exists, do you want to overwrite?") [] Void
>?* [ (ActionYes, Always (return name))
, (ActionNo, Always (newModuleName config))
]
>>* [ ] // TODO
//(ActionYes, Always (return name))
//, (ActionNo, Always (newModuleName config))
//]
)
( return name )
......
......@@ -34,30 +34,30 @@ printGTypeExpression withParens (GList e) = brackets (printGTypeExpression F
printGTypeExpression withParens (GTuple es) = tupled (map (printGTypeExpression False) es)
printGTypeExpression withParens (GTypeApplication es) = addParens withParens (fillSep (map (printGTypeExpression True) es))
printGTypeExpression withParens (GTypeVariable v) = text v
printGTypeExpression withParens (GFunction e1 e2) = addParens withParens (printGTypeExpression False e1 </> text "->" </> printGTypeExpression False e2)
printGTypeExpression withParens (GFunction e1 e2) = addParens withParens (printGTypeExpression False e1 <-/> text "->" <-/> printGTypeExpression False e2)
printGTypeExpression withParens GUndefinedTypeExpression = text "<<undefined type expression>>"
addParens :: Bool a -> a | Printer a
addParens withParens a = if withParens (parens a) a
printGTypeDefinition :: GTypeDefinition -> a | Printer a
printGTypeDefinition gt = def ( text "::" </> text gt.GTypeDefinition.name
</> printGTypeRhs gt.GTypeDefinition.rhs
printGTypeDefinition gt = def ( text "::" <-/> text gt.GTypeDefinition.name
<-/> printGTypeRhs gt.GTypeDefinition.rhs
)
printGTypeRhs :: GTypeRhs -> a | Printer a
printGTypeRhs (GAlgebraicTypeRhs conss) = text "=" </> fillSep (punctuate (text "|") (map printGDataConstructor conss))
printGTypeRhs (GRecordTypeRhs fields) = text "=" </> braces (fillSep ((punctuate comma (map printGRecordField fields))))
printGTypeRhs (GSynonymTypeRhs exp) = text ":==" </> printGTypeExpression False exp
printGTypeRhs (GAlgebraicTypeRhs conss) = text "=" <-/> fillSep (punctuate (text "|") (map printGDataConstructor conss))
printGTypeRhs (GRecordTypeRhs fields) = text "=" <-/> braces (fillSep ((punctuate comma (map printGRecordField fields))))
printGTypeRhs (GSynonymTypeRhs exp) = text ":==" <-/> printGTypeExpression False exp
printGTypeRhs GAbstractTypeRhs = empty
printGDataConstructor :: GDataConstructor -> a | Printer a
printGDataConstructor cons = text cons.GDataConstructor.name
</> fillSep (map (printGTypeExpression True) cons.GDataConstructor.arguments)
<-/> fillSep (map (printGTypeExpression True) cons.GDataConstructor.arguments)
printGRecordField :: GRecordField -> a | Printer a
printGRecordField field = text field.GRecordField.name
</> text "::" </> printGTypeExpression False field.GRecordField.type
<-/> text "::" <-/> printGTypeExpression False field.GRecordField.type
instance toString GTypeExpression
where
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment