diff --git a/.gitignore b/.gitignore index a3f70edda..d7c0f17a5 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ tags TAGS cross/ release/ +.stack-work diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs new file mode 100644 index 000000000..1b6eea589 --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Pill where + +import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Jam +import Data.Flat +import Control.Monad.Except +import Control.Lens +import Data.Either.Extra (mapLeft) +import GHC.Natural +import Data.Bits +import GHC.Integer.GMP.Internals + +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.Vector.Primitive as VP +import qualified Data.ByteString as BS + +-------------------------------------------------------------------------------- + +stripTrailingZeros :: ByteString -> ByteString +stripTrailingZeros buf = BS.take (len - go 0 (len - 1)) buf + where + len = length buf + go n i | i < 0 = n + | 0 == BS.index buf i = go (n+1) (i-1) + | otherwise = n + +unpackWord :: ByteString -> Word +unpackWord buf = + case length buf of + 0 -> 0 + 1 -> i 0 0 + 2 -> i 0 0 .|. i 1 8 + 3 -> i 0 0 .|. i 1 8 .|. i 2 16 + n -> i 0 0 .|. i 1 8 .|. i 2 16 .|. i 3 24 + where + i :: Int -> Int -> Word + i idx off = shiftL (fromIntegral $ BS.index buf idx) off + +words2Nat :: [Word] -> Natural +words2Nat [] = 0 +words2Nat [w] = fromIntegral w +words2Nat ws = + if off /= 0 then error "words2Nat bad vec" else + NatJ# (BN# buf) + where + VP.Vector off len (Prim.ByteArray buf) = VP.fromList ws + +unpackWords :: ByteString -> [Word] +unpackWords = + \case buf | length buf <= 4 -> [unpackWord buf] + | otherwise -> go [] buf + where + go :: [Word] -> ByteString -> [Word] + go acc buf | null buf = reverse acc + go acc buf | otherwise = go (unpackWord buf : acc) (BS.drop 4 buf) + +unpackAtom :: ByteString -> Atom +unpackAtom = MkAtom . words2Nat . unpackWords . stripTrailingZeros + +loadFile :: FilePath -> IO Atom +loadFile = fmap unpackAtom . readFile + +loadJam :: FilePath -> IO (Maybe Noun) +loadJam = fmap cue . loadFile + +-- dumpJam :: FilePath -> Noun -> IO () +-- dumpJam pat = writeFile pat . packAtom . jam + +-- packWord :: Word -> ByteString +-- packWord buf = undefined + +-- packAtom :: Atom -> ByteString +-- packAtom = undefined + +dumpFlat :: Flat a => FilePath -> a -> IO () +dumpFlat pat = writeFile pat . flat + +loadFlat :: Flat a => FilePath -> IO (Either Text a) +loadFlat pat = do + bs <- readFile pat + pure $ mapLeft tshow $ unflat bs + +{- +/* u3i_bytes(): +** +** Copy `a` bytes from `b` to an LSB first atom. +*/ +u3_noun +u3i_bytes(c3_w a_w, + const c3_y* b_y) +{ + /* Strip trailing zeroes. + */ + while ( a_w && !b_y[a_w - 1] ) { + a_w--; + } + + /* Check for cat. + */ + if ( a_w <= 4 ) { + if ( !a_w ) { + return 0; + } + else if ( a_w == 1 ) { + return b_y[0]; + } + else if ( a_w == 2 ) { + return (b_y[0] | (b_y[1] << 8)); + } + else if ( a_w == 3 ) { + return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16)); + } + else if ( (b_y[3] <= 0x7f) ) { + return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16) | (b_y[3] << 24)); + } + } + + /* Allocate, fill, return. + */ + { + c3_w len_w = (a_w + 3) >> 2; + c3_w* nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom))); + u3a_atom* nov_u = (void*)nov_w; + + nov_u->mug_w = 0; + nov_u->len_w = len_w; + + /* Clear the words. + */ + { + c3_w i_w; + + for ( i_w=0; i_w < len_w; i_w++ ) { + nov_u->buf_w[i_w] = 0; + } + } + + /* Fill the bytes. + */ + { + c3_w i_w; + + for ( i_w=0; i_w < a_w; i_w++ ) { + nov_u->buf_w[i_w >> 2] |= (b_y[i_w] << ((i_w & 3) * 8)); + } + } + return u3a_to_pug(u3a_outa(nov_w)); + } +} +-} diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index d7af7a452..a61830612 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -29,6 +29,7 @@ import Data.Typeable (Typeable) import Control.Monad.State.Strict hiding (forM_, replicateM) import Control.Monad.Trans.Maybe +import qualified ClassyPrelude import qualified Data.Vector as V import qualified Data.List as L import qualified Data.Vector.Unboxed as UV @@ -95,16 +96,15 @@ refCount = go mempty go acc c@(Cell l r) = go (go (ins c acc) l) r zipTable :: Noun -> (Vector Noun, Map Noun Int) -zipTable top = (tbl, keys tbl) +zipTable top = (V.fromList tbl, keys) where - keys = mapFromList . V.toList . fmap swap . V.indexed - big = \case { Atom a -> a >= 128; _ -> True } - tbl = filter big - $ fmap fst - $ V.fromList + keys = mapFromList (ClassyPrelude.zip tbl [0..]) + big = \case Atom a -> a >= 127+8 + _ -> True + tbl = fmap fst $ sortBy (comparing snd) + $ filter (\(k,v) -> big k && v>1) $ mapToList - $ filterMap (> 1) $ refCount top zip :: Noun -> Zip diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 69e8b10b8..120009b7d 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -28,6 +28,7 @@ executables: dependencies: - async - base + - bytestring - case-insensitive - classy-prelude - containers @@ -45,6 +46,7 @@ dependencies: - multimap - para - pretty-show + - primitive - QuickCheck - semigroups - smallcheck diff --git a/pkg/hoon/.gitignore b/pkg/hoon/.gitignore new file mode 100644 index 000000000..c99ca9e13 --- /dev/null +++ b/pkg/hoon/.gitignore @@ -0,0 +1,2 @@ +.stack-work +*.cabal diff --git a/pkg/hair/lib/Language/Hoon/AST/Parser.hs b/pkg/hoon/lib/Language/Hoon/AST/Parser.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/AST/Parser.hs rename to pkg/hoon/lib/Language/Hoon/AST/Parser.hs diff --git a/pkg/hair/lib/Language/Hoon/AST/Types.hs b/pkg/hoon/lib/Language/Hoon/AST/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/AST/Types.hs rename to pkg/hoon/lib/Language/Hoon/AST/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/Desugar.hs b/pkg/hoon/lib/Language/Hoon/Desugar.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Desugar.hs rename to pkg/hoon/lib/Language/Hoon/Desugar.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Desugar.hs b/pkg/hoon/lib/Language/Hoon/IR/Desugar.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Desugar.hs rename to pkg/hoon/lib/Language/Hoon/IR/Desugar.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Infer.hs b/pkg/hoon/lib/Language/Hoon/IR/Infer.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Infer.hs rename to pkg/hoon/lib/Language/Hoon/IR/Infer.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Ty.hs b/pkg/hoon/lib/Language/Hoon/IR/Ty.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Ty.hs rename to pkg/hoon/lib/Language/Hoon/IR/Ty.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Wing.hs b/pkg/hoon/lib/Language/Hoon/IR/Wing.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Wing.hs rename to pkg/hoon/lib/Language/Hoon/IR/Wing.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Gen.hs b/pkg/hoon/lib/Language/Hoon/LL/Gen.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Gen.hs rename to pkg/hoon/lib/Language/Hoon/LL/Gen.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Run.hs b/pkg/hoon/lib/Language/Hoon/LL/Run.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Run.hs rename to pkg/hoon/lib/Language/Hoon/LL/Run.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Types.hs b/pkg/hoon/lib/Language/Hoon/LL/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Types.hs rename to pkg/hoon/lib/Language/Hoon/LL/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/Nock/Types.hs b/pkg/hoon/lib/Language/Hoon/Nock/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Nock/Types.hs rename to pkg/hoon/lib/Language/Hoon/Nock/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/SpecToBunt.hs b/pkg/hoon/lib/Language/Hoon/SpecToBunt.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/SpecToBunt.hs rename to pkg/hoon/lib/Language/Hoon/SpecToBunt.hs diff --git a/pkg/hair/lib/Language/Hoon/SpecToMold.hs b/pkg/hoon/lib/Language/Hoon/SpecToMold.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/SpecToMold.hs rename to pkg/hoon/lib/Language/Hoon/SpecToMold.hs diff --git a/pkg/hair/lib/Language/Hoon/Types.hs b/pkg/hoon/lib/Language/Hoon/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Types.hs rename to pkg/hoon/lib/Language/Hoon/Types.hs diff --git a/pkg/hoon/package.yaml b/pkg/hoon/package.yaml new file mode 100644 index 000000000..9cc4e550d --- /dev/null +++ b/pkg/hoon/package.yaml @@ -0,0 +1,79 @@ +name: language-hoon +version: 0.1.0 +license: AGPL-3.0-only + +library: + source-dirs: lib + ghc-options: + - -fwarn-incomplete-patterns + - -O2 + +dependencies: + - async + - base + - case-insensitive + - classy-prelude + - containers + - data-fix + - extra + - flat + - ghc-prim + - http-client + - http-types + - integer-gmp + - largeword + - lens + - megaparsec + - mtl + - multimap + - para + - pretty-show + - QuickCheck + - semigroups + - smallcheck + - stm + - stm-chans + - tasty + - tasty-quickcheck + - tasty-th + - text + - these + - time + - transformers + - unordered-containers + - vector + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - PartialTypeSignatures + - QuasiQuotes + - Rank2Types + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - ViewPatterns diff --git a/pkg/hair/stack.yaml b/stack.yaml similarity index 90% rename from pkg/hair/stack.yaml rename to stack.yaml index 2140ef2f3..e15320c3f 100644 --- a/pkg/hair/stack.yaml +++ b/stack.yaml @@ -1,7 +1,8 @@ resolver: lts-13.10 packages: - - . + - pkg/hair + - pkg/hoon ghc-options: vere: "-fobject-code"