diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/lib/Technique/Builtins.hs b/lib/Technique/Builtins.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Builtins.hs @@ -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 diff --git a/lib/Technique/Diagnostics.hs b/lib/Technique/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Diagnostics.hs @@ -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 + <> " ↘ " + ) + ) + +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 diff --git a/lib/Technique/Evaluator.hs b/lib/Technique/Evaluator.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Evaluator.hs @@ -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 diff --git a/lib/Technique/Failure.hs b/lib/Technique/Failure.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Failure.hs @@ -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 = "", + 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" diff --git a/lib/Technique/Formatter.hs b/lib/Technique/Formatter.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Formatter.hs @@ -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) diff --git a/lib/Technique/Internal.hs b/lib/Technique/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Internal.hs @@ -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) diff --git a/lib/Technique/Language.hs b/lib/Technique/Language.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Language.hs @@ -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) diff --git a/lib/Technique/Parser.hs b/lib/Technique/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Parser.hs @@ -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 + } diff --git a/lib/Technique/Quantity.hs b/lib/Technique/Quantity.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Quantity.hs @@ -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) diff --git a/lib/Technique/Translate.hs b/lib/Technique/Translate.hs new file mode 100644 --- /dev/null +++ b/lib/Technique/Translate.hs @@ -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' diff --git a/src/TechniqueMain.hs b/src/TechniqueMain.hs new file mode 100644 --- /dev/null +++ b/src/TechniqueMain.hs @@ -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" diff --git a/src/TechniqueUser.hs b/src/TechniqueUser.hs new file mode 100644 --- /dev/null +++ b/src/TechniqueUser.hs @@ -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) + ) diff --git a/technique.cabal b/technique.cabal new file mode 100644 --- /dev/null +++ b/technique.cabal @@ -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 +maintainer: Andrew Cowie +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 diff --git a/tests/CheckConcreteSyntax.hs b/tests/CheckConcreteSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/CheckConcreteSyntax.hs @@ -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 + } +|] diff --git a/tests/CheckQuantityBehaviour.hs b/tests/CheckQuantityBehaviour.hs new file mode 100644 --- /dev/null +++ b/tests/CheckQuantityBehaviour.hs @@ -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" diff --git a/tests/CheckSkeletonParser.hs b/tests/CheckSkeletonParser.hs new file mode 100644 --- /dev/null +++ b/tests/CheckSkeletonParser.hs @@ -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"])] + } + ) diff --git a/tests/CheckTranslationPhase.hs b/tests/CheckTranslationPhase.hs new file mode 100644 --- /dev/null +++ b/tests/CheckTranslationPhase.hs @@ -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" diff --git a/tests/ExampleProcedure.hs b/tests/ExampleProcedure.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleProcedure.hs @@ -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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -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