technique (empty) → 0.2.5
raw patch · 20 files changed
+3369/−0 lines, 20 filesdep +asyncdep +basedep +containers
Dependencies added: async, base, containers, core-data, core-program, core-text, dlist, free, hashable, hspec, ivar-simple, megaparsec, mtl, parser-combinators, prettyprinter, technique, text, transformers, uuid-types
Files
- LICENSE +19/−0
- lib/Technique/Builtins.hs +91/−0
- lib/Technique/Diagnostics.hs +98/−0
- lib/Technique/Evaluator.hs +83/−0
- lib/Technique/Failure.hs +241/−0
- lib/Technique/Formatter.hs +285/−0
- lib/Technique/Internal.hs +138/−0
- lib/Technique/Language.hs +165/−0
- lib/Technique/Parser.hs +656/−0
- lib/Technique/Quantity.hs +138/−0
- lib/Technique/Translate.hs +342/−0
- src/TechniqueMain.hs +78/−0
- src/TechniqueUser.hs +154/−0
- technique.cabal +119/−0
- tests/CheckConcreteSyntax.hs +96/−0
- tests/CheckQuantityBehaviour.hs +40/−0
- tests/CheckSkeletonParser.hs +336/−0
- tests/CheckTranslationPhase.hs +127/−0
- tests/ExampleProcedure.hs +144/−0
- tests/TestSuite.hs +19/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright © 2002-2020 Athae Eredh Siniath and Others++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
+ lib/Technique/Builtins.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- |+-- This is the beginnings of the standard library.+module Technique.Builtins where++import Core.Data.Structures+import Core.Text.Rope ()+import Technique.Internal+import Technique.Language++-- Do these need descriptions? Not really, unless this becomes a form of+-- online help. Such text would not be used in overviews, so we'll see if+-- we ever need them.++builtinProcedures :: Map Identifier Function+builtinProcedures =+ intoMap+ ( fmap+ (\p -> (functionName p, p))+ [ builtinProcedureWaitEither,+ builtinProcedureWaitBoth,+ builtinProcedureCombineValues,+ builtinProcedureTask,+ builtinProcedureRecord+ ]+ )++builtinProcedureTask :: Function+builtinProcedureTask =+ Primitive+ emptyProcedure+ { procedureName = Identifier "task",+ procedureInput = [Type "Text"],+ procedureOutput = [Type "()"], -- ?+ procedureTitle = Just (Markdown "Task"),+ procedureDescription = Just (Markdown "A task to be executed by the person carrying out this role.")+ }+ undefined++builtinProcedureRecord :: Function+builtinProcedureRecord =+ Primitive+ emptyProcedure+ { procedureName = Identifier "record",+ procedureInput = [Type "Text"],+ procedureOutput = [Type "Text"], -- ?+ procedureTitle = Just (Markdown "Record"),+ procedureDescription = Just (Markdown "Input from the user to be parsed as a quantity.")+ }+ undefined++-- the '|' operation+builtinProcedureWaitEither :: Function+builtinProcedureWaitEither =+ Primitive+ emptyProcedure+ { procedureName = Identifier "wait_either",+ procedureInput = [Type "*", Type "*"],+ procedureOutput = [Type "()"],+ procedureTitle = Just (Markdown "Wait Either"),+ procedureDescription = Just (Markdown "Wait for either of two values to be ready.")+ }+ undefined++-- the '&' operation+builtinProcedureWaitBoth :: Function+builtinProcedureWaitBoth =+ Primitive+ emptyProcedure+ { procedureName = Identifier "wait_both",+ procedureInput = [Type "*", Type "*"],+ procedureOutput = [Type "()"],+ procedureTitle = Just (Markdown "Wait Both"),+ procedureDescription = Just (Markdown "Wait for two values to both be ready.")+ }+ undefined++-- the '+' operation+builtinProcedureCombineValues :: Function+builtinProcedureCombineValues =+ Primitive+ emptyProcedure+ { procedureName = Identifier "combine_values",+ procedureInput = [Type "*", Type "*"],+ procedureOutput = [Type "*"],+ procedureTitle = Just (Markdown "Combine Two Values"),+ procedureDescription = Just (Markdown "Combine two values. This will involve coersion if the concrete types differ.")+ }+ undefined
+ lib/Technique/Diagnostics.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-imports #-}++module Technique.Diagnostics where++import Core.System.Pretty+import Core.Text.Rope+import Core.Text.Utilities+import Data.DList (toList)+import Data.Foldable (foldl')+import Data.Int (Int8)+import Technique.Formatter -- already have lots of useful definitions+import Technique.Internal+import Technique.Language++instance Render Function where+ type Token Function = TechniqueToken+ colourize = colourizeTechnique+ highlight func =+ nest+ 3+ ( " ↘ "+ <> ( case func of+ Unresolved i ->+ annotate ErrorToken "Unresolved" <+> annotate ProcedureToken (pretty (unIdentifier i)) <> line+ Subroutine proc step ->+ annotate StepToken "Subroutine" <+> annotate ProcedureToken (pretty (procedureName proc))+ <> line+ <> (nest 3 (" ↘ " <> highlight step))+ Primitive proc action ->+ annotate StepToken "Primitive" <+> annotate ProcedureToken (pretty (procedureName proc))+ <> line+ <> " ↘ <primitive>"+ )+ )++instance Render Step where+ type Token Step = TechniqueToken+ colourize = colourizeTechnique+ highlight step = case step of+ Known _ value ->+ annotate StepToken "Known" <+> highlight value+ Depends _ name ->+ annotate StepToken "Depends" <+> highlight name+ NoOp ->+ annotate ErrorToken "NoOp"+ Tuple _ steps ->+ annotate StepToken "Tuple"+ <+> lparen+ <+> hsep (punctuate comma (fmap highlight steps))+ <+> rparen+ Nested _ steps ->+ vcat (toList (fmap highlight steps))+ Asynchronous _ names substep ->+ annotate StepToken "Asynch" <+> commaCat names <+> "◀-" <+> highlight substep+ Invocation _ attr func substep ->+ let i = functionName func+ in annotate StepToken "Invoke" <+> highlight attr <+> annotate ApplicationToken (highlight i)+ <> line+ <> nest 3 (" ↘ " <> highlight substep)+ Bench _ pairs ->+ -- [(Label,Step)]+ annotate StepToken "Bench"+ <> line+ <> " "+ <> hang+ 2+ ( lbracket+ <+> vsep (punctuate comma bindings)+ )+ <+> rbracket+ where+ bindings = fmap f pairs+ f :: (Label, Step) -> Doc TechniqueToken+ f (label, substep) =+ highlight label <+> "◀-" <+> highlight substep++instance Render Name where+ type Token Name = TechniqueToken+ colourize = colourizeTechnique+ highlight (Name name) = annotate VariableToken (pretty name)++instance Render Value where+ type Token Value = TechniqueToken+ colourize = colourizeTechnique+ highlight value = case value of+ Unitus ->+ annotate QuantityToken "()"+ Literali text ->+ annotate SymbolToken dquote+ <> annotate StringToken (pretty text)+ <> annotate SymbolToken dquote+ Quanticle qty ->+ highlight qty+ _ ->+ undefined
+ lib/Technique/Evaluator.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- At present this is a proof of concept. It might benefit from being+-- converted to a typeclass in the tagless final style.++-- |+-- Given an instantiated Technique Procedure, evalutate it at runtime.+module Technique.Evaluator where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.Trans.Reader (ReaderT (..))+import Core.Data+import Core.Text+import Data.UUID.Types (UUID)+import Technique.Internal++-- |+-- In order to execute a Procedure we need to supply a Context: an identifier+-- for the event (collection of procedure calls) it is a part of, and the path+-- history we took to get here.++-- TODO values needs to be somewhere, but here?+data Context = Context+ { contextEvent :: UUID,+ contextPath :: Rope, -- or a list or a fingertree or...+ contextValues :: Map Name Promise -- TODO this needs to evolve to IVars or equivalent+ }++{-+data Expression b where+ Binding :: Variable b -> Expression a -> Expression b+ Comment :: Rope -> Expression ()+ Declaration :: (a -> b) -> Expression (a -> b)+ Application :: Expression (a -> b) -> Expression a -> Expression b+ Attribute :: Role -> Expression a -> Expression a+-}++-- Does this need to upgrade to a MonadEvaluate mtl style class in order to+-- support different interpeters / backends? This seems so cumbersome+-- compared to the elegent tagless final method.++newtype Evaluate a = Evaluate (ReaderT Context IO a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Context)++unEvaluate :: Evaluate a -> ReaderT Context IO a+unEvaluate (Evaluate r) = r++-- |+-- The heart of the evaluation loop. Translate from the abstract syntax tree+-- into a monadic sequence which results in a Result.+evaluateStep :: Step -> Evaluate Value+evaluateStep step = case step of+ Known _ value -> do+ return value+ Depends _ name -> do+ blockUntilValue name+ Tuple _ steps -> do+ values <- traverse evaluateStep steps+ return (Parametriq values)+ Asynchronous _ names substep -> do+ promise <- assignNames names substep+ undefined -- TODO put promise into environment+ Invocation _ attr func substep -> do+ functionApplication func substep -- TODO do something with role!++functionApplication :: Function -> Step -> Evaluate Value -- IO Promise ?+functionApplication = undefined++executeAction :: Function -> Step -> Evaluate Value -- IO Promise ?+executeAction = undefined++blockUntilValue :: Name -> Evaluate Value+blockUntilValue = undefined++-- |+-- Take a step and lauch it asynchronously, binding its result to a name.+-- Returns a promise of a value that can be in evaluated (block on) when+-- needed.+assignNames :: [Name] -> Step -> Evaluate Promise+assignNames = do+ -- dunno+ return (undefined) -- fixme not empty list
+ lib/Technique/Failure.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- I generally try to avoid modules full of (only) types but these are here+-- so the can be shared in both Technique.Translate and Technique.Builtins.++-- |+-- Error messages from compiling.+module Technique.Failure where++import Core.System.Base+import Core.System.Pretty+import Core.Text.Rope+import Core.Text.Utilities+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as OrdSet+import qualified Data.Text as T+import Data.Void+import Technique.Formatter+import Technique.Language hiding (Label)+import Text.Megaparsec (PosState (..), SourcePos (..))+import Text.Megaparsec.Error+ ( ErrorItem (..),+ ParseError (..),+ ParseErrorBundle (..),+ )+import Text.Megaparsec.Pos (unPos)+import Prelude hiding (lines)++data Status = Ok | Failed CompilationError | Reload++instance Render Status where+ type Token Status = TechniqueToken+ colourize = colourizeTechnique+ highlight status = case status of+ Ok -> annotate LabelToken "ok"+ Failed e -> highlight e+ Reload -> annotate MagicToken "Δ"++data Source = Source+ { sourceContents :: Rope,+ sourceFilename :: FilePath,+ sourceOffset :: !Offset+ }+ deriving (Eq, Ord, Show)++instance Located Source where+ locationOf = sourceOffset++instance Render Source where+ type Token Source = TechniqueToken+ colourize = colourizeTechnique+ highlight source = pretty (sourceFilename source) <+> pretty (sourceOffset source)++emptySource :: Source+emptySource =+ Source+ { sourceContents = emptyRope,+ sourceFilename = "<undefined>",+ sourceOffset = -1+ }++data FailureReason+ = InvalidSetup -- TODO placeholder+ | ParsingFailed [ErrorItem Char] [ErrorItem Char]+ | VariableAlreadyInUse Identifier+ | ProcedureAlreadyDeclared Identifier+ | CallToUnknownProcedure Identifier+ | UseOfUnknownIdentifier Identifier+ | EncounteredUndefined+ deriving (Show, Eq)++instance Enum FailureReason where+ fromEnum x = case x of+ InvalidSetup -> 1+ ParsingFailed _ _ -> 2+ VariableAlreadyInUse _ -> 3+ ProcedureAlreadyDeclared _ -> 4+ CallToUnknownProcedure _ -> 5+ UseOfUnknownIdentifier _ -> 6+ EncounteredUndefined -> 7+ toEnum = undefined++data CompilationError = CompilationError Source FailureReason+ deriving (Show)++instance Exception CompilationError++exitCodeFor :: CompilationError -> Int+exitCodeFor (CompilationError _ reason) = fromEnum reason++-- TODO upgrade this to (Doc ann) so we can get prettier error messages.++instance Render FailureReason where+ type Token FailureReason = TechniqueToken+ colourize = colourizeTechnique+ highlight failure = case failure of+ InvalidSetup -> "Invalid setup!"+ ParsingFailed unexpected expected ->+ let un = case unexpected of+ [] -> emptyDoc+ (item : _) -> "unexpected " <> formatErrorItem FilenameToken item <> hardline+ ex = case expected of+ [] -> emptyDoc+ items -> "expecting " <> fillCat (fancyPunctuate (fmap (formatErrorItem SymbolToken) items)) <> "."+ in un <> ex+ VariableAlreadyInUse i -> "Variable by the name of '" <> annotate VariableToken (highlight i) <> "' already defined."+ ProcedureAlreadyDeclared i -> "Procedure by the name of '" <> annotate ProcedureToken (highlight i) <> "' already declared."+ CallToUnknownProcedure i -> "Call to unknown procedure '" <> annotate ApplicationToken (highlight i) <> "'."+ UseOfUnknownIdentifier i -> "Variable '" <> annotate VariableToken (highlight i) <> "' not in scope."+ EncounteredUndefined -> "Encountered an " <> annotate ErrorToken "undefined" <> " marker."++fancyPunctuate :: [Doc ann] -> [Doc ann]+fancyPunctuate list = case list of+ [] -> []+ [x] -> [x]+ (x1 : x2 : []) -> x1 : ", or " : x2 : []+ (x1 : xs) -> x1 : ", " : fancyPunctuate xs++-- |+-- ErrorItem is a bit overbearing, but we handle its /four/ cases by saying+-- single quotes around characters, double quotes around strings, /no/ quotes+-- around labels (descriptive text) and hard code the end of input and newline+-- cases.+formatErrorItem :: TechniqueToken -> ErrorItem Char -> Doc TechniqueToken+formatErrorItem token item = case item of+ -- It would appear that **prettyprinter** has a Pretty instance for+ -- NonEmpty a. In this case token ~ Char so these are Strings, ish.+ -- Previously we converted to Rope, but looks like we can go directly.++ Tokens tokens ->+ case NonEmpty.uncons tokens of+ (ch, Nothing) -> case ch of+ '\n' -> annotate token "newline"+ _ -> pretty '\'' <> annotate token (pretty ch) <> pretty '\''+ _ -> pretty '\"' <> annotate token (pretty tokens) <> pretty '\"'+ Label chars ->+ annotate token (pretty chars)+ EndOfInput ->+ "end of input"++numberOfCarots :: FailureReason -> Int+numberOfCarots reason = case reason of+ InvalidSetup -> 0+ ParsingFailed unexpected _ -> case unexpected of+ [] -> 1+ (item : _) -> case item of+ Tokens tokens -> NonEmpty.length tokens+ Label chars -> NonEmpty.length chars+ EndOfInput -> 1+ VariableAlreadyInUse i -> widthRope (unIdentifier i)+ ProcedureAlreadyDeclared i -> widthRope (unIdentifier i)+ CallToUnknownProcedure i -> widthRope (unIdentifier i)+ UseOfUnknownIdentifier i -> widthRope (unIdentifier i)+ EncounteredUndefined -> 1++instance Render CompilationError where+ type Token CompilationError = TechniqueToken+ colourize = colourizeTechnique+ highlight (CompilationError source reason) =+ let filename = pretty (sourceFilename source)+ contents = intoRope (sourceContents source)+ o = sourceOffset source+ -- Given an offset point where the error occured, split the input at that+ -- point.++ (before, _) = splitRope o contents+ (l, c) = calculatePositionEnd before+ -- Isolate the line on which the error occured. l and c are 1-origin here,+ -- so if there's only a single line (or empty file) we take that one single+ -- line and then last one is also that line.++ lines = breakLines contents+ lines' = take l lines+ offending =+ if nullRope contents+ then emptyRope+ else last lines'+ -- Now prepare for rendering. If the offending line is long trim it. Then+ -- create a line with some carets which show where the problem is.++ linenum = pretty l+ colunum = pretty c+ (truncated, _) = splitRope 77 offending+ trimmed =+ if widthRope offending > 77 && c < 77+ then truncated <> "..."+ else offending+ padding = replicateChar (c - 1) ' '+ num = numberOfCarots reason+ caroted = replicateChar num '^'+ columns =+ if num > 1+ then colunum <> "-" <> pretty (c + num - 1)+ else colunum+ in annotate FilenameToken filename <> ":" <> linenum <> ":" <> columns <> hardline+ <> hardline+ <> pretty trimmed+ <> hardline+ <> pretty padding+ <> annotate ErrorToken (pretty caroted)+ <> hardline+ <> hardline+ <> highlight reason++-- |+-- When we get a failure in the parsing stage **megaparsec** returns a+-- ParseErrorBundle. Extract the first error message therein (later handle+-- more? Yeah nah), and convert it into something we can use.+extractErrorBundle :: Source -> ParseErrorBundle T.Text Void -> CompilationError+extractErrorBundle source bundle =+ let errors = bundleErrors bundle+ first = NonEmpty.head errors+ (o, unexpected, expected) = extractParseError first+ pstate = bundlePosState bundle+ srcpos = pstateSourcePos pstate+ l0 = unPos . sourceLine $ srcpos+ c0 = unPos . sourceColumn $ srcpos+ -- Do we need these? For all the examples we have seen the values of l0 and c0+ -- are `1`. **megaparsec** delays calculation of line and column until+ -- error rendering time. Perhaps we need to record this.++ l = if l0 > 1 then error "Unexpected line balance" else 0+ c = if c0 > 1 then error "Unexpected columns balance" else 0+ reason = ParsingFailed unexpected expected+ source' =+ source+ { sourceOffset = o + l + c+ }+ in CompilationError source' reason++extractParseError :: ParseError T.Text Void -> (Int, [ErrorItem Char], [ErrorItem Char])+extractParseError e = case e of+ TrivialError o unexpected0 expected0 ->+ let unexpected = case unexpected0 of+ Just item -> item : []+ Nothing -> []+ expected = OrdSet.toList expected0+ in (o, unexpected, expected)+ FancyError _ _ -> error "Unexpected parser error"
+ lib/Technique/Formatter.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-imports #-}++module Technique.Formatter where++import Core.System.Pretty+import Core.Text.Rope+import Core.Text.Utilities+import Data.Foldable (foldl')+import Data.Int (Int8)+import Technique.Language+import Technique.Quantity++data TechniqueToken+ = MagicToken+ | ProcedureToken+ | TypeToken+ | SymbolToken+ | OperatorToken+ | VariableToken+ | ApplicationToken+ | LabelToken+ | StringToken+ | QuantityToken+ | RoleToken+ | ErrorToken+ | FilenameToken+ | StepToken++instance Pretty Procedure where+ pretty = unAnnotate . highlight++colourizeTechnique :: TechniqueToken -> AnsiColour+colourizeTechnique token = case token of+ MagicToken -> brightGrey+ ProcedureToken -> bold dullBlue+ TypeToken -> dullYellow+ SymbolToken -> bold dullCyan+ OperatorToken -> bold dullYellow+ VariableToken -> brightCyan+ ApplicationToken -> bold brightBlue+ LabelToken -> brightGreen+ StringToken -> bold brightGreen+ QuantityToken -> bold brightMagenta+ RoleToken -> dullYellow+ ErrorToken -> bold pureRed+ FilenameToken -> bold brightWhite+ StepToken -> bold brightGrey -- for diagnostics in evalutator++instance Render Procedure where+ type Token Procedure = TechniqueToken+ colourize = colourizeTechnique+ highlight proc =+ let name = highlight . procedureName $ proc+ params = case procedureParams proc of+ [] -> emptyDoc+ xs -> commaCat xs <> " "+ from = commaCat . procedureInput $ proc+ into = highlight . procedureOutput $ proc+ block = highlight . procedureBlock $ proc+ description = case procedureDescription proc of+ Nothing -> emptyDoc+ Just text -> highlight text+ in description+ <> ( indent+ 4+ ( annotate ProcedureToken name+ <+> params+ <> annotate SymbolToken ":"+ <+> annotate TypeToken from+ <+> annotate SymbolToken "->"+ <+> annotate TypeToken into+ <> line+ <> block+ )+ )++-- |+-- Punctuate a list with commas annotated with Symbol highlighting.+commaCat :: (Render a, Token a ~ TechniqueToken) => [a] -> Doc (Token a)+commaCat = hcat . punctuate (annotate SymbolToken comma) . fmap (annotate VariableToken . highlight)++instance Render Type where+ type Token Type = TechniqueToken+ colourize = colourizeTechnique+ highlight (Type name) = annotate TypeToken (pretty name)++instance Render Markdown where+ type Token Markdown = TechniqueToken+ colourize = colourizeTechnique+ highlight (Markdown text) = pretty text++instance Render Block where+ type Token Block = TechniqueToken+ colourize = colourizeTechnique+ highlight (Block statements) =+ nest+ 4+ ( annotate SymbolToken lbrace+ <> go statements+ )+ <> line+ <> annotate SymbolToken rbrace+ where+ go :: [Statement] -> Doc TechniqueToken+ go [] = emptyDoc+ go (x@(Series _) : x1 : xs) = highlight x <> highlight x1 <> go xs+ go (x : xs) = line <> highlight x <> go xs++instance Render Statement where+ type Token Statement = TechniqueToken+ colourize = colourizeTechnique+ highlight statement = case statement of+ Assignment _ vars expr ->+ commaCat vars <+> annotate SymbolToken "=" <+> highlight expr+ Execute _ expr ->+ highlight expr+ Comment _ text ->+ "-- " <> pretty text -- TODO what about multiple lines?+ Declaration _ proc ->+ highlight proc+ Blank _ ->+ emptyDoc+ Series _ ->+ annotate SymbolToken " ; "++instance Render Attribute where+ type Token Attribute = TechniqueToken+ colourize = colourizeTechnique+ highlight role = case role of+ Role name -> annotate RoleToken ("@" <> pretty name)+ Place name -> annotate RoleToken ("#" <> pretty name)+ Inherit -> annotate ErrorToken "Inherit"++instance Render Expression where+ type Token Expression = TechniqueToken+ colourize = colourizeTechnique+ highlight expr = case expr of+ Application _ name subexpr ->+ annotate ApplicationToken (highlight name) <+> highlight subexpr+ None _ ->+ annotate SymbolToken ("()")+ Undefined _ ->+ annotate ErrorToken "?"+ Amount _ qty ->+ highlight qty+ Text _ text ->+ annotate SymbolToken dquote+ <> annotate StringToken (pretty text)+ <> annotate SymbolToken dquote+ Object _ tablet ->+ highlight tablet+ Variable _ vars ->+ commaCat vars+ Operation _ operator subexpr1 subexpr2 ->+ highlight subexpr1 <+> highlight operator <+> highlight subexpr2+ Grouping _ subexpr ->+ annotate SymbolToken lparen+ <> highlight subexpr+ <> annotate SymbolToken rparen+ Restriction _ attribute block ->+ highlight attribute+ <> line+ <> highlight block -- TODO some nesting?++instance Render Identifier where+ type Token Identifier = TechniqueToken+ colourize = colourizeTechnique+ highlight (Identifier name) = pretty name++instance Pretty Identifier where+ pretty = unAnnotate . highlight++instance Render Decimal where+ type Token Decimal = TechniqueToken+ colourize = colourizeTechnique+ highlight = pretty . decimalToRope++instance Render Quantity where+ type Token Quantity = TechniqueToken+ colourize = colourizeTechnique+ highlight qty = case qty of+ Number i ->+ annotate QuantityToken (pretty i)+ Quantity i u m unit ->+ let measurement =+ highlight i <> " "+ uncertainty =+ if isZeroDecimal u+ then emptyDoc+ else "± " <> highlight u <> " "+ magnitude =+ if m == 0+ then emptyDoc+ else "× 10" <> numberToSuperscript m <> " "+ in annotate QuantityToken (measurement <> uncertainty <> magnitude <> pretty unit)++numberToSuperscript :: Int8 -> Doc ann+numberToSuperscript number =+ let digits = show number+ digits' = fmap toSuperscript digits+ in pretty digits'++toSuperscript :: Char -> Char+toSuperscript c = case c of+ '0' -> '⁰' -- U+2070+ '1' -> '¹' -- U+00B9+ '2' -> '²' -- U+00B2+ '3' -> '³' -- U+00B3+ '4' -> '⁴' -- U+2074+ '5' -> '⁵' -- U+2075+ '6' -> '⁶' -- U+2076+ '7' -> '⁷' -- U+2077+ '8' -> '⁸' -- U+2078+ '9' -> '⁹' -- U+2079+ '-' -> '⁻' -- U+207B+ _ -> error "Invalid, digit expected"++instance Pretty Quantity where+ pretty = unAnnotate . highlight++instance Render Tablet where+ type Token Tablet = TechniqueToken+ colourize = colourizeTechnique+ highlight (Tablet bindings) =+ nest+ 4+ ( annotate SymbolToken lbracket+ <> foldl' g emptyDoc bindings+ )+ <> line+ <> annotate SymbolToken rbracket+ where+ g :: Doc TechniqueToken -> Binding -> Doc TechniqueToken+ g built binding = built <> line <> highlight binding++instance Render Label where+ type Token Label = TechniqueToken+ colourize = colourizeTechnique+ highlight (Label text) =+ annotate SymbolToken dquote+ <> annotate LabelToken (pretty text)+ <> annotate SymbolToken dquote++instance Pretty Label where+ pretty = unAnnotate . highlight++-- the annotation for the label duplicates the code Quantity's Text+-- constructor, but for the LabelToken token. This distinction may not be+-- necessary (at present we have the same colouring for both).+instance Render Binding where+ type Token Binding = TechniqueToken+ colourize = colourizeTechnique+ highlight (Binding label subexpr) =+ highlight label+ <+> annotate SymbolToken "~"+ <+> highlight subexpr++instance Render Operator where+ type Token Operator = TechniqueToken+ colourize = colourizeTechnique+ highlight operator =+ annotate OperatorToken $ case operator of+ WaitBoth -> pretty '&'+ WaitEither -> pretty '|'+ Combine -> pretty '+'++instance Render Technique where+ type Token Technique = TechniqueToken+ colourize = colourizeTechnique+ highlight technique =+ let version = pretty . techniqueVersion $ technique+ license = pretty . techniqueLicense $ technique+ copyright = case techniqueCopyright technique of+ Just owner -> "; ©" <+> pretty owner+ Nothing -> emptyDoc+ body = fmap highlight . techniqueBody $ technique+ in annotate MagicToken ("%" <+> "technique" <+> "v" <> version) <> line+ <> annotate MagicToken ("!" <+> license <> copyright)+ <> line+ <> line+ <> vsep (punctuate line body)
+ lib/Technique/Internal.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- I generally try to avoid modules full of (only) types but these are here+-- so the can be shared in both Technique.Translate and Technique.Builtins.++-- |+-- Builing blocks for the translation stage of the compiler.+module Technique.Internal where++import Core.Text+import Data.DList+import Technique.Language+import Technique.Quantity++-- FIXME ??? upgrade to named IVar+newtype Promise = Promise Value++-- |+-- The resolved value of eiter a literal or function applicaiton, either as+-- that literal, the expression, or as the result of waiting on the variable+-- it was assigned to.+--+-- Need names? Science names newly discovered creatures in Latin. I don't+-- speak Latin, but neither does anyone else so we can just make words up.+-- Yeay! (The lengths some people will go to in order to avoid qualified+-- imports is really impressive, isn't it?)+data Value+ = Unitus+ | Literali Rope+ | Quanticle Quantity+ | Tabularum [(Rope, Value)]+ | Parametriq [Value]+ deriving (Eq, Show)++-- |+-- The internal representation of a Procedure, with ambiguities resolved.+--+-- We landed on Subroutine as the name of translated user-defined Procedure.+--+-- Procedures which are actually fundamental [in the context of the domain+-- specific language] represented by builtin IO actions which we call+-- Primatives.+--+-- The first constructor, Unresolved, is for the first stage pass through the+-- translate phase when we are still accumulating definitions, thereby+-- allowing for the forward use of not-yet-defiend procedures that will be+-- encountered in the same scope.++-- Didn't want to call this "function" because that means something in+-- functional programming and in programming language theory and this isn't+-- it. Other alternatives considered include Instance (the original name,+-- but we've reserved that to be used when instantiating a procedure at+-- runtime), Representation, and Internal. Subroutine is ok.+data Function+ = Unresolved Identifier+ | Subroutine Procedure Step+ | Primitive Procedure (Step -> IO Value)++functionName :: Function -> Identifier+functionName func = case func of+ Unresolved name -> name+ Subroutine proc _ -> procedureName proc+ Primitive prim _ -> procedureName prim++instance Show Function where+ show func =+ let name = fromRope (unIdentifier (functionName func))+ in case func of+ Unresolved _ -> "Unresolved \"" ++ name ++ "\""+ Subroutine _ step -> "Subroutine \"" ++ name ++ "\": " ++ show step+ Primitive _ _ -> "Primitive \"" ++ name ++ "\""++instance Eq Function where+ (==) f1 f2 = case f1 of+ Unresolved i1 -> case f2 of+ Unresolved i2 -> i1 == i2+ _ -> False+ Subroutine proc1 step1 -> case f2 of+ Subroutine proc2 step2 -> proc1 == proc2 && step1 == step2+ _ -> False+ -- this is weak, but we can't compare Haskell functions for equality so if+ -- the Procedures are the same then we assume the Primitives are.++ Primitive proc1 _ -> case f2 of+ Primitive proc2 _ -> proc1 == proc2+ _ -> False++newtype Name = Name Rope -- ??? upgrade to named IVar := Promise ???+ deriving (Eq, Show)++-- |+-- Names. Always needing names. These ones are from original work when we+-- envisioned technique as a shallow embedding of a domain specific+-- language implemented in Haskell. Comments describing constructors are+-- taken from a suggestion by Oleg Kiselyov on page 23 of his course "Typed+-- Tagless Final Interpreters" that the constructors of a simply typed+-- lambda calculus in this style could be considered a "minimal+-- intuitionistic logic" which is absolutely fabulous.++-- While it probably would work to put an Asynchronous into a Tuple list,+-- it's not valid from the point of view of the surface language syntax.+data Step+ = Known Offset Value -- literals ("axioms")+ | Bench Offset [(Label, Step)]+ | Depends Offset Name -- block waiting on a value ("reference to a hypothesis denoted by a variable")+ | NoOp+ | Tuple Offset [Step]+ | Asynchronous Offset [Name] Step -- assignment (ie lambda, "implication introduction"+ | Invocation Offset Attribute Function Step -- function application ("implication elimination") on a [sub] Procedure+ | Nested Offset (DList Step)+ -- assumption axiom?+ -- weakening?+ deriving (Eq, Show)++instance Located Step where+ locationOf step = case step of+ Known o _ -> o+ Bench o _ -> o+ Depends o _ -> o+ NoOp -> -2+ Tuple o _ -> o+ Asynchronous o _ _ -> o+ Invocation o _ _ _ -> o+ Nested o _ -> o++instance Semigroup Step where+ (<>) = mappend++instance Monoid Step where+ mempty = NoOp+ mappend NoOp s2 = s2+ mappend s1 NoOp = s1+ mappend (Nested o1 list1) (Nested _ list2) = Nested o1 (append list1 list2)+ mappend (Nested o1 list1) s2 = Nested o1 (snoc list1 s2)+ mappend s1 (Nested _ list2) = Nested (locationOf s1) (cons s1 list2)+ mappend s1 s2 = Nested (locationOf s1) (snoc (singleton s1) s2)
+ lib/Technique/Language.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Technique.Language where++import Core.Data.Structures (Key)+import Core.Text.Rope+import Data.Hashable (Hashable)+import GHC.Generics (Generic)+import Technique.Quantity++data Technique = Technique+ { techniqueVersion :: Int,+ techniqueLicense :: Rope,+ techniqueCopyright :: Maybe Rope,+ techniqueBody :: [Procedure]+ }+ deriving (Show, Eq)++emptyTechnique :: Technique+emptyTechnique =+ Technique+ { techniqueVersion = 0,+ techniqueLicense = emptyRope,+ techniqueCopyright = Nothing,+ techniqueBody = []+ }++-- TODO+data Identifier+ = Identifier Rope+ deriving (Show, Eq, Ord, Generic, Hashable)++unIdentifier :: Identifier -> Rope+unIdentifier (Identifier text) = text+{-# INLINE unIdentifier #-}++instance Key Identifier++-- TODO construction needs to validate internal rules for labels. No+-- newlines, perhaps.+newtype Label = Label Rope+ deriving (Show, Eq, Ord)++data Attribute+ = Role Identifier+ | Place Identifier+ | Inherit+ deriving (Show, Eq, Ord)++{-+ | Anyone+ | Anywhere+-}++data Markdown+ = Markdown Rope+ deriving (Eq, Ord)++instance Show Markdown where+ show (Markdown text) = "[quote|\n" ++ fromRope text ++ "|]"++data Type+ = Type Rope+ deriving (Show, Eq, Ord)++unitType :: Type+unitType = Type "()"++data Procedure = Procedure+ { procedureOffset :: Offset,+ procedureName :: Identifier,+ procedureParams :: [Identifier],+ procedureInput :: [Type],+ procedureOutput :: [Type],+ procedureTitle :: Maybe Markdown,+ procedureDescription :: Maybe Markdown,+ procedureBlock :: Block+ }+ deriving (Show, Eq, Ord)++emptyProcedure :: Procedure+emptyProcedure =+ Procedure+ { procedureOffset = -1,+ procedureName = Identifier "none",+ procedureParams = [],+ procedureInput = [unitType],+ procedureOutput = [unitType],+ procedureTitle = Nothing,+ procedureDescription = Nothing,+ procedureBlock = Block []+ }++data Block = Block [Statement]+ deriving (Show, Eq, Ord)++type Offset = Int++class Located a where+ locationOf :: a -> Offset++instance Located Procedure where+ locationOf = procedureOffset++data Statement+ = Assignment Offset [Identifier] Expression+ | Execute Offset Expression+ | Comment Offset Rope+ | Declaration Offset Procedure+ | Blank Offset+ | Series Offset+ deriving (Show, Ord, Eq)++instance Located Statement where+ locationOf statement = case statement of+ Assignment o _ _ -> o+ Execute o _ -> o+ Comment o _ -> o+ Declaration o _ -> o+ Blank o -> o+ Series o -> o++data Expression+ = Application Offset Identifier Expression -- this had better turn out to be a procedure+ | None Offset+ | Text Offset Rope+ | Amount Offset Quantity+ | Undefined Offset+ | Object Offset Tablet+ | Variable Offset [Identifier]+ | Operation Offset Operator Expression Expression+ | Grouping Offset Expression+ | Restriction Offset Attribute Block+ deriving (Show, Ord, Eq)++instance Located Expression where+ locationOf expr = case expr of+ Application o _ _ -> o+ None o -> o+ Text o _ -> o+ Amount o _ -> o+ Undefined o -> o+ Object o _ -> o+ Variable o _ -> o+ Operation o _ _ _ -> o+ Grouping o _ -> o+ Restriction o _ _ -> o++data Tablet+ = Tablet [Binding]+ deriving (Show, Ord, Eq)++-- only valid Expressions are Literal and Variable. Should we enforce that+-- somewhere?+data Binding+ = Binding Label Expression+ deriving (Show, Eq, Ord)++data Operator+ = WaitEither+ | WaitBoth+ | Combine+ deriving (Show, Eq, Ord)
+ lib/Technique/Parser.hs view
@@ -0,0 +1,656 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- |+--+-- /Commentary/+--+-- We're optimizing for simplicity here. The language balances conventions+-- from other languages with choices to not overcomplicate things. Not+-- overloading operators, for example. Mostly we want to have "good error+-- messages" which is tough and subjective anyway. Not having multiline+-- anything, for example, might be a good choice, except that we also want to+-- be whitepsace insensitive.+module Technique.Parser+ ( -- parser for technique procedure files.+ pTechnique,+ -- everthing else is only exposed for testing purposes.+ pMagicLine,+ pSpdxLine,+ pIdentifier,+ pType,+ stringLiteral,+ numberLiteral,+ pQuantity,+ pAttribute,+ pExpression,+ pStatement,+ pBlock,+ pProcedureDeclaration,+ pProcedureCode,+ )+where++import Control.Monad+ ( unless,+ void,+ )+import Control.Monad.Combinators+ ( (<|>),+ many,+ optional,+ sepBy,+ sepBy1,+ some,+ )+import Core.Text.Rope+ ( Rope,+ appendRope,+ emptyRope,+ intoRope,+ singletonRope,+ )+import Data.Foldable+ ( foldl',+ )+import Data.Int+ ( Int64,+ Int8,+ )+import Data.Text+ ( Text,+ )+import qualified Data.Text as T (pack)+import Data.Void+ ( Void,+ )+import Technique.Language+import Technique.Quantity+import Text.Megaparsec+ ( (<?>),+ Parsec,+ getOffset,+ hidden,+ label,+ lookAhead,+ notFollowedBy,+ oneOf,+ skipMany,+ takeWhile1P,+ takeWhileP,+ try,+ )+import Text.Megaparsec.Char+ ( char,+ digitChar,+ lowerChar,+ newline,+ printChar,+ space,+ spaceChar,+ string,+ upperChar,+ )+import Text.Read+ ( readMaybe,+ )++type Parser = Parsec Void Text++__VERSION__ :: Int+__VERSION__ = 0++-- |+-- Skip /zero/ or more actual space characters. The __megaparsec__ function+-- @space@ etc consume all whitespace, not just ' '. That includes newlines,+-- which is very unhelpful.+skipSpace :: Parser ()+skipSpace = void (hidden (many (char ' ' <|> char '\t')))++-- |+-- Skip at least /one/ actual space character.+skipSpace1 :: Parser ()+skipSpace1 = void (hidden (some (char ' ' <|> char '\t')))++digitChar0 :: Parser Char+digitChar0 = label "a digit" $ digitChar++pMagicLine :: Parser Int+pMagicLine = do+ void (char '%') <?> "first line to begin with % character"+ void spaceChar <?> "a space character"+ void (string "technique")+ void spaceChar <?> "a space character"+ void (char 'v') <?> "the character 'v' and then a number"+ v <- numberLiteral <?> "the language version"+ void newline+ return (fromIntegral v)++pSpdxLine :: Parser (Rope, Maybe Rope)+pSpdxLine = do+ void (char '!') <?> "second line to begin with ! character"+ skipSpace++ -- I know we're supposed to use takeWhile1P in cases like this, but aren't+ -- we just duplicating the work of the parser combinators?+ license <-+ takeWhile1P+ (Just "software license description (ie an SPDX-Licence-Header value)")+ (\c -> not (c == ';' || c == '\n'))++ copyright <- optional $ do+ void (char ';') <?> "a semicolon"+ skipSpace+ void (char '©') <|> void (string "(c)")+ skipSpace+ takeWhile1P (Just "a copyright declaration") (/= '\n')+ void newline+ return (intoRope license, fmap intoRope copyright)++---------------------------------------------------------------------++pProcedureDeclaration :: Parser (Identifier, [Identifier], [Type], [Type])+pProcedureDeclaration = do+ name <- pIdentifier+ skipSpace+ -- zero or more separated by comma+ params <- pIdentifiers++ skipSpace+ void (char ':')+ skipSpace++ ins <- pTypes1++ skipSpace+ void (string "->")+ skipSpace++ out <- pTypes1+ return (name, params, ins, out)++identifierChar :: Parser Char+identifierChar = hidden (lowerChar <|> digitChar0 <|> char '_' <|> char '\'')++-- these do NOT consume trailing space. That's for pExpression to do.+pIdentifier :: Parser Identifier+pIdentifier = label "a valid identifier" $ do+ first <- lowerChar+ remainder <- many identifierChar+ return (Identifier (singletonRope first <> intoRope remainder))++pIdentifiers :: Parser [Identifier]+pIdentifiers = sepBy (pIdentifier <* skipSpace) (char ',' <* skipSpace)++pIdentifiers1 :: Parser [Identifier]+pIdentifiers1 = sepBy1 (pIdentifier <* skipSpace) (char ',' <* skipSpace)++typeChar :: Parser Char+typeChar = hidden (upperChar <|> lowerChar <|> digitChar0)++pType :: Parser Type+pType =+ label "a valid type" $+ try+ ( do+ void (string "()")+ return (Type "()")+ )+ <|> ( do+ first <- upperChar+ remainder <- many typeChar+ return (Type (singletonRope first <> intoRope remainder))+ )++pTypes1 :: Parser [Type]+pTypes1 = sepBy1 (pType <* skipSpace) (char ',' <* skipSpace)++---------------------------------------------------------------------++stringLiteral :: Parser Text+stringLiteral = label "a string literal" $ do+ void (char '\"')+ str <-+ many+ ( do+ try+ ( do+ void (char '\\')+ void (char '"')+ return '"'+ )+ <|> ( do+ notFollowedBy (char '\"')+ printChar+ )+ )+ void (char '\"')+ return (T.pack str)++unitChar :: Parser Char+unitChar = hidden (upperChar <|> lowerChar <|> char '°')++unitLiteral :: Parser Rope+unitLiteral = label "a units symbol" $ do+ str <- some unitChar+ return (intoRope str)++numberLiteral :: Parser Int64+numberLiteral = label "a number literal" $ do+ digits <- some digitChar0+ let result = readMaybe digits+ case result of+ Just number -> return number+ Nothing -> fail "expected a number but couldn't parse"++decimalLiteral :: Parser Decimal+decimalLiteral = label "a decimal literal" $ do+ digits1 <- some digitChar0+ fraction <-+ optional+ ( do+ void (char '.')+ some digitChar0+ )++ return+ ( case fraction of+ Nothing ->+ let number = read digits1+ in Decimal number 0+ Just digits2 ->+ let e = fromIntegral (length digits2)+ decimal = read digits1 * 10 ^ e + read digits2+ in Decimal decimal e+ )++superscriptLiteral :: Parser Int8+superscriptLiteral = label "a superscript literal" $ do+ sign <- optional (char '⁻' <|> char '¯') -- honestly not sure what the second of those is+ digits <- some (oneOf ['⁰', '¹', '²', '³', '⁴', '⁵', '⁶', '⁷', '⁸', '⁹'])+ let number = read (map toNumbers digits)+ return+ ( case sign of+ Just _ -> negate number+ Nothing -> number+ )++toNumbers :: Char -> Char+toNumbers c = case c of+ '⁰' -> '0'+ '¹' -> '1'+ '²' -> '2'+ '³' -> '3'+ '⁴' -> '4'+ '⁵' -> '5'+ '⁶' -> '6'+ '⁷' -> '7'+ '⁸' -> '8'+ '⁹' -> '9'+ _ -> error "Invalid, superscript expected"++pQuantity :: Parser Quantity+pQuantity =+ ( do+ -- look ahead far enough to commit to this branch: the pieces of a+ -- decimal, a space, and then one of the characters that starts an+ -- uncertainty, magnitude, or symbol.+ lookAhead+ ( try+ ( do+ skipMany (digitChar0 <|> char '.' <|> char '-' <|> char ' ')+ void (char '±' <|> char '+' <|> char '×' <|> char 'x' <|> unitChar)+ )+ )++ n <- pMantissa+ u <- pUncertainty <|> pure (Decimal 0 0)+ m <- pMagnitude <|> pure 0+ s <- pSymbol+ return (Quantity n u m s)+ )+ <|> ( do+ n <- pNumber+ return (Number n)+ )+ where+ pNumber = do+ sign <- optional (char '-')+ number <- numberLiteral+ return+ ( case sign of+ Just _ -> negate number+ Nothing -> number+ )+ pMantissa = do+ sign <- optional (char '-')+ decimal <- try decimalLiteral+ skipSpace+ return+ ( case sign of+ Just _ -> negateDecimal decimal+ Nothing -> decimal+ )+ pUncertainty = do+ void (char '±') <|> void (string "+/-")+ skipSpace+ decimal <- decimalLiteral+ skipSpace+ return decimal+ pMagnitude = do+ void (char '×') <|> void (char 'x') <|> hidden (void (char '*'))+ skipSpace+ void (string "10")+ number <-+ ( do+ void (char '^')+ sign <- optional (char '-')+ e <- numberLiteral+ pure+ ( fromIntegral+ ( case sign of+ Just _ -> negate e+ Nothing -> e+ )+ )+ <|> superscriptLiteral+ )+ skipSpace+ return number+ pSymbol = do+ symbol <- unitLiteral+ skipSpace+ return symbol++pOperator :: Parser Operator+pOperator =+ (char '&' *> return WaitBoth)+ <|> (char '|' *> return WaitEither)+ <|> (char '+' *> return Combine)++-- |+-- Parse a Tablet. This consumes trailing space around initial delimiter and+-- removes blank lines within the table (they're not syntactically meaningful)+-- but only cosnsumes a single newline after trailing delimeter, leaving+-- further consumption to pStatement.+--+-- TODO this doesn't preserve alternate syntax if employed by user+pTablet :: Parser Tablet+pTablet = do+ void (char '[' <* hidden space)++ bindings <-+ many+ (pBinding <* hidden space)++ void (char ']' <* skipSpace)++ return (Tablet bindings)+ where+ pBinding = do+ name <- stringLiteral+ skipSpace+ void (char '~')+ skipSpace+ subexpr <- pExpression++ -- handle alternate syntax here+ {-+ -- FIXME this is not working+ void (optional (char ','))+ -}+ return (Binding (Label (intoRope name)) subexpr)++pAttribute :: Parser Attribute+pAttribute =+ ( do+ void (char '@')+ role <- pIdentifier <|> pAny+ return (Role role)+ )+ <|> ( do+ void (char '#')+ place <- pIdentifier <|> pAny+ return (Place place)+ )+ where+ pAny = do+ void (char '*')+ return (Identifier (singletonRope '*'))++pExpression :: Parser Expression+pExpression = do+ o <- getOffset+ expr1 <- pTerm o+ skipSpace+ rest <- (optional (try pOperation2))+ skipSpace+ case rest of+ Just (oper, expr2) -> return (Operation o oper expr1 expr2)+ Nothing -> return expr1+ where+ pTerm o =+ pNone o+ <|> pUndefined o+ <|> pRestriction o+ <|> pGrouping o+ <|> pObject o+ <|> pApplication o+ <|> pLiteral o+ <|> pVariable o+ pNone :: Offset -> Parser Expression+ pNone o = do+ void (string "()")+ return (None o)+ pUndefined o = do+ void (char '?')+ return (Undefined o)+ pOperation2 = do+ -- 2 as in 2nd half+ operator <- pOperator+ skipSpace+ subexpr2 <- pExpression+ return (operator, subexpr2)+ pRestriction o = do+ attr <- pAttribute+ hidden space+ block <- pBlock+ return (Restriction o attr block)+ pGrouping o = do+ void (char '(')+ skipSpace++ subexpr <- pExpression++ void (char ')')+ skipSpace++ return (Grouping o subexpr)+ pObject o = do+ tablet <- pTablet+ return (Object o tablet)+ pApplication o = do+ lookAhead+ ( try+ ( do+ skipMany identifierChar+ skipSpace1+ void (identifierChar <|> digitChar0 <|> char '(' <|> char '\"')+ )+ )++ name <- pIdentifier+ -- ie at least one space+ skipSpace1+ -- FIXME better do this manually, not all valid+ subexpr <- pExpression+ return (Application o name subexpr)+ pLiteral o =+ ( do+ str <- stringLiteral+ return (Text o (intoRope str))+ )+ <|> ( do+ qty <- pQuantity+ return (Amount o qty)+ )+ pVariable o = do+ names <- pIdentifiers1++ return (Variable o names)++pStatement :: Parser Statement+pStatement = do+ o <- getOffset+ statement <-+ pAssignment o+ <|> pDeclaration o+ <|> pExecute o+ <|> pBlank o+ <|> pSeries o+ return statement+ where+ pAssignment o = label "an assignment" $ do+ lookAhead+ ( try+ ( do+ skipMany (identifierChar <|> char ',' <|> char ' ')+ void (char '=')+ )+ )+ names <- pIdentifiers1+ skipSpace+ void (char '=')+ hidden space+ expr <- pExpression+ return (Assignment o names expr)+ pDeclaration o = label "a declaration" $ do+ lookAhead+ ( try+ ( do+ skipMany (identifierChar <|> char ',' <|> char ' ')+ void (char ':')+ )+ )++ proc <- pProcedureCode+ return (Declaration o proc)+ pExecute o = label "a value to execute" $ do+ expr <- pExpression+ return (Execute o expr)+ pBlank o = hidden $ do+ -- label "a blank line"+ void newline+ return (Blank o)+ pSeries o = do+ void (char ';')+ return (Series o)++---------------------------------------------------------------------++pBlock :: Parser Block+pBlock = do+ -- open block, absorb whitespace+ void (char '{' <* hidden space)++ -- process statements, but only single newline at a time+ statements <-+ many+ (pStatement <* skipSpace <* optional newline <* skipSpace)++ -- close block, and wipe out any trailing whitespace+ void (char '}' <* skipSpace <* optional newline)++ return (Block statements)++-- Frankly, this parser looks ridiculous. Someone who knows what they are+-- doing *please* help refactor this. It seems unavoidlable to run the+-- pProcedureDeclaration parser twice, unless we can combine the successful+-- parse and the consumtion of description lines into one function. Maybe+-- this would be better done scanning ahead to count characters until a+-- declaration shows up, then explicitly taking that many?++fourSpaces :: Parser ()+fourSpaces =+ -- label "a code block indented by four spaces" $+ void (char ' ' <* char ' ' <* char ' ' <* char ' ')+ <|> fail "code blocks must be indented by four spaces"++pMarkdown :: Parser Markdown+pMarkdown = do+ -- gobble blank newlines before a heading+ void+ ( many+ ( do+ notFollowedBy fourSpaces+ notFollowedBy pProcedureDeclaration+ void (skipSpace *> hidden newline)+ )+ )++ -- TODO heading++ results <-+ some+ ( do+ notFollowedBy fourSpaces+ notFollowedBy pProcedureDeclaration+ line <- takeWhileP (Just "another line of description text") (/= '\n')+ void (hidden newline)+ return line+ )++ let description = foldl' (\acc text -> appendRope text acc <> "\n") emptyRope results+ return (Markdown description)++pProcedureCode :: Parser Procedure+pProcedureCode = do+ o <- getOffset+ (name, params, ins, out) <- pProcedureDeclaration <* skipSpace <* optional newline <* skipSpace++ block <- pBlock <* skipSpace <* optional newline++ return+ ( Procedure+ { procedureOffset = o,+ procedureName = name,+ procedureParams = params,+ procedureInput = ins,+ procedureOutput = out,+ procedureTitle = Nothing, -- FIXME+ procedureDescription = Nothing,+ procedureBlock = block+ }+ )++pProcedure :: Parser Procedure+pProcedure = do+ description <- optional pMarkdown+ fourSpaces+ proc <- pProcedureCode++ return+ ( proc+ { procedureTitle = Nothing, -- FIXME+ procedureDescription = description+ }+ )++---------------------------------------------------------------------++pTechnique :: Parser Technique+pTechnique = do+ version <- pMagicLine+ unless (version == __VERSION__) (fail ("currently the only recognized language version is v" ++ show __VERSION__))+ (license, copyright) <- pSpdxLine+ void (many newline)++ body <- many pProcedure++ return $+ Technique+ { techniqueVersion = version,+ techniqueLicense = intoRope license,+ techniqueCopyright = fmap intoRope copyright,+ techniqueBody = body+ }
+ lib/Technique/Quantity.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++module Technique.Quantity+ ( Quantity (..),+ Decimal (..),+ Magnitude,+ decimalToRope,+ isZeroDecimal,+ negateDecimal,+ Symbol,+ Unit (..),+ Group (..),+ Prefix (..),+ units,+ prefixes,+ )+where++import Core.Data.Structures+import Core.Text.Rope+import Core.Text.Utilities+import Data.Int (Int64, Int8)++data Quantity+ = Number Int64+ | Quantity Decimal Decimal Magnitude Symbol+ deriving (Show, Eq, Ord)++type Symbol = Rope++type Magnitude = Int8++-- |+-- A decimal number with a fixed point resolution. The resolution (number+-- of decimal places) is arbitrary within the available range. This isn't+-- really for numerical analysis. It is for carrying information.+--+-- /Implementation note/+--+-- Internally this is a floating point where the mantissa is 19 characters+-- wide (the width of a 64-bit int in base 10). Thus the biggest number+-- representable is 9223372036854775807 and the smallest is+-- 0.0000000000000000001. We could change this to Integer and be arbitrary+-- precision but meh.+data Decimal = Decimal Int64 Int8+ deriving (Eq, Ord)++instance Show Decimal where+ show = show . decimalToRope++decimalToRope :: Decimal -> Rope+decimalToRope (Decimal number resolution)+ | resolution < 0 = error "resolution can't be negative"+ | resolution == 0 = intoRope (show number)+ | otherwise =+ let digits = intoRope (show (abs number))+ len = widthRope digits+ res = fromIntegral resolution+ pos = len - res+ result =+ if (pos <= 0)+ then "0." <> leftPadWith '0' res digits+ else let (whole, fraction) = splitRope pos digits in whole <> "." <> fraction+ in if number >= 0+ then result+ else "-" <> result++isZeroDecimal :: Decimal -> Bool+isZeroDecimal (Decimal number _) = if number == 0 then True else False++negateDecimal :: Decimal -> Decimal+negateDecimal (Decimal number resolution) = Decimal (negate number) resolution++units :: Map Symbol Unit+units =+ foldr f emptyMap knownUnits+ where+ f unit m = insertKeyValue (unitSymbol unit) unit m++-- |+-- Whether Système International metric prefixes can be used, or (as is the+-- case of time units) quantities should not be aggregated to other scales.+data Group+ = Metric -- has prefixes+ | Time+ | Normal+ | Scientific -- probable collision with type from **base**+ | Engineering+ deriving (Show, Eq)++knownUnits :: [Unit]+knownUnits =+ [ Unit "metre" "metres" "m" Metric,+ Unit "gram" "grams" "g" Metric,+ Unit "litre" "litres" "L" Metric,+ Unit "second" "seconds" "sec" Time,+ Unit "minute" "minutes" "min" Time,+ Unit "hour" "hours" "hr" Time,+ Unit "day" "days" "d" Time,+ Unit "degree celsius" "degrees celsius" "°C" Normal,+ Unit "degree kelvin" "degrees kelvin" "K" Metric+ ]++prefixes :: Map Symbol Prefix+prefixes =+ foldr g emptyMap knownPrefixes+ where+ g prefix m = insertKeyValue (prefixSymbol prefix) prefix m++knownPrefixes :: [Prefix]+knownPrefixes =+ [ Prefix "peta" "P" 15,+ Prefix "tera" "T" 12,+ Prefix "giga" "G" 9,+ Prefix "mega" "M" 6,+ Prefix "kilo" "k" 3,+ Prefix "" "" 0,+ Prefix "milli" "m" (-3),+ Prefix "micro" "μ" (-6),+ Prefix "nano" "n" (-9),+ Prefix "pico" "p" (-12)+ ]++data Prefix = Prefix+ { prefixName :: Rope,+ prefixSymbol :: Symbol,+ prefixScale :: Int -- FIXME change this to a hard coded numerical constant?+ }+ deriving (Show, Eq)++data Unit = Unit+ { unitName :: Rope,+ unitPlural :: Rope,+ unitSymbol :: Rope,+ unitGroup :: Group+ }+ deriving (Show, Eq)
+ lib/Technique/Translate.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Given a Technique Procedure (concrete syntax tree), translate it into an+-- internalized representation (abstract syntax tree) that can be subsequently+-- executed (that is, interpreted; evaluated).+module Technique.Translate where++import Control.Monad (foldM, when)+import Control.Monad.Except (MonadError (..))+import Control.Monad.State.Class (MonadState (..))+import Control.Monad.Trans.Except (Except (), runExcept)+import Control.Monad.Trans.State.Strict (StateT (..), runStateT)+import Core.Data+import Core.Text+import Data.DList (fromList, toList)+import Data.Foldable (traverse_)+import Technique.Builtins+import Technique.Failure+import Technique.Internal+import Technique.Language++-- |+-- Environment in the type-theory sense of the word: the map(s) between+-- names and their bindings.++-- TODO perhaps the role should be Maybe Attribute? This will likely need+-- work as there are three states: 1) as yet unspecified, 2) specified, and+-- 3) explicitly reset to any. Are (1) and (3) the same?+data Environment = Environment+ { environmentVariables :: Map Identifier Name,+ environmentFunctions :: Map Identifier Function,+ environmentRole :: Attribute,+ -- for reporting compiler errors+ environmentSource :: Source,+ -- the accumulator for the fold that the Translate monad represents+ environmentAccumulated :: Step+ }+ deriving (Eq, Show)++emptyEnvironment :: Environment+emptyEnvironment =+ Environment+ { environmentVariables = emptyMap,+ environmentFunctions = emptyMap,+ environmentRole = Inherit,+ environmentSource = emptySource,+ environmentAccumulated = NoOp+ }++newtype Translate a = Translate (StateT Environment (Except CompilationError) a)+ deriving (Functor, Applicative, Monad, MonadState Environment, MonadError CompilationError)++-- |+-- Take a translator action and an environment and spin it up into a Step+-- or nest of Steps ("Subroutine") suitable for interpretation. In other+-- words, translate between the concrete syntax types and the abstract+-- syntax we can feed to an evaluator.++-- we use runStateT rather than evalStateT as we did previously so we can+-- access the final state in test cases.+runTranslate :: Environment -> Translate a -> Either CompilationError (a, Environment)+runTranslate env (Translate action) = runExcept (runStateT action env)+{-# INLINE runTranslate #-}++translateTechnique :: Technique -> Translate [Function]+translateTechnique technique = do+ -- Stage 1: conduct translation+ funcs1 <- traverse translateProcedure (techniqueBody technique)++ -- Stage 2: resolve functions+ funcs2 <- traverse resolver funcs1+ return funcs2+ where+ resolver :: Function -> Translate Function+ resolver func = case func of+ Subroutine proc step -> do+ step' <- resolveFunctions step+ return (Subroutine proc step')+ _ -> error ("Illegal state: How did you get a top level " ++ (show func) ++ "?")++translateProcedure :: Procedure -> Translate Function+translateProcedure procedure =+ let is = procedureParams procedure+ o = procedureOffset procedure+ block = procedureBlock procedure+ in do+ env <- get++ -- calling runTranslate here *is* the act of refining, but there's no way+ -- we're going to remember that so make it explicit. Gives us the+ -- opportunity to modify the environment before descending if necessary.++ let subenv = env+ let result = runTranslate subenv $ do+ traverse_ (insertVariable o) is+ translateBlock block++ case result of+ Left e -> throwError e+ Right (step, _) -> do+ let func = Subroutine procedure step+ registerProcedure (locationOf procedure) func+ return func++-- |+-- Blocks are scoping mechanisms, so accumulated environment is discarded+-- once we finish resolving names within it.+translateBlock :: Block -> Translate Step+translateBlock (Block statements) = do+ traverse_ translateStatement statements++ env' <- get+ let step = environmentAccumulated env'+ return step++translateStatement :: Statement -> Translate ()+translateStatement statement = do+ case statement of+ Assignment o vars expr -> do+ -- FIXME this offset will be incorrect if > 1 variable.+ names <- traverse (insertVariable o) vars+ step <- translateExpression expr++ let step' = Asynchronous o names step+ appendStep step'+ Execute _ expr -> do+ step <- translateExpression expr+ appendStep step+ Declaration _ proc -> do+ _ <- translateProcedure proc+ return ()++ -- the remainder are functionally no-ops+ Comment _ _ -> return ()+ Blank _ -> return ()+ Series _ -> return ()++-- |+-- Note that this does NOT add the steps to the Environment.+translateExpression :: Expression -> Translate Step+translateExpression expr = do+ env <- get+ let attr = environmentRole env++ case expr of+ Application o i subexpr -> do+ let func = Unresolved i+ step <- translateExpression subexpr+ return (Invocation o attr func step)+ None o ->+ return (Known o Unitus)+ Text o text ->+ return (Known o (Literali text))+ Amount o qty ->+ return (Known o (Quanticle qty))+ Undefined o -> do+ failBecause o EncounteredUndefined+ Object o (Tablet bindings) -> do+ pairs <- foldM f [] bindings+ return (Bench o pairs)+ where+ f :: [(Label, Step)] -> Binding -> Translate [(Label, Step)]+ f acc (Binding label subexpr) = do+ step <- translateExpression subexpr+ return (acc <> [(label, step)])+ Variable o is -> do+ steps <- traverse g is+ case steps of+ [] -> return NoOp+ [step] -> return step+ _ -> return (Tuple o steps)+ where+ g :: Identifier -> Translate Step+ g i = do+ name <- lookupVariable o i+ return (Depends o name)+ Operation o oper subexpr1 subexpr2 ->+ let prim = case oper of+ WaitEither -> builtinProcedureWaitEither+ WaitBoth -> builtinProcedureWaitBoth+ Combine -> builtinProcedureCombineValues+ in do+ step1 <- translateExpression subexpr1+ step2 <- translateExpression subexpr2+ let tuple = Tuple o [step1, step2]+ return (Invocation o attr prim tuple)+ Grouping _ subexpr ->+ translateExpression subexpr+ Restriction _ subattr block ->+ applyRestriction subattr block++-- |+-- A given procedure call can either be to a user declared in-scope+-- procedure or to a primative builtin. We have Invocation as the Step+-- constructors for these cases.+registerProcedure :: Offset -> Function -> Translate ()+registerProcedure o func = do+ env <- get++ let i = functionName func+ let known = environmentFunctions env+ let defined = containsKey i known++ when defined $ do+ failBecause o (ProcedureAlreadyDeclared i)++ let known' = insertKeyValue i func known+ let env' = env {environmentFunctions = known'}++ put env'++-- the overloading of throw between MonadError / ExceptT and the GHC+-- exceptions mechansism is unfortunate. We're not throwing an exception,+-- end it's definitely not pure `error`. Wrap it for clarity.+failBecause :: Offset -> FailureReason -> Translate a+failBecause o reason = do+ env <- get+ let source = environmentSource env+ let source' = source {sourceOffset = o}++ let failure = CompilationError source' reason+ throwError failure++lookupVariable :: Offset -> Identifier -> Translate Name+lookupVariable o i = do+ env <- get+ let known = lookupKeyValue i (environmentVariables env)++ case known of+ Just name -> return name+ Nothing -> failBecause o (UseOfUnknownIdentifier i)++-- |+-- Identifiers are valid names but Names are unique, so that we can put+-- them into the environment map. This is where we check for reuse of an+-- already declared name (TODO) and given the local use of the identifier a+-- scope-local (or globally?) unique name.+insertVariable :: Offset -> Identifier -> Translate Name+insertVariable o i = do+ env <- get+ let known = environmentVariables env++ when (containsKey i known) $ do+ failBecause o (VariableAlreadyInUse i)++ let n = Name (singletonRope '!' <> unIdentifier i) -- TODO+ let known' = insertKeyValue i n known+ let env' = env {environmentVariables = known'}+ put env'+ return n++-- |+-- Accumulate a Step.+appendStep :: Step -> Translate ()+appendStep step = do+ env <- get+ let steps = environmentAccumulated env++ -- see the Monoid instance for Step for the clever here+ let steps' = mappend steps step++ let env' = env {environmentAccumulated = steps'}+ put env'++-- |+-- This begins a new (more refined) scope and does *not* add its+-- declarations or variables to the current environment.+applyRestriction :: Attribute -> Block -> Translate Step+applyRestriction attr block = do+ env <- get++ let subenv =+ env+ { environmentRole = attr+ }++ let result = runTranslate subenv (translateBlock block)++ case result of+ Left e -> throwError e+ Right (steps, _) -> return steps++-----------------------------------------------------------------------------++-- |+-- The second stage of translation phase: iterate through the Steps and+-- where a function call is made, look up to see if we actually know what+-- it is.+resolveFunctions :: Step -> Translate Step+resolveFunctions step = case step of+ Invocation o attr func substep -> do+ func' <- lookupFunction o func+ substep' <- resolveFunctions substep+ return (Invocation o attr func' substep')+ Tuple o substeps -> do+ substeps' <- traverse resolveFunctions substeps+ return (Tuple o substeps')+ Asynchronous o names substep -> do+ substep' <- resolveFunctions substep+ return (Asynchronous o names substep')+ Nested o sublist -> do+ let actual = toList sublist+ actual' <- traverse resolveFunctions actual+ let sublist' = fromList actual'+ return (Nested o sublist')+ Bench o pairs -> do+ pairs' <- traverse f pairs+ return (Bench o pairs')+ where+ f :: (Label, Step) -> Translate (Label, Step)+ f (label, substep) = do+ substep' <- resolveFunctions substep+ return (label, substep')+ Known _ _ -> return step+ Depends _ _ -> return step+ NoOp -> return step++lookupFunction :: Offset -> Function -> Translate Function+lookupFunction o func = do+ env <- get++ let i = functionName func+ known = environmentFunctions env+ result = lookupKeyValue i known++ case result of+ Nothing -> failBecause o (CallToUnknownProcedure i)+ Just actual -> return actual++-- |+-- Update the environment's idea of where in the source we are, so that if+-- we need to generate an error message we can offer one with position+-- information.+setLocationFrom :: (Located a) => a -> Translate ()+setLocationFrom thing = do+ env <- get+ let source = environmentSource env+ let o = locationOf thing+ let source' = source {sourceOffset = o}+ let env' = env {environmentSource = source'}+ put env'
+ src/TechniqueMain.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import Core.Program+import Core.Text+import TechniqueUser+ ( commandCheckTechnique,+ commandFormatTechnique,+ )++#ifdef __GHCIDE__+version :: Version+version = "0"+#else+version :: Version+version = $(fromPackage)+#endif++main :: IO ()+main = do+ context <-+ configure+ version+ None+ ( complex+ [ Command+ "check"+ "Syntax- and type-check the given procedure"+ [ Option+ "watch"+ Nothing+ Empty+ [quote|+ Watch the given procedure file and recompile if changes are detected.+ |],+ Argument+ "filename"+ [quote|+ The file containing the code for the procedure you want to type-check.+ |]+ ],+ Command+ "format"+ "Format the given procedure"+ [ Option+ "raw-control-chars"+ (Just 'R')+ Empty+ [quote|+ Emit ANSI escape codes for syntax highlighting even if output+ is redirected to a pipe or file.+ |],+ Argument+ "filename"+ [quote|+ The file containing the code for the procedure you want to format.+ |]+ ]+ ]+ )+ executeWith context program++program :: Program None ()+program = do+ params <- getCommandLine+ case commandNameFrom params of+ Nothing -> do+ write "Illegal state?"+ terminate 2+ Just command -> case command of+ "check" -> commandCheckTechnique+ "format" -> commandFormatTechnique+ _ -> do+ write "Unknown command?"+ terminate 3+ event "Done"
+ src/TechniqueUser.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Programs implementing front-end commands for users: check, format+module TechniqueUser where++import Control.Monad (forever)+import Core.Program+import Core.System+import Core.Text+import System.IO (hIsTerminalDevice)+import Technique.Builtins+import Technique.Diagnostics ()+import Technique.Failure+import Technique.Formatter ()+import Technique.Internal+import Technique.Language+import Technique.Parser+import Technique.Translate+import Text.Megaparsec (parse)++data Mode = Cycle | Once++commandCheckTechnique :: Program None ()+commandCheckTechnique = do+ params <- getCommandLine++ let procfile = case lookupArgument "filename" params of+ Just file -> file+ _ -> error "Invalid State"++ let mode = case lookupOptionFlag "watch" params of+ Just True -> Cycle+ Nothing -> Once+ _ -> error "Invalid State"++ case mode of+ Once -> do+ -- normal operation, single pass+ code <- syntaxCheck procfile+ terminate code+ Cycle -> do+ -- use inotify to rebuild on changes+ forever (syntaxCheck procfile >> waitForChange [procfile] >> writeR Reload)++syntaxCheck :: FilePath -> Program None Int+syntaxCheck procfile =+ catch+ ( do+ surface <- loadTechnique procfile+ let source =+ emptySource+ { sourceFilename = procfile,+ sourceContents = surface+ }+ concrete <- parsingPhase source+ abstract <- translationPhase source concrete+ debugR "abstract" abstract+ -- TODO extractionPhase+ writeR Ok+ return 0+ )+ ( \(e :: CompilationError) -> do+ writeR (Failed e)+ return (exitCodeFor e)+ )++-- |+-- Load a technique file hopefully containing a procedure.+loadTechnique :: FilePath -> Program None Rope+loadTechnique filename = do+ event "Read source from technique file"++ -- This is somewhat horrible; reading into Bytes, then going through+ -- Rope to get to Text is a bit silly... except that interop was kinda+ -- the whole point of the unbeliever library. So, good? We can make+ -- this better if/when we come up with an effecient Stream Rope+ -- instance so megaparsec can use Rope directly.++ bytes <- liftIO $ withFile filename ReadMode hInput+ let contents = intoRope bytes+ return contents++-- |+-- Parse technique content into a concrete syntax object.+parsingPhase :: Source -> Program None Technique+parsingPhase source = do+ event "Parse surface language into concrete Procedures"+ let contents = sourceContents source++ let result = parse pTechnique "" (fromRope contents)++ case result of+ Right technique -> return technique+ Left bundle -> throw (extractErrorBundle source bundle)++-- |+-- Take a static Procedure definition and spin it up into a sequence of+-- "Subroutine" suitable for interpretation. In other words, translate+-- between the concrete syntax types and the abstract syntax we can feed to+-- an evaluator.++-- FIXME better return type+translationPhase :: Source -> Technique -> Program None [Function]+translationPhase source technique =+ let env0 =+ emptyEnvironment+ { environmentFunctions = builtinProcedures,+ environmentSource = source+ }+ result = runTranslate env0 (translateTechnique technique)+ in do+ event "Translate Procedures into abstract Subroutines"+ case result of+ Left failure -> do+ throw failure+ Right (xs, _) -> do+ return xs++commandFormatTechnique :: Program None ()+commandFormatTechnique = do+ params <- getCommandLine++ let raw = case lookupOptionFlag "raw-control-chars" params of+ Nothing -> False+ Just True -> True+ _ -> error "Invalid State"++ let procfile = case lookupArgument "filename" params of+ Just file -> file+ _ -> error "Invalid State"++ catch+ ( do+ surface <- loadTechnique procfile+ let source =+ emptySource+ { sourceFilename = procfile,+ sourceContents = surface+ }++ technique <- parsingPhase source++ terminal <- liftIO $ hIsTerminalDevice stdout+ case (terminal || raw) of+ True -> writeR technique+ False -> write (renderNoAnsi 80 technique)+ )+ ( \(e :: CompilationError) -> do+ write ("failed: " <> render 78 e)+ terminate (exitCodeFor e)+ )
+ technique.cabal view
@@ -0,0 +1,119 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: cbe0786c7bf00b6678b46b415fb4932fe7b1a118f5328cdbe2c0595c80d99623++name: technique+version: 0.2.5+synopsis: Procedures and Sequences+description: A domain specific lanaguage for procedures.+category: Tools+stability: experimental+homepage: https://github.com/technique-lang/technique#readme+bug-reports: https://github.com/technique-lang/technique/issues+author: Andrew Cowie <istathar@gmail.com>+maintainer: Andrew Cowie <istathar@gmail.com>+copyright: © 2002-2020 Athae Eredh Siniath and Others+license: MIT+license-file: LICENSE+tested-with: GHC == 8.8.4+build-type: Simple++source-repository head+ type: git+ location: https://github.com/technique-lang/technique++library technique-internal+ exposed-modules:+ Technique.Builtins+ Technique.Diagnostics+ Technique.Evaluator+ Technique.Failure+ Technique.Formatter+ Technique.Language+ Technique.Internal+ Technique.Parser+ Technique.Quantity+ Technique.Translate+ hs-source-dirs:+ lib+ ghc-options: -Wall -Wwarn -fwarn-tabs+ build-depends:+ async+ , base >=4.11 && <5+ , containers+ , core-data >=0.2.1+ , core-program >=0.2.4.2+ , core-text >=0.3.0+ , dlist+ , free+ , hashable+ , ivar-simple+ , megaparsec+ , mtl+ , parser-combinators+ , prettyprinter+ , text+ , transformers+ , uuid-types+ default-language: Haskell2010++executable technique+ main-is: TechniqueMain.hs+ other-modules:+ TechniqueUser+ hs-source-dirs:+ src+ ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+ build-depends:+ base >=4.11 && <5+ , containers+ , core-data >=0.2.1+ , core-program >=0.2.4.2+ , core-text >=0.3.0+ , dlist+ , free+ , ivar-simple+ , megaparsec+ , parser-combinators+ , prettyprinter+ , technique-internal+ , text+ default-language: Haskell2010++test-suite check+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ other-modules:+ CheckConcreteSyntax+ CheckSkeletonParser+ CheckQuantityBehaviour+ CheckTranslationPhase+ ExampleProcedure+ hs-source-dirs:+ tests+ ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+ build-depends:+ async+ , base >=4.11 && <5+ , containers+ , core-data >=0.2.1+ , core-program >=0.2.4.2+ , core-text >=0.3.0+ , dlist+ , free+ , hashable+ , hspec+ , ivar-simple+ , megaparsec+ , mtl+ , parser-combinators+ , prettyprinter+ , technique-internal+ , text+ , transformers+ , uuid-types+ default-language: Haskell2010
+ tests/CheckConcreteSyntax.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module CheckConcreteSyntax+ ( checkConcreteSyntax,+ main,+ )+where++import Core.System+import Core.Text.Rope ()+import Core.Text.Utilities+import ExampleProcedure hiding (main)+import Technique.Builtins+import Technique.Formatter+import Technique.Internal+import Technique.Language+import Technique.Quantity+import Test.Hspec++main :: IO ()+main = do+ finally (hspec checkConcreteSyntax) (putStrLn ".")++-- |+-- When we set the expectation using a [quote| ... |] here doc we get a+-- trailing newline that is not present in the rendered AST element. So+-- administratively add one here.+renderTest :: Render a => a -> String+renderTest x = show (highlight x <> line)++-- |+-- These are less tests than a body of code that exercises construction of+-- our concrete syntax tree.+checkConcreteSyntax :: Spec+checkConcreteSyntax = do+ describe "Constructions matching intended language design" $ do+ it "key builtin procedures are available" $ do+ functionName builtinProcedureTask `shouldBe` Identifier "task"++ it "procedure's function name is correct" $ do+ procedureName exampleRoastTurkey `shouldBe` Identifier "roast_turkey"++ describe "Rendering of concrete syntax tree to Technique language" $ do+ it "renders a list as tuple" $ do+ show (commaCat [Identifier "one", Identifier "two", Identifier "three"])+ `shouldBe` "one,two,three"+ show (commaCat ([] :: [Identifier]))+ `shouldBe` ""++ it "renders a tablet as expected" $+ let tablet =+ Tablet+ [ Binding (Label "Final temperature") (Variable 0 [Identifier "temp"]),+ Binding (Label "Cooking time") (Grouping 0 (Amount 0 (Quantity (Decimal 3 0) (Decimal 0 0) 0 "hr")))+ ]+ in do+ renderTest tablet+ `shouldBe` [quote|+[+ "Final temperature" ~ temp+ "Cooking time" ~ (3 hr)+]+|]++ describe "Rendering of a Block" $ do+ it "renders a normal block with indentation" $+ let b =+ Block+ [ Execute 0 (Variable 0 [Identifier "x"])+ ]+ in do+ renderTest b+ `shouldBe` [quote|+{+ x+}+|]++ describe "Rendering of a Procedure" $ do+ it "renders a function signature correctly" $+ let p =+ emptyProcedure+ { procedureName = Identifier "f",+ procedureInput = [Type "X"],+ procedureOutput = [Type "Y"],+ procedureBlock = Block [Execute 0 (Variable 0 [Identifier "z"])]+ }+ in do+ renderTest p+ `shouldBe` [quote|+ f : X -> Y+ {+ z+ }+|]
+ tests/CheckQuantityBehaviour.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module CheckQuantityBehaviour+ ( checkQuantityBehaviour,+ main,+ )+where++import Core.System+import Core.Text.Rope ()+import Core.Text.Utilities+import Technique.Formatter ()+import Technique.Quantity+import Test.Hspec++main :: IO ()+main = do+ finally (hspec checkQuantityBehaviour) (putStrLn ".")++renderTest :: Render a => a -> String+renderTest x = show (highlight x)++-- |+-- These are less tests than a body of code that exercises construction of+-- an abstract syntax tree.+checkQuantityBehaviour :: Spec+checkQuantityBehaviour = do+ describe "Basic behaviour of Quantity type" $ do+ it "Numbers serialze as integers" $ do+ renderTest (Number 42) `shouldBe` "42"++ it "Abbreviated measurement and unit" $ do+ renderTest (Quantity (Decimal 4 0) (Decimal 0 0) 0 "kg") `shouldBe` "4 kg"++ it "Full measurement with uncertainty, magnitude, and unit" $ do+ renderTest (Quantity (Decimal 4 0) (Decimal 1 0) 2 "kg") `shouldBe` "4 ± 1 × 10² kg"++ it "Full measurement with decimal precision" $ do+ renderTest (Quantity (Decimal 59722 4) (Decimal 6 4) 24 "kg") `shouldBe` "5.9722 ± 0.0006 × 10²⁴ kg"
+ tests/CheckSkeletonParser.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module CheckSkeletonParser+ ( checkSkeletonParser,+ main,+ )+where++import Core.System+import Core.Text+import Technique.Language+import Technique.Parser+import Technique.Quantity+import Test.Hspec+import Text.Megaparsec hiding (Label)++main :: IO ()+main = do+ finally (hspec checkSkeletonParser) (putStrLn ".")++checkSkeletonParser :: Spec+checkSkeletonParser = do+ describe "Parse procfile header" $ do+ it "correctly parses a complete magic line" $ do+ parseMaybe pMagicLine "% technique v2\n" `shouldBe` Just 2+ it "errors if magic line has incorrect syntax" $ do+ parseMaybe pMagicLine "%\n" `shouldBe` Nothing+ parseMaybe pMagicLine "%technique\n" `shouldBe` Nothing+ parseMaybe pMagicLine "% technique\n" `shouldBe` Nothing+ parseMaybe pMagicLine "% technique \n" `shouldBe` Nothing+ parseMaybe pMagicLine "% technique v\n" `shouldBe` Nothing+ parseMaybe pMagicLine "% technique v2\n" `shouldBe` Nothing+ parseMaybe pMagicLine "% technique v2 asdf\n" `shouldBe` Nothing++ it "correctly parses an SPDX header line" $ do+ parseMaybe pSpdxLine "! BSD-3-Clause\n" `shouldBe` Just ("BSD-3-Clause", Nothing)+ it "correctly parses an SPDX header line with Copyright" $ do+ parseMaybe pSpdxLine "! BSD-3-Clause; (c) 2019 Kermit le Frog\n" `shouldBe` Just ("BSD-3-Clause", Just "2019 Kermit le Frog")+ it "errors if SPDX line has incorrect syntax" $ do+ parseMaybe pSpdxLine "!\n" `shouldBe` Nothing+ parseMaybe pSpdxLine "! Public-Domain;\n" `shouldBe` Nothing+ parseMaybe pSpdxLine "! Public-Domain; (\n" `shouldBe` Nothing+ parseMaybe pSpdxLine "! Public-Domain; (c)\n" `shouldBe` Nothing+ parseMaybe pSpdxLine "! Public-Domain; (c) \n" `shouldBe` Nothing++ it "correctly parses a complete technique program header" $ do+ parseMaybe+ pTechnique+ [quote|+% technique v0+! BSD-3-Clause+ |]+ `shouldBe` Just+ ( Technique+ { techniqueVersion = 0,+ techniqueLicense = "BSD-3-Clause",+ techniqueCopyright = Nothing,+ techniqueBody = []+ }+ )++ describe "Parses a proecdure declaration" $ do+ it "name parser handles valid identifiers" $ do+ parseMaybe pIdentifier "" `shouldBe` Nothing+ parseMaybe pIdentifier "i" `shouldBe` Just (Identifier "i")+ parseMaybe pIdentifier "ingredients" `shouldBe` Just (Identifier "ingredients")+ parseMaybe pIdentifier "roast_turkey" `shouldBe` Just (Identifier "roast_turkey")+ parseMaybe pIdentifier "1x" `shouldBe` Nothing+ parseMaybe pIdentifier "x1" `shouldBe` Just (Identifier "x1")++ it "type parser handles valid type names" $ do+ parseMaybe pType "" `shouldBe` Nothing+ parseMaybe pType "I" `shouldBe` Just (Type "I")+ parseMaybe pType "Ingredients" `shouldBe` Just (Type "Ingredients")+ parseMaybe pType "RoastTurkey" `shouldBe` Just (Type "RoastTurkey")+ parseMaybe pType "Roast_Turkey" `shouldBe` Nothing+ parseMaybe pType "2Dinner" `shouldBe` Nothing+ parseMaybe pType "Dinner3" `shouldBe` Just (Type "Dinner3")++ it "handles a name, parameters, and a type signature" $ do+ parseMaybe pProcedureDeclaration "roast_turkey i : Ingredients -> Turkey"+ `shouldBe` Just (Identifier "roast_turkey", [Identifier "i"], [Type "Ingredients"], [Type "Turkey"])+ parseMaybe pProcedureDeclaration "roast_turkey i : Ingredients -> Turkey"+ `shouldBe` Just (Identifier "roast_turkey", [Identifier "i"], [Type "Ingredients"], [Type "Turkey"])+ parseMaybe pProcedureDeclaration "roast_turkey:Ingredients->Turkey"+ `shouldBe` Just (Identifier "roast_turkey", [], [Type "Ingredients"], [Type "Turkey"])++ describe "Literals" $ do+ it "quoted string is interpreted as text" $ do+ parseMaybe stringLiteral "\"Hello world\"" `shouldBe` Just "Hello world"+ parseMaybe stringLiteral "\"Hello \\\"world\"" `shouldBe` Just "Hello \"world"+ parseMaybe stringLiteral "\"\"" `shouldBe` Just ""++ it "positive integers" $ do+ parseMaybe numberLiteral "42" `shouldBe` Just 42+ parseMaybe numberLiteral "0" `shouldBe` Just 0+ parseMaybe numberLiteral "1a" `shouldBe` Nothing++ describe "Parses quantities" $ do+ it "a number is a Number" $ do+ parseMaybe pQuantity "42" `shouldBe` Just (Number 42)+ parseMaybe pQuantity "-42" `shouldBe` Just (Number (-42))++ it "a quantity with units is a Quantity" $ do+ parseMaybe pQuantity "149 kg" `shouldBe` Just (Quantity (Decimal 149 0) (Decimal 0 0) 0 "kg")++ it "a quantity with mantissa, magnitude, and units is a Quantity" $ do+ parseMaybe pQuantity "5.9722 × 10^24 kg" `shouldBe` Just (Quantity (Decimal 59722 4) (Decimal 0 0) 24 "kg")++ it "a quantity with mantissa, uncertainty, and units is a Quantity" $ do+ parseMaybe pQuantity "5.9722 ± 0.0006 kg" `shouldBe` Just (Quantity (Decimal 59722 4) (Decimal 6 4) 0 "kg")++ it "a quantity with mantissa, uncertainty, magnitude, and units is a Quantity" $ do+ parseMaybe pQuantity "5.9722 ± 0.0006 × 10^24 kg" `shouldBe` Just (Quantity (Decimal 59722 4) (Decimal 6 4) 24 "kg")++ it "same quantity, with superscripts, is a Quantity" $ do+ parseMaybe pQuantity "5.9722 ± 0.0006 × 10²⁴ kg" `shouldBe` Just (Quantity (Decimal 59722 4) (Decimal 6 4) 24 "kg")++ it "negative Quantities also parse" $ do+ parseMaybe pQuantity "1234567890" `shouldBe` Just (Number 1234567890)+ parseMaybe pQuantity "-1234567890" `shouldBe` Just (Number (-1234567890))+ parseMaybe pQuantity "3.14 ± 0.01 m" `shouldBe` Just (Quantity (Decimal 314 2) (Decimal 001 2) 0 "m")+ parseMaybe pQuantity "-3.14 ± 0.01 m" `shouldBe` Just (Quantity (Decimal (-314) 2) (Decimal 001 2) 0 "m")++ describe "Parses attributes" $ do+ it "recognizes a role marker" $ do+ parseMaybe pAttribute "@butler" `shouldBe` Just (Role (Identifier "butler"))+ it "recognizes a place marker" $ do+ parseMaybe pAttribute "#library" `shouldBe` Just (Place (Identifier "library"))+ it "recognizes any" $ do+ parseMaybe pAttribute "@*" `shouldBe` Just (Role (Identifier "*"))+ parseMaybe pAttribute "#*" `shouldBe` Just (Place (Identifier "*"))++ describe "Parses expressions" $ do+ it "an empty input an error" $ do+ parseMaybe pExpression "" `shouldBe` Nothing++ it "an pair of parentheses is None" $ do+ parseMaybe pExpression "()" `shouldBe` Just (None 0)++ it "a quoted string is a Text" $ do+ parseMaybe pExpression "\"Hello world\"" `shouldBe` Just (Text 0 "Hello world")+ parseMaybe pExpression "\"\"" `shouldBe` Just (Text 0 "")++ it "a bare identifier is a Variable" $ do+ parseMaybe pExpression "x" `shouldBe` Just (Variable 0 [Identifier "x"])++ it "an identifier, space, and then expression is an Application" $ do+ parseMaybe pExpression "a x"+ `shouldBe` Just (Application 0 (Identifier "a") (Variable 2 [Identifier "x"]))++ it "a quoted string is a Literal Text" $ do+ parseMaybe pExpression "\"Hello world\"" `shouldBe` Just (Text 0 "Hello world")++ it "a bare number is a Literal Number" $ do+ parseMaybe pExpression "42" `shouldBe` Just (Amount 0 (Number 42))++ it "a nested expression is parsed as Grouped" $ do+ parseMaybe pExpression "(42)" `shouldBe` Just (Grouping 0 (Amount 1 (Number 42)))++ it "an operator between two expressions is an Operation" $ do+ parseMaybe pExpression "x & y"+ `shouldBe` Just+ ( Operation+ 0+ WaitBoth+ (Variable 0 [Identifier "x"])+ (Variable 4 [Identifier "y"])+ )++ it "handles tablet with one binding" $ do+ parseMaybe pExpression "[ \"King\" ~ george ]"+ `shouldBe` Just+ ( Object+ 0+ ( Tablet+ [ Binding (Label "King") (Variable 11 [Identifier "george"])+ ]+ )+ )++ it "handles tablet with multiple bindings" $ do+ parseMaybe pExpression "[ \"first\" ~ \"George\" \n \"last\" ~ \"Windsor\" ]"+ `shouldBe` Just+ ( Object+ 0+ ( Tablet+ [ Binding (Label "first") (Text 12 "George"),+ Binding (Label "last") (Text 32 "Windsor")+ ]+ )+ )+ {-+ it "handles tablet with alternate single-line syntax" $+ let expected =+ Just+ ( Object+ ( Tablet+ [ Binding "name" (Variable [Identifier "n"]),+ Binding "king" (Amount (Number 42))+ ]+ )+ )+ in do+ parseMaybe pExpression "[\"name\" ~ n,\"king\" ~ 42]" `shouldBe` expected+ parseMaybe pExpression "[\"name\" ~ n , \"king\" ~ 42]" `shouldBe` expected+ -}++ describe "Parses statements containing expressions" $ do+ it "a blank line is a Blank" $ do+ parseMaybe pStatement "\n" `shouldBe` Just (Blank 0)++ it "considers a single identifier an Execute" $ do+ parseMaybe pStatement "x"+ `shouldBe` Just (Execute 0 (Variable 0 [Identifier "x"]))++ it "considers a line with an '=' to be an Assignment" $ do+ parseMaybe pStatement "answer = 42"+ `shouldBe` Just (Assignment 0 [Identifier "answer"] (Amount 9 (Number 42)))++ describe "Parses blocks of statements" $ do+ it "an empty block is a [] (special case)" $ do+ parseMaybe pBlock "{}" `shouldBe` Just (Block [])++ it "a block with a newline (only) is []" $ do+ parseMaybe pBlock "{\n}" `shouldBe` Just (Block [])++ it "a block with single statement surrounded by a newlines" $ do+ parseMaybe pBlock "{\nx\n}"+ `shouldBe` Just+ ( Block+ [ Execute 2 (Variable 2 [Identifier "x"])+ ]+ )+ parseMaybe pBlock "{\nanswer = 42\n}"+ `shouldBe` Just+ ( Block+ [ (Assignment 2 [Identifier "answer"] (Amount 11 (Number 42)))+ ]+ )++ it "a block with a blank line contains a Blank" $ do+ parseMaybe pBlock "{\nx1\n\nx2\n}"+ `shouldBe` Just+ ( Block+ [ Execute 2 (Variable 2 [Identifier "x1"]),+ Blank 5,+ Execute 6 (Variable 6 [Identifier "x2"])+ ]+ )++ it "a block with multiple statements separated by newlines" $ do+ parseMaybe pBlock "{\nx\nanswer = 42\n}"+ `shouldBe` Just+ ( Block+ [ Execute 2 (Variable 2 [Identifier "x"]),+ Assignment 4 [Identifier "answer"] (Amount 13 (Number 42))+ ]+ )++ it "a block with multiple statements separated by semicolons" $ do+ parseMaybe pBlock "{x ; answer = 42}"+ `shouldBe` Just+ ( Block+ [ Execute 1 (Variable 1 [Identifier "x"]),+ Series 3,+ Assignment 5 [Identifier "answer"] (Amount 14 (Number 42))+ ]+ )++ it "consumes whitespace in inconvenient places" $ do+ parseMaybe pBlock "{ \n }"+ `shouldBe` Just (Block [])+ parseMaybe pBlock "{ \n x \n }"+ `shouldBe` Just+ ( Block+ [ Execute 4 (Variable 4 [Identifier "x"])+ ]+ )+ parseMaybe pBlock "{ \n (42) \n}"+ `shouldBe` Just+ ( Block+ [ Execute 4 (Grouping 4 (Amount 5 (Number 42)))+ ]+ )+ parseMaybe pBlock "{ \n (42 ) \n}"+ `shouldBe` Just+ ( Block+ [ Execute 4 (Grouping 4 (Amount 5 (Number 42)))+ ]+ )+ parseMaybe pBlock "{ answer = 42 ; }"+ `shouldBe` Just+ ( Block+ [ Assignment 2 [Identifier "answer"] (Amount 11 (Number 42)),+ Series 14+ ]+ )++ describe "Parses a procedure declaration" $ do+ it "simple declaration " $ do+ parseMaybe pProcedureDeclaration "f x : X -> Y"+ `shouldBe` Just (Identifier "f", [Identifier "x"], [Type "X"], [Type "Y"])++ it "declaration with multiple variables and input types" $ do+ parseMaybe pProcedureDeclaration "after_dinner i,s,w : IceCream,Strawberries,Waffles -> Dessert"+ `shouldBe` Just+ ( Identifier "after_dinner",+ [Identifier "i", Identifier "s", Identifier "w"],+ [Type "IceCream", Type "Strawberries", Type "Waffles"],+ [Type "Dessert"]+ )++ it "handles spurious whitespace" $ do+ parseMaybe pProcedureDeclaration "after_dinner i ,s ,w : IceCream ,Strawberries, Waffles -> Dessert"+ `shouldBe` Just+ ( Identifier "after_dinner",+ [Identifier "i", Identifier "s", Identifier "w"],+ [Type "IceCream", Type "Strawberries", Type "Waffles"],+ [Type "Dessert"]+ )++ describe "Parses a the code for a complete procedure" $ do+ it "parses a declaration and block" $ do+ parseMaybe pProcedureCode "f : X -> Y\n{ x }\n"+ `shouldBe` Just+ ( emptyProcedure+ { procedureOffset = 0,+ procedureName = Identifier "f",+ procedureInput = [Type "X"],+ procedureOutput = [Type "Y"],+ procedureBlock = Block [Execute 13 (Variable 13 [Identifier "x"])]+ }+ )
+ tests/CheckTranslationPhase.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module CheckTranslationPhase+ ( checkTranslationPhase,+ main,+ )+where++import Core.Data.Structures+import Core.System+import Core.Text.Rope ()+import ExampleProcedure hiding (main)+import Technique.Builtins+import Technique.Failure+import Technique.Internal+import Technique.Language+import Technique.Translate+import Test.Hspec++main :: IO ()+main = do+ finally (hspec checkTranslationPhase) (putStrLn ".")++testEnv :: Environment+testEnv =+ emptyEnvironment+ { environmentVariables = singletonMap (Identifier "x") (Name "!x"),+ environmentFunctions = insertKeyValue (Identifier "oven") (Subroutine exampleProcedureOven NoOp) builtinProcedures+ }++simpleProcedure :: Procedure+simpleProcedure =+ emptyProcedure+ { procedureName = Identifier "mock",+ procedureParams = [Identifier "a", Identifier "b"],+ procedureInput = [Type "OneThing", Type "Another"],+ procedureOutput = [Type "Stuff"],+ procedureBlock = Block [Execute 0 (Variable 0 [Identifier "a", Identifier "b"])]+ }++checkTranslationPhase :: Spec+checkTranslationPhase = do+ describe "Invalid code emits expected compiler failures" $ do+ it "encountering undefined symbol" $+ let expr = Undefined 0+ result = runTranslate testEnv (translateExpression expr)+ in do+ case result of+ Left (CompilationError _ failure) -> do+ failure `shouldBe` EncounteredUndefined+ Right _ -> fail "Should have emitted CompilerFailure"++ it "encountering unknown variable" $+ let expr = Variable 0 [Identifier "y"]+ result = runTranslate testEnv (translateExpression expr)+ in do+ case result of+ Left (CompilationError _ failure) ->+ failure `shouldBe` UseOfUnknownIdentifier (Identifier "y")+ Right _ -> fail "Should have emitted CompilerFailure"++ it "encountering unknown procedure" $+ let expr1 = Variable 0 [Identifier "x"]+ expr2 = Application 0 (Identifier "f") expr1+ stmt = Execute 0 expr2+ block = Block [stmt]+ technique = emptyTechnique {techniqueBody = [emptyProcedure {procedureBlock = block}]}+ in do+ let result = runTranslate testEnv (translateTechnique technique)+ case result of+ Left (CompilationError _ (CallToUnknownProcedure (Identifier i))) ->+ i `shouldBe` "f"+ Left _ -> fail "Incorrect CompilerFailure encountered"+ Right _ -> fail "Should have emitted CompilerFailure"++ it "expected builtin procedures are defined" $ do+ fmap functionName (lookupKeyValue (Identifier "task") (environmentFunctions testEnv))+ `shouldBe` Just (Identifier "task")++ it "encountering builtin procedure" $+ let expr = Application 0 (Identifier "task") (Text 5 "Say Hello")+ stmt = Execute 0 expr+ block = Block [stmt]+ proc = emptyProcedure {procedureName = Identifier "hypothetical", procedureBlock = block}+ tech = emptyTechnique {techniqueBody = [proc]}+ in do+ let result = runTranslate testEnv (translateTechnique tech)+ case result of+ Right ([(Subroutine _ (Invocation _ _ (Primitive proc1 _) _))], _) ->+ procedureName proc1 `shouldBe` Identifier "task"+ Right (((Subroutine _ step) : _), _) -> fail ("Should have translated to a Primitive, step " ++ show step) -- probable that the above pattern match now needs fixing+ _ -> fail "Should have pattern matched"++ it "encounters a declaration for an already existing procedure name" $+ let proc = exampleProcedureOven -- already in testEnv+ stmt = Declaration 0 proc+ block = Block [stmt]+ in do+ -- verify precondition that there is one already there+ fmap functionName (lookupKeyValue (Identifier "oven") (environmentFunctions testEnv))+ `shouldBe` Just (Identifier "oven")+ -- attempt to declare a procedure by a name already in use+ let result = runTranslate testEnv (translateBlock block)+ case result of+ Left (CompilationError _ (ProcedureAlreadyDeclared (Identifier i))) ->+ i `shouldBe` "oven"+ Left _ -> fail "Incorrect CompilerFailure encountered"+ Right _ -> fail "Should have emitted CompilerFailure"++ {-+ Having made it past the various things that should throw CompilationErrors,+ we now run through some examples which should parse and translate correctly+ to full abstract syntax trees.+ -}++ describe "Known Procedure is translated to correct abstract syntax tree" $ do+ it "multiple params of a procedure are in scope as variables" $+ let result = runTranslate testEnv (translateProcedure simpleProcedure)+ in do+ case result of+ Right (func, _) ->+ func+ `shouldBe` Subroutine+ simpleProcedure+ (Tuple 0 [Depends 0 (Name "!a"), Depends 0 (Name "!b")])+ _ -> fail "Should have translated procedure"
+ tests/ExampleProcedure.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module ExampleProcedure where++import Core.Program.Execute hiding (None)+import Core.Program.Logging+import Core.Text.Rope ()+import Core.Text.Utilities ()+import Technique.Formatter ()+import Technique.Language+import Technique.Quantity++-- Render instances for main function++{-+ roast_turkey i : Ingredients -> Turkey+ {+ @chef+ {+ preheat = oven (180 °C)+ task "Bacon strips onto bird"+ preheat++ task "Put bird into oven"++ t = timer (3 h)+ t++ temp = record "Probe bird temperature"+ [+ "Final temperature" ~ temp+ ]+ }+-}++exampleProcedureOven :: Procedure+exampleProcedureOven =+ emptyProcedure+ { procedureName = Identifier "oven",+ procedureInput = [Type "Temperature"],+ procedureOutput = [Type "()"], -- ?+ procedureBlock = Block [Execute 0 (Application 0 (Identifier "task") (Text 0 "Set oven temperature!"))]+ }++exampleRoastTurkey :: Procedure+exampleRoastTurkey =+ let i = Type "Ingredients"+ o = Type "Turkey"+ celsius = "°C"+ chef = Role (Identifier "chef")+ block =+ Block+ [ Execute+ 0+ ( Restriction+ 0+ chef+ ( Block+ [ Assignment+ 0+ [Identifier "preheat"]+ ( Application+ 0+ (Identifier "oven")+ (Grouping 0 (Amount 0 (Quantity (Decimal 180 0) (Decimal 0 0) 0 celsius)))+ ),+ Execute+ 0+ ( Application+ 0+ (Identifier "task")+ (Text 0 "Bacon strips onto bird")+ ),+ Execute+ 0+ (Variable 0 [Identifier "preheat"]),+ Execute+ 0+ (Undefined 0),+ Blank 0,+ Execute+ 0+ ( Operation+ 0+ WaitBoth+ (Variable 0 [Identifier "w1"])+ ( Grouping+ 0+ ( Operation+ 0+ WaitEither+ (Variable 0 [Identifier "w2"])+ (Variable 0 [Identifier "w3"])+ )+ )+ ),+ Blank 0,+ Execute 0 (Variable 0 [Identifier "v1"]),+ Series 0,+ Execute 0 (Variable 0 [Identifier "v2"]),+ Assignment+ 0+ [Identifier "temp"]+ ( Application+ 0+ (Identifier "record")+ (Text 0 "Probe bird temperature")+ ),+ Execute+ 0+ ( Object+ 0+ ( Tablet+ [Binding (Label "Final temperature") (Variable 0 [Identifier "temp"])]+ )+ )+ ]+ )+ )+ ]+ in Procedure+ { procedureOffset = 0,+ procedureName = Identifier "roast_turkey",+ procedureParams = [Identifier "i", Identifier "j", Identifier "k"],+ procedureInput = [i],+ procedureOutput = [o],+ procedureTitle = Just (Markdown "Roast Turkey"),+ procedureDescription = Nothing,+ procedureBlock = block+ }++exampleTechnique :: Technique+exampleTechnique =+ Technique+ { techniqueVersion = 0,+ techniqueLicense = "BSD-3-Clause",+ techniqueCopyright = Just "2018 Allicin Wonderland",+ techniqueBody = [exampleRoastTurkey]+ }++main :: IO ()+main = execute $ do+ writeR exampleTechnique
+ tests/TestSuite.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++import CheckConcreteSyntax hiding (main)+import CheckQuantityBehaviour hiding (main)+import CheckSkeletonParser hiding (main)+import CheckTranslationPhase hiding (main)+import Core.System+import Test.Hspec (Spec, hspec)++main :: IO ()+main = do+ finally (hspec suite) (putStrLn ".")++suite :: Spec+suite = do+ checkQuantityBehaviour+ checkConcreteSyntax+ checkSkeletonParser+ checkTranslationPhase